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

;; "_system.scm"

(##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 (##unassigned? x)
  (##eq? x ##unass-object))

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

(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 (##placeholder? x)
  (##eq? (##type x) (type-placeholder)))

(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 (##bignum? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-bignum))))

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

(define-system (##vector-shrink! x y))

(define-system (##string-shrink! x y)
  (##vector8-shrink x y))

(define-system (##make-vector8 x y)
  (##make-string x (##type-cast y (type-special))))

(define-system (##vector8-length x)
  (##string-length x))

(define-system (##vector8-ref x y)
  (##type-cast (##string-ref x y) (type-fixnum)))

(define-system (##vector8-set! x y z)
  (##string-set! x y (##type-cast z (type-special))))

(define-system (##vector8-shrink! x y)
  (##string-shrink x y))

(define-system (##make-vector16 x y)
  (let ((v (##make-vector8 (##fixnum.* x 2) 0)))
    (let loop ((i (##fixnum.- x 1)))
      (if (##not (##fixnum.< i 0))
        (begin
          (##vector16-set! v i y)
          (loop (##fixnum.- i 1)))))
    v))

(define-system (##vector16-length x)
  (##fixnum.quotient (##vector8-length x) 2))

(define-system (##vector16-ref x y)
  (let ((i (##fixnum.* y 2)))
    (##fixnum.+ (##fixnum.* (##vector8-ref x i) 256)
                (##vector8-ref x (##fixnum.+ i 1)))))

(define-system (##vector16-set! x y z)
  (let ((i (##fixnum.* y 2)))
    (##vector8-set! x i (##fixnum.quotient z 256))
    (##vector8-set! x (##fixnum.+ i 1) (##fixnum.modulo z 256))))

(define-system (##vector16-shrink! x y)
  (##vector8-shrink x (##fixnum.* y 2)))

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

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

(define-system (##pstate))

(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 (##touch x))

(define-system (##startup)
  (let loop ((i 1))
    (let ((ev ##exec-vector))
      (let ((len (##vector-length ev)))
        (if (##fixnum.< i len)
          (if (##fixnum.= i (##fixnum.- len 1))
            ((##vector-ref ev i))
            (begin
              ((##vector-ref ev i))
              (loop (##fixnum.+ i 1)))))))))

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

; SPECIAL objects

(define ##undef-object   (##type-cast (data-undef)   (type-special)))
(define ##unass-object   (##type-cast (data-unass)   (type-special)))
(define ##unbound-object (##type-cast (data-unbound) (type-special)))
(define ##eof-object     (##type-cast (data-eof)     (type-special)))

(define ##unprint-object ##undef-object)

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

; Variants of standard procedures.

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

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

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

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

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

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

  (define (equal x y)

    (define (vector=? 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 ((##eq? x y)
           #t)
          ((##pair? x)
           (and (##pair? y)
                (equal (##car x) (##car y))
                (equal (##cdr x) (##cdr y))))
          ((##symbol? x)
           #f)
          ((##subtyped? x)
           (and (##subtyped? y)
                (let ((tag (##subtype x)))
                  (if (##eq? tag (##subtype y))
                    (if (subtype-ovector? tag)
                      (vector=? x y)
                      (vector8=? x y))
                    #f))))
          (else
           #f)))

  (define (equal* x y)

    (define (vector=? 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 (##touch x)) (y (##touch y)))
      (cond ((##eq? x y)
             #t)
            ((##pair? x)
             (and (##pair? y)
                  (equal* (##car x) (##car y))
                  (equal* (##cdr x) (##cdr y))))
            ((##symbol? x)
             #f)
            ((##subtyped? x)
             (and (##subtyped? y)
                  (let ((tag (##subtype x)))
                    (if (##eq? tag (##subtype y))
                      (if (subtype-ovector? tag)
                        (vector=? x y)
                        (vector8=? x y))
                      #f))))
            (else
             #f))))

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

(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 (##weak-pair? x))
(define-system (##weak-cons x y))
(define-system (##weak-set-car! x y))
(define-system (##weak-set-cdr! x y))
(define-system (##weak-car x))
(define-system (##weak-cdr 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 (##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-system (##symbol? x)
  (and (##subtyped? x)
       (##eq? (##subtype x) (subtype-symbol))))

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

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

  (define (hash str n)
    (let ((len (##string-length str)))
      (let loop ((h 0) (i 0))
        (if (##not (##fixnum.< i len))
          h
          (let ((x (##fixnum.+ (##fixnum.* h 256)
                               (##type-cast (##string-ref str i)
                                            (type-fixnum)))))
            (loop (##fixnum.remainder x n) (##fixnum.+ i 1)))))))

  (let ((h (hash str (##vector-length ##symbol-table))))
    (let loop ((l (##vector-ref ##symbol-table h)))
      (cond ((##not (##pair? l))
             (let ((sym (symbol-make (##string-copy str))))
               (##vector-set! ##symbol-table h
                 (##cons sym (##vector-ref ##symbol-table h)))
               sym))
            ((##string=? (symbol-string (##car l)) str)
             (##car l))
            (else
             (loop (##cdr l)))))))

(define-system (##string->uninterned-symbol str)
  (symbol-make (##string-copy str)))

; numeric procedures are in "_numbers.scm"

(define-system (##char? x)
  (and (##eq? (##type x) (type-special))
       (let ((y (##type-cast x (type-fixnum))))
         (and (##fixnum.< 0 y) (##fixnum.< y (char-range))))))

(define-nary0-boolean (##char=? x y)
  (##eq? x y) no-check no-touch)

(define-nary0-boolean (##char<? x y)
  (##char<? x y) no-check no-touch)

(define-nary0-boolean (##char>? x y)
  (##char<? y x) no-check no-touch)

(define-nary0-boolean (##char<=? x y)
  (##not (##char<? y x)) no-check no-touch)

(define-nary0-boolean (##char>=? x y)
  (##not (##char<? x y)) no-check no-touch)

(define-nary0-boolean (##char-ci=? x y)
  (##char=? (##char-downcase x) (##char-downcase y)) no-check no-touch)

(define-nary0-boolean (##char-ci<? x y)
  (##char<? (##char-downcase x) (##char-downcase y)) no-check no-touch)

(define-nary0-boolean (##char-ci>? x y)
  (##char<? (##char-downcase y) (##char-downcase x)) no-check no-touch)

(define-nary0-boolean (##char-ci<=? x y)
  (##not (##char<? (##char-downcase y) (##char-downcase x))) no-check no-touch)

(define-nary0-boolean (##char-ci>=? x y)
  (##not (##char<? (##char-downcase x) (##char-downcase y))) no-check no-touch)

(define-system (##char-alphabetic? c)
  (let ((x (##char-downcase c)))
    (and (##not (##char<? x #\a)) (##not (##char<? #\z x)))))

(define-system (##char-numeric? c)
  (and (##not (##char<? c #\0)) (##not (##char<? #\9 c))))

(define-system (##char-whitespace? c)
  (char-whitespace c))

(define-system (##char-upper-case? c)
  (and (##not (##char<? c #\A)) (##not (##char<? #\Z c))))

(define-system (##char-lower-case? c)
  (and (##not (##char<? c #\a)) (##not (##char<? #\z c))))

(define-system (##char->integer c)
  (##type-cast c (type-fixnum)))

(define-system (##integer->char n)
  (##type-cast n (type-special)))

(define-system (##char-upcase c)
  (if (and (##not (##char<? c #\a)) (##not (##char<? #\z c)))
    (##type-cast (##fixnum.- (##type-cast c (type-fixnum)) (char-up-to-down))
                 (type-special))
    c))

(define-system (##char-downcase c)
  (if (and (##not (##char<? c #\A)) (##not (##char<? #\Z c)))
    (##type-cast (##fixnum.+ (##type-cast c (type-fixnum)) (char-up-to-down))
                 (type-special))
    c))

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

(define-system (##make-string x y)
  (##make-vector8 x (##type-cast y (type-fixnum))))

(define-system (##string-length str)
  (##vector8-length str))

(define-system (##string-ref str i)
  (##type-cast (##vector8-ref str i) (type-special)))

(define-system (##string-set! str i c)
  (##vector8-set! str i (##type-cast c (type-fixnum))))

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

(define-system (##string<? x y)
  (let ((lx (##string-length x))
        (ly (##string-length y)))
    (let ((n (if (##fixnum.< lx ly) lx ly)))
      (let loop ((i 0))
        (if (##fixnum.< i n)
          (let ((cx (##string-ref x i))
                (cy (##string-ref y i)))
            (if (##char=? cx cy)
              (loop (##fixnum.+ i 1))
              (##char<? cx cy)))
          (##fixnum.< n ly))))))

(define-system (##string>? x y)
  (##string<? y x))

(define-system (##string<=? x y)
  (##not (##string<? y x)))

(define-system (##string>=? x y)
  (##not (##string<? x y)))

(define-system (##string-ci=? x y)
  (let ((len (##string-length x)))
    (if (##eq? len (##string-length y))
      (let loop ((i (##fixnum.- len 1)))
        (cond ((##fixnum.< i 0)
               #t)
              ((##char=? (##char-downcase (##string-ref x i))
                         (##char-downcase (##string-ref y i)))
               (loop (##fixnum.- i 1)))
              (else
               #f)))
      #f)))

(define-system (##string-ci<? x y)
  (let ((lx (##string-length x))
        (ly (##string-length y)))
    (let ((n (if (##fixnum.< lx ly) lx ly)))
      (let loop ((i 0))
        (if (##fixnum.< i n)
          (let ((cx (##char-downcase (##string-ref x i)))
                (cy (##char-downcase (##string-ref y i))))
            (if (##char=? cx cy)
              (loop (##fixnum.+ i 1))
              (##char<? cx cy)))
          (##fixnum.< n ly))))))

(define-system (##string-ci>? x y)
  (##string-ci<? y x))

(define-system (##string-ci<=? x y)
  (##not (##string-ci<? y x)))

(define-system (##string-ci>=? x y)
  (##not (##string-ci<? x y)))

(define-system (##substring x y z)
  (let* ((n (##fixnum.- z y))
         (result (##make-string n #\space)))
    (let loop ((i (##fixnum.- n 1)))
      (if (##not (##fixnum.< i 0))
        (begin
          (##string-set! result i (##string-ref x (##fixnum.+ y i)))
          (loop (##fixnum.- i 1)))))
    result))

(define-system (##string-append . l)
  (let loop1 ((n 0) (x l) (y '()))
    (if (##pair? x)
      (let ((s (##car x)))
        (loop1 (##fixnum.+ n (##string-length s)) (##cdr x) (##cons s y)))
      (let ((result (##make-string n #\space)))
        (let loop2 ((k (##fixnum.- n 1)) (y y))
          (if (##pair? y)
            (let ((s (##car y)))
              (let loop3 ((i k) (j (##fixnum.- (##string-length s) 1)))
                (if (##not (##fixnum.< j 0))
                  (begin
                    (##string-set! result i (##string-ref s j))
                    (loop3 (##fixnum.- i 1) (##fixnum.- j 1)))
                  (loop2 i (##cdr y)))))
            result))))))

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

(define-system (##make-vector x y))

(define-system (##vector-length vect))

(define-system (##vector-ref str i))

(define-system (##vector-set! str i c))

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

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

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

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

(define-system (##string-copy str)
  (let* ((n (##string-length str))
         (result (##make-string n #\space)))
    (let loop ((i (##fixnum.- n 1)))
      (if (##fixnum.< i 0)
        result
        (begin
          (##string-set! result i (##string-ref str i))
          (loop (##fixnum.- i 1)))))))

(define-system (##vector->list vect)
  (let loop ((l '()) (i (##fixnum.- (##vector-length vect) 1)))
    (if (##fixnum.< i 0)
      l
      (loop (##cons (##vector-ref vect i) l) (##fixnum.- i 1)))))

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

; Procedures for front end

(define-system (##quasi-append x y)
  (touch-vars (x)
    (if (##pair? x)
      (let ((result (##cons (##car x) '())))
        (##set-cdr!
          (let loop ((end result) (x (##cdr x)))
            (touch-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))
    (touch-vars (x)
      (if (##pair? x)
        (loop1 (##cdr x) (##fixnum.+ n 1))
        (let ((vect (##make-vector n #f)))
          (let loop2 ((x l) (i 0))
            (touch-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)
  (touch-vars (x)
    (let loop ((l l))
      (if (##pair? l)
        (if (##eqv? x (##car l))
          l
          (loop (##cdr l)))
        #f))))

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

; Global variables

(define-system (##global-var sym))

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

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

(define (##object->global-var-name val)
  (let loop ((ind 0))
    (if (##fixnum.< ind ##global-var-count)
      (if (##eq? (##global-var-ref ind) val)
        (##index->global-var-name ind)
        (loop (##fixnum.+ ind 1)))
      #f)))

(define (##index->global-var-name ind)
  (let loop1 ((i (##fixnum.- (##vector-length ##symbol-table) 1)))
    (if (##fixnum.< i 0)
      #f
      (let loop2 ((l (##vector-ref ##symbol-table i)))
        (if (##null? l)
          (loop1 (##fixnum.- i 1))
          (let ((sym (##car l)))
            (if (##eq? ind (symbol-glob-var sym))
              sym
              (loop2 (##cdr l)))))))))

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

; Dynamic environment stuff:

(define-system (##dynamic-ref name (default))
  (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)))))
          ((##unassigned? default)
           (##signal '##SIGNAL.UNBOUND-DYNAMIC-VAR name))
          (else
           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) ##undef-object)
                   (loop2 (##cdr l2))))
               (loop1 (##cdr l1)))))
          (else
           (##signal '##SIGNAL.UNBOUND-DYNAMIC-VAR name)))))

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

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

; Benchmarking stuff

(define-system (##benchmark thunk)
  (let ((buf1 (##make-vector 2 0))
        (buf2 (##make-vector 2 0)))
    (##cpu-times buf1)
    (let ((real1 (##real-time)))
      (let ((result (thunk)))
        (let ((real2 (##real-time)))
          (##cpu-times buf2)
          (##list
            (##fixnum.- (##vector-ref buf2 0) (##vector-ref buf1 0))
            (##fixnum.- (##vector-ref buf2 1) (##vector-ref buf1 1))
            (##fixnum.- real2 real1)
            result))))))

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