'
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file basic.scm.

;;;; Fundamental definitions

(define-all-compiler-primitives)

; Scalar operations

(define t   (= 0 0))
(define nil (= 0 1))
(define (not x) (if x nil t))
(define (boolean? x) (or (eq? x t) (eq? x nil)))

; Operational equivalence  [eq? is primitive]

(define eqv? eq?)

; Numbers  [primitive: = < + * - quotient remainder]

(define integer?  fixnum?)
(define rational? integer?)
(define real?	  rational?)
(define complex?  real?)
(define number?   complex?)

(define (zero? x) (= x 0))
(define (positive? x) (< 0 x))
(define (negative? x) (< x 0))
(define (even? n) (= 0 (remainder n 2)))
(define (odd? n) (not (even? n)))
(define (exact? n) t)      ;?
(define (inexact? n) nil)

(define (> x y) (< y x))
(define (<= x y) (not (< y x)))
(define (>= x y) (not (< x y)))

(define (max x y) (if (< x y) y x))
(define (min x y) (if (< x y) x y))

(define (/ x y)
  (if (= (remainder x y) 0)
      (quotient x y)
      (error "ratios not yet implemented" `(/ x y))))
(define (abs n) (if (< n 0) (- 0 n) n))

(define (expt n p)   ;losing algorithm, fix later
  (do ((a 1 (* a n))
       (p p (- p 1)))
      ((<= p 0) a)))

;;;; Lists

; [Primitive: pair? cons car cdr set-car! set-cdr!]

(define (caar   x) (car (car x)))
(define (cadr   x) (car (cdr x)))
(define (cdar   x) (cdr (car x)))
(define (cddr   x) (cdr (cdr x)))

(define (caaar  x) (car (caar x)))
(define (caadr  x) (car (cadr x)))
(define (cadar  x) (car (cdar x)))
(define (caddr  x) (car (cddr x)))
(define (cdaar  x) (cdr (caar x)))
(define (cdadr  x) (cdr (cadr x)))
(define (cddar  x) (cdr (cdar x)))
(define (cdddr  x) (cdr (cddr x)))

(define (caaaar x) (car (caaar x)))
(define (caaadr x) (car (caadr x)))
(define (caadar x) (car (cadar x)))
(define (caaddr x) (car (caddr x)))
(define (cadaar x) (car (cdaar x)))
(define (cadadr x) (car (cdadr x)))
(define (caddar x) (car (cddar x)))
(define (cadddr x) (car (cdddr x)))
(define (cdaaar x) (cdr (caaar x)))
(define (cdaadr x) (cdr (caadr x)))
(define (cdadar x) (cdr (cadar x)))
(define (cdaddr x) (cdr (caddr x)))
(define (cddaar x) (cdr (cdaar x)))
(define (cddadr x) (cdr (cdadr x)))
(define (cdddar x) (cdr (cddar x)))
(define (cddddr x) (cdr (cdddr x)))

(define (null? x) (eq? x '()))

(define (list . l) l)

(define (length l)
  (do ((l l (cdr l))
       (i 0 (+ i 1)))
      ((null? l) i)))

(define (append . lists)
  (letrec ((append2 (lambda (l1 l2)
		      (if (null? l1) l2
			  (cons (car l1) (append2 (cdr l1) l2))))))
    (cond ((null? lists) '())
          ((null? (cdr lists)) (car lists))
          ((null? (cddr lists)) (append2 (car lists) (cadr lists)))
          (else (append2 (car lists) (apply append (cdr lists)))))))

(define (reverse list)
  (letrec ((append-reverse
	     (lambda (list seed)
	       (if (null? list)
		   seed
		   (append-reverse (cdr list) (cons (car list) seed))))))
    (append-reverse list '())))

(define (list-tail l index)
  (let loop ((l l) (i index))
    (cond ((= i 0) l)
	  (else (loop (cdr l) (- i 1))))))

(define (list-ref l k)
  (car (list-tail l k)))

(define (last-pair l)
  (let loop ((l l))
    (if (not (pair? (cdr l))) 
	l
	(loop (cdr l)))))

(define (equal? obj1 obj2)
  (cond ((eqv? obj1 obj2) t)
        ((pair? obj1)
         (and (pair? obj2)
	      (equal? (car obj1) (car obj2))
	      (equal? (cdr obj1) (cdr obj2))))
	((string? obj1)
	 (and (string? obj2)
	      (string=? obj1 obj2)))
	((vector? obj1)
	 (and (vector? obj2)
	      (let ((z (vector-length obj1)))
		(and (= z (vector-length obj2))
		     (let loop ((i 0))
		       (cond ((= i z) t)
			     ((equal? (vector-ref obj1 i) (vector-ref obj2 i))
			      (loop (+ i 1)))
			     (else nil)))))))
        (else nil)))

(define (mem pred)
  (lambda (obj l)
    (let loop ((l l))
	 (cond ((null? l) nil)
	       ((pred obj (car l)) l)
	       (else (loop (cdr l)))))))

(define memq   (mem eq?))
(define memv   (mem eqv?))
(define member (mem equal?))

(define (ass pred)
  (lambda (obj l)
    (let loop ((l l))
      (cond ((null? l) nil)
	    ((pred obj (caar l)) (car l))
	    (else (loop (cdr l)))))))

(define assq  (ass eq?))
(define assv  (ass eqv?))
(define assoc (ass equal?))

(define (delq obj l)
  (cond ((null? l) l)
	((eq? obj (car l)) (delq obj (cdr l)))
	(else (cons (car l) (delq obj (cdr l))))))

;;;; Characters

; [Primitive:  char? char->ascii ascii->char char=? char<?]

(define (char>? x y) (char<? y x))
(define (char>=? x y) (not (char<? x y)))
(define (char<=? x y) (not (char<? y x)))
(define char->integer char->ascii)
(define integer->char ascii->char)

(define ay      (char->integer #\a))
(define zed     (char->integer #\z))
(define cap-ay  (char->integer #\A))
(define cap-zed (char->integer #\Z))
(define zero    (char->integer #\0))
(define nine    (char->integer #\9))

(define (char-whitespace? c)
  (or (char=? c #\space)
      (char=? c #\newline)
      (char=? c #\tab)
      (char=? c #\page)))

(define (char-lower-case? c)
  (let ((c (char->ascii c)))
    (and (>= c ay)
	 (<= c zed))))

(define (char-upper-case? c)
  (let ((c (char->ascii c)))
    (and (>= c cap-ay)
	 (<= c cap-zed))))

(define (char-numeric? c)
  (let ((c (char->ascii c)))
    (and (>= c zero)
	 (<= c nine))))

(define (char-alphabetic? c)
  (or (char-upper-case? c)
      (char-lower-case? c)))

(define (char-upcase c)
  (if (char-lower-case? c)
      (ascii->char (- (char->ascii c) (- ay cap-ay)))
      c))

(define (char-downcase c)
  (if (char-upper-case? c)
      (ascii->char (+ (char->ascii c) (- ay cap-ay)))
      c))

(define (digit c radix)	  ;Auxiliary for reader
  (let ((c (char->integer (char-upcase c))))
    (cond ((and (>= c zero)
                (<= c nine))
           (- c zero))
          ((and (> radix 10)
                (>= c cap-ay)
                (< c (+ cap-ay (- radix 10))))
           (+ (- c cap-ay) 10))
          (else nil))))

;;;; Strings

(define (substring s start end)
  (let ((new-string (make-string (- end start))))
    (do ((i start (+ i 1))
	 (j 0 (+ j 1)))
	((= i end) new-string)
      (string-set! new-string j (string-ref s i)))))

(define (string-append s1 s2)  ;Wants to be n-ary
  (let ((l1 (string-length s1))
	(l2 (string-length s2)))
    (let ((new-string (make-string (+ l1 l2))))
      (do ((i 0 (+ i 1)))
	  ((= i l1)
	   (do ((i i (+ i 1))
		(j 0 (+ j 1)))
	       ((= j l2) new-string)
	     (string-set! new-string i (string-ref s2 j))))
	(string-set! new-string i (string-ref s1 i))))))

(define (string->list v)
  (let ((z (string-length v)))
    (do ((i (- z 1) (- i 1))
	 (l '() (cons (string-ref v i) l)))
	((< i 0) l))))

(define (list->string l)
  (let ((v (make-string (length l))))
    (do ((i 0 (+ i 1))
	 (l l (cdr l)))
	((null? l) v)
      (string-set! v i (car l)))))

(define (string<? s1 s2)
  (let ((l1 (string-length s1))
	(l2 (string-length s2)))
    (let ((z (min l1 l2)))
      (let loop ((i 0))
	(cond ((= i z) (< l1 l2))
	      ((char<? (string-ref s1 i) (string-ref s2 i)) t)
	      (else (loop (+ i 1))))))))

(define (string>? s1 s2) (string<? s2 s1))
(define (string<=? s1 s2) (not (string>? s1 s2)))
(define (string>=? s1 s2) (not (string<? s1 s2)))

(define (string->symbol string)
  (intern string the-symbol-table))

;(define (reverse-list->string l n)   ;In microcode?
;  (do ((l l (cdr l))
;       (i (- n 1) (- i 1)))
;      ((< i 0) (return obj))
;    (string-set! obj i (car l))))

(define (string-find-if pred string)
  (let loop ((i 0))
    (cond ((>= i (string-length string)) nil)
	  ((pred (string-ref string i)) i)
	  (else (loop (+ i 1))))))

;;;; Vectors

(define (vector . l)
  (list->vector l))

(define (vector->list v)
  (let ((z (vector-length v)))
    (do ((i (- z 1) (- i 1))
	 (l '() (cons (vector-ref v i) l)))
	((< i 0) l))))

(define (list->vector l)
  (let ((v (make-vector (length l) nil)))
    (do ((i 0 (+ i 1))
	 (l l (cdr l)))
	((null? l) v)
      (vector-set! v i (car l)))))

(define (vector-fill! v x)       ;Not essential, but useful
  (let ((z (vector-length v)))
    (do ((i 0 (+ i 1)))
	((= i z) unspecified)
      (vector-set! v i x))))

(define (vector-posq thing v)    ;Useful
  (let loop ((i 0))
    (cond ((>= i (vector-length v)) nil)
	  ((eq? thing (vector-ref v i)) i)
	  (else (loop (+ i 1))))))

; Control features

(define procedure? closure?)

(define (map proc l)
  (if (null? l)
      '()
      (cons (proc (car l)) (map proc (cdr l)))))

(define (for-each proc l)
  (if (null? l)
      unspecified
      (begin (proc (car l))
	     (for-each proc (cdr l)))))

(define (make-promise thunk)
  (let ((already-run? nil) (result nil))
    (lambda ()
      (cond ((not already-run?)
	     (set! result (thunk))
	     (set! already-run? t)))
      result)))

(define (force promise)
  (promise))

;;;; Tables

; (Not a standard Scheme feature, but a handy one)

(define (make-table)
  (list 'table))

(define (table-ref table key)
  (let ((probe (assq key (cdr table))))
    (if probe (cdr probe) nil)))

(define (table-set! table key val)
  (let ((probe (assq key (cdr table))))
    (if probe
	(set-cdr! probe val)
	(set-cdr! table (cons (cons key val) (cdr table))))))

; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME  -*-

; This is file io.scm.

; [Still to do:  transcript-on, transcript-off]

;;;; I/O system

; Ports

(define (call-with-input-file string proc)
  (let ((port nil))
    (unwind-protect (lambda ()
		      (set! port (open-input-file string))
		      (proc port))
		    (lambda ()
		      (if port (close-input-port port))))))

(define (call-with-output-file string proc)
  (let ((port nil))
    (unwind-protect (lambda ()
		      (set! port (open-output-file string))
		      (proc port))
		    (lambda ()
		      (if port (close-output-port port))))))

(define the-current-input-port  (make-fluid initial-input-port))
(define the-current-output-port (make-fluid initial-output-port))

(define (current-input-port)
  (fluid the-current-input-port))

(define (current-output-port)
  (fluid the-current-output-port))

(define (with-input-from-file string thunk)
  (call-with-input-file string
    (lambda (port)
      (let-fluid the-current-input-port port thunk))))

(define (with-output-to-file string thunk)
  (call-with-output-file string
    (lambda (port)
      (let-fluid the-current-output-port port thunk))))

;;;; WRITE

(define (write obj . port-option)
  (really-write obj (output-port-option port-option)))

(define (display obj . port-option)
  (write-string obj (output-port-option port-option))) 

(define (newline . port-option)
  (write-char #\newline (output-port-option port-option)))

(define (output-port-option port-option)
  (if (null? port-option) (current-output-port) (car port-option)))

(define (really-write obj port)
  (cond ((null? obj) (write-string "()" port))
	((pair? obj) (write-list obj port))
	((eq? obj t) (write-string "#T" port))
	((eq? obj nil) (write-string "#F" port))
	((vector? obj) (write-vector obj port))
	((symbol? obj) (write-string (symbol->string obj) port))
	((number? obj) (write-number obj port))
	((string? obj)
	 (write-char #\" port)
	 (write-string obj port)
	 (write-char #\" port))
	((char? obj) (write-char-literal obj port))
	(else
	 (write-string "#{" port)
	 (write-string (random-identification-string obj) port)
	 (write-string "}" port))))

(define (write-char-literal obj port)
  (cond ((char=? obj #\space)
	 (write-string "#\\SPACE" port))
	((char=? obj #\newline)
	 (write-string "#\\NEWLINE" port))
	(else
	 (write-string "#\\" port)
	 (write-char obj port))))

(define (write-list obj port)
  (write-char #\( port)
  (really-write (car obj) port)
  (let loop ((l (cdr obj))
	     (n 1))
       (cond ((not (pair? l))
	      (cond ((not (null? l))
		     (write-string " . " port)
		     (really-write l port))))
	     (else
	      (write-char #\space port)
	      (really-write (car l) port)
	      (loop (cdr l) (+ n 1)))))
  (write-char #\) port))

(define (write-vector obj port)
   (write-string "#(" port)
   (let ((z (vector-length obj)))
     (cond ((> z 0)
	    (really-write (vector-ref obj 0) port)
	    (let loop ((i 1))
	      (cond ((>= i z))
		    (else
		     (write-char #\space port)
		     (really-write (vector-ref obj i) port)
		     (loop (+ i 1))))))))
   (write-char #\) port))

(define (write-number n port)
  (write-integer port n 10))

(define (write-integer port n radix)
  (cond ((= n 0) (write-char #\0 port))
        ((< n 0)
         ;; Loses on least fixnum.
         (write-char #\- port)
         (write-integer-1 port (- 0 n) radix))
        (else (write-integer-1 port n radix))))

(define (write-integer-1 port n radix)
  (cond ((< n radix)
         (write-char (digit->char n) port))
        (else
         (write-integer-1 port (quotient n radix) radix)
         (write-char (digit->char (remainder n radix)) port))))

(define (digit->char n)
  (ascii->char (if (< n 10)
                   (+ n (char->ascii #\0))
                   (+ (- n 10) (char->ascii #\a)))))

(define (random-identification-string obj)
  (cond ((procedure? obj) "Procedure")
	((eq? obj unspecified) "Unspecified")
	((eq? obj initial-input-port) "Initial input port")
	((eq? obj initial-output-port) "Initial output port")
	((input-port? obj) "Input port")
	((output-port? obj) "Output-port")
	((eq? obj eof-object) "End of file")
	((code-vector? obj) "Code vector")
	(else "Random object")))

;;;; READ

(define (read . optionals)
  (if (null? optionals)
      (really-read (current-input-port) standard-readtable)
      (if (null? (cdr optionals))
	  (really-read (car optionals) standard-readtable)
	  (really-read (car optionals) (cadr optionals)))))
	  
(define close-paren (list 'close-paren))
(define dot         (list 'dot))

(define (really-read port readtable)
  (let ((form (sub-read port readtable)))
    (cond ((eq? form dot)
           (error "\" . \" in illegal context"))
          ((eq? form close-paren)
	   ;; Too many right parens.
           (really-read port readtable))
          (else form))))

(define (sub-read port readtable)
  (let ((c (read-char port)))
    (if (eof-object? c)
	c
	((rt-entry-reader (get-character-syntax readtable c))
	 c port readtable))))

(define (sub-read-illegal c port readtable)
  (error "illegal character" c))

; Read table entries

(define (make-rt-entry reader terminating?) (cons terminating? reader))
(define rt-entry-reader cdr)
(define rt-entry-terminating? car)

(define (make-character-syntax type . maybe-arg)
  (let ((arg (if (null? maybe-arg) nil (car maybe-arg))))
    (case type
      ((constituent)     (make-rt-entry sub-read-constituent nil))
      ((whitespace)      (make-rt-entry sub-read-whitespace  t))
      ((illegal)	 (make-rt-entry sub-read-illegal     t))
      ((non-terminating-macro)   (make-rt-entry arg nil))
      ((terminating-macro macro) (make-rt-entry arg   t))
      ;;((single-escape)	 not yet implemented)
      ;;((multiple-escape)	 not yet implemented)
      (else (error "bad argument to MAKE-CHARACTER-SYNTAX" type)))))

; Read tables

(define (make-readtable)
  (vector 'readtable
	  nil           ;token parser
	  (make-vector byte-limit (make-character-syntax 'illegal))))

(define (get-token-parser readtable)
  (vector-ref readtable 1))
(define (set-token-parser! readtable val)
  (vector-set! readtable 1 val))

(define (get-character-syntax readtable char)
  (vector-ref (vector-ref readtable 2) (char->ascii char)))
(define (set-character-syntax! readtable char val)
  (vector-set! (vector-ref readtable 2) (char->ascii char) val))

; The standard read table

(define standard-readtable (make-readtable))

(define (sub-read-whitespace c port readtable)
  c ;ignored
  (sub-read port readtable))

(let ((whitespace (make-character-syntax 'whitespace)))
  (for-each (lambda (c)
	      (set-character-syntax! standard-readtable c whitespace))
	    '(#\space #\newline #\page #\tab)))

(define (sub-read-token c port readtable)
  (let loop ((l (list (char-upcase c))) (n 1))
    (let ((c (peek-char port)))
      (cond ((or (eof-object? c)
		 (rt-entry-terminating? (get-character-syntax readtable c)))
	     (reverse-list->string l n))
	    (else
	     (loop (cons (char-upcase (read-char port)) l) ;fix Will's proposal?
		   (+ n 1)))))))

(define (sub-read-constituent c port readtable)
  (let ((s (sub-read-token c port readtable)))
    ((get-token-parser readtable) s 0 (string-length s))))

(let ((constituent (make-character-syntax 'constituent)))
  (for-each (lambda (c)
	      (set-character-syntax! standard-readtable c constituent))
	    (string->list
	      (string-append "!$%&*+-./0123456789:<=>?@^_~ABCDEFGHIJKLM"
			     "NOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))))

(define (standard-token-parser string start end)
  (let ((c (string-ref string start)))
    (cond ((or (not (= start 0))
	       (not (= end (string-length string))))
	   (error "this isn't very general" string start end))
	  ((char=? c #\+)
	   (if (= end 1)
	       '+
	       (string->number string 'e 'd)))
	  ((char=? c #\-)
	   (if (= end 1)
	       '-
	       (string->number string 'e 'd)))
	  ((char=? c #\.)
	   (if (= end 1)
	       dot
	       (string->number string 'e 'd)))
	  (else
	   (let ((n (digit c 10)))
	     (if n
		 (string->number string 'e 'd)
		 (string->symbol string)))))))

(set-token-parser! standard-readtable standard-token-parser)
  
(define (sub-read-list c port readtable)
  (let ((form (sub-read port readtable)))
    (cond ((eof-object? form)
	   (error "end of file inside list -- unbalanced parentheses"))
          ((eq? form close-paren) '())
          ((eq? form dot)
	   (let ((last-form (sub-read port readtable)))
	     (cond ((eof-object? last-form)
		    (error "end of file inside list -- unbalanced parentheses"))
		   ((eq? last-form close-paren)
		    (error "\" . )\" encountered"))
		   ((eq? last-form dot)
		    (error "\" . . \" encountered"))
		   (else
		    (let ((another-form (sub-read port readtable)))
		      (cond ((eq? another-form close-paren) last-form)
			    (else
			     (error "randomness after form after dot" another-form))))))))
          (else (cons form (sub-read-list c port readtable))))))

(define (set-standard-read-macro! c proc)
  (set-character-syntax! standard-readtable c
			 (make-character-syntax 'macro proc)))

(set-standard-read-macro! #\( sub-read-list)

(set-standard-read-macro! #\)
  (lambda (c port readtable) close-paren))

(set-standard-read-macro! #\'
  (lambda (c port readtable)
    (list 'quote (sub-read port readtable))))

(set-standard-read-macro! #\`
  (lambda (c port readtable)
    (list 'quasiquote (sub-read port readtable))))

(set-standard-read-macro! #\,
  (lambda (c port readtable)
    (list (cond ((char=? (peek-char port) #\@)
		 (read-char port)
		 'unquote-splicing)
		(else 'unquote))
	  (sub-read port readtable))))

(set-standard-read-macro! #\"
  (lambda (c port readtable)
    (let loop ((l '()) (i 0))
      (let ((c (read-char port)))
	(cond ((eof-object? c)
	       (error "end of file within a string"))
	      ((char=? c #\\)
	       (loop (cons (sub-read-escaped-char port) l) (+ i 1)))
	      ((char=? c #\") (reverse-list->string l i))
	      (else (loop (cons c l) (+ i 1))))))))

(define (sub-read-escaped-char port)
  (let ((c (read-char port)))
    (cond ((or (char=? c #\\) (char=? c #\")) c)
          (else
           (error "invalid escaped character in string" c)))))

(set-standard-read-macro! #\;
  (lambda (c port readtable)
    (let loop ()
      (let ((c (read-char port)))
	(cond ((eof-object? c) c)		; no test with conditions
	      ((char=? c #\newline) (sub-read port readtable))
	      (else (loop)))))))

(set-standard-read-macro! #\#
  (lambda (c port readtable)
    c ;ignored
    (let ((c (char-upcase (read-char port))))
      (cond ((eof-object? c) (error "end of file after #"))
	    ((char=? c #\F) nil)
	    ((char=? c #\T) t)
	    ((char=? c #\\)
	     (let ((c (peek-char port)))
	       (if (char-alphabetic? c)
		   (let ((name (sub-read port readtable)))
		     (if (= (string-length (symbol->string name)) 1)
			 c
			 (cadr (assq name '((space   #\space)
					    (newline #\newline)
					    (tab     #\tab)
					    (page    #\page))))))
		   (read-char port))))
	    ((char=? c #\()
	     (list->vector (sub-read-list c port readtable)))
	    ;; ## should evaluate to the last REP-loop result.
	    ((char=? c #\#)
	     `(,(make-system-ref 'output)))
	    ((char=? c #\B) (sub-read-number port readtable 'b))
	    ((char=? c #\O) (sub-read-number port readtable 'o))
	    ((char=? c #\D) (sub-read-number port readtable 'd))
	    ((char=? c #\X) (sub-read-number port readtable 'x))
	    (else
	     (error "unknown # syntax" c))))))

(define (sub-read-number port readtable radix)
  (string->number (sub-read-token (read-char port) port readtable) 'e radix))

; Miscellaneous utilities

; String->number

(define (string->number string exactness radix)
  exactness  ;ignored for now
  (let ((radix (case radix ((b) 2) ((o) 8) ((d) 10) ((x) 16)
		 (else (error "losing radix" radix)))))
    ((lambda (foo)
       (cond ((= (string-length string) 0)
	      (error "null string argument to STRING->NUMBER"))
	     ((char=? (string-ref string 0) #\+)
	      (foo 1 1))
	     ((char=? (string-ref string 0) #\-)
	      (foo 1 -1))
	     (else (foo 0 1))))
     (lambda (start sign)
       (if (>= start (string-length string))
	   (error "no digits follow sign in STRING->NUMBER" string)
	   (let loop ((n 0)
		      (pos start))
	     (cond ((>= pos (string-length string)) n)
		   (else
		    (loop (+ (* n radix)
			     (* sign (digit (string-ref string pos) radix)))
			  (+ pos 1))))))))))

(define (read-line port)
  (let loop ((l '()) (n 0))
    (let ((c (read-char port)))
      (if (char=? c #\newline)
	  (reverse-list->string l n)
	  (loop (cons c l) (+ n 1))))))

(define (skip-whitespace port)
  (let loop ()
    (let ((c (peek-char port)))
      (cond ((eof-object? c) c)
	    ((char-whitespace? c) (read-char port) (loop))
	    (else c)))))

; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME  -*-

; This is file sys.scm.

;;;; Dynamic state

(define (without-interrupts thunk)
  (let* ((temp (set-enabled-interrupts! 0))
	 (val (thunk)))
    (set-enabled-interrupts! temp)
    val))

; Dynamic binding

(define *fluid-env* '())

(define (make-fluid top-level-value)
  (make-cell top-level-value '<fluid>))

(define (fluid cell)
  (let ((probe (assq cell *fluid-env*)))
    (if probe (cdr probe) (contents cell))))

(define (set-fluid! cell val)
  (let ((probe (assq cell *fluid-env*)))
    (if probe (set-cdr! probe val) (set-contents! cell val))))

(define (let-fluid cell val thunk)
  (call-with-current-continuation
      (lambda (cont)
	(set! *fluid-env* (cons (cons cell val) *fluid-env*))
	(cont (thunk)))))

(define (call-with-current-continuation proc)
  (primitive-catch
     (lambda (cont)
       (let ((env *fluid-env*))
	 (proc (lambda (val)
		 (set! *fluid-env* env)
		 (primitive-throw cont val)))))))

;;;; Unwind protection

;  This might be better if recast using Hanson/Lamping state spaces
;  (i.e. dynamic-wind).  But then again maybe not.

(define unwind-protections (make-fluid '()))

(define (unwind-protect thunk protection)
  (let ((k (call-with-current-continuation
	     (lambda (cont)
	       (let-fluid unwind-protections
			  (cons cont (fluid unwind-protections))
			  (lambda ()
			    (let ((val (thunk)))
			      (lambda () val))))))))
    (protection)
    (k)))

(define (call-with-protected-continuation proc)
  (let ((p (fluid unwind-protections)))
    (call-with-current-continuation
	(lambda (cont)
	  (proc (lambda (val)
		  (let ((q (fluid unwind-protections)))
		    ;; We must perform all protect actions from
		    ;; q out to p.
		    (if (list-tail? p q)
			(let loop ((q q))
			  (if (eq? q p)
			      (cont val)
			      ;; Not there yet; pop out another level.
			      ((car q) (lambda ()
					 ;; Assuming that (fluid unwind-protections)
					 ;; and (cdr q) have the same value here...
					 ;; probably not valid, but who knows?
					 (loop (fluid unwind-protections))))))
			(error "you can only throw up")))))))))

(define (list-tail? l1 l2)
  (or (eq? l1 l2)
      (and (not (null? l2))
	   (list-tail? l1 (cdr l2)))))

;;;; LOAD, EVAL, initialization

(define (load filename . env-option)
  (let ((env (if (null? env-option) *current-environment* (car env-option))))
    (call-with-input-file
      filename
      (lambda (port)
	(let loop ()
	  (let ((form (read port)))
	    (cond ((eof-object? form) 'done)
		  (else
		   (eval form env)
		   (loop)))))))))

(define (eval form env)
  (process-top-level-form
      form
      (lambda (exp)
	(really-eval exp env))
      (lambda (var exp)  ;definition
	(environment-set! env var (really-eval exp env)))))

(define (really-eval exp env)
  ((make-closure (compile-top exp env) nil)))

; Initialization and top level

(define (initialize)
  (set-enabled-interrupts! (adjoin-bits 1 0 interrupt/keyboard)) ;!?
  (newline)
  (display "Welcome to Scheme-48" initial-output-port))

(define (dump filename)  ;(dump "z:>jar>s48>s48.sus")
  (newline)
  (display "Dumping to ")
  (write filename)
  (newline)
  (suspend filename)
  (initialize)
  (reset))

(define *reset* (lambda (ignore) (top-level)))
(define *output* (list nil))      ;kludge -- fix later
(define (output) (car *output*))

(define (top-level)
  (call-with-protected-continuation
      (lambda (-reset-)
	(set! *reset* -reset-)
	(command-loop)))
  ;; A call to the RESET procedure transfers control here.
  (display "Top level")
  (top-level))

(define (reset)
  (*reset* nil))

;;;; Command loop

(define *the-non-printing-object* (list '*the-non-printing-object*))

(define *current-environment* system-environment)

(define (command-loop)
  (newline initial-output-port)
  (display "==> " initial-output-port)
  (let ((form (read-form-or-command initial-input-port)))
    (cond ((eof-object? form)
	   (display "Use the :EXIT command to exit." initial-output-port))
	  (else
	   (let ((output (top-level-eval form *current-environment*)))
	     (cond ((not (eq? output *the-non-printing-object*))
		    (set-car! *output* output)
		    (newline initial-output-port)
		    (write-result output initial-output-port)))))))
  (command-loop))

(define (top-level-eval form env)
  (process-top-level-form
      form
      (lambda (exp)
	(really-eval exp env))
      (lambda (var exp)  ;definition
	(environment-set! env var (really-eval exp env))
	(write var initial-output-port)
	(display " defined." initial-output-port)
	*the-non-printing-object*)))

(define (write-result thing port)
  (if (or (symbol? thing) (pair? thing))
      (write-char #\' port))
  (write thing port))

(define (read-form-or-command port)
  (let loop ()
    (let ((c (peek-char port)))
      (cond ((eof-object? c) c)
	    ((char-whitespace? c)
	     (read-char port)
	     (loop))
	    ((char=? c #\:)
	     (read-char port)
	     (read-command port))
	    (else (read port))))))

; Commands
;   :reset
;   :exit
;   :load <filename>
;  (unimplemented --
;   :pp <name>
;   :trace <name>
;   :inspect <exp>
;   :debug
;   :ge      -- go to environment
;   :help
;   :enable  -- ???)
; etc.

(define (read-command port)
  (let ((c-name (read port)))
    (case c-name
      ((exit)  `(,(make-system-ref 'exit)))
      ((reset) `(,(make-system-ref 'reset)))
      ((load)
       (skip-whitespace port)
       `(,(make-system-ref 'load) ,(read-line port)))
      (else (error "unknown command" c-name)))))

; This ought to go into the debugger.  Unfortunately there isn't a debugger yet.

(define (error message . items)
  (newline)
  (display "Error: ")
  (display message)
  (for-each (lambda (item)
	      (newline)
	      (display "       ")
	      (write item))
	    items)
  (break))

(define (not-proceedable)
  (error "this error is not proceedable")
  (not-proceedable))

(define (exit) (halt 0))  ;?

;;;; Exception handlers

; ----THIS NEEDS TO BE REWRITTEN----
; The whole exception system is currently quite broken.

; Cases to handle in future:
;   n-ary + * < = etc.
;   generic arithmetic
;     (a) wrong type arg to arithmetic primitives
;     (b) fixnum arithmetic overflow
;   make optional the init argument to make-vector
;   allow optional init arg to make-string
;   make optional the port argument to I/O primitives

(vector-fill! exception-handlers
	      (lambda (exc cont val nargs)
		(error "an error occurred" (enumerand->name n exception))
		(not-proceedable)))

(vector-set! exception-handlers exception/undefined-global
	     (lambda (exc cont val)
	       (error "undefined variable" val)))

(vector-set! exception-handlers exception/bad-procedure
	     (lambda (exc cont val)
	       (let ((proc (machine-state-ref m register/val))
		     (argvals (get-argvals cont nargs)))
		 (error "call to a non-procedure" proc argvals)
		 (proceed-after-exception m))))

(define (get-argvals m)
  (let ((nargs (machine-state-ref m register/nargs)))
    (do ((s (machine-state-ref m register/stack) (cdr s))
	 (l '() (cons (car s) l))
	 (i 0 (+ i 1)))
	((= i nargs) l))))

(vector-set! exception-handlers exception/wrong-number-of-arguments
	     (lambda (exc cont val)
	       (let ((proc (machine-state-ref m register/val))
		     (argvals (get-argvals m)))
		 ;; Eventually deal with n-ary and optional versions of these:
		 ;;   make-vector make-string
		 ;;   read-char peek-char write-char write-string
		 ;;   [non-essential:  + - * < =]
		 (error "wrong number of arguments" proc argvals)
		 (proceed-after-exception m))))

(vector-set! exception-handlers exception/wrong-type-argument
	     (lambda (exc cont val)
	       (let ((proc (machine-state-ref m register/val))
		     (argvals (get-argvals m)))
		 ;; Eventually handle generic arithmetic.
		 ;;   + - * quotient remainder < =
		 (error "wrong type argument" proc argvals)
		 (proceed-after-exception m))))

;     exception/undefined-lexical
;     exception/index-out-of-range
;     exception/arithmetic-exception   [escape to bignum]
;     exception/losing-projection
;     exception/port-problem
;     exception/heap-overflow  [make-vector, make-string]
;     exception/uuo   [intern, string=?, write-string, apply, etc.]

(define machine-state-ref vector-ref)

; Interrupts

(vector-set! interrupt-handlers interrupt/keyboard
  (lambda (machine-state enabled-interrupts interrupt)
    (set-enabled-interrupts! enabled-interrupts)	;Re-enable
    (display "Interrupt")
    (command-loop)
    (proceed-after-exception machine-state)))

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file derive.scm.

;;;; Macro expanders

; Some day, update this module to implement Alan Bawden's proposal.

(define rewriters (make-table))

(define (get-macro-expander sym)
  (table-ref rewriters sym))

(define (parse-top-level-form form evaluator definer)
  ;; To do later: make this deal with macro definitions as well
  (cond ((definition? form)
	 (let ((d (parse-definition form)))
	   (definer (car d) (cadr d))))
	((not (pair? form)) (evaluator form))
	((eq? (car form) 'begin)
	 (do ((f (cdr form) (cdr f)))
	     ((null? (cdr f))
	      (parse-top-level-form (car f) evaluator definer))
	   (parse-top-level-form (car f) evaluator definer)))
	((eq? (car form) 'define-macro)
	 (let ((pat (cadr form))
	       (body (cddr form)))
	   ;; Kludge!!
	   (define-rewriter (car pat)
	     (eval `(lambda ,(cdr pat) ,@body)
		   user-initial-environment))
	   (evaluator `',(car pat))))
	(else
	 (let ((probe (get-macro-expander (car form))))
	   (if probe
	       (parse-top-level-form (probe form) evaluator definer)
	       (evaluator form))))))

(define (definition? thing)
  (and (pair? thing)
       (eq? (car thing) 'define)))

(define (parse-definition d)
  (let ((pat (cadr d)) (body (cddr d)))
    (cond ((pair? pat)
	   `(,(car pat) (lambda ,(cdr pat) ,@body)))
	  (else
	   `(,pat ,@body)))))

; Absolute references

(define system-ref-marker (list 'system-ref-marker))  ;unique marker

(define (make-system-ref x)
  (list system-ref-marker x))

; The expanders:

(define (define-rewriter name proc)
  (table-set! rewriters name (lambda (exp) (apply proc (cdr exp)))))

(define-rewriter 'and
  (lambda conjuncts
    (cond ((null? conjuncts) t)			;t => #t which self-evaluates
	  ((null? (cdr conjuncts)) (car conjuncts))
	  (else `((lambda (p th)
		    (if p (th) p))
		  ,(car conjuncts)
		  (lambda () (and ,@(cdr conjuncts))))))))

(define-rewriter 'case
  (lambda (key . clauses)
    (let ((var '%%key%%))
      `(let ((,var ,key))
	 (cond ,@(map (lambda (clause)
			(let ((cases (car clause)))
			  `(,(cond ((eq? cases 'else) 'else)
				   ((null? cases) nil)
				   (else
				    `(,(make-system-ref 'memv) ,var ',cases)))
			    ,@(cdr clause))))
		      clauses))))))

(define-rewriter 'cond
  (lambda clauses
    (cond ((null? clauses) (make-system-ref 'unspecified))  ;How to do absolute references?
	  ((null? (cdar clauses))
	   `(or ,(caar clauses)
		(cond ,@(cdr clauses))))
	  ((eq? (caar clauses) 'else)
	   `(begin ,@(cdar clauses)))
	  ((eq? (cadr (car clauses)) '=>)
	   `((lambda (p q th) (if p (q p) (th)))
	     ,(car (car clauses))
	     (lambda () ,(caddr (car clauses)))
	     (lambda () (cond ,@(cdr clauses)))))
	  (else `(if ,(caar clauses)
		     (begin ,@(cdar clauses))
		     (cond ,@(cdr clauses)))))))

(define-rewriter 'delay
  (lambda (thing)
    `(,(make-system-ref 'make-promise) (lambda () ,thing))))

(define-rewriter 'do
  (lambda (specs end . body)
    (let ((loop '%%do%%))
      `(letrec ((,loop
		  (lambda ,(map car specs)
		    (cond ,end
			  (else ,@body
				(,loop
				 ,@(map (lambda (y)
					  (if (null? (cddr y))
					      (car y)
					      (caddr y)))
					specs)))))))
	 (,loop ,@(map cadr specs))))))

(define-rewriter 'let
  (lambda (specs . body)
    (cond ((symbol? specs)
	   (let ((tag specs)
		 (specs (car body))
		 (body (cdr body)))
	     `(letrec ((,tag (lambda ,(map car specs) ,@body)))
		(,tag ,@(map cadr specs)))))
	  (else
	   `((lambda ,(map car specs) ,@body)
	     ,@(map cadr specs))))))

(define-rewriter 'let*
  (lambda (specs . body)
    (if (or (null? specs)
	    (null? (cdr specs)))
	`(let ,specs ,@body)
	`(let (,(car specs)) (let* ,(cdr specs) ,@body)))))

(define-rewriter 'letrec
  (lambda (specs . body)
    `((lambda ,(map car specs)
	,@(map (lambda (spec) `(set! ,@spec)) specs)
	,@body)
      ,@(map (lambda (spec)
	       spec ;ignored
	       `(,(make-system-ref 'unassigned)))
	     specs))))

(define-rewriter 'or
  (lambda disjuncts
    (cond ((null? disjuncts) nil)			;nil => #f which self-evaluates
	  ((null? (cdr disjuncts)) (car disjuncts))
	  (else `((lambda (p th)
		    (if p p (th)))
		  ,(car disjuncts)
		  (lambda () (or ,@(cdr disjuncts))))))))

(define-rewriter 'define-all-compiler-primitives
  (lambda ()
    `(begin ,@(definitions-for-all-compiler-primitives))))

(define (process-body exp-list)			;flush this??
  (let loop ((e exp-list)
	     (d '()))
    (cond ((null? e)
	   (error "null body" exp-list))
	  ((definition? (car e))
	   (loop (cdr e) (cons (parse-definition (car e)) d)))
	  ((not (null? d))
	   `(letrec ,d ,@e))
	  ((null? (cdr e))
	   (car e))
	  (else
	   `(begin ,@e)))))

;;;; Quasiquote

(define-rewriter 'quasiquote
  (lambda (x)
    (expand-quasiquote x 0)))

(define (expand-quasiquote x level)
  (descend-quasiquote x level finalize-quasiquote))

(define (finalize-quasiquote mode arg)
  (cond ((eq? mode 'quote) `',arg)
	((eq? mode 'unquote) arg)
	((eq? mode 'unquote-splicing)
	 (error ",@ in illegal context" arg))
	(else `(,mode ,@arg))))

(define (descend-quasiquote x level return)
  (cond ((vector? x)
	 (descend-quasiquote-vector x level return))
	((not (pair? x))
	 (return 'quote x))
	((interesting-to-quasiquote? x 'quasiquote)
	 (descend-quasiquote-pair x (1+ level) return))
	((interesting-to-quasiquote? x 'unquote)
	 (cond ((= level 0)
		(return 'unquote (cadr x)))
	       (else
		(descend-quasiquote-pair x (- level 1) return))))
	((interesting-to-quasiquote? x 'unquote-splicing)
	 (cond ((= level 0)
		(return 'unquote-splicing (cadr x)))
	       (else
		(descend-quasiquote-pair x (- level 1) return))))
        (else (descend-quasiquote-pair x level return))))

(define (descend-quasiquote-pair x level return)
  (descend-quasiquote (car x) level
    (lambda (car-mode car-arg)
      (descend-quasiquote (cdr x) level
        (lambda (cdr-mode cdr-arg)
	  (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
		 (return 'quote x))
		((eq? car-mode 'unquote-splicing)
		 ;; (,@mumble ...)
		 (cond ((and (eq? cdr-mode 'quote) (null? cdr-arg))
			(return 'unquote car-arg))
		       (else
			(return (make-system-ref 'append)
				(list car-arg (finalize-quasiquote cdr-mode cdr-arg))))))
		(else
		 (return (make-system-ref 'cons)
			 (list (finalize-quasiquote car-mode car-arg)
			       (finalize-quasiquote cdr-mode cdr-arg))))))))))

(define (descend-quasiquote-vector x level return)
  (descend-quasiquote (vector->list x) level
    (lambda (mode arg)
      (case mode
	((quote) (return 'quote x))
	(else (return (make-system-ref 'list->vector)
		      (list (finalize-quasiquote mode arg))))))))

(define (interesting-to-quasiquote? x marker)
  (and (pair? x) (eq? (car x) marker)))

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file comp.scm.

;;;; The compiler

; COMPILE-TOP

(define (compile-top exp env)
  (compile-lambda-top `(lambda () ,exp) env nil))

(define (compile-lambda-top exp env name)
  (compile-lambda exp (environment->cenv env) name))

(define (compile-lambda exp cenv name)
  (compiling
   (lambda (state)
     (let* ((args (cadr exp))
	    (body (cddr exp))
	    (nargs (number-of-required-args args)))
       (sequentially
	(if (n-ary? args)
	    (sequentially
	     (if (pair? args)
		 (emit op/check-nargs>= nargs)
		 empty-segment)
	     (emit op/make-rest-list nargs)
	     (emit op/make-env (+ nargs 1)))
	    (sequentially
	     (emit op/check-nargs= nargs)
	     (if (null? args)
		 empty-segment
		 (emit op/make-env nargs))))
	(compile (process-body body)
		 (if (null? args)
		     cenv
		     (bind-vars (normalize-formals args) cenv))
		 '(return)
		 state))))
   name))

(define (number-of-required-args formals)
  (do ((l formals (cdr l))
       (i 0 (+ i 1)))
      ((not (pair? l)) i)))

(define (n-ary? formals)
  (not (null? (if (pair? formals)
		  (cdr (last-pair formals))
		  formals))))

(define (normalize-formals formals)
  (cond ((null? formals) '())
	((pair? formals) (cons (car formals) (normalize-formals (cdr formals))))
	(else (list formals))))

(define (reverse-list->vector l i) i
  (list->vector (reverse l)))

(define (compile exp cenv cont state)
  (cond ((symbol? exp)
	 (compile-variable exp cenv cont state))
	((or (number? exp) (char? exp) (string? exp) (boolean? exp))
	 (compile-literal exp cont state))
	((not (pair? exp))
	 (error "invalid expression" exp))
	((eq? (car exp) system-ref-marker)
	 (compile (cadr exp)
		  (environment->cenv system-environment)
		  cont
		  state))
	((not (symbol? (car exp)))
	 (compile-unknown-call exp cenv cont state))
	(else
	 (let ((probe (table-ref compilators (car exp))))
	   (if probe
	       (probe exp cenv cont state)
	       (let ((probe (get-macro-expander (car exp))))
		 (if probe
		     (compile (probe exp) cenv cont state)
		     (compile-var-call exp cenv cont state))))))))

(define (compile-variable exp cenv cont state)
  (sequentially
   (let ((info (clookup cenv exp)))
     (case (car info)
       ((local)
	(emit op/local (cadr info) (caddr info)))
       ((global primitive)
	(emit op/global (get-literal state (cadr info))))))
   (dispose-of-val cont)))

(define compilators (make-table))

(define (define-compilator name proc)
  (table-set! compilators name proc))

(define-compilator 'quote
  (lambda (exp cenv cont state)
    cenv ;ignored
    (compile-literal (cadr exp) cont state)))

(define-compilator 'lambda
  (lambda (exp cenv cont state)
    (let ((name (if (eq? (car cont) 'set!) (cadr cont) nil)))
      (sequentially
       (emit op/make-closure
	     (get-literal state (compile-lambda exp cenv name)))
       (dispose-of-val cont)))))

(define-compilator 'set!
  (lambda (exp cenv cont state)
    (let ((var (cadr exp))
	  (val (caddr exp)))
      (sequentially
       (compile val cenv `(set! ,var) state)
       (let ((info (clookup cenv var)))
	 (case (car info)
	   ((local)
	    (emit op/set-local! (cadr info) (caddr info)))
	   ((global)
	    (emit op/set-global! (get-literal state (cadr info))))
	   ((primitive)
	    (warn "assigning a primitive" var)
	    (emit op/set-global! (get-literal state (cadr info))))))
       (dispose-of-val cont)))))

(define-compilator 'if
  (lambda (exp cenv cont state)
    (let* ((alt-segment (compile (cadddr exp) cenv cont state))
	   (con-segment
	    (sequentially
	     (compile (caddr exp) cenv cont state)
	     ;; If (segment-size alt-segment) is too big, we ought to
	     ;; shrink it somehow (e.g. by eta-converting: e =>
	     ;; ((lambda () e))).  All three of the EMIT-OFFSET's have
	     ;; this problem.  Deal with this later...
	     (if (eq? (car cont) 'return)  ;Eliminate dead code.
		 empty-segment
		 (emit-offset op/jump (segment-size alt-segment))))))
      (sequentially
       (compile (cadr exp) cenv '(val) state)
       (emit-offset op/jump-if-false (segment-size con-segment))
       con-segment
       alt-segment))))

(define-compilator 'begin
  (lambda (exp cenv cont state)
    (compile-begin (cdr exp) cenv cont state)))

(define (compile-literal obj cont state)
  (sequentially
   (emit op/literal (get-literal state obj))
   (dispose-of-val cont)))

(define (compile-begin exp-list cenv cont state)
  (cond ((null? (cdr exp-list))
	 (compile (car exp-list) cenv cont state))
	(else
	 (sequentially
	  (compile (car exp-list) cenv '(val) state)
	  (compile-begin (cdr exp-list) cenv cont state)))))

(define (compile-var-call exp cenv cont state)
  (let ((info (clookup cenv (car exp))))
    (case (car info)
      ((primitive)
       (compile-primitive-call (caddr info) (cdr exp) cenv cont state))
      (else
       (compile-unknown-call exp cenv cont state)))))

; Compile a call to an unknown procedure

(define (compile-unknown-call exp cenv cont state)
  (maybe-push-continuation (sequentially 
			    (push-all (cdr exp) cenv state)
			    (compile (car exp) cenv '(val) state)
			    (emit op/call (length (cdr exp))))
			   cont))

(define (maybe-push-continuation code cont)
  (sequentially (if (eq? (car cont) 'return)
		    empty-segment
		    (emit-offset op/make-cont (segment-size code)))
		code))

(define (push-all exp-list cenv state)
  (if (null? exp-list)
      empty-segment
      ;; Sort of a kludge.  Push all but last, then push last.
      (sequentially (push-all-but-last exp-list cenv state)
		    (emit op/push))))

(define (push-all-but-last exp-list cenv state)
  (let loop ((l exp-list)
	     (code empty-segment))
    (if (null? (cdr l))
	(sequentially code
		      (compile (car l) cenv '(val) state))
	(loop (cdr l)
	      (sequentially
	         code
		 (compile (car l) cenv '(val) state)
		 (emit op/push))))))

(define (dispose-of-val cont)
  (case (car cont)
    ((return) (emit op/return))
    (else empty-segment)))

; CLOOKUP returns one of
;  (LOCAL back over)
;  (GLOBAL cell)
;  (PRIMITIVE cell primitive)

(define (clookup cenv var)
  (cenv var 0))

(define (environment->cenv env)
  (let ((cenv (lambda (var back)
		back			;ignored
		(list 'global (lookup env var)))))
    (if (eq? env system-environment)
	(add-usual-integrations cenv)
	cenv)))

(define (add-usual-integrations cenv)
  (lambda (var back)
    back ;ignored
    (let ((info (clookup cenv var))
	  (probe (table-ref primitives var)))
      (if probe
	  (list 'primitive (cadr info) probe)
	  info))))

; Local environment management

(define (bind-vars vars cenv)
  (lambda (var back)
    (let loop ((rib vars) (over 1))
      (cond ((null? rib)
	     (cenv var (+ back 1)))  ;Not here, try outer env.
	    ((eq? var (car rib))
	     (list 'local back over))
	    (else (loop (cdr rib) (+ over 1)))))))

(define (compiling proc name)
  ;; Has type  (proc ((proc (state) segment)) template)
  (let* ((state (make-state))
	 (segment (proc state)))
    (make-template segment state name)))

; Literal management

(define (make-template segment state name)
  (list->vector (cons (segment->code-vector segment)
		      (cons name 
			    (reverse (state-literals state))))))

(define (make-state) (list '() 2))
(define state-literals       car)
(define state-literals-index cadr)
(define (set-state-literals! state val)       (set-car!      state  val))
(define (set-state-literals-index! state val) (set-car! (cdr state) val))

(define (get-literal state thing)
  ;; Potential optimization: eliminate duplicate entries.
  (let ((index (state-literals-index state)))
    (if (>= index byte-limit)
	(error "code too complicated for this system"
	       (state-literals state)))
    (set-state-literals! state (cons thing (state-literals state)))
    (set-state-literals-index! state (+ index 1))
    index))

; Code emission utilities

(define (sequentially . segments)
  (make-segment (lambda (cv pc)
		  (let loop ((pc pc) (s segments))
		    (if (null? s)
			pc
			(loop (emit-segment! cv pc (car s)) (cdr s)))))
		(let loop ((size 0) (s segments))
		  (if (null? s)
		      size
		      (loop (+ size (segment-size (car s))) (cdr s))))))

(define (emit opcode . operands)
  (for-each (lambda (byte)
	      (if (>= byte byte-limit)
		  (error "byte too big (probably due to complicated code)"
			 (cons (enumerand->name opcode op) operands))))
	    operands)
  (make-segment
    (lambda (cv pc)
      (do ((l operands (cdr l))
	   (pc (emit-byte! cv pc opcode) (emit-byte! cv pc (car l))))
	  ((null? l) pc)))
    (+ 1 (length operands))))

(define (emit-offset opcode offset)
  (emit opcode offset))

(define (emit-byte! cv pc byte)
  (code-vector-set! cv pc byte)
  (+ pc 1))

(define make-segment cons)
(define segment-size cdr)
(define (emit-segment! cv pc segment)
  ((car segment) cv pc))

(define empty-segment (sequentially))

(define (segment->code-vector segment)
  (let ((cv (make-code-vector (segment-size segment))))
    (emit-segment! cv 0 segment)
    cv))

; Print a warning message

(define (warn msg . things)
  (newline)
  (display "** Warning: ")
  (display msg)
  (let ((o (current-output-port)))
    (for-each (lambda (thing)
		(write-char #\space o)
		(write thing o))
	      things)))

; Primitives

(define (definitions-for-all-compiler-primitives) ;yuck
  (map (lambda (name)
	 (let* ((prim (table-ref primitives name))
		(nargs (primitive-nargs prim))
		(some-names (reverse '(a b c d e f g h i j k l)))
		(args (list-tail some-names
				 (- (length some-names) nargs))))
	   ;; Note that if  (primitive-n-ary? prim)  then we are losing!
	   ;; Fix later, somehow.
	   `(define (,name ,@args)
	      (call-primitively ,(primitive-name prim) ,@args))))
       (reverse *primitive-names*)))

(define (make-primitive name nargs n-ary? proc)
  (list name nargs n-ary? proc))
(define primitive-name car)
(define primitive-nargs cadr)
(define primitive-n-ary? caddr)
(define primitive-compilator cadddr)

(define-compilator 'call-primitively
  (lambda (exp cenv cont state)
    (let ((exp (cdr exp)))
      (let ((probe (table-ref primitives (car exp))))
        (if probe
            (compile-primitive-call probe (cdr exp) cenv cont state)
            (begin (warn "procedure in CALL-PRIMITIVELY isn't primitive" exp)
                   (compile-unknown-call exp cenv cont state)))))))

(define (compile-primitive-call primitive args cenv cont state)
  (let ((name (primitive-name primitive)))
    (if ((if (primitive-n-ary? primitive) >= =)
	 (length args) (primitive-nargs primitive))
	((primitive-compilator primitive) args cenv cont state)
        (begin (warn "wrong number of arguments to primitive"
		     (cons name args))
	       (compile-unknown-call (cons (make-system-ref name) args)
				     cenv cont state)))))

(define primitives (make-table))
(define *primitive-names* '())

; "dp" stands for "define-compiler-primitive".
; It wants a short name so that definitions can fit on a single line.

(define (dp name nargs n-ary? proc)
  (table-set! primitives name (make-primitive name nargs n-ary? proc))
  (if (not (memq name *primitive-names*))
      (set! *primitive-names* (cons name *primitive-names*)))
  name)

(dp 'primitive-catch 1 #f  ;(primitive-catch (lambda (cont) ...))
  (lambda (args cenv cont state)
    (maybe-push-continuation (sequentially (emit op/push-cont)
                                           (compile (car args) cenv '(val) state)
                                           (emit op/call 1))
                             cont)))

(dp 'primitive-throw 2 #f  ;(primitive-throw cont val)
  (lambda (args cenv cont state)
    cont ;ignored
    (sequentially (compile (car args) cenv '(val) state)
		  (emit op/push)
		  (compile (cadr args) cenv '(val) state)
		  (emit op/pop-cont)
		  (emit op/return))))

; APPLY wants to first spread the list, then load the procedure.
(dp 'apply 2 #f
  (lambda (args cenv cont state)
    (maybe-push-continuation
     (sequentially (push-all (cdr args) cenv state)
                   (emit op/spread-args (length (cdr args)))
                   (compile (car args) cenv '(val) state) ;procedure arg
                   (emit op/n-call))                  ;pops nargs
     cont)))

; Easy miscellaneous primitives
(define (simply seg)
  (lambda (args cenv cont state)
    (sequentially (if (null? args)
		      empty-segment
		      (push-all-but-last args cenv state))
		  seg
		  (dispose-of-val cont))))

(define (trivial name)
  (simply (emit (name->enumerand name op))))

(for-each (lambda (z)
	    (dp (car z) (cadr z) #f (trivial (car z))))
	  '((set-enabled-interrupts! 1)
	    (unassigned 0)
	    (halt 1)))

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme  -*-

; This is file cprim.scm.

;;;; Compilation of primitives

; Synchronize this list with ARCH.SCM and PRIM.SCM

(for-each (lambda (z)
	    (dp (car z) (cadr z) #f (trivial (car z))))
	  '((eq?	       2)
	    (fixnum?           1)
	    (+                 2)
	    (-                 2)
	    (*                 2)
	    (=                 2)
	    (<                 2)
	    (quotient          2)
	    (remainder         2)
	    (char?             1)
	    (char->ascii       1)
	    (ascii->char       1)
	    (char=?            2)
	    (char<?            2)
	    (suspend           1)
	    (open-port         2)
	    (close-port	       1)
	    (read-char         1)
	    (peek-char         1)
	    (write-char        2)
	    (write-string      2)
	    (reverse-list->string 2)
	    (string=?          2)
	    (intern	       2)
	    (lookup	       2)))

(dp 'eof-object?   1 #f
    (lambda (args cenv cont state)
      (compile `(call-primitively eq? ,(car args) ,(make-system-ref 'eof-object))
	       cenv cont state)))


; Vectors, strings, code vectors

(dp 'make-vector   2 #f (simply (emit op/make-d-vector   stob/vector)))
(dp 'vector?	   1 #f (simply (emit op/stob-of-type?   stob/vector)))
(dp 'vector-length 1 #f (simply (emit op/d-vector-length stob/vector)))
(dp 'vector-ref	   2 #f (simply (emit op/d-vector-ref	 stob/vector)))
(dp 'vector-set!   3 #f (simply (emit op/d-vector-set!	 stob/vector)))

(dp 'make-string   1 #f (simply (emit op/make-b-vector stob/string)))
(dp 'string?	   1 #f (simply (emit op/stob-of-type? stob/string)))
(dp 'string-length 1 #f (simply (emit op/b-vector-length stob/string)))
(dp 'string-ref	   2 #f (simply (sequentially (emit op/b-vector-ref stob/string)
					      (emit op/ascii->char))))
(dp 'string-set!   3 #f (simply (sequentially (emit op/char->ascii)
					      (emit op/b-vector-set! stob/string))))

(dp 'make-code-vector   1 #f (simply (emit op/make-b-vector stob/code-vector)))
(dp 'code-vector?	1 #f (simply (emit op/stob-of-type? stob/code-vector)))
(dp 'code-vector-length 1 #f (simply (emit op/b-vector-length stob/code-vector)))
(dp 'code-vector-ref	2 #f (simply (emit op/b-vector-ref stob/code-vector)))
(dp 'code-vector-set!   3 #f (simply (emit op/b-vector-set! stob/code-vector)))

; Primitive structure types

(define (constructor type n)
  (simply (emit op/d-vector type n)))

(define (predicator type)
  (simply (emit op/stob-of-type? type)))

(define (accessor type i)
  (lambda (args cenv cont state)
    (sequentially 
     (push-all args cenv state)
     (emit op/literal (get-literal state i))
     (emit op/d-vector-ref type)
     (dispose-of-val cont))))

(define (updater type i)
  (lambda (args cenv cont state)
    (sequentially 
     (push-all args cenv state)
     (emit op/literal (get-literal state i))
     (emit op/d-vector-set! type)
     (dispose-of-val cont))))

(define (*define-primitive-structure-type type make pred slots)
  (dp make (length slots) #f (constructor type (length slots)))
  (dp pred 1 #f (predicator type))
  (do ((s slots (cdr s))
       (i 0 (+ i 1)))
      ((null? s) make)
    (let ((slot (car s)))
      (dp (car slot) 1 #f (accessor type i))
      (if (not (null? (cdr slot)))
	  (dp (cadr slot) 2 #f (updater type i))))))

(define-macro (define-primitive-structure-type type make pred . body)
  `(*define-primitive-structure-type ,type ',make ',pred ',body))

; Synchronize these with struct.scm.

(define-primitive-structure-type stob/pair cons pair?
  (car set-car!)
  (cdr set-cdr!))

(define-primitive-structure-type stob/symbol make-symbol symbol?
  (symbol->string))

(define-primitive-structure-type stob/closure make-closure closure?
  (closure-template)
  (closure-env))

(define-primitive-structure-type stob/cell make-cell cell?
  (contents set-contents!)
  (name))

(define-primitive-structure-type stob/port make-port port?
  (port-mode)
  (port-index set-port-index!)
  (peeked-char set-peeked-char!)
  (port-id))

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme  -*-

; This is file user.scm.

;;;; Set up the user's environment

(define user-initial-environment (make-empty-environment))

(set! *current-environment* user-initial-environment)

(for-each (lambda (name)
	    (environment-set! user-initial-environment
			      name
			      (environment-ref system-environment name)))
	  '(;;----------------
	    ;;  Unimplemented non-essential features:
	    ;;     acos angle atan ceiling
	    ;;     char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>?
	    ;;     char-ready?
	    ;;     cos denominator exact->inexact exp floor gcd
	    ;;     imag-part inexact->exact lcm log magnitude make-polar
	    ;;     make-rectangular modulo
	    ;;     number->string                 ;Important
	    ;;     numerator rationalize real-part round sin sqrt
	    ;;     string-ci<=? string-ci<? string-ci>=? string-ci>?
	    ;;     string-copy string-fill!
	    ;;     tan
	    ;;     transcript-on transcript-off   ;Important
	    ;;     truncate
	    ;;----------------
	    ;; Nonstandard features:
	    error eval user-initial-environment
	    system-environment  ;A necessary and sufficient loophole
	    ;;----------------
	    ;; Entries are in alphabetical order.
	    * + - / < <= = > >= abs append apply assoc assq assv
	    boolean?
	    caaaar caaadr caadar caaddr caaar caadr caar
	    cadaar cadadr caddar cadddr cadar caddr cadr
	    call-with-current-continuation call-with-input-file
	    call-with-output-file car
	    cdaaar cdaadr cdadar cdaddr cdaar cdadr cdar
	    cddaar cddadr cdddar cddddr cddar cdddr cddr
	    cdr char->integer char-alphabetic? char-downcase
	    char-lower-case? char-numeric? char-upcase
	    char-upper-case? char-whitespace? char<=? char<? char=?
	    char>=? char>? char? close-input-port close-output-port
	    complex? cons current-input-port current-output-port
	    denominator display eof-object? eq? equal? eqv? even?
	    exact->inexact exact? expt for-each force inexact->exact
	    inexact? input-port? integer->char integer? last-pair
	    length list list->string list->vector list-ref list-tail
	    load	;This should be user interface only...
	    make-string make-vector map max member memq memv min
	    negative? newline nil not null? number? numerator odd?
	    open-input-file open-output-file output-port? pair?
	    peek-char positive?  procedure? quotient rational? read
	    read-char real-part real? remainder reverse set-car!
	    set-cdr! string->list string->number string->symbol string-length
	    string-ref string-set! string=? string? symbol->string
	    symbol? t vector vector->list vector-fill! vector-length
	    vector-ref vector-set! vector? with-input-from-file
	    with-output-to-file write write-char zero?
	    ))