;==============================================================================

; file: "header.scm"

; Copyright (C) 1994-1998 by Marc Feeley, All Rights Reserved.

(##namespace (""
   not boolean? eqv? eq? equal? pair? cons car cdr set-car! set-cdr!
   caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
   caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr
   cdadar cdaddr cddaar cddadr cdddar cddddr null? list? list length
   append reverse list-ref memq memv member assq assv assoc symbol?
   symbol->string string->symbol number? complex? real? rational?
   integer? exact? inexact? = < > <= >= zero? positive? negative? odd?
   even? max min + * - / abs quotient remainder modulo gcd lcm numerator
   denominator floor ceiling truncate round rationalize exp log sin cos
   tan asin acos atan sqrt expt make-rectangular make-polar real-part
   imag-part magnitude angle exact->inexact inexact->exact number->string
   string->number char? char=? char<? char>? char<=? char>=? char-ci=?
   char-ci<? char-ci>? char-ci<=? char-ci>=? char-alphabetic?
   char-numeric? char-whitespace? char-upper-case? char-lower-case?
   char->integer integer->char char-upcase char-downcase string?
   make-string string string-length string-ref string-set! string=?
   string<? string>? string<=? string>=? string-ci=? string-ci<?
   string-ci>? string-ci<=? string-ci>=? substring string-append vector?
   make-vector vector vector-length vector-ref vector-set! procedure?
   apply map for-each call-with-current-continuation call-with-input-file
   call-with-output-file input-port? output-port? current-input-port
   current-output-port open-input-file open-output-file close-input-port
   close-output-port eof-object? read read-char peek-char write display
   newline write-char

   eval error pp compile-file-to-c compile-file link-incremental link-flat

   script-arguments
))

(##declare
  (multilisp)
  (extended-bindings)
  (not safe)
  (block)
  (fixnum)
  (inlining-limit 134)
)

;------------------------------------------------------------------------------

; Type tags

(##define-macro (type-fixnum)   0)
(##define-macro (type-subtyped) 1)
(##define-macro (type-special)  2)
(##define-macro (type-pair)     3)

; Subtype tags

(##define-macro (subtype-vector)       0)
(##define-macro (subtype-pair)         1)
(##define-macro (subtype-ratnum)       2)
(##define-macro (subtype-cpxnum)       3)
(##define-macro (subtype-structure)    4)
(##define-macro (subtype-meroon)       6)

(##define-macro (subtype-symbol)       8)
(##define-macro (subtype-keyword)      9)
(##define-macro (subtype-frame)        10)
(##define-macro (subtype-continuation) 11)
(##define-macro (subtype-promise)      12)
(##define-macro (subtype-procedure)    13)
(##define-macro (subtype-will)         14)

(##define-macro (subtype-string)       16)
(##define-macro (subtype-bignum)       17)
(##define-macro (subtype-u8vector)     25)
(##define-macro (subtype-u16vector)    26)
(##define-macro (subtype-u32vector)    27)
(##define-macro (subtype-f32vector)    28)
(##define-macro (subtype-f64vector)    29) ; for alignment these 3 must be last
(##define-macro (subtype-flonum)       30)
(##define-macro (subtype-pointer)      31)

(##define-macro (subtype-ovector? x) `(##fixnum.< ,x 8))
(##define-macro (subtype-bvector? x) `(##fixnum.< 15 ,x))

; Special objects

(##define-macro (absent-obj)
  (##namespace ("c#" absent-object))
  `',absent-object)

; Bignum related constants

(##define-macro (max-fixnum32)        536870911)
(##define-macro (min-fixnum32)       -536870912)
(##define-macro (radix)                   16384) ; must be <=sqrt(max fixnum)+1
(##define-macro (radix-width)                14)
(##define-macro (radix-minus-1)           16383)
(##define-macro (minus-radix)            -16384)
(##define-macro (max-fixnum32-div-radix)  32767) ; truncate(max fixnum / radix)
(##define-macro (min-fixnum32-div-radix) -32768) ; truncate(min fixnum / radix)
(##define-macro (max-digits-for-fixnum32)     3) ; bignum if > this many digits
(##define-macro (max-length-for-64bit)        6) ; 1+ceiling(64 / radix-width)

(##define-macro (radix-log-den)      32)
(##define-macro (r.2)                16384)
(##define-macro (r-log-rad.2)        14)
(##define-macro (radix-log-r-num.2)  32)
(##define-macro (r.8)                4096)
(##define-macro (r-log-rad.8)        4)
(##define-macro (radix-log-r-num.8)  38)
(##define-macro (r.10)               10000)
(##define-macro (r-log-rad.10)       4)
(##define-macro (radix-log-r-num.10) 34)
(##define-macro (r.16)               4096)
(##define-macro (r-log-rad.16)       3)
(##define-macro (radix-log-r-num.16) 38)

(##define-macro (max-lines)                  65536)
(##define-macro (max-fixnum32-div-max-lines)  8191)

; Flonum related constants

(##define-macro (flonum-m-bits)         52)
(##define-macro (flonum-m-bits-plus-1)  53)
(##define-macro (flonum-e-bits)         11)
(##define-macro (flonum-sign-bit)       #x8000000000000000) ; (expt 2 (+ (flonum-e-bits) (flonum-m-bits)))
(##define-macro (flonum-m-min)          4503599627370496.0) ; (expt 2.0 (flonum-m-bits))
(##define-macro (flonum-+m-min)         4503599627370496)   ; (expt 2 (flonum-m-bits))
(##define-macro (flonum-+m-max)         9007199254740991)   ; (- (* flonum-+m-min 2) 1)
(##define-macro (flonum--m-min)         -4503599627370496)  ; (- (flonum-+m-min))
(##define-macro (flonum--m-max)         -9007199254740991)  ; (- (flonum-+m-max))
(##define-macro (flonum-e-bias)         1023) ; (- (expt 2 (- (flonum-e-bits) 1)) 1)
(##define-macro (flonum-e-bias-plus-1)  1024) ; (+ (flonum-e-bias) 1)
(##define-macro (flonum-e-bias-minus-1) 1022) ; (- (flonum-e-bias) 1)
(##define-macro (flonum-e-min)          -1074) ; (- (+ (flonum-e-bias) (flonum-m-bits) -1))
(##define-macro (flonum-max-digits)     17)

(##define-macro (inexact-radix)   16384.0) ; (exact->inexact (radix))

; Dispatch for number representation

(##define-macro (number-dispatch num err fix big rat flo cpx)
  `(cond ((##fixnum? ,num)                           ,fix)
         ((##flonum? ,num)                           ,flo)
         ((##subtyped? ,num)
          (let ((##s (##subtype ,num)))
            (cond ((##fixnum.= ##s (subtype-bignum)) ,big)
                  ((##fixnum.= ##s (subtype-ratnum)) ,rat)
                  ((##fixnum.= ##s (subtype-cpxnum)) ,cpx)
                  (else                              ,err))))
         (else                                       ,err)))

; System procedure classes

(##define-macro (define-system form . exprs)

  (define inlinable-procs '(

##type ##type-cast ##subtype ##subtype-set!
##not ##null? ##unbound? ##eq? ##eof-object?
##fixnum? ##flonum? ##special? ##pair? ##subtyped? ##procedure? ##promise?
##vector? ##symbol? ##keyword? ##ratnum? ##cpxnum?
##string? ##structure? ##bignum?
##char? ;;;;  ##closure? ##subprocedure?
##fixnum.max ##fixnum.min
##fixnum.+ ##fixnum.- ##fixnum.*
##fixnum.quotient ##fixnum.remainder ##fixnum.modulo
##fixnum.logior ##fixnum.logxor ##fixnum.logand ##fixnum.lognot
##fixnum.ashr ##fixnum.lshr ##fixnum.shl
##fixnum.zero? ##fixnum.positive? ##fixnum.negative?
##fixnum.odd? ##fixnum.even?
##fixnum.= ##fixnum.< ##fixnum.> ##fixnum.<= ##fixnum.>=
##fixnum.->char ##fixnum.<-char
##flonum.->fixnum ##flonum.<-fixnum
##flonum.max ##flonum.min
##flonum.+ ##flonum.- ##flonum.*  ##flonum./
##flonum.abs ##flonum.floor ##flonum.ceiling ##flonum.round
##flonum.exp ##flonum.log
##flonum.sin ##flonum.cos ##flonum.tan
##flonum.asin ##flonum.acos ##flonum.atan
##flonum.sqrt ##flonum.copysign
##flonum.zero? ##flonum.positive? ##flonum.negative?
##flonum.finite? ##flonum.nan?
##flonum.= ##flonum.< ##flonum.> ##flonum.<= ##flonum.>=
##char=? ##char<? ##char>? ##char<=? ##char>=?
##cons ##set-car! ##set-cdr! ##car ##cdr
##caar ##cadr ##cdar ##cddr
##caaar ##caadr ##cadar ##caddr ##cdaar ##cdadr ##cddar ##cdddr
##caaaar ##caaadr ##caadar ##caaddr ##cadaar ##cadadr ##caddar ##cadddr
##cdaaar ##cdaadr ##cdadar ##cdaddr ##cddaar ##cddadr ##cdddar ##cddddr
##list
##make-cell ##cell-ref ##cell-set!
##vector
##vector-length ##vector-ref ##vector-set! ##vector-shrink!
##string
##string-length ##string-ref ##string-set! ##string-shrink!
##u8vector? ##u8vector
##u8vector-length ##u8vector-ref ##u8vector-set! ##u8vector-shrink!
##u16vector? ##u16vector
##u16vector-length ##u16vector-ref ##u16vector-set! ##u16vector-shrink!
##u32vector? ##u32vector
##u32vector-length ##u32vector-ref ##u32vector-set! ##u32vector-shrink!
##f32vector? ##f32vector
##f32vector-length ##f32vector-ref ##f32vector-set! ##f32vector-shrink!
##f64vector? ##f64vector
##f64vector-length ##f64vector-ref ##f64vector-set! ##f64vector-shrink!
##symbol->string ##keyword->string
##closure-code ##closure-ref ##closure-set!
;;; ##subprocedure-id ##subprocedure-parent
;;; ##procedure-info
##make-promise ##force ##void

##will? ##make-will ##will-owner

##global-var-ref
##global-var-set!
))

  (define kernel-procs '(

##make-string
##make-vector
##make-u8vector
##make-u16vector
##make-u32vector
##make-f32vector
##make-f64vector
##apply
##call-with-current-continuation
##make-global-var


##closure? ##subprocedure?

##subprocedure-id ##subprocedure-parent
##procedure-info

))

  (if (memq (car form) kernel-procs)
    `(begin)
    (if (and (memq (car form) inlinable-procs)
             (list? (cdr form)))
      `(define ,form ,form)
      `(define ,form ,@exprs))))

;------------------------------------------------------------------------------

; Object representation:

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Numbers

; There are 5 internal representations for numbers:
;
; fixnum, bignum, ratnum, flonum, cpxnum
;
; Fixnums and bignums form the class of exact-int.
; Fixnums, bignums and ratnums form the class of exact-real.
; Fixnums, bignums, ratnums and flonums form the class of non-cpxnum.

; The representation has some invariants:
;
; The numerator of a ratnum is a non-zero exact-int.
; The denominator of a ratnum is an exact-int greater than 1.
; The numerator and denominator have no common divisors greater than 1.
;
; The real part of a cpxnum is a non-cpxnum.
; The imaginary part of a cpxnum is a non-cpxnum != fixnum 0

; The following table gives the mapping of the Scheme exact numbers to their
; internal representation:
;
;    type          representation
; exact integer  = exact-int (fixnum, bignum)
; exact rational = exact-real (fixnum, bignum, ratnum)
; exact real     = exact-real (fixnum, bignum, ratnum)
; exact complex  = exact-real or cpxnum with exact-real real and imag parts

; For inexact numbers, the representation is not quite as straightforward.
;
; There are 3 "special" classes of inexact representation:
; flonum-int : flonum with integer value
; cpxnum-real: cpxnum with imag part = flonum 0.0
; cpxnum-int : cpxnum-real with exact-int or flonum-int real part
;
; This gives the following table for Scheme's inexact numbers:
;
;      type          representation
; inexact integer  = flonum-int or cpxnum-int
; inexact rational = flonum     or cpxnum-real
; inexact real     = flonum     or cpxnum-real
; inexact complex  = flonum     or cpxnum

(##define-macro (exact-int? x) ; x can be any object
  `(or (##fixnum? ,x) (##bignum? ,x)))

(##define-macro (exact-real? x) ; x can be any object
  `(or (exact-int? ,x) (##ratnum? ,x)))

(##define-macro (flonum-int? x) ; x must be a flonum
  `(and (##flonum.finite? ,x) (##flonum.= ,x (##flonum.floor ,x))))

(##define-macro (flonum-rational? x) ; x must be a flonum
  `(##flonum.finite? ,x))

(##define-macro (non-cpxnum-int? x) ; x must be in fixnum/bignum/ratnum/flonum
  `(if (##flonum? ,x) (flonum-int? ,x) (##not (##ratnum? ,x))))

(##define-macro (non-cpxnum-rational? x) ; x must be in fixnum/bignum/ratnum/flonum
  `(or (##not (##flonum? ,x)) (flonum-rational? ,x)))

(##define-macro (cpxnum-int? x) ; x must be a cpxnum
  `(and (cpxnum-real? ,x)
        (let ((real (cpxnum-real ,x))) (non-cpxnum-int? real))))

(##define-macro (cpxnum-rational? x) ; x must be a cpxnum
  `(let ((imag (cpxnum-imag ,x)))
     (and (##flonum? imag)
          (##flonum.zero? imag)
          (let ((real (cpxnum-real ,x)))
            (non-cpxnum-rational? real)))))

(##define-macro (cpxnum-real? x) ; x must be a cpxnum
  `(let ((imag (cpxnum-imag ,x)))
     (and (##flonum? imag)
          (##flonum.zero? imag))))

(##define-macro (inexact-+2)     2.0)
(##define-macro (inexact--2)    -2.0)
(##define-macro (inexact-+1)     1.0)
(##define-macro (inexact--1)    -1.0)
(##define-macro (inexact-+1/2)   0.5)
(##define-macro (inexact-0)      0.0)
(##define-macro (inexact-+pi)    3.141592653589793)
(##define-macro (inexact--pi)   -3.141592653589793)
(##define-macro (inexact-+pi/2)  1.5707963267948966)
(##define-macro (inexact--pi/2) -1.5707963267948966)
(##define-macro (inexact-+inf)  ''+inf.)
(##define-macro (inexact--inf)  ''-inf.)
(##define-macro (inexact-+nan)  ''+nan.)
(##define-macro (cpxnum-+2i)    +2i)
(##define-macro (cpxnum--i)     -i)
(##define-macro (cpxnum-+i)     +i)

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Symbol objects

; A symbol is represented by an object vector of length 3
; slot 0 = symbol name (string or symbol)
; slot 1 = hash code (#f or non-negative fixnum)
; slot 2 = pointer to corresponding global variable (0 if none exists)

(##define-macro (symbol-name s)        `(##vector-ref ,s 0))
(##define-macro (symbol-name-set! s x) `(##vector-set! ,s 0 ,x))
(##define-macro (symbol-hash s)        `(##vector-ref ,s 1))
(##define-macro (symbol-hash-set! s x) `(##vector-set! ,s 1 ,x))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Keyword objects

; A keyword is represented by an object vector of length 2
; slot 0 = symbol name (string or symbol) not including trailing ':'
; slot 1 = hash code (#f or non-negative fixnum)

(##define-macro (keyword-name k)        `(##vector-ref ,k 0))
(##define-macro (keyword-name-set! k x) `(##vector-set! ,k 0 ,x))
(##define-macro (keyword-hash k)        `(##vector-ref ,k 1))
(##define-macro (keyword-hash-set! k x) `(##vector-set! ,k 1 ,x))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Bignum objects

; A bignum is represented by a word vector
; slot 0    = sign
; slot 1    = least significant digit
; slot 2... = other digits

(##define-macro (bignum-make n)
  `(##subtype-set! (##make-u16vector ,n 0) (subtype-bignum)))

(##define-macro (bignum-length x)        `(##u16vector-length ,x))
(##define-macro (bignum-shrink! x n)     `(##u16vector-shrink! ,x ,n))
(##define-macro (bignum-digit-ref x i)   `(##u16vector-ref ,x ,i))
(##define-macro (bignum-digit-set! x i y) `(##u16vector-set! ,x ,i ,y))
(##define-macro (bignum-sign x)          `(##u16vector-ref ,x 0))
(##define-macro (bignum-sign* x)         `(##fixnum.- 1 (##u16vector-ref ,x 0)))
(##define-macro (bignum-sign-set! x n)   `(##u16vector-set! ,x 0 ,n))
(##define-macro (bignum-set-negative! x) `(##u16vector-set! ,x 0 0))
(##define-macro (bignum-negative? x)     `(##eq? (##u16vector-ref ,x 0) 0))
(##define-macro (bignum-set-positive! x) `(##u16vector-set! ,x 0 1))
(##define-macro (bignum-positive? x)     `(##eq? (##u16vector-ref ,x 0) 1))
(##define-macro (bignum-zero? x)         `(##eq? (##u16vector-length ,x) 1))
(##define-macro (bignum-odd? x)          `(##fixnum.odd? (##u16vector-ref ,x 1)))
(##define-macro (bignum-even? x)         `(##fixnum.even? (##u16vector-ref ,x 1)))

(##define-macro (bignum-constants) ; create these constants at compile time!
  (##namespace ("c#" make-u16vect u16vect-set!))
  (let ((v (make-vector 33 #f)))
    (let loop ((i 0) (n -16))
      (if (< n 17)
        (begin
          (if (= n 0)
            (let ((b (make-u16vect 1)))
              (u16vect-set! b 0 1)
              (vector-set! v i b))
            (let ((b (make-u16vect 2)))
              (u16vect-set! b 0 (if (< n 0) 0 1))
              (u16vect-set! b 1 (if (< n 0) (- n) n))
              (vector-set! v i b)))
          (loop (+ i 1) (+ n 1)))))
    `',v))

(##define-macro (10^-constants) ; create these constants at compile time!
  (define n 326)
  (let ((v (make-vector n #f)))
    (let loop ((i 0) (x 1))
      (if (< i n)
        (begin
          (vector-set! v i x)
          (loop (+ i 1) (* x 10)))))
    `',v))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Ratnum objects

; A ratnum is represented by an object vector of length 2
; slot 0 = numerator
; slot 1 = denominator

(##define-macro (ratnum-make num den)
  `(##subtype-set! (##vector ,num ,den) (subtype-ratnum)))

(##define-macro (ratnum-numerator x)   `(##vector-ref ,x 0))
(##define-macro (ratnum-denominator x) `(##vector-ref ,x 1))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Cpxnum objects

; A cpxnum is represented by an object vector of length 2
; slot 0 = real
; slot 1 = imag

(##define-macro (cpxnum-make r i)
  `(##subtype-set! (##vector ,r ,i) (subtype-cpxnum)))

(##define-macro (cpxnum-real x) `(##vector-ref ,x 0))
(##define-macro (cpxnum-imag x) `(##vector-ref ,x 1))

;------------------------------------------------------------------------------

(##define-macro (if-forces forces noforces)
  (if (memq 'force ##compilation-options)
    forces
    noforces))

(##define-macro (force-vars vars expr)
  (if (memq 'force ##compilation-options)
    `(let ,(map (lambda (x) `(,x (##force ,x))) vars) ,expr)
    expr))

(##define-macro (if-checks checks nochecks)
  (if (memq 'check ##compilation-options)
    checks
    nochecks))

(##define-macro (no-force vars expr)
  expr)

(##define-macro (no-check var form expr)
  expr)

(##define-macro (trap-list-lengths form)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  (if (list? form)
    `(##trap-list-lengths ',(car form) ,@(cdr form))
    `(##trap-list-lengths* ',(car form) ,@(flat (cdr form)))))

(##define-macro (trap-list form)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  (if (list? form)
    `(##trap-list ',(car form) ,@(cdr form))
    `(##trap-list* ',(car form) ,@(flat (cdr form)))))

(##define-macro (trap-open-file form)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  (if (list? form)
    `(##trap-open-file ',(car form) ,@(cdr form))
    `(##trap-open-file* ',(car form) ,@(flat (cdr form)))))

(##define-macro (trap-open-pipe form)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  (if (list? form)
    `(##trap-open-pipe ',(car form) ,@(cdr form))
    `(##trap-open-pipe* ',(car form) ,@(flat (cdr form)))))

(##define-macro (trap-load form msg)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  (if (list? form)
    `(##trap-load ,msg ',(car form) ,@(cdr form))
    `(##trap-load* ,msg ',(car form) ,@(flat (cdr form)))))

(##define-macro (trap-no-transcript form)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  (if (list? form)
    `(##trap-no-transcript ',(car form) ,@(cdr form))
    `(##trap-no-transcript* ',(car form) ,@(flat (cdr form)))))

(##define-macro (check-pair var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##pair? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-pair ',(car form) ,@(cdr form))
          `(##trap-check-pair* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-list-end var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##null? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-list ',(car form) ,@(cdr form))
          `(##trap-list* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-will var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##will? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-will ',(car form) ,@(cdr form))
          `(##trap-check-will* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-char var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##char? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-char ',(car form) ,@(cdr form))
          `(##trap-check-char* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-symbol var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##symbol? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-symbol ',(car form) ,@(cdr form))
          `(##trap-check-symbol* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-keyword var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##keyword? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-keyword ',(car form) ,@(cdr form))
          `(##trap-check-keyword* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-string var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##string? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-string ',(car form) ,@(cdr form))
          `(##trap-check-string* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-vector var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##vector? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-vector ',(car form) ,@(cdr form))
          `(##trap-check-vector* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-u8vector var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##u8vector? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-u8vector ',(car form) ,@(cdr form))
          `(##trap-check-u8vector* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-u16vector var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##u16vector? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-u16vector ',(car form) ,@(cdr form))
          `(##trap-check-u16vector* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-u32vector var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##u32vector? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-u32vector ',(car form) ,@(cdr form))
          `(##trap-check-u32vector* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-f32vector var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##f32vector? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-f32vector ',(car form) ,@(cdr form))
          `(##trap-check-f32vector* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-f64vector var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##f64vector? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-f64vector ',(car form) ,@(cdr form))
          `(##trap-check-f64vector* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-procedure var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##procedure? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-procedure ',(car form) ,@(cdr form))
          `(##trap-check-procedure* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-input-port var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (and (##port? ,var) (##input-port? ,var))
       ,expr
       ,(if (list? form)
          `(##trap-check-input-port ',(car form) ,@(cdr form))
          `(##trap-check-input-port* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-output-port var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (and (##port? ,var) (##output-port? ,var))
       ,expr
       ,(if (list? form)
          `(##trap-check-output-port ',(car form) ,@(cdr form))
          `(##trap-check-output-port* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-open-port var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##open-port? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-open-port ',(car form) ,@(cdr form))
          `(##trap-check-open-port* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-readtable var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##readtable? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-readtable ',(car form) ,@(cdr form))
          `(##trap-check-readtable* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro (check-exact-int-non-neg var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##fixnum? ,var)
       (if (##not (##fixnum.< ,var 0))
         ,expr
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form)))))
       (if (##bignum? ,var)
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form))))
         ,(if (list? form)
            `(##trap-check-exact-int ',(car form) ,@(cdr form))
            `(##trap-check-exact-int* ',(car form) ,@(flat (cdr form))))))
     ,expr))

(##define-macro (check-exact-int-range var lo hi form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##fixnum? ,var)
       (if (and (##not (##fixnum.< ,var ,lo))
                (##fixnum.< ,var ,hi))
         ,expr
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form)))))
       (if (##bignum? ,var)
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form))))
         ,(if (list? form)
            `(##trap-check-exact-int ',(car form) ,@(cdr form))
            `(##trap-check-exact-int* ',(car form) ,@(flat (cdr form))))))
     ,expr))

(##define-macro (check-exact-int-range-incl var lo hi form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##fixnum? ,var)
       (if (and (##not (##fixnum.< ,var ,lo))
                (##not (##fixnum.< ,hi ,var)))
         ,expr
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form)))))
       (if (##bignum? ,var)
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form))))
         ,(if (list? form)
            `(##trap-check-exact-int ',(car form) ,@(cdr form))
            `(##trap-check-exact-int* ',(car form) ,@(flat (cdr form))))))
     ,expr))

(##define-macro (check-exact-int8 var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##fixnum? ,var)
       (if (and (##not (##fixnum.< ,var -128))
                (##not (##fixnum.< 255 ,var)))
         ,expr
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form)))))
       (if (##bignum? ,var)
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form))))
         ,(if (list? form)
            `(##trap-check-exact-int ',(car form) ,@(cdr form))
            `(##trap-check-exact-int* ',(car form) ,@(flat (cdr form))))))
     ,expr))

(##define-macro (check-exact-int16 var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##fixnum? ,var)
       (if (and (##not (##fixnum.< ,var -32768))
                (##not (##fixnum.< 65535 ,var)))
         ,expr
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form)))))
       (if (##bignum? ,var)
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form))))
         ,(if (list? form)
            `(##trap-check-exact-int ',(car form) ,@(cdr form))
            `(##trap-check-exact-int* ',(car form) ,@(flat (cdr form))))))
     ,expr))

(##define-macro (check-exact-int32 var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (or (##fixnum? ,var) (##bignum? ,var))
       (if (and (##not (##< ,var -2147483648))
                (##not (##< 4294967295 ,var)))
         ,expr
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form)))))
       (if (##bignum? ,var)
         ,(if (list? form)
            `(##trap-check-range ',(car form) ,@(cdr form))
            `(##trap-check-range* ',(car form) ,@(flat (cdr form))))
         ,(if (list? form)
            `(##trap-check-exact-int ',(car form) ,@(cdr form))
            `(##trap-check-exact-int* ',(car form) ,@(flat (cdr form))))))
     ,expr))

(##define-macro (check-inexact-real var form expr)
  (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  `(if-checks
     (if (##flonum? ,var)
       ,expr
       ,(if (list? form)
          `(##trap-check-inexact-real ',(car form) ,@(cdr form))
          `(##trap-check-inexact-real* ',(car form) ,@(flat (cdr form)))))
     ,expr))

(##define-macro
  (define-fold bool? form zero one two forcing pre-check . post-checks)
  (let* ((name-fn (car form))
         (name-param1 (cadr form))
         (name-param2 (caddr form))
         (name-others 'others)
         (name-result 'result)
         (name-folded-result 'folded-result)
         (param-name-map
          (list (cons name-param1 'param1) (cons name-param2 'param2)))
         (two-wrap
          (if (pair? (cadr two)) (car two) #f))
         (two-call
          (if (pair? (cadr two)) (cadr two) two)))

    (define (param-name sym)
      (cdr (assq sym param-name-map)))

    (define (rewrite expr)
      (let ((x (assq expr param-name-map)))
        (if x
          (cdr x)
          (if (pair? expr)
            (cons (car expr)
                  (map rewrite (cdr expr)))
            expr))))

    (define (parameter-list)
      (if (null? zero)
        ; 1 or more arguments
        (list (param-name name-param1)
              '#!optional
              (list (param-name name-param2) '(absent-obj))
              '#!rest
              name-others)
        ; 0 or more arguments
        (list '#!optional
              (list (param-name name-param1) '(absent-obj))
              (list (param-name name-param2) '(absent-obj))
              '#!rest
              name-others)))

    (define (add-post-checks wrap expr cont)

      (define (add-wrap x)
        (if wrap
          (list wrap x)
          x))

      (define (inside lst)
        (if (null? lst)
          (if cont
            (cont (add-wrap name-result))
            (add-wrap name-result))
          (let ((check (car lst)))
            (list 'if
                  (list (car check) name-result)
                  (list (cadr check)
                        (list 'quote name-fn)
                        (param-name name-param1)
                        (param-name name-param2)
                        name-others)
                  (inside (cdr lst))))))

      (if (or cont (not (null? post-checks)))
        (list 'let
              (list (list name-result expr))
              (inside post-checks))
        (add-wrap expr)))

    (define (add-forcing names expr)
      (list forcing
            names
            expr))

    (define (add-pre-check name expr)
      (list pre-check
            name
            (cons name-fn
                  (cons (param-name name-param1)
                        (cons (param-name name-param2)
                              name-others)))
            expr))

    (define (exactly-1-arg)
      (add-forcing
       (list (param-name name-param1))
       (add-pre-check
        (param-name name-param1)
        (if (pair? one)
          (add-post-checks
           #f
           (rewrite one)
           #f)
          (rewrite one)))))

    (define (exactly-2-args)
      (add-post-checks
       two-wrap
       (rewrite two-call)
       #f))

    (define (at-least-2-args)
      (list 'let
            'loop
            (append (if bool?
                      (list (list name-folded-result #t))
                      '())
                    (list (list name-param1 (param-name name-param1))
                          (list name-param2 (param-name name-param2))
                          (list 'lst name-others)))
            (add-post-checks
             two-wrap
             two-call
             (lambda (result)
               (list 'if
                     '(##null? lst)
                     (if bool?
                       (list 'and
                             result
                             name-folded-result)
                       result)
                     (list 'let
                           '((next (##car lst)))
                           (add-forcing
                            '(next)
                            (add-pre-check
                             'next
                             (if bool?
                               (list 'loop
                                     (list 'and
                                           result
                                           name-folded-result)
                                     name-param2
                                     'next
                                     '(##cdr lst))
                               (list 'loop
                                     result
                                     'next
                                     '(##cdr lst)))))))))))

    (define (body)
      (cons 'cond
            (cons (list (list '##not
                              (list '##eq?
                                    (param-name name-param2)
                                    '(absent-obj)))
                        (add-forcing
                         (list (param-name name-param1)
                               (param-name name-param2))
                         (add-pre-check
                          (param-name name-param1)
                          (add-pre-check
                           (param-name name-param2)
;                           (list 'if
;                                 (list '##null? name-others)
;                                 (exactly-2-args)
                                 (at-least-2-args)))))
;)
                  (append (if (null? zero)
                            '()
                            (list (list (list '##eq?
                                              (param-name name-param1)
                                              '(absent-obj))
                                        zero)))
                          (list (list 'else
                                      (exactly-1-arg)))))))

    (list 'define
          name-fn
          (list 'lambda
                (parameter-list)
                (body)))))

(##define-macro
  (define-nary form zero one two forcing pre-check . post-checks)
  `(define-fold #f ,form ,zero ,one ,two ,forcing ,pre-check ,@post-checks))

(##define-macro
  (define-nary-bool form zero one two forcing pre-check . post-checks)
  `(define-fold #t ,form ,zero ,one ,two ,forcing ,pre-check ,@post-checks))

;------------------------------------------------------------------------------

; Macros for "_eval.scm" and "_repl.scm".

(##define-macro (make-global-var id) `(##make-global-var ,id))
(##define-macro (global-var-ref gv) `(##global-var-ref ,gv))
(##define-macro (global-var-set! gv val) `(##global-var-set! ,gv ,val))
(##define-macro (global-var->identifier gv) `(##global-var->identifier ,gv))

(##define-macro (quasi-list->vector x) `(##quasi-list->vector ,x))
(##define-macro (quasi-append x y) `(##quasi-append ,x ,y))
(##define-macro (quasi-cons x y) `(##quasi-cons ,x ,y))

(##define-macro (true? x) x)
(##define-macro (unbound? x) `(##unbound? ,x))

(##define-macro (self-var)     '##self-var)
(##define-macro (selector-var) '##selector-var)
(##define-macro (do-loop-var)  '##do-loop-var)

(##define-macro (rt-error-unbound-global-var code rte)
  `(##signal '##signal.global-unbound ,code ,rte))

(##define-macro (rt-error-non-procedure-send code rte)
  `(##signal '##signal.non-procedure-send ,code ,rte))

(##define-macro (rt-error-non-procedure-oper code rte)
  `(##signal '##signal.non-procedure-operator ,code ,rte))

(##define-macro (rt-error-wrong-nb-args proc args)
  `(##signal '##signal.wrong-nb-arg ,proc ,args))

(##define-macro (rt-error-unknown-keyword-arg proc args)
  `(##signal '##signal.unknown-keyword-arg ,proc ,args))

(##define-macro (rt-error-keyword-expected proc args)
  `(##signal '##signal.keyword-expected ,proc ,args))

(##define-macro (ct-error-global-env-overflow var)
  `(##signal '##signal.global-env-overflow ,var))

(##define-macro (ct-error-syntax src msg . args)
  `(##signal '##signal.syntax-error ,src ,msg ,@args))

; Macro to create a node of executable code.

(##define-macro (mk-code code-prc cte src stepper subcodes . lst)
  `(let (($code (##vector #f ,code-prc ,cte ,src ,stepper ,@subcodes ,@lst)))
     ,@(let loop ((l subcodes) (i 5) (r '()))
         (if (pair? l)
           (loop (cdr l)
                 (+ i 1)
                 (cons `(##vector-set! (##vector-ref $code ,i) 0 $code) r))
           (reverse r)))
     $code))

(##define-macro (code-link c)         `(##vector-ref ,c 0))
(##define-macro (code-cprc c)         `(##vector-ref ,c 1))
(##define-macro (code-cte c)          `(##vector-ref ,c 2))
(##define-macro (code-locat c)        `(##vector-ref ,c 3))
(##define-macro (code-locat-set! c l) `(##vector-set! ,c 3 ,l))
(##define-macro (code-stepper c)      `(##vector-ref ,c 4))
(##define-macro (code-length c)       `(##fixnum.- (##vector-length ,c) 5))
(##define-macro (code-ref c n)        `(##vector-ref ,c (##fixnum.+ ,n 5)))
(##define-macro (code-set! c n x)     `(##vector-set! ,c (##fixnum.+ ,n 5) ,x))
(##define-macro (^ n)                 `(##vector-ref $code ,(+ n 5)))

(##define-macro (is-child-code? child parent)
  `(let ((child ,child)
         (parent ,parent))
     (and (##vector? child)
          (##fixnum.< 3 (##vector-length child))
          (##eq? (code-link child) parent))))

(##define-macro (code-run c)
  `(let (($$code ,c))
     ((##vector-ref $$code 1) $$code rte)))

; Macro to create the "code procedure" associated with a code node.

(##define-macro (mk-cprc . body)
  `(let ()
     (##declare (not inline) (not interrupts-enabled) (environment-map))
     (lambda ($code rte)
       (let (($$continue
              (lambda ($code rte)
                (##declare (inline))
                ,@body)))
         (##declare (interrupts-enabled))
         ($$continue $code rte)))))

(##define-macro (mk-gen params . def)
  `(let ()
     (##declare (not inline))
     (lambda (cte tail? src ,@params) ,@def)))

(##define-macro (gen proc src . args)
  `(,proc cte tail? ,src ,@args))

(##define-macro (call-step! vars . body)      `(step! #t 1 ,vars ,@body))
(##define-macro (future-step! vars . body)    `(step! #f 2 ,vars ,@body))
(##define-macro (delay-step! vars . body)     `(step! #f 2 ,vars ,@body))
(##define-macro (lambda-step! vars . body)    `(step! #f 3 ,vars ,@body))
(##define-macro (define-step! vars . body)    `(step! #f 4 ,vars ,@body))
(##define-macro (set!-step! vars . body)      `(step! #f 5 ,vars ,@body))
(##define-macro (reference-step! vars . body) `(step! #f 6 ,vars ,@body))
(##define-macro (constant-step! vars . body)  `(step! #f 7 ,vars ,@body))

(##define-macro (make-no-stepper)
  ''#(#(#f #f #f #f #f #f #f) #f #f #f #f #f #f #f))

(##define-macro (make-step-handlers)
  '(##vector ##step-handler
             ##step-handler
             ##step-handler
             ##step-handler
             ##step-handler
             ##step-handler
             ##step-handler))

(##define-macro (make-main-stepper)
  '(##vector (##vector-copy ##step-handlers)
             #f
             #f
             #f
             #f
             #f
             #f
             #f))

(##define-macro (step! leapable? handler-index vars . body)
  `(let* (($$execute-body
           (lambda ($code rte ,@vars) ,@body))
          ($$handler
           (##vector-ref (code-stepper $code) ,handler-index)))
     (if $$handler
       ($$handler ,leapable?
                  $code
                  rte
                  (lambda ($code rte ,@vars)
                    ($$execute-body $code rte ,@vars))
                  ,@vars)
       ($$execute-body $code rte ,@vars))))

;------------------------------------------------------------------------------

; Macros to manipulate the runtime environment

(##define-macro (mk-rte rte . lst)
  `(##vector ,rte ,@lst))

(##define-macro (mk-rte* rte ns)
  `(let (($rte (##make-vector (##fixnum.+ ,ns 1) (##void))))
     (##vector-set! $rte 0 ,rte)
     $rte))

(##define-macro (rte-up rte)         `(##vector-ref ,rte 0))
(##define-macro (rte-ref rte i)      `(##vector-ref ,rte ,i))
(##define-macro (rte-set! rte i val) `(##vector-set! ,rte ,i ,val))

;==============================================================================