;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

(##declare
  (multilisp)
  (extended-bindings)
  (not safe)
  (not autotouch)
  (block)
  (fixnum))

(##include "config.scm") ; include target dependent stuff

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

; Object representation:

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

; Symbol objects

; A symbol is represented by an object vector of length 3
; slot 0 = symbol string
; slot 1 = property list
; slot 2 = corresponding global variable

(##define-macro (symbol-make str)
  `(##vector-set!
     (##vector-set!
       (##vector-set!
         (##subtype-set! (##make-vector 3 #f) (subtype-symbol))
         2
         #f)
       1
       '())
     0
     ,str))

(##define-macro (symbol-string s)          `(##vector-ref ,s 0))
(##define-macro (symbol-string-set! s x)   `(##vector-set! ,s 0 ,x))
(##define-macro (symbol-plist s)           `(##vector-ref ,s 1))
(##define-macro (symbol-plist-set! s x)    `(##vector-set! ,s 1 ,x))
(##define-macro (symbol-glob-var s)        `(##vector-ref ,s 2))
(##define-macro (symbol-glob-var-set! s x) `(##vector-set! ,s 2 ,x))

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

; Port objects

; A port is represented by an object vector of length 11
; slot 0 = 0 for input port, 1 for input-output, 2 for output port (type+4 when closed)
; slot 1 = filename
; slot 2 = read procedure
; slot 3 = write procedure
; slot 4 = ready procedure
; slot 5 = close procedure
; slot 6 = pos currently at in read buffer
; slot 7 = length of active part of read buffer
; slot 8 = read buffer
; slot 9 = write buffer
; slot 10 = misc.

(##define-macro (port-make)
  `(##subtype-set! (##make-vector 11 #f) (subtype-port)))

(##define-macro (port-kind p)         `(##vector-ref ,p 0))
(##define-macro (port-kind-set! p x)  `(##vector-set! ,p 0 ,x))
(##define-macro (port-name p)         `(##vector-ref ,p 1))
(##define-macro (port-name-set! p x)  `(##vector-set! ,p 1 ,x))
(##define-macro (port-read p)         `(##vector-ref ,p 2))
(##define-macro (port-read-set! p x)  `(##vector-set! ,p 2 ,x))
(##define-macro (port-write p)        `(##vector-ref ,p 3))
(##define-macro (port-write-set! p x) `(##vector-set! ,p 3 ,x))
(##define-macro (port-ready p)        `(##vector-ref ,p 4))
(##define-macro (port-ready-set! p x) `(##vector-set! ,p 4 ,x))
(##define-macro (port-close p)        `(##vector-ref ,p 5))
(##define-macro (port-close-set! p x) `(##vector-set! ,p 5 ,x))
(##define-macro (port-pos p)          `(##vector-ref ,p 6))
(##define-macro (port-pos-set! p x)   `(##vector-set! ,p 6 ,x))
(##define-macro (port-len p)          `(##vector-ref ,p 7))
(##define-macro (port-len-set! p x)   `(##vector-set! ,p 7 ,x))
(##define-macro (port-rbuf p)         `(##vector-ref ,p 8))
(##define-macro (port-rbuf-set! p x)  `(##vector-set! ,p 8 ,x))
(##define-macro (port-wbuf p)         `(##vector-ref ,p 9))
(##define-macro (port-wbuf-set! p x)  `(##vector-set! ,p 9 ,x))
(##define-macro (port-misc p)         `(##vector-ref ,p 10))
(##define-macro (port-misc-set! p x)  `(##vector-set! ,p 10 ,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-vector16 ,n 0) (subtype-bignum)))

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

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

; 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)
  `(##vector-set!
     (##vector-set!
       (##subtype-set! (##make-vector 2 0) (subtype-ratnum))
       1
       ,den)
     0
     ,num))

(##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)
  `(##vector-set!
     (##vector-set!
       (##subtype-set! (##make-vector 2 0) (subtype-cpxnum))
       1
       ,i)
     0
     ,r))

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

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

(##define-macro (if-touches touches notouches)
  (if (memq 'TOUCH ##compilation-options)
    touches
    notouches))

(##define-macro (touch-vars vars expr)
  (if (memq 'TOUCH ##compilation-options)
    `(LET ,(map (lambda (x) `(,x (##TOUCH ,x))) vars) ,expr)
    expr))

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

(##define-macro (no-touch 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-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-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-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-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-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 (##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 (##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 (##NOT (##CLOSED-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-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 (##NOT (##FIXNUM.< ,var ,lo))
         (IF (##FIXNUM.< ,var ,hi)
           ,expr
           ,(if (list? form)
              `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
              `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form)))))
         ,(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 (##NOT (##FIXNUM.< ,var ,lo))
         (IF (##NOT (##FIXNUM.< ,hi ,var))
           ,expr
           ,(if (list? form)
              `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
              `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form)))))
         ,(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 (define-nary0 form no-args one-arg two-args touching)
  (let ((name   (car form))
        (param1 (cadr form))
        (param2 (caddr form)))
    `(DEFINE (,name (,param1) (,param2) . OTHERS)
       (IF (##UNASSIGNED? ,param1)
         ,no-args
         (,touching (,param1)
           (IF (##UNASSIGNED? ,param2)
             ,one-arg
             (,touching (,param2)
               (IF (##NOT (##PAIR? OTHERS))
                 ,two-args
                 (LET LOOP ((,param1 ,two-args) (OTHERS OTHERS))
                   (IF (##PAIR? OTHERS)
                     (LET ((,param2 (##CAR OTHERS)))
                       (,touching (,param2)
                         (LOOP ,two-args (##CDR OTHERS))))
                     ,param1))))))))))

(##define-macro (define-nary1 form one-arg two-args touching)
  (let ((name   (car form))
        (param1 (cadr form))
        (param2 (caddr form)))
    `(DEFINE (,name ,param1 (,param2) . OTHERS)
       (,touching (,param1)
         (IF (##UNASSIGNED? ,param2)
           ,one-arg
           (,touching (,param2)
             (IF (##NOT (##PAIR? OTHERS))
               ,two-args
               (LET LOOP ((,param1 ,two-args) (OTHERS OTHERS))
                 (IF (##PAIR? OTHERS)
                   (LET ((,param2 (##CAR OTHERS)))
                     (,touching (,param2)
                       (LOOP ,two-args (##CDR OTHERS))))
                   ,param1)))))))))

(##define-macro (define-nary0-boolean form two-args checking touching)
  (let ((name   (car form))
        (param1 (cadr form))
        (param2 (caddr form)))
    `(DEFINE (,name (,param1) (,param2) . OTHERS)
       (IF (##UNASSIGNED? ,param1)
         #T
         (,touching (,param1)
           (IF (##UNASSIGNED? ,param2)
             #T
             (,touching (,param2)
               (,checking ,param1 (,name ,param1 ,param2 . OTHERS)
                 (,checking ,param2 (,name ,param1 ,param2 . OTHERS)
                   (IF (##NOT (##PAIR? OTHERS))
                     ,two-args
                     (AND ,two-args
                          (LET ((TEMP1 ,param1) (TEMP2 ,param2))
                            (LET LOOP ((,param1 ,param2) (TEMP3 OTHERS))
                              (IF (##PAIR? TEMP3)
                                (LET ((,param2 (##CAR TEMP3)))
                                  (,touching (,param2)
                                    (,checking ,param2 (,name TEMP1 TEMP2 . OTHERS)
                                      (AND ,two-args
                                           (LOOP ,param2 (##CDR TEMP3))))))
                                #T))))))))))))))

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