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

; file: "_system.scm"

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

(##include "header.scm")

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

; System procedures

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

(define-system (##type x))
(define-system (##type-cast x y))
(define-system (##subtype x))
(define-system (##subtype-set! x y))

(define-system (##unbound? x))

(define-system (##fixnum? x)
  (##eq? (##type x) (type-fixnum)))

(define-system (##special? x)
  (##eq? (##type x) (type-special)))

(define-system (##subtyped? x)
  (##eq? (##type x) (type-subtyped)))

(define-system (##promise? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-promise))))

(define-system (##ratnum? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-ratnum))))

(define-system (##cpxnum? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-cpxnum))))

(define-system (##structure? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-structure))))

(define-system (##pointer? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-pointer))))

(define-system (##bignum? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-bignum))))

(define-system (##flonum? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-flonum))))

(define-system (##closure? x))

(define-system (##closure-code x))

(define-system (##closure-ref x y))

(define-system (##closure-set! x y z))

(define-system (##subprocedure? x))

(define-system (##subprocedure-id x))

(define-system (##subprocedure-parent x))

(define-system (##procedure-info x))

(define-system (##make-cell x)
  (##cons x '()))

(define-system (##cell-ref x)
  (##car x))

(define-system (##cell-set! x y)
  (##set-car! x y))

(define-system (##make-promise thunk))

(define-system (##force x))

(define-system (##void))

(define (##first-argument arg1 #!optional arg2 arg3 #!rest l)
  arg1)

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

; Variants of standard procedures.

; Most of these procedures do not force their arguments and are mostly
; of fixed arity.

(define-system (##not x)
  (if x #f #t))

; ##eqv? is defined in "_num1.scm"

(define-system (##eq? x y))

(define-system (##equal? x y force?)

  (define (equal x y)

    (define (ovector=? x y)
      (let ((len (##vector-length x)))
        (if (##eq? len (##vector-length y))
          (let loop ((i (##fixnum.- len 1)))
            (cond ((##fixnum.< i 0)
                  #t)
                  ((equal (##vector-ref x i) (##vector-ref y i))
                   (loop (##fixnum.- i 1)))
                  (else
                   #f)))
          #f)))

    (cond ((##pair? x)
           (and (##pair? y)
                (equal (##car x) (##car y))
                (equal (##cdr x) (##cdr y))))
          ((##subtyped? x)
           (and (##subtyped? y)
                (let ((tag (##subtype x)))
                  (and (##eq? tag (##subtype y))
                       (cond ((subtype-ovector? tag)
                              (ovector=? x y))
                             ((subtype-bvector? tag)
                              (##bvector=? x y))
                             (else
                              (##eq? x y)))))))
          (else
           (##eq? x y))))

  (define (equal* x y)

    (define (ovector=? x y)
      (let ((len (##vector-length x)))
        (if (##eq? len (##vector-length y))
          (let loop ((i (##fixnum.- len 1)))
            (cond ((##fixnum.< i 0)
                  #t)
                  ((equal* (##vector-ref x i) (##vector-ref y i))
                   (loop (##fixnum.- i 1)))
                  (else
                   #f)))
          #f)))

    (let ((x (##force x)) (y (##force y)))
      (cond ((##pair? x)
             (and (##pair? y)
                  (equal* (##car x) (##car y))
                  (equal* (##cdr x) (##cdr y))))
            ((##subtyped? x)
             (and (##subtyped? y)
                  (let ((tag (##subtype x)))
                    (and (##eq? tag (##subtype y))
                         (cond ((subtype-ovector? tag)
                                (ovector=? x y))
                               ((subtype-bvector? tag)
                                (##bvector=? x y))
                               (else
                                (##eq? x y)))))))
            (else
             (##eq? x y)))))

  (if force?
    (equal* x y)
    (equal x y)))

(define (##bvector=? x y)

  (define (u16vect=? x y len)
    (let loop ((i (##fixnum.- len 1)))
      (cond ((##fixnum.< i 0)
             #t)
            ((##eq? (##u16vector-ref x i) (##u16vector-ref y i))
             (loop (##fixnum.- i 1)))
            (else
             #f))))

  (let ((len (##u8vector-length x)))
    (and (##eq? len (##u8vector-length y))
         (if (##fixnum.odd? len)
           (let ((i (##fixnum.- len 1)))
             (and (##eq? (##u8vector-ref x i) (##u8vector-ref y i))
                  (u16vect=? x y (##fixnum.quotient i 2))))
           (u16vect=? x y (##fixnum.quotient len 2))))))

(define-system (##pair? x))

(define-system (##cons x y))

(define-system (##set-car! x y))

(define-system (##set-cdr! x y))

(define-system (##car x))

(define-system (##cdr x))

(##define-macro (define-c...r name pattern)

  (define (gen name pattern)
    (if (<= pattern 3)
       (if (= pattern 3) '(##cdr x) '(##car x))
       (let ((x (gen name (quotient pattern 2))))
         (if (odd? pattern) '(##cdr ,x) '(##car ,x)))))

  `(define-system (,name x)
     ,(gen name pattern)))

(define-c...r ##caar 4)
(define-c...r ##cadr 5)
(define-c...r ##cdar 6)
(define-c...r ##cddr 7)
(define-c...r ##caaar 8)
(define-c...r ##caadr 9)
(define-c...r ##cadar 10)
(define-c...r ##caddr 11)
(define-c...r ##cdaar 12)
(define-c...r ##cdadr 13)
(define-c...r ##cddar 14)
(define-c...r ##cdddr 15)
(define-c...r ##caaaar 16)
(define-c...r ##caaadr 17)
(define-c...r ##caadar 18)
(define-c...r ##caaddr 19)
(define-c...r ##cadaar 20)
(define-c...r ##cadadr 21)
(define-c...r ##caddar 22)
(define-c...r ##cadddr 23)
(define-c...r ##cdaaar 24)
(define-c...r ##cdaadr 25)
(define-c...r ##cdadar 26)
(define-c...r ##cdaddr 27)
(define-c...r ##cddaar 28)
(define-c...r ##cddadr 29)
(define-c...r ##cdddar 30)
(define-c...r ##cddddr 31)

(define-system (##will? x))
(define-system (##make-will x y))
(define-system (##will-owner x))

(define-system (##null? x)
  (##eq? x '()))

(define-system (##list . l)
  l)

(define-system (##length l)
  (let loop ((l l) (n 0))
    (if (##pair? l)
      (loop (##cdr l) (##fixnum.+ n 1))
      n)))

(define-system (##append l1 l2)
  (if (##pair? l1)
    (let ((result (##cons (##car l1) '())))
      (##set-cdr!
        (let loop ((end result) (l1 (##cdr l1)))
          (if (##pair? l1)
            (let ((tail (##cons (##car l1) '())))
              (##set-cdr! end tail)
              (loop tail (##cdr l1)))
            end))
        l2)
      result)
    l2))

(define-system (##reverse l)
  (let loop ((l l) (x '()))
    (if (##pair? l)
      (loop (##cdr l) (##cons (##car l) x))
      x)))

(define-system (##memq x l)
  (let loop ((l l))
    (if (##pair? l)
      (if (##eq? x (##car l))
        l
        (loop (##cdr l)))
      #f)))

(define-system (##member x l)
  (let loop ((l l))
    (if (##pair? l)
      (if (##equal? x (##car l) #f)
        l
        (loop (##cdr l)))
      #f)))

(define-system (##assq x l)
  (let loop ((y l))
    (if (##pair? y)
      (let ((couple (##car y)))
        (if (##eq? x (##car couple))
          couple
          (loop (##cdr y))))
        #f)))

(define (##assq-cdr x l)
  (let loop ((y l))
    (if (##pair? y)
      (let ((couple (##car y)))
        (if (##eq? x (##cdr couple))
          couple
          (loop (##cdr y))))
        #f)))

(define-system (##assoc x lst)
  (let loop ((lst lst))
    (if (##pair? lst)
      (let ((couple (##car lst)))
        (let ((y (##car couple)))
          (if (##equal? x y #f)
            couple
            (loop (##cdr lst)))))
      #f)))

(define-system (##symbol? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-symbol))))

(define-system (##symbol->string sym)
  (symbol-name sym))

(define-system (##symbol-hash sym)
  (symbol-hash sym))

(define-system (##string->symbol str)
  (##make-interned-symbol str))

(define-system (##keyword? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-keyword))))

(define-system (##keyword->string key)
  (keyword-name key))

(define-system (##keyword-hash key)
  (keyword-hash key))

(define-system (##string->keyword str)
  (##make-interned-keyword str))

; numeric procedures are in "_num1.scm"

; character procedures are in "_std.scm"

; string procedures are in "_std.scm"

; vector procedures are in "_std.scm"

(define-system (##procedure? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-procedure))))

(define-system (##apply p l))

(define-system (##map p lst)
  (let loop ((lst lst))
    (if (##pair? lst)
      (##cons (p (##car lst)) (loop (##cdr lst)))
      '())))

(define-system (##for-each p lst)
  (let loop ((lst lst))
    (if (##pair? lst)
      (begin (p (##car lst)) (loop (##cdr lst)))
      '())))

(define-system (##call-with-current-continuation p))

; input/output procedures are in "ports.scm"

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

; Procedures for front end

(define-system (##quasi-append x y)
  (force-vars (x)
    (if (##pair? x)
      (let ((result (##cons (##car x) '())))
        (##set-cdr!
          (let loop ((end result) (x (##cdr x)))
            (force-vars (x)
              (if (##pair? x)
                (let ((tail (##cons (##car x) '())))
                  (##set-cdr! end tail)
                  (loop tail (##cdr x)))
                end)))
          y)
        result)
      y)))

(define-system (##quasi-list . l)
  l)

(define-system (##quasi-cons x y)
  (##cons x y))

(define-system (##quasi-list->vector l)
  (let loop1 ((x l) (n 0))
    (force-vars (x)
      (if (##pair? x)
        (loop1 (##cdr x) (##fixnum.+ n 1))
        (let ((vect (##make-vector n #f)))
          (let loop2 ((x l) (i 0))
            (force-vars (x)
              (if (##pair? x)
                (begin
                  (##vector-set! vect i (##car x))
                  (loop2 (##cdr x) (##fixnum.+ i 1)))
                vect))))))))

(define-system (##case-memv x l)
  (force-vars (x)
    (let loop ((l l))
      (if (##pair? l)
        (if (let () (##declare (generic)) (##eqv? x (##car l)))
          l
          (loop (##cdr l)))
        #f))))

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

; Global variables

(define-system (##make-global-var id))

(define-system (##global-var-ref gv))

(define-system (##global-var-set! gv val))

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

; Dynamic environment stuff:

(define ##dynamic-global-env '())

(define-system (##dynamic-define name #!optional (val (absent-obj)))
  (let ((env ##dynamic-global-env))
    (let loop ((l env))
      (if (##pair? l)
        (let ((couple (##car l)))
          (if (##eq? (##car couple) name)
            (begin (##set-cdr! couple val) (##void))
            (loop (##cdr l))))
        (begin
          (set! ##dynamic-global-env
                (##cons (##cons name
                                (if (##eq? val (absent-obj))
                                  (##void)
                                  val))
                        env))
          (##void))))))

(define-system (##dynamic-ref name #!optional (default (absent-obj)))
  (let loop1 ((l1 (##dynamic-env-ref)))
    (cond ((##pair? l1)
           (let loop2 ((l2 (##car l1)))
             (if (##pair? l2)
               (let ((couple (##car l2)))
                 (if (##eq? (##car couple) name)
                   (##cdr couple)
                   (loop2 (##cdr l2))))
               (loop1 (##cdr l1)))))
          (else
           (let loop3 ((l3 ##dynamic-global-env))
             (if (##pair? l3)
               (let ((couple (##car l3)))
                 (if (##eq? (##car couple) name)
                   (##cdr couple)
                   (loop3 (##cdr l3))))
               (if (##eq? default (absent-obj))
                 (##signal '##signal.unbound-dynamic-var name)
                 default)))))))

(define-system (##dynamic-set! name val)
  (let loop1 ((l1 (##dynamic-env-ref)))
    (cond ((##pair? l1)
           (let loop2 ((l2 (##car l1)))
             (if (##pair? l2)
               (let ((couple (##car l2)))
                 (if (##eq? (##car couple) name)
                   (begin (##set-cdr! couple val) (##void))
                   (loop2 (##cdr l2))))
               (loop1 (##cdr l1)))))
          (else
           (let loop3 ((l3 ##dynamic-global-env))
             (if (##pair? l3)
               (let ((couple (##car l3)))
                 (if (##eq? (##car couple) name)
                   (begin (##set-cdr! couple val) (##void))
                   (loop3 (##cdr l3))))
               (##signal '##signal.unbound-dynamic-var name)))))))

(define-system (##dynamic-let bindings thunk)
  (let ((env (##dynamic-env-ref)))
    (##dynamic-env-bind (##cons bindings env) thunk)))

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

; Jobs

(define (##make-jobs)
  (##make-queue))

(define (##add-job jobs h)
  (##queue-put! jobs h))

(define (##invoke-jobs jobs)
  (let loop ((lst (##queue-peek-list jobs)))
    (if (##pair? lst)
      (begin
        ((##car lst))
        (loop (##cdr lst))))))

(define (##make-queue)
  (let ((queue (##cons '() '())))
    (##set-car! queue queue)
    queue))

(define (##queue-put! queue x)
  (##declare (not interrupts-enabled))
  (let ((last (##cons x '())))
    (##set-cdr! (##car queue) last)
    (##set-car! queue last)
    queue))

(define (##queue-peek-list queue)
  (##cdr queue))

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