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

; This is file assem.scm.

;;;; Disassembler and assembler

(define (disassemble tem)
  (newline)
  (really-disassemble (cond ((number? tem)
			     (extract (if (($ vm closure?) tem)
					  (($ vm closure-template) tem)
					  tem)))
			    ((and (pair? tem) (eq? (car tem) 'lambda))
			     (compile-lambda tem
					     (environment->cenv system-environment)
					     nil))
			    ((template? tem) tem)
			    ((closure? tem) (closure-template tem))
			    (else (error "not coercable to a template" tem)))
                      1)
  'done)

(define (really-disassemble tem level)
  (display "(%LAP ")  ;field reserved for template name
  (if (template-name tem)
      (write (template-name tem))
      (display "#F"))
  (let loop ((pc 0))
    (if (< pc (code-vector-length (template-code tem)))
	(loop (write-instruction tem pc level))
	(write-char #\) ))))

(define (newline-indent n)
  (newline)
  (do ((i n (- i 1)))
      ((= i 0))
    (write-char #\space)))

(define (write-instruction tem pc level)
  (let* ((code  (template-code tem))
         (const tem)  ;constants vector
         (opcode (code-vector-ref code pc))
	 (pc+1 (+ pc 1))
	 (lit (lambda () (vector-ref const (code-vector-ref code pc+1))))
	 (pc+2 (+ pc 2)))
    (newline-indent (* level 2))
    (if (< pc 10) (display " "))
    (write pc)
    (display "  (")
    (write (enumerand->name opcode op))
    (let ((new-pc
	   (cond ((= opcode op/literal)
		  (write-string " '")
		  (write (lit))
		  pc+2)
		 ((= opcode op/native)
		  (write-char #\space)
		  (write (code-vector-ref code pc+1))
		  (write-string " '")
		  (write (vector-ref const (code-vector-ref code pc+2)))
		  (+ pc 3))
		 ((or (= opcode op/global)
		      (= opcode op/set-global!))
		  (write-char #\space)
		  (write `(cell ,(cell-name (lit))))
		  pc+2)
		 ((= opcode op/make-closure)
		  (write-char #\space)
		  (really-disassemble (lit) (+ level 1))
		  pc+2)
		 ((or (= opcode op/local)
		      (= opcode op/set-local!))
		  (write-char #\space)
		  (write (code-vector-ref code pc+1))
		  (write-char #\space)
		  (write (code-vector-ref code pc+2))
		  (+ pc 3))
		 ((or (= opcode op/check-nargs=)
		      (= opcode op/check-nargs>=)
		      (= opcode op/make-env)
		      (= opcode op/make-rest-list)
		      (= opcode op/call)
		      (= opcode op/spread-args)
		      (= opcode op/open-port))
		  (write-char #\space)
		  (write (code-vector-ref code pc+1))
		  pc+2)
		 ((or (= opcode op/jump-if-false)
		      (= opcode op/jump)
		      (= opcode op/make-cont))
		  (write-char #\space)
		  (write `(-> ,(+ pc (code-vector-ref code pc+1) 2)))
		  pc+2)
		 ((or (= opcode op/make-d-vector)
		      (= opcode op/stob-of-type?)
		      (= opcode op/d-vector-ref)
		      (= opcode op/d-vector-set!)
		      (= opcode op/d-vector-length)
		      (= opcode op/make-b-vector)
		      (= opcode op/b-vector-ref)
		      (= opcode op/b-vector-set!)
		      (= opcode op/b-vector-length))
		  (write-char #\space)
		  (write `(e stob ,(enumerand->name (code-vector-ref code pc+1) stob)))
		  pc+2)
		 ((= opcode op/d-vector)
		  (write-char #\space)
		  (write `(e stob ,(enumerand->name (code-vector-ref code pc+1) stob)))
		  (write-char #\space)
		  (write (code-vector-ref code pc+2))
		  (+ pc 3))
		 (else pc+1))))
      (write-char #\))
      new-pc)))

; The rudiments of an assembler.

(define-compilator '%lap
  (lambda (exp cenv cont state)
    (sequentially
     (emit op/make-closure
	   (get-literal state (compile-lap (cadr exp) (cddr exp))))
     (dispose-of-val cont))))

(define (compile-lap name instruction-list)
  name  ;ignored for now
  (compiling (lambda (state)
	       (assemble instruction-list state))))

(define (assemble instruction-list state)
 (do ((l instruction-list (cdr l))
      (seg empty-segment
	   (if (pair? (car l))
	       (sequentially seg (assemble-instruction (car l) state))
	       seg)))  ;Ignore labels.
     ((null? l) seg)))

(define (assemble-instruction instr state)
  (do ((os (cdr instr) (cdr os))
       (seg (emit (name->enumerand (car instr) op))
	    (sequentially seg (assemble-operand (car os) state))))
      ((null? os) seg)))

(define (assemble-operand opcode state)
  (cond ((integer? opcode) (emit opcode))
	((eq? (car opcode) 'quote) (emit (get-literal state (cadr opcode))))
	((eq? (car opcode) 'e)
	 (emit (name->enumerand (caddr opcode)
				(case (cadr opcode)
				  ((stob) stob)
				  (else (error "losing" opcode))))))
	((eq? (car opcode) '->)
	 (error "not yet implemented" opcode))
	(else (error "unknown operand type" opcode))))
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file basic.scm.

;;;; Fundamental definitions

; The value returned by SET! is unspecified.

(define unspecified (let ((x 0)) (set! x 1)))

; Booleans

(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)))

; Equality

(define eqv? eq?)

(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)))

; Numbers
;  How to modularize for VM's like Maclisp that have generic arithmetic
;  built-in?

(define integer?  fixnum?)   ;Fix later
(define rational? integer?)  ;Fix later
(define real?	  number?)   ;Fix later
(define complex?  number?)   ;Fix later

(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 (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))

; 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))))))

; Macro auxiliaries

(define (or-aux p else-thunk)
  (if p p (else-thunk)))

(define (and-aux p then-thunk)
  (if p (then-thunk) p))

(define (=>-aux p proc-thunk else-thunk)
  (if p ((proc-thunk) p) (else-thunk)))

(define (case-aux key key-lists else-thunk . thunks)
  (let loop ((k key-lists)
	     (t thunks))
    (cond ((null? k) (else-thunk))
	  ((memv key (car k)) ((car thunks)))
	  (else (loop (cdr k) (cdr t))))))
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file comp.scm.

;;;; The compiler

; Opimizations are marked with +++, and may be flushed.

; COMPILE-TOP

(define (compile-top l-exp env name)
  (compile-lambda l-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-compilator 'letrec
  (lambda (exp cenv cont state)
    (compile (rewrite-letrec exp) cenv cont state)))

(define (rewrite-letrec exp)
  (let ((specs (car exp)) (body (cdr exp)))
    `((lambda ,(map car specs)
	,@(map (lambda (spec) `(set! ,@spec)) specs)
	,@body)
      ,@(map (lambda (spec)
	       spec ;ignored
	       `(,(make-system-ref 'unassigned)))
	     specs))))

(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)
  (if (eq? (car cont) 'return)
      code
      (sequentially (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)"
			 opcode 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)))
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file cprim.scm.

;;;; Compiling 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 (trivial name)
  (lambda (args cenv cont state)
    (sequentially (if (null? args)
		      empty-segment
		      (push-all-but-last args cenv state))
		  (emit (name->enumerand name op))
		  (dispose-of-val cont))))

; Synchronize this list with ARCH.SCM and PRIM.SCM
; THIS IS RIDICULOUS.  The list should appear in only one place.

(for-each (lambda (z)
	    (dp (car z) (cadr z) #f (trivial (car z))))
	  '(;; Scalar
	    (eq?	       2)
	    (fixnum?           1)
	    (number?           1)
	    (+                 2)	;or n-ary
	    (-                 2)	;or n-ary
	    (*                 2)	;or n-ary
	    (=                 2)	;or n-ary
	    (<                 2)	;or n-ary
	    (quotient          2)
	    (remainder         2)
	    (char?             1)
	    (char=?            2)
	    (char<?            2)
	    (char->ascii       1)
	    (ascii->char       1)
	    (eof-object?       1)
	    ;; Stored
	    (pair? 1) (cons 2) (car 1) (cdr 1) (set-car! 2) (set-cdr! 2)
	    (symbol? 1) (make-symbol 1) (symbol->string 1)
	    (cell? 1) (make-cell 2) (cell-name 1) (contents 1) (set-contents! 2)
	    (closure? 1) (make-closure 2) (closure-env 1) (closure-template 1)
	    (code-vector? 1) (make-code-vector 2) (code-vector-length 1)
	    (code-vector-ref 2) (code-vector-set! 3)
	    (string? 1)
	    (make-string 2)		;or 1
	    (string-length 1) (string-ref 2) (string-set! 3)
	    (vector? 1)
	    (make-vector 2)		;or 1
	    (vector-length 1) (vector-ref 2) (vector-set! 3)
	    ;; I/O
	    (input-port?       1)
	    (output-port?      1)
	    (open-port         2)
	    (close-port	       1)
	    (read-char         1)	;or 0
	    (peek-char         1)	;or 0
	    (write-char        2)	;or 1
	    (write-string      2)
	    ;; Misc
	    (unassigned        0)
	    (halt	       1)
	    (set-enabled-interrupts! 1)
	    (return-from-handler 1)
	    (write-image       1)
	    ;; Unnecessary
	    (reverse-list->string 2)
	    (string=?          2)
	    (intern	       2)
	    (lookup	       2)))
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file defprim.scm.

;;;; Macros for defining primitives

(define expand-define-primitive
  (make-expander
   (lambda (close opcode input-types action . returner-option)
     (let ((places (reverse (shorten `(*val* *arg2* *arg3* *arg4*)
				     input-types)))
	   (nargs (length input-types)))
       (close				;Cheat
	`(define-opcode ,opcode
	   (lambda ()
	     ,@(if (>= nargs 2) `((set! *arg2* (pop))) `())
	     ,@(if (>= nargs 3) `((set! *arg3* (pop))) `())
	     ,@(if (>= nargs 4) `((set! *arg4* (pop))) `())
	     (if (and ,@(map (lambda (in place)
			       `((input-type-predicate ,in) ,place))
			     input-types
			     places))
		 ,(let ((yow `(,action
			       ,@(map (lambda (in place)
					`((input-type-coercion ,in) ,place))
				      input-types
				      places))))
		    (if (null? returner-option)
			yow
			`(,(car returner-option) ,yow)))
		 (goto wrong-type-argument)))))))))

(define expand-define-primitive-structure-type
  (make-expander
   (lambda (close type make . body)
     (let* ((type-> (concatenate-symbol type '->))
	    (type?  (concatenate-symbol type '?))
	    (size   (concatenate-symbol type '-size))
	    (op/    (lambda (name) (concatenate-symbol 'op/ name)))
	    (vars (shorten `(a b c d e f g) body)))
       (close				;Cheat
	`(let ((,type-> (input-type ,type? no-coercion)))
	   (define-primitive ,(op/ type?) (any->) ,type? ->boolean)
	   (define-primitive ,(op/ make) ,(map (lambda (var) var `any->) vars)
	     (lambda ,vars
	       (ensure-space ,size
		 (lambda ()
		   (return (,make ,@vars))))))
	   ,@(apply append
		    (map (lambda (slot)
			   (let ((get (car slot)))
			     `((define-primitive ,(op/ get) (,type->) ,get return)
			       ,@(if (null? (cdr slot))
				     `()
				     (let ((set (cadr slot)))
				       `((define-primitive ,(op/ set) (,type-> any->)
					   ,set ->unspecified)))))))
			 body))))))))

(define expand-define-vector-type
  (make-expander
   (lambda (close type)
     (let* ((type-> (concatenate-symbol type '->))
	    (type?  (concatenate-symbol type '?))
	    (size   (concatenate-symbol type '-size))
	    (make   (concatenate-symbol 'make- type))
	    (length (concatenate-symbol type '-length))
	    (ref    (concatenate-symbol type '-ref))
	    (set    (concatenate-symbol type '-set!))
	    (op/    (lambda (name) (concatenate-symbol 'op/ name))))
       (close				;Cheat
	`(let ((,type-> (input-type ,type? no-coercion)))
	   (define-primitive ,(op/ type?) (any->) ,type? ->boolean)
	   (define-primitive ,(op/ length) (,type->) ,length ->fixnum)
	   (define-primitive ,(op/ make) (fixnum-> any->)
	     (vector-maker ,size ,make ,set))
	   (define-primitive ,(op/ ref) (,type-> fixnum->)
	     (vector-referencer ,length ,ref))
	   (define-primitive ,(op/ set) (,type-> fixnum-> any->)
	     (vector-setter ,length ,set))
	   ))))))

(define (shorten l1 l2)
  (map (lambda (x1 x2) x2 x1) l1 l2))

(define defprim-sig
  (make-signature 'defprim-sig
    `((define-primitive
	,(make-macro-alphatizer expand-define-primitive))
      (define-primitive-structure-type
	,(make-macro-alphatizer expand-define-primitive-structure-type))
      (define-vector-type
	,(make-macro-alphatizer define-vector-type)))
    ;;+++ KLUDGE
    '()
    '()))
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file derive.scm.

;;;; Macro expanders for standard derived expression types

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

(define rewriters (make-table))

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

; The output of PARSE-TOP-LEVEL-FORM is a <form>:
;   <form> ::= <exp>
;	     | (define <var> <exp>)
;	     | (begin <form>*)
; where ALPHA has been applied to each subexpression.
; The second argument to ALPHA is either <var> or #f.
;
;+++ Should perhaps return two values: a form and an updated
;    syntactic-environment.

(define (parse-top-level-form form alpha)
  (cond ((definition? form)
	 (let ((lhs (definition-lhs form)))
	   `(define ,lhs ,(alpha (definition-rhs form) lhs))))
	((not (pair? form)) (alpha form nil))
	((eq? (car form) 'begin)
	 `(begin ,@(map (lambda (form)
			  (parse-top-level-form form alpha))
			(cdr form))))
	((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))
	   `',(car pat)))
	(else
	 (let ((probe (get-macro-expander (car form))))
	   (if probe
	       (parse-top-level-form (probe form) alpha)
	       (alpha form nil))))))

; Definitions

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

(define (definition-lhs form)
  (let ((pat (cadr form)))
    (if (pair? pat) (car pat) pat)))

(define (definition-rhs form)
  (let ((pat (cadr form)))
    (if (pair? pat)
	`(lambda ,(cdr pat) ,@(cddr form))
	(caddr form))))

; Absolute references

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

(define (make-system-ref x)
  (list system-ref-marker x))

(define (system-ref? x)
  (and (pair? x) (eq? (car x) system-ref-marker)))

(define system-ref-name cadr)

; Deal with internal defines (ugh)

(define (process-body exp-list)
  (let loop ((e exp-list)
	     (d '()))
    (cond ((null? e)
	   (error "null body" exp-list))
	  ((definition? (car e))
	   (loop (cdr e) (cons `(,(definition-lhs (car e))
				 ,(definition-rhs (car e)))
			       d)))
	  ((not (null? d))
	   `(letrec ,d ,@e))
	  ((null? (cdr e))
	   (car e))
	  (else
	   `(begin ,@e)))))

; 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 `(,(make-system-ref 'and-aux)
		  ,(car conjuncts)
		  (lambda () (and ,@(cdr conjuncts))))))))

; (case key ((a b) x) ((c) y) (else z))
;  ==>  (case-aux key
;		  '((a b) (c))
;		  (lambda () z)
;		  (lambda () x)
;		  (lambda () y))

(define-rewriter 'case
  (lambda (key . clauses)
    (let ((form-result
	   (lambda (else-thunk thunks key-lists)
	     `(,(make-system-ref 'case-aux)
	       ,key
	       ',(reverse key-lists)
	       ,else-thunk
	       ,@(reverse thunks)))))
    (let loop ((c clauses) (thunks '()) (key-lists '()))
      (if (null? c)
	  (form-result `(lambda () ,(make-system-ref 'unspecified))
		       thunks key-lists)
	  (let ((clause (car c)))
	    (if (eq? (car clause) 'else)
		(form-result `(lambda () ,@(cdr clause)) thunks key-lists)
		(loop (cdr c)
		      (cons `(lambda () ,@(cdr clause)) thunks)
		      (cons (car clause) key-lists)))))))))

(define-rewriter 'cond
  (lambda clauses
    (cond ((null? clauses) (make-system-ref 'unspecified))
	  ((null? (cdar clauses))
	   `(or ,(caar clauses)
		(cond ,@(cdr clauses))))
	  ((eq? (caar clauses) 'else)
	   `(begin ,@(cdar clauses)))
	  ((eq? (cadr (car clauses)) '=>)
	   `(,(make-system-ref '=>-aux)
	     ,(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 'or
  (lambda disjuncts
    (cond ((null? disjuncts) nil)			;nil => #f which self-evaluates
	  ((null? (cdr disjuncts)) (car disjuncts))
	  (else `(,(make-system-ref 'or-aux)
		  ,(car disjuncts)
		  (lambda () (or ,@(cdr disjuncts))))))))

(define-rewriter 'define
  (lambda (pat . body)
    (error "definition occurs in illegal context"
	   `(define ,pat ,@body))))

;;;; 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 (+ level 1) 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 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")
	((eof-object? obj) "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)))))

(define (sub-read-comment port readtable)
  (let ((c (read-char port)))
    (cond ((eof-object? c) c)                     ; no test with conditions
          ((char=? c #\newline) (sub-read port readtable))
          (else (sub-read-comment port readtable)))))

(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))

; Misc. 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 (digit c radix)	  ;Auxiliary for above
  (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))))

(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 ssig.scm.

;;;; Scheme signature

(define-signature revised^3-scheme-sig
  (syntax and begin case cond delay do if lambda let let* letrec or
	  quasiquote quote set!)
  (values * + - / < <= = > >=		;193
	  abs acos angle append apply asin assoc assq assv atan
	  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 ceiling char->integer char-alphabetic?
	  char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>?
	  char-downcase char-lower-case? char-numeric? char-ready?
	  char-upcase
	  char-upper-case? char-whitespace? char<=? char<? char=?
	  char>=? char>? char? close-input-port close-output-port
	  complex? cons cos current-input-port current-output-port
	  denominator display
	  eof-object? eq? equal? eqv? even? exact->inexact exact?
	  exp expt
	  floor for-each force
	  gcd
	  imag-part inexact->exact inexact? input-port?
	  integer->char integer?
	  last-pair lcm length list list->string list->vector
	  list-ref list-tail load log
	  magnitude make-polar make-rectangular make-string
	  make-vector map max member memq memv min modulo
	  negative? newline nil not null? number? number->string
	  numerator
	  odd? open-input-file open-output-file output-port?
	  pair? positive? procedure?
	  quotient
	  rational? rationalize read read-char real-part real?
	  remainder reverse round
	  set-car! set-cdr! sin sqrt string->list string->number
	  string->symbol string-append
	  string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>?
	  string-copy string-fill! string-length string-ref
	  string-set! string<=? string<? string=? string>=? string>?
	  string? substring symbol->string symbol?
	  t tan transcript-on transcript-off truncate
	  vector vector->list vector-fill! vector-length
	  vector-ref vector-set! vector?
	  with-input-from-file with-output-to-file write write-char
	  zero?
	  )
  (auxiliaries and-aux case-aux make-promise or-aux
	       unassigned unspecified =>-aux))
; -*- 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).

(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, command loop, ERROR, 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)
  (letrec ((recur
	    (lambda (form)
	      (cond ((not (pair? form)) (eval-expression form env))
		    ((eq? (car form) 'define)
		     (environment-set! env
				       (cadr form)
				       (eval-expression (caddr form) env))
		     `(,(cadr form) defined))
		    ((eq? (car form) 'begin)
		     (do ((f (cdr form) (cdr f)))
			 ((null? (cdr f)) (recur (car f)))
		       (recur (car f))))
		    (else (eval-expression f env))))))
    (recur (parse-top-level-form form
	     (lambda (exp where) exp)))))

(define (eval-expression 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)
  (write-image 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 (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 (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.

(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

; Exception and interrupt handlers take one argument, an "istate"
; (interpreter state).  An istate has fields for cont, nargs, val, etc.

(define (set-exception-handler! e proc)
  (vector-set! exception-handlers
	       e
	       (lambda (istate)
		 (set-istate-val! istate (proc istate))
		 (return-from-handler istate))))

(do ((i 0 (+ i 1)))
    ((= i (length exception)))
  (set-exception-handler! i
    (lambda (istate)
      (error "exception"
	     (enumerand->name i exception))
      (not-proceedable))))

(set-exception-handler! exception/unassigned-global
  (lambda (istate)
    (error "reference to unassigned variable"
	   (cell-name (istate-arg2 istate)))))

(set-exception-handler! exception/unbound-global
  (lambda (istate)
    (error "reference or assignment to unbound variable"
	   (cell-name (istate-arg2 istate)))))

(set-exception-handler! exception/bad-procedure
  (lambda (istate)
    (let ((proc (istate-val istate))
	  (argvals (istate-argvals istate)))
      (error "call to a non-procedure" proc argvals))))

(set-exception-handler! exception/wrong-number-of-arguments
  (lambda (istate)
    (let ((proc (istate-val istate))
	  (argvals (istate-argvals istate)))
      (error "wrong number of arguments" proc argvals))))  

(define (istate-argvals istate)
  (let ((nargs (istate-nargs istate)))
    (do ((s (LOSELOSELOSE (istate-cont istate)))
	 (l '() (cons (car s) l))
	 (i 0 (+ i 1)))
	((= i nargs) (reverse l)))))

; This is the place to install generic arithmetic.

(set-exception-handler! exception/wrong-type-argument
  (lambda (istate)
    (let ((opcode (enumerand->name
		   (code-vector-ref (- (continuation-pc (istate-cont istate))
				       1))
		   op)))
      (error "wrong type argument"
	     opcode
	     (istate-val istate)
	     (istate-arg2 istate)
	     (istate-arg3 istate)))))

; Many others to deal with as well.

(vector-set! interrupt-handlers interrupt/keyboard
  (lambda (istate)
    (set-enabled-interrupts! (istate-ei istate))	;Re-enable
    (display "Interrupt")
    (command-loop)
    (return-from-handler istate)))
; -*- 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)))
	  (signature-vars scheme-sig))

	    ;;----------------
	    ;;  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->number
	    ;;     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
	    ;;----------------