rASl0w{ ,6CJ*HfTP(E`$dG%E>~@&T PAG>n&TNm\XvI$"D?fTIY`"P*r\UG%ʝ"2TI_K;-P(7]r\ULMM9$@85fRpxhO .>q S;$\X,dCex$3^S<(`K=fTP3aJMP(@S 3e>00\!pleVp"d^>3=gS, &P`r\edgg2d m6Mp0jIpbG;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file arch.scm. ;;; Requires DEFINE-ENUMERATION macro. ;;;; Architecture description ;;; Things that the VM and the runtime system both need to know. ;;; Bytecodes: for compiler and interpreter (define-enumeration opcode (literal ;index make-env ;number of formals make-env-rest ;number of required formals lexical ;back over set-lexical! ;back over user ;index set-user! ;index system ;index set-system! ;index make-closure ;index push-argument ; -- push VAL onto stack make-continuation ;delta -- save state call ;nargs -- result to VAL register call-return ;nargs -- return results jump-if-false ;delta join ;delta -- rejoin after conditional return )) ;;; Machine state: for exception generators and handlers. (define-enumeration register (template val env cont stack pc enabled-interrupts interrupt-handlers exception-handlers empty-vector empty-string symbol-table )) ;;; Exception types: for exception generators and handlers. ;;; - How fine should the granularity be? (define-enumeration exception (undefined-lexical undefined-free ;symbol is in *val* bad-procedure wrong-number-of-arguments wrong-type-argument index-out-of-range arithmetic-exception losing-projection ;(project foo wrong-type) heap-overflow ;(make-vector huge) port-problem ;generic i/o error out-of-ports ;too many opens )) ;;; Interrupts (define-enumeration interrupt (none keyboard ;alarmclock, ... )) ;;; BITS-PER-BYTE: ;;; The compiler needs to know how many bits there are in a byte, ;;; since it constructs byte vectors. (define bits-per-byte 7) ;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file basic.scm. ;;;; Fundamental definitions ;;; At the time this file is loaded, the only definitions in existence ;;; are the system primitives (enumerated in the architecture ;;; definition). ;;; 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))) ;;; 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 (odd? n) (< 0 (remainder n 2))) (define (even? n) (not (odd? 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)) ;;; 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?)) ;;; Characters [primitive: char? char->ascii ascii->char char=? char? x y) (char=? x y) (not (charinteger 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) (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) (string? s1 s2))) (define (string>=? s1 s2) (not (stringsymbol string) (intern string the-symbol-table)) ;;; 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)))) (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)))) ;;; Control features (define (apply proc arg . other-args) (let ((apply2 (lambda (proc args) (case (length args) ((0) (proc)) ((1) (proc (car args))) ((2) (proc (car args) (cadr args))) ((3) (proc (car args) (cadr args) (caddr args))) ((4) (proc (car args) (cadr args) (caddr args) (cadddr args))) ((5) (proc (car args) (cadr args) (caddr args) (cadddr args) (cadddr (cdr args)))) ;; ... ad infinitum. (else (eval `(',proc ,@(map (lambda (args) `',args) args)) s48-implementation-environment)))))) (if (null? other-args) (apply2 proc arg) (apply2 proc (cons arg (letrec ((r (lambda (a) (if (null? (cdr a)) (car a) (cons (car a) (r (cdr a))))))) (r other-args))))))) (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 boot.scm. ;;;; Bootstrapping and debugging ;;; Definitions here are necessary if and only if you want to build a ;;; heap from scratch. (define (boot) (init) (cold-load) (run! '(dump "s48.sus")) 'booted) (define (init) (newline) (display "Initializing...") (initialize-heap) (initialize-machine) (establish-initial-definitions)) (define (cold-load) ;; Takes about 7 minutes on a 3600, if no procedures are integrated. (for-each (lambda (f) ($load (string-append "AI: S48; " f " >"))) '("basic" "enum" "arch" "io" "comp" "sys")) 'done) (define (initialize-machine) ;; Pre-allocate the root so we don't have to cons it at GC time. (set! *root* ($make-vector (vector-length register))) (set! *exception-handlers* ($make-vector (vector-length exception))) (set! *interrupt-handlers* ($make-vector (vector-length interrupt))) (set! *empty-vector* ($make-vector 0)) (set! *empty-string* ($make-string 0)) (set! *symbol-table* ($cons $unspecified $null)) ;For use by ENTER 'done) (define (establish-initial-definitions) ($define 'the-symbol-table *symbol-table*) ($define 'unspecified $unspecified) ;Needed by COND ($define 'exception-handlers *exception-handlers*) ($define 'interrupt-handlers *interrupt-handlers*) ($define 'user-initial-environment $user-initial-environment) ($define 's48-implementation-environment $s48-implementation-environment) ($define 'eof-object $eof-object) ($define 'initial-input-port (make-initial-input-port)) ($define 'initial-output-port (make-initial-output-port)) (for-each-label (lambda (name tag) ($define name ($make-primitive tag))))) (define ($define name val) ($environment-set! $s48-implementation-environment (enter name) val)) ;;; Scheme value -> simulated value ;;; Quite dangerous. It's essential that there be enough space for the ;;; routine to do what it needs to do, without any need for GC, since there ;;; won't be any opportunity to do one. (define (enter obj) (cond ((target-fixnum? obj) (enter-fixnum obj)) ((char? obj) (enter-char obj)) ;; The relative ordering of this case and the next is important! ((eq? obj '()) $null) ((eq? obj nil) $nil) ((eq? obj t) $t) ((pair? obj) ($cons (enter (car obj)) (enter (cdr obj)))) ((symbol? obj) ($intern (enter (symbol->string obj)) *symbol-table*)) ((string? obj) (if (= (string-length obj) 0) *empty-string* (let ((v ($make-string (string-length obj)))) (do ((i 0 (+ i 1))) ((>= i (string-length obj)) v) ($string-set! v i (string-ref obj i)))))) ((byte-vector? obj) (let ((v ($make-byte-vector (byte-vector-length obj)))) (do ((i 0 (+ i 1))) ((>= i (byte-vector-length obj)) v) ($byte-vector-set! v i (byte-vector-ref obj i))))) ((template? obj) ($make-template (enter (template-code obj)) (enter (template-literals obj)) (enter (template-name obj)))) ;; Vector case must be last, for simulation ((vector? obj) (if (= (vector-length obj) 0) *empty-vector* (let ((v ($make-vector (vector-length obj)))) (do ((i 0 (+ i 1))) ((>= i (vector-length obj)) v) ($vector-set! v i (enter (vector-ref obj i))))))) (else (error "unenterable object" obj)))) ;;; Misc. bootstrap and debugging stuff ;;; The storage manager can run independently of the interpreter if ;;; desired. The following definitions for invoking the evaluator ;;; aren't necessary if you're only going to use the storage manager. (define ($load filename) (call-with-input-file filename (lambda (port) (newline) (display "Loading ") (write filename) (let loop () (let ((form (read port))) (cond ((eof-object? form) 'done) (else (run! form) (write-char #\.) (loop)))))))) (define (run! exp) (set! *val* ($make-closure (enter (compile-top exp 'system)) $s48-implementation-environment)) (set! *nargs* 0) (set! *cont* $nil) ;Meaning halt when done (set! *stack* $nil) (run-machine perform-application)) (define ($gc) (save-registers *root*) (set! *finished* halt-machine) (run-machine collect) (restore-registers *root*) 'done) q;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file comp.scm. ;;;; The compiler ;;; Still needs some work. How to make this more elegant without making ;;; it too slow or strange? ;;; COMPILE-TOP: ;;; The top-level CENV should be one of the two symbols SYSTEM or USER ;;; for system code and user code, resp. (define (compile-top exp cenv) (compile-lambda `(lambda () ,(expressionify-top exp)) cenv nil)) (define (expressionify-top exp) (cond ((definition? exp) `(set! ,@(process-definition exp))) ((not (pair? exp)) exp) ((eq? (car exp) 'begin) `(begin ,@(map expressionify-top (cdr exp)))) (else (let ((probe (table-ref rewriters (car exp)))) (if probe (expressionify-top (probe exp)) exp))))) (define (compile-lambda exp cenv name) (let* ((nargs (number-of-required-args (cadr exp))) (state (make-state)) (segment (sequentially (if (n-ary? (cadr exp)) (emit opcode/make-env-rest nargs) (emit opcode/make-env nargs)) (compile (process-body (cddr exp)) (bind-vars (normalize-formals (cadr exp)) cenv) '(return) state))) (bv (make-byte-vector (segment-size segment)))) (emit-segment bv 0 segment) (make-template bv (reverse-list->vector (state-literals state) (+ (state-literals-index state) 1)) 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) (sequentially (let ((info (lookup exp cenv))) (case (car info) ((user) (emit opcode/user (get-literal state exp))) ((system) (emit opcode/system (get-literal state exp))) ((required) (emit opcode/lexical (cadr info) (caddr info))))) (dispose-of-val 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) 'system cont state)) ((not (symbol? (car exp))) (compile-call exp cenv cont state)) (else (let ((probe (table-ref compilators (car exp)))) (if probe (probe exp cenv cont state) (let ((probe (table-ref rewriters (car exp)))) (if probe (compile (probe exp) cenv cont state) (compile-call exp cenv cont state)))))))) (define compilators (make-table)) (define (define-compilator name proc) (table-set! compilators name proc)) (define-compilator 'quote (lambda (exp cenv cont state) (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 opcode/make-closure (get-literal state (compile-lambda exp cenv name))) (dispose-of-val cont state))))) (define-compilator 'set! (lambda (exp cenv cont state) (let ((var (cadr exp)) (val (caddr exp))) (sequentially (compile val cenv `(set! ,var) state) (let ((info (lookup var cenv))) (case (car info) ((user) (emit opcode/set-user! (get-literal state var))) ((system) (emit opcode/set-system! (get-literal state var))) ((required) (emit opcode/set-lexical! (cadr info) (caddr info))))) (dispose-of-val cont state))))) (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) (emit-delta opcode/join (segment-size alt-segment))))) (sequentially (compile (cadr exp) cenv '(val) state) (emit-delta opcode/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 opcode/literal (get-literal state obj)) (dispose-of-val cont state))) (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-call exp cenv cont state) (let ((nargs (length (cdr exp)))) (if (eq? (car cont) 'return) (sequentially (compile-call-subexpressions exp cenv state) (emit opcode/call-return nargs)) (let ((code (sequentially (compile-call-subexpressions exp cenv state) (emit opcode/call nargs)))) (sequentially (emit-delta opcode/make-continuation (segment-size code)) code))))) (define (compile-call-subexpressions exp cenv state) (let loop ((args (cdr exp)) (code empty-segment)) (if (null? args) (sequentially code (compile (car exp) cenv '(val) state)) (loop (cdr args) (sequentially code (compile (car args) cenv '(val) state) (emit opcode/push-argument)))))) (define (dispose-of-val cont state) (if (eq? (car cont) 'return) (emit opcode/return) empty-segment)) ;;; Lexical environment management (define bind-vars cons) ;;; Returns one of ;;; (USER) ;;; (SYSTEM) ;;; (REQUIRED back over) (define (lookup var cenv) (let outer ((cenv cenv) (back 0)) (cond ((not (pair? cenv)) (list cenv)) (else (let inner ((rib (car cenv)) (over 0)) (cond ((not (pair? rib)) (outer (cdr cenv) (+ back 1))) ((eq? var (car rib)) (list 'required back over)) (else (inner (cdr rib) (+ over 1))))))))) ;;; Literal management (define (make-state) (list '() -1)) (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) 1))) (set-state-literals-index! state index) (if (>= index byte-factor) (error "code too complicated for this system" (state-literals state))) (set-state-literals! state (cons thing (state-literals state))) index)) ;;; Code emission utilities (define (sequentially . segments) (make-segment (lambda (bv pc) (let loop ((pc pc) (s segments)) (if (null? s) pc (loop (emit-segment bv 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 op . operands) (make-segment (lambda (bv pc) (do ((l operands (cdr l)) (pc (emit-byte! bv pc op) (emit-byte! bv pc (car l)))) ((null? l) pc))) (+ 1 (length operands)))) (define byte-factor 128) (define (emit-delta opcode delta) (emit opcode (quotient delta byte-factor) (remainder delta byte-factor))) (define (emit-byte! bv pc byte) (if (>= byte byte-factor) (error "byte too big (probably due to complicated code)" byte bv)) (byte-vector-set! bv pc byte) (+ pc 1)) (define make-segment cons) (define segment-size cdr) (define (emit-segment bv pc segment) ((car segment) bv pc)) (define empty-segment (sequentially)) ;;; Absolute references (define system-ref-marker (list 'system-ref-marker)) ;unique marker (define (make-system-ref x) (list system-ref-marker x)) ;;;; Macros (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 (process-definition (car e)) d))) ((not (null? d)) `(letrec ,d ,@e)) ((null? (cdr e)) (car e)) (else `(begin ,@e))))) (define (definition? thing) (and (pair? thing) (eq? (car thing) 'define))) (define (process-definition d) (let ((pat (cadr d)) (body (cddr d))) (cond ((pair? pat) `(,(car pat) (lambda ,(cdr pat) ,@body))) (else `(,pat ,@body))))) (define rewriters (make-table)) (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) `(,(make-system-ref 'undefined))) 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-macro (lambda (pat . body) (define-rewriter (car pat) (eval `(lambda ,(cdr pat) ,@body) user-initial-environment)) `',(car pat) ;; `(,(make-system-ref 'define-rewriter) ',(car pat) (lambda ,(cdr 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 (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))) A;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file data.scm. ;;; Requires DEFINE-ENUMERATION macro. ;;;; Data representations ;;; This implementation of the data representations is particularly ;;; tuned for byte-addressable machines with 4 bytes per word. ;;; Good representations for other kinds of machines would necessarily ;;; look quite different; e.g. on a word-addressed machine you might ;;; want to put tag bits in the high end of a word, or even go to some ;;; king of BIBOP system. ;;; Exports: ;;; enter-fixnum extract-fixnum $fixnum? ;;; enter-boolean $nil $t $false? ;;; $eq? $unspecified $undefined ;;; $pair? $cons $car $cdr $set-car! $set-cdr! ;;; $null $list-ref $list-tail ;;; enter-char extract-char ;;; extract-string $string? $make-string $string-ref $string-set! ;;; $intern ;;; $vector? $make-vector $vector-ref $vector-set! ;;; $byte-vector? $byte-vector-ref ;;; $template? $template-code $template-literals ;;; $procedure? $primitive? ;;; $closure? $make-closure $closure-template $closure-env ;;; $continuation? $make-continuation $continuation-ref $continuation-set! ;;; $user-initial-environment $s48-implementation-environment ;;; $environment-ref $environment-set! ;;; $user-value $set-user-value! $system-value $set-system-value! ;;; ... and similar operations on ports ;;; ;;; Imports: ;;; *HP* from GC ;;; LABEL->FIXNUM from RUN ;;; Descriptors ;;; A "descriptor" represents a Scheme object. ;;; A descriptors is represented as an integer whose low two bits ;;; are tag bits. The high bits contain information whose format and meaning ;;; are dependent on the tag. (define (make-descriptor tag data) (adjoin-bits data tag 2)) (define (descriptor-tag descriptor) (low-bits descriptor 2)) (define (descriptor-data descriptor) (high-bits descriptor 2)) (define $eq? =&) ;;; The four tags are: fixnum, immediate (character, boolean, etc.), ;;; header (gives the type and size of a stored object), and stored ;;; (pointer into memory). (define-enumeration tag (fixnum immediate header ;Could be shared with immediate, but easier programmed this way stored)) (define ($fixnum? descriptor) (=& (descriptor-tag descriptor) tag/fixnum)) (define (immediate? descriptor) (=& (descriptor-tag descriptor) tag/immediate)) (define (header? descriptor) (=& (descriptor-tag descriptor) tag/header)) (define (stored? descriptor) (=& (descriptor-tag descriptor) tag/stored)) ;;; Fixnums (define bits-per-target-fixnum (- (* bits-per-byte 4) 2)) ;26 or 30 (define least-target-fixnum (- 0 (expt 2 bits-per-target-fixnum))) (define greatest-target-fixnum (- (expt 2 bits-per-target-fixnum) 1)) (define (target-fixnum? n) (and (integer? n) (>= n least-target-fixnum) (<= n greatest-target-fixnum))) (define (enter-fixnum n) (make-descriptor tag/fixnum (enforce target-fixnum? n))) (define (extract-fixnum p) (descriptor-data (enforce $fixnum? p))) ;;; Immediates (define (make-immediate type value) (make-descriptor tag/immediate (adjoin-bits value type 6))) (define (immediate-type imm) (low-bits (descriptor-data (enforce immediate? imm)) 6)) (define (immediate-info imm) (high-bits (descriptor-data (enforce immediate? imm)) 6)) (define-enumeration imm (false ; #f () true ; #t char bogus ;undefined, unspecified eof global-environment)) (define (immediate-predicate type) (lambda (descriptor) (and (immediate? (descriptor-tag descriptor)) (=& (immediate-type descriptor) type)))) (define $false? (immediate-predicate imm/false)) (define $char? (immediate-predicate imm/char)) (define $global-environment? (immediate-predicate imm/global-environment)) (define $null (make-immediate imm/false 1)) (define $eof-object (make-immediate imm/eof 0)) (define $unspecified (make-immediate imm/bogus 0)) (define $-undefined- (make-immediate imm/bogus 1)) (define ($undefined) $-undefined-) (define $s48-implementation-environment (make-immediate imm/global-environment 0)) (define $user-initial-environment (make-immediate imm/global-environment 1)) (define $environment? $global-environment?) ;The only kind, for now (define ($environment-ref env symbol) (cond (($eq? env $s48-implementation-environment) ($system-value symbol)) (($eq? env $user-initial-environment) ($user-value symbol)) (else (error "this should never happen")))) (define ($environment-set! env symbol val) (cond (($eq? env $s48-implementation-environment) ($set-system-value! symbol val)) (($eq? env $user-initial-environment) ($set-user-value! symbol val)) (else (error "this should never happen")))) ;;; Booleans (define $t (make-immediate imm/true 0)) (define $nil (make-immediate imm/false 0)) (define (enter-boolean b) (if b $t $nil)) ;;; Characters (define ($ascii->char n) (make-immediate imm/char n)) (define ($char->ascii d) (immediate-info (enforce $char? d))) (define (enter-char c) ($ascii->char (char->ascii c))) (define (extract-char d) (ascii->char ($char->ascii d))) ;;; Headers (define (make-header type info) (make-descriptor tag/header (adjoin-bits info type 6))) (define (header-type h) (low-bits (descriptor-data (enforce header? h)) 6)) (define (header-info h) (high-bits (descriptor-data (enforce header? h)) 6)) (define-enumeration header (;; -- Contain descriptorss -- pair symbol vector closure continuation template input-port output-port injection ;; -- Contain no descriptors -- string byte-vector primitive ;primitive procedure ;; double ;double precision floating point )) (define (boxed-data-header? descriptor) (and (header? descriptor) (<& (header-type descriptor) header/string))) (define (unboxed-data-header? descriptor) (and (header? descriptor) (>=& (header-type descriptor) header/string))) (define (header-length-in-bytes header) (header-info header)) ;;; Memory (define *memory-size* 200000) (define *memory* (make-vector *memory-size* ($undefined))) (define *memory-begin* 0) (define *memory-end* *memory-size*) (define (fetch location) (vector-ref *memory* location)) (define (store! location value) (vector-set! *memory* location value)) ;;; The following operations work on pointers (which just happen to be ;;; implemented as fixnums). (define (raw+ ptr delta) (+& ptr delta)) (define (raw- ptr delta) (-& ptr delta)) (define (raw/ ptr n) (quotient& ptr n)) (define (raw< x y) (<& x y)) (define (raw<= x y) (<=& x y)) (define (raw> x y) (>& x y)) (define (raw>= x y) (>=& x y)) ;;; An "addressing unit" is the smallest quantum of storage addressed by ;;; an address on a particular machine. In the simulation, which has a ;;; big array with one cell per entry, there is one addressing unit per ;;; cell. Similarly on a DEC-20, 3600, or other word-addressed ;;; architecture. On the VAX or 68000, though, the addressing unit is ;;; the byte, of which there are 4 to a cell. ;;; Note: by a "byte" is meant enough bits to store either a character or ;;; a bytecode. (define log-addressing-units-per-cell 0) ;2 (define addressing-units-per-cell (adjoin-bits 1 0 log-addressing-units-per-cell)) (define (cells->delta cell-count) (*& cell-count addressing-units-per-cell)) (define (delta->cells delta) (quotient& delta addressing-units-per-cell)) (define bytes-per-cell 4) ;Number of bytes (or characters) per cell (define (bytes->cells bytes) (high-bits (+& bytes (-& bytes-per-cell 1)) 2)) (define (bytes->delta byte-count) (cells->delta (bytes->cells byte-count))) (define one-cell addressing-units-per-cell) (define (raw1+ x) (raw+ x one-cell)) ;;; Descriptors for stored objects (define (make-stored addr) (make-descriptor tag/stored addr)) (define (address-after-header descriptor) ;; Address of first cell after header cell (descriptor-data (enforce stored? descriptor))) ;;; Acessing memory via descriptors (define (really-m-ref descriptor index) (fetch (raw+ (address-after-header descriptor) (cells->delta index)))) (define (really-m-set! descriptor index value) (store! (raw+ (address-after-header descriptor) (cells->delta index)) value)) (define (object-header descriptor) (really-m-ref descriptor -1)) (define (object-header-set! descriptor header) (really-m-set! descriptor -1 header)) (define (header-length-in-cells h) (bytes->cells (header-length-in-bytes h))) (define (header-delta h) (cells->delta (header-length-in-cells h))) (define (object-length-in-cells descriptor) (header-length-in-cells (object-header descriptor))) (define (object-length-in-bytes descriptor) (header-length-in-bytes (object-header descriptor))) (define (m-ref descriptor index) (assert (<& index (object-length-in-cells descriptor))) (really-m-ref descriptor index)) (define (m-set! descriptor index value) (assert (<& index (object-length-in-cells descriptor))) (really-m-set! descriptor index value)) (define (field-ref obj type index) (really-m-ref (enforce type obj) index)) (define (field-set! obj type index val) (m-set! (enforce type obj) index val)) ;;; Stored object type predicates (define (stored-object-predicate type) (lambda (descriptor) (and (stored? (descriptor-tag descriptor)) (=& (header-type (object-header descriptor)) type)))) (define $pair? (stored-object-predicate header/pair)) (define $string? (stored-object-predicate header/string)) (define $byte-vector? (stored-object-predicate header/byte-vector)) (define $symbol? (stored-object-predicate header/symbol)) (define $vector? (stored-object-predicate header/vector)) (define $closure? (stored-object-predicate header/closure)) (define $continuation? (stored-object-predicate header/continuation)) (define $template? (stored-object-predicate header/template)) (define $primitive? (stored-object-predicate header/primitive)) (define $input-port? (stored-object-predicate header/input-port)) (define $output-port? (stored-object-predicate header/output-port)) (define $injection? (stored-object-predicate header/injection)) (define ($pair-or-null? x) (or ($pair? x) ($eq? x $null))) ;;; Some allocators (define (header-total-size header) ;=> delta (raw1+ (header-delta header))) (define (allocate header) (assert (raw< (header-total-size header) margin)) ;*** Modularity violation *** (really-allocate header (header-total-size header))) (define (really-allocate header need) (store! *hp* header) (let ((new (make-stored (raw1+ *hp*)))) (set! *hp* (raw+ *hp* need)) (assert (raw< *hp* *newspace-end*)) ;*** Modularity violation *** new)) (define (allocate-large-object header) (really-allocate header (header-total-size header))) (define (allocate-1 header a) (let ((obj (allocate header))) (really-m-set! obj 0 a) obj)) (define (allocate-2 header a b) (let ((obj (allocate header))) (really-m-set! obj 0 a) (really-m-set! obj 1 b) obj)) (define (allocate-3 header a b c) (let ((obj (allocate header))) (really-m-set! obj 0 a) (really-m-set! obj 1 b) (really-m-set! obj 2 c) obj)) (define (allocate-4 header a b c d) (let ((obj (allocate header))) (really-m-set! obj 0 a) (really-m-set! obj 1 b) (really-m-set! obj 2 c) (really-m-set! obj 3 d) obj)) ;;; Pairs (define the-pair-header (make-header header/pair (*& 2 bytes-per-cell))) (define ($cons a b) (allocate-2 the-pair-header a b)) (define ($car x) (field-ref x $pair? 0)) (define ($cdr x) (field-ref x $pair? 1)) (define ($set-car! x val) (field-set! x $pair? 0 val)) (define ($set-cdr! x val) (field-set! x $pair? 1 val)) (define ($list-tail l k) (do ((l l ($cdr l)) (i 0 (+& i 1))) ((=& i k) l))) (define ($list-ref l k) ($car ($list-tail l k))) ;;; Vectors (define ($make-vector n) (let ((v (allocate-large-object (make-header header/vector (*& n bytes-per-cell))))) (do ((i 0 (+& i 1))) ((>=& i n) v) (m-set! v i $unspecified)))) (define ($vector-length v) (object-length-in-cells v)) (define $vector-ref m-ref) (define $vector-set! m-set!) ;;; Byte vectors (define ($make-byte-vector n) (allocate-large-object (make-header header/byte-vector n))) (define ($byte-vector-length s) (header-length-in-bytes (object-header s))) (define ($byte-vector-ref s i) (let ((word (m-ref s (quotient& i bytes-per-cell)))) (low-bits (high-bits word (*& bits-per-byte (remainder& i bytes-per-cell))) bits-per-byte))) (define ($byte-vector-set! s i x) (let* ((word-index (quotient& i bytes-per-cell)) (start (*& (remainder& i bytes-per-cell) bits-per-byte)) (end (+& start bits-per-byte)) (word (m-ref s word-index))) (m-set! s word-index ;; ...aaa b ccc... -> ...aaa x ccc... (adjoin-bits (high-bits word end) ;= ...aaa (adjoin-bits x (low-bits word start) ;= ccc... start) end)))) ;;; Strings (define endianness 1) ;1 = little, 2 = big (define ($make-string n) (let ((s (allocate-large-object (make-header header/string (+& n 1))))) (m-set! s (quotient& n bytes-per-cell) 0) ;Null terminate it s)) (define ($string-length s) (-& (header-length-in-bytes (object-header s)) 1)) (define ($string-ref s i) (ascii->char ($byte-vector-ref s i))) (define ($string-set! s i c) ($byte-vector-set! s i (char->ascii c))) (define ($string=? string1 string2) ;CMPC3 or "strcmp" (let ((z1 (object-header string1)) (z2 (object-header string2))) (and (=& z1 z2) (let ((z (header-length-in-cells z1))) (let loop ((i 0)) (cond ((>=& i z) t) ((=& (really-m-ref string1 i) (really-m-ref string2 i)) (loop (+& i 1))) (else nil))))))) (define (extract-string string) (let ((z ($string-length string))) (let ((v (make-string z))) (do ((i 0 (+& i 1))) ((>=& i z) v) (string-set! v i ($string-ref string i)))))) ;;; Symbols (define the-symbol-header (make-header header/symbol (*& 3 bytes-per-cell))) (define ($make-symbol a b c) (allocate-3 the-symbol-header a b c)) (define ($symbol->string x) (field-ref x $symbol? 0)) (define ($system-value x) (field-ref x $symbol? 1)) (define ($set-system-value! x val) (field-set! x $symbol? 1 val)) (define ($user-value x) (field-ref x $symbol? 2)) (define ($set-user-value! x val) (field-set! x $symbol? 2 val)) (define ($intern string symbol-table) ;For now, the symbol table is a pair (let loop ((st ($cdr symbol-table))) (cond (($eq? st $null) (let ((symbol ($make-symbol string ($undefined) ($undefined)))) ($set-cdr! symbol-table ($cons symbol ($cdr symbol-table))) symbol)) (($string=? string ($symbol->string ($car st))) ($car st)) (else (loop ($cdr st)))))) ;;; WRITE uses this for displaying the name of a primitive procedure. ;;; It could, in principle, be written as user code, but isn't. (define ($symbol-with-system-value value symbol-table) (let loop ((st ($cdr symbol-table))) (cond (($eq? st $null) $nil) (($eq? value ($system-value ($car st))) ($car st)) (else (loop ($cdr st)))))) ;;; Primitive procedures (define the-primitive-header (make-header header/primitive (*& 1 bytes-per-cell))) (define ($make-primitive tag) (allocate-1 the-primitive-header (label->fixnum tag))) (define ($primitive-tag x) (field-ref x $primitive? 0)) (define ($procedure? descriptor) (or ($primitive? descriptor) ($closure? descriptor) ($continuation? descriptor))) ;;; Opaque types (intended for future implementation of bignums, complexes, ...) (define the-injection-header (make-header header/injection (*& 2 bytes-per-cell))) (define ($inject a b) (allocate-2 the-injection-header a b)) (define ($injection-thing x) (field-ref x $injection? 0)) (define ($injection-type x) (field-ref x $injection? 1)) (define ($in? obj type) (and ($injection? obj) ($eq? ($injection-type obj) type))) (define ($project obj type) type ($injection-thing obj)) ;;; Templates, closures, continuations (define the-template-header (make-header header/template (*& 3 bytes-per-cell))) (define ($make-template a b c) (allocate-3 the-template-header a b c)) (define ($template-code x) (field-ref x $template? 0)) (define ($template-literals x) (field-ref x $template? 1)) (define ($template-name x) (field-ref x $template? 2)) (define the-closure-header (make-header header/closure (*& 2 bytes-per-cell))) (define ($make-closure a b) (allocate-2 the-closure-header a b)) (define ($closure-template x) (field-ref x $closure? 0)) (define ($closure-env x) (field-ref x $closure? 1)) (define ($make-continuation n) (allocate (make-header header/continuation (*& n bytes-per-cell)))) (define $continuation-ref m-ref) (define $continuation-set! m-set!) ;;; Ports (define the-input-port-header (make-header header/input-port (*& 2 bytes-per-cell))) (define ($make-input-port a b) (allocate-2 the-input-port-header (enter-fixnum a) b)) (define ($input-port-index x) (extract-fixnum (field-ref x $input-port? 0))) (define ($set-input-port-index! x val) (field-set! x $input-port? 0 (enter-fixnum val))) (define ($input-port-name x) (field-ref x $input-port? 1)) (define the-output-port-header (make-header header/output-port (*& 2 bytes-per-cell))) (define ($make-output-port a b) (allocate-2 the-output-port-header (enter-fixnum a) b)) (define ($output-port-index x) (extract-fixnum (field-ref x $output-port? 0))) (define ($set-output-port-index! x val) (field-set! x $output-port? 0 (enter-fixnum val))) (define ($output-port-name x) (field-ref x $output-port? 1)) ;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file debug.scm. ;;;; Debugging utilities ;;; Break the enumerated types abstraction. ;;; (enumerand->name ) => a symbol ;;; (name->enumerand ) => an integer (define (enumerand->name e e-type) (vector-ref e-type e)) (define (name->enumerand e e-type) (or (vector-posq e e-type) (error "unknown enumerand name" e))) (define (vector-posq thing v) (let loop ((i 0)) (cond ((>= i (vector-length v)) nil) ((eq? thing (vector-ref v i)) i) (else (loop (+ i 1)))))) ;;; (define (display-interpreter-state) (newline) (write *pc*) (write-char #\space) (write (enumerand->name ($byte-vector-ref ($template-code *template*) *pc*) opcode)) (write-char #\space) (write (extract *val*)) (write-char #\space) (write (extract *cont*)) (write-char #\space) (write (extract *stack*))) (define (run exp) (clear-registers) (run! exp) (extract *val*)) (define (clear-registers) (set! *template* $unspecified) (set! *val* $unspecified) (set! *env* $unspecified) (set! *cont* $unspecified) (set! *stack* $unspecified) (set! *pc* -1) (set! *enabled-interrupts* 0)) ;;; Simulated value -> scheme value (define (extract obj) (cond (($fixnum? obj) (extract-fixnum obj)) (($char? obj) (extract-char obj)) (($eq? obj $null) '()) (($eq? obj $nil) nil) (($eq? obj $t) t) (($eq? obj ($undefined)) ') (($eq? obj $unspecified) ') (($eq? obj *symbol-table*) ') (($pair? obj) (cons (extract ($car obj)) (extract ($cdr obj)))) (($vector? obj) (let ((z ($vector-length obj))) (let ((v (make-vector z))) (do ((i 0 (+ i 1))) ((>= i z) v) (vector-set! v i (extract ($vector-ref obj i))))))) (($symbol? obj) (string->symbol (extract ($symbol->string obj)))) (($string? obj) (extract-string obj)) (($byte-vector? obj) (let ((z ($byte-vector-length obj))) (let ((v (make-byte-vector z))) (do ((i 0 (+ i 1))) ((>= i z) v) (byte-vector-set! v i ($byte-vector-ref obj i)))))) (($template? obj) (make-template (extract ($template-code obj)) (extract ($template-literals obj)) (extract ($template-name obj)))) (($closure? obj) `( ,obj ,(extract ($template-name ($closure-template obj))))) (($continuation? obj) `( ,obj)) (($primitive? obj) `( ,(label->name ($primitive-tag obj)))) (else `( ,obj)))) ;;; Debugging stuff for storage manager (define (subgc) ;Dangerous -- doesn't save or restore registers (room) (set! *finished* halt-machine) (run-machine collect) (newline) (display "[gc]") (room) 'done) (define (room) (let ((w (lambda (x) (newline) (display " ") (write x)))) (w `(used ,(- *hp* *newspace-begin*))) (w `(free ,(- *limit* *hp*))) (w `(*hp* = ,*hp*)) (w `(new = ,*newspace-begin* ,*newspace-end*)) (w `(old = ,*oldspace-begin* ,*oldspace-end*)) 'room)) (define (show-memory) (do ((i *newspace-begin* (show-location i))) ((>= i *newspace-end*) 'done))) (define (show-all-memory) (do ((i 0 (show-location i))) ((>= i *memory-size*) 'done))) (define (show-location index) ;Returns index for next location (let ((x (fetch index))) (cond ((not (= x ($undefined))) (newline) (write index) (ddescribe x) (cond ((unboxed-data-header? x) (do ((z (raw+ (raw1+ index) (header-delta x))) (index (raw1+ index) (raw1+ index))) ((>= index z) index) (newline) (display " ") (write (fetch index)))) (else (raw1+ index)))) (else (+ index 1))))) (define (ddescribe x) (let ((tag (descriptor-tag x))) (cond ((= tag tag/fixnum) (display " fix ") (write (extract-fixnum x))) ((= tag tag/stored) (display " sto ") (write (address-after-header x))) ((= x $null) (display " ()")) ((= x ($undefined)) (display " undefined")) ((= tag tag/header) (let ((type (header-type x))) (display " hdr ") (write (enumerand->name type header)) (write-char #\space) (write (header-info x)))) ((= tag tag/immediate) (let ((type (immediate-type x))) (display (if (< type 8) " imm " " hdr ")) (write (enumerand->name type imm)) (write-char #\space) (write (immediate-info x))))))) ;(define *emit-trace?* nil) ;(define (emit op . operands) ; (cond (*emit-trace?* ; (newline) ; (display " ") ; (write *code-index*) ; (display " ") ; (write (enumerand->name op opcode)) ; (display " ") ; (if (not (null? operands)) (write operands)))) ; (emit-byte op) ; (for-each emit-byte operands)) ;(define-primitive 'room ;? ; (lambda () ; (return-from-primitive ; ($cons (enter-fixnum (delta->cells (raw- *limit* *hp*))) ; ($cons (enter-fixnum (delta->cells (raw- *hp* *newspace-begin*))) ; $null))))) ;(define-primitive 'gc ; (lambda () ; (set! *limit* *newspace-begin*) ; (force-collect) ; (return-from-primitive $unspecified))) ;;; Disassembler (define (disassemble tem) (really-disassemble (if (number? tem) (extract (if ($closure? tem) ($closure-template tem) tem)) (if (and (pair? tem) (eq? (car tem) 'lambda)) (compile-lambda tem 'system nil) tem)) 1)) (define (really-disassemble tem level) (let loop ((pc 0)) (if (>= pc (byte-vector-length (template-code tem))) 'done (loop (write-instruction tem pc level))))) (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 (template-literals tem)) (op (byte-vector-ref code pc))) (newline-indent (* level 2)) (if (< pc 10) (display " ")) (write pc) (display " ") (write (enumerand->name op opcode)) (write-char #\space) (cond ((or (= op opcode/literal) (= op opcode/user) (= op opcode/set-user!) (= op opcode/system) (= op opcode/set-system!)) (write (vector-ref const (byte-vector-ref code (+ pc 1)))) (+ pc 2)) ((= op opcode/make-closure) (newline-indent (* (+ level 1) 2)) (display "[-----") (really-disassemble (vector-ref const (byte-vector-ref code (+ pc 1))) (+ level 1)) (newline-indent (* (+ level 1) 2)) (display "-----]") (+ pc 2)) ((or (= op opcode/lexical) (= op opcode/set-lexical!)) (write (list (byte-vector-ref code (+ pc 1)) (byte-vector-ref code (+ pc 2)))) (+ pc 3)) ((or (= op opcode/call) (= op opcode/call-return) (= op opcode/make-env) (= op opcode/make-env-rest)) (write (byte-vector-ref code (+ pc 1))) (+ pc 2)) ((or (= op opcode/jump-if-false) (= op opcode/join) (= op opcode/make-continuation)) (write (list (byte-vector-ref code (+ pc 1)) (byte-vector-ref code (+ pc 2)))) (display " ;") (write (+ pc (* (byte-vector-ref code (+ pc 1)) byte-factor) (byte-vector-ref code (+ pc 2)) 3)) (+ pc 3)) (else (+ pc 1))))) ;;; Metering (define *a-count* 0) (define *e-count* 0) (define *push-count* 0) (define *cont-count* 0) (define *arg-count* 0) (define *closure-count* 0) (define *p-win* 0) ;453 - saves 4 cells each time (define *p-lose* 0) ;246 (define (xrun x) (room) (set! *a-count* 0) ;831 *3 2493 (set! *e-count* 0) ;624 *3 (set! *push-count* 0) ;1790 *1 (set! *cont-count* 0) (set! *arg-count* 0) (set! *closure-count* 0) (set! *p-win* 0) ;453 *3 (set! *p-lose* 0) ;246 *8 ;; ; (run x)) ; 12370 (define (summary) (let ((total 12370) (breakdown (list (* *e-count* 3) ;contours (* *push-count* 3) (* *cont-count* 5) (* *arg-count* 3) (* *closure-count* 3)))) (apply format t "~&Contours ~5d~ ~%Pushes ~5d~ ~%Continuations ~5d~ ~%Arguments ~5d~ ~%Closures ~5d~ ~%Other ?? ~5d~ ~%Total ~5d~%" (append breakdown (list (- total (apply + breakdown)) total))))) ;; Evaluating (+ 1 2): ;; consed 12370 cells ;; performed 453 primitive applications with *cont* = cont/val ;; 246 ;; optimization saved (* 5 453) = 2265 cells ;; = 18 % ;; ;; Procedure call breakdown: ;; Closures 624 ;; Primitives 699 ;; Contours 1872 ;; Pushes 2427 ;; Continuations 1790 ;; Arguments 5601 of which 1872 end up in environments ;; Closures 558 ;; Other 122 ;; Total 12370 #| (set! *push-count* (+ *push-count* 1)) (set! *closure-count* (+ *closure-count* 1)) (set! *arg-count* (+ *arg-count* 1)) (set! *a-count* (+ *a-count* *nargs*)) (set! *e-count* (+ *e-count* 1)) (set! *cont-count* (+ *cont-count* 1)) (if (= *cont* cont/val) (set! *p-win* (+ *p-win* 1)) (set! *p-lose* (+ *p-lose* 1))) |# ;;;; -*- Mode: LISP; Syntax: Scheme; Package: SCHEME -*- ;;;; Derived expression types ;;; Given a core-syntax-table, this file defines a scheme-syntax-table ;;; which defines the derived expression types. (define (rewrite-and j) (lambda forms (cond ((null? forms) t) ;t => #t which self-evaluates ((null? (cdr forms)) (j (car forms))) (else `((lambda (p th) (if p (th) p)) ,(car forms) (lambda () (and ,@(map j (cdr forms))))))))) (define (rewrite-case j) (lambda (key . clauses) (let ((var '%%key%%)) `(let ((,var ,(j key))) (cond ,@(map (lambda (clause) (let ((cases (car clause))) `(,(cond ((eq? cases 'else) 'else) ((null? cases) nil) (else `((global scheme-env memv) ,var ',cases))) ,@(map j (cdr clause))))) clauses)))))) (define (rewrite-cond j) (lambda clauses (cond ((null? clauses) `(global xscheme-env unspecified)) ;How to do absolute references? ((eq? (caar clauses) 'else) `(begin ,@(map j (cdar clauses)))) (else (let ((alt (apply (rewrite-cond j) (cdr clauses)))) (cond ((null? (cdar clauses)) `(or ,(j (caar clauses)) ,alt)) ((eq? (cadr (car clauses)) '=>) `((lambda (p q th) (if p (q p) (th))) ,(j (car (car clauses))) (lambda () ,(j (caddr (car clauses)))) (lambda () ,alt))) (else `(if ,(j (caar clauses)) (begin ,@(map j (cdar clauses))) ,alt)))))))) (define (rewrite-delay j) (lambda (thing) `((global xscheme-env make-promise) (lambda () ,(j thing))))) (define (rewrite-do j) (lambda (specs end . body) (let ((loop '%%do%%)) `(letrec ((,loop (lambda ,(map car specs) (cond ,(map j end) (else ,@(map j body) (,loop ,@(map (lambda (y) (if (null? (cddr y)) (car y) (j (caddr y)))) specs))))))) (,loop ,@(map (lambda (spec) (j (cadr spec))) specs)))))) (define (rewrite-let j) (lambda (specs . body) (cond ((symbol? specs) (let ((tag specs) (specs (car body)) (body (cdr body))) `(letrec ((,tag (lambda ,(map car specs) ,@(map j body)))) (,tag ,@(map (lambda (spec) (j (cadr spec))) specs))))) (else `((lambda ,(map car specs) ,@(map j body)) ,@(map (lambda (spec) (j (cadr spec))) specs)))))) (define (rewrite-letrec j) (lambda (specs . body) `((lambda ,(map car specs) ,@(map (lambda (spec) `(set! ,(car spec) ,(j (cadr spec)))) specs) ,@(map j body)) ,@(map (lambda (spec) `(global xscheme-env undefined)) specs)))) (define (rewrite-or j) (lambda args (cond ((null? args) nil) ;nil => #f which self-evaluates ((null? (cdr args)) (j (car args))) (else `((lambda (p th) (if p p (th))) ,(j (car args)) (lambda () (or ,@(map j (cdr args))))))))) ;;;; Quasiquote (define (rewrite-quasiquote j) (lambda (x) (expand-quasiquote x 0 j))) (define (expand-quasiquote x level j) (descend-quasiquote x level j finalize-quasiquote)) (define (finalize-quasiquote mode arg j) (cond ((eq? mode 'quote) `',arg) ((eq? mode 'unquote) (j arg)) ((eq? mode 'unquote-splicing) (error ",@ in illegal context" arg)) (else `(,mode ,@arg)))) (define (descend-quasiquote x level j return) (cond ((vector? x) (descend-quasiquote-vector x level j return)) ((not (pair? x)) (return 'quote x j)) ((interesting-to-quasiquote? x 'quasiquote) (descend-quasiquote-pair x (1+ level) j return)) ((interesting-to-quasiquote? x 'unquote) (cond ((= level 0) (return 'unquote (cadr x) j)) (else (descend-quasiquote-pair x (- level 1) j return)))) ((interesting-to-quasiquote? x 'unquote-splicing) (cond ((= level 0) (return 'unquote-splicing (cadr x) j)) (else (descend-quasiquote-pair x (- level 1) j return)))) (else (descend-quasiquote-pair x level j return)))) (define (descend-quasiquote-pair x level j return) (descend-quasiquote (car x) level j (lambda (car-mode car-arg) (descend-quasiquote (cdr x) level j (lambda (cdr-mode cdr-arg) (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote)) (return 'quote x j)) ((eq? car-mode 'unquote-splicing) ;; (,@mumble ...) (cond ((and (eq? cdr-mode 'quote) (null? cdr-arg)) (return 'unquote car-arg j)) (else (return `(global scheme-env append) (list car-arg (finalize-quasiquote cdr-mode cdr-arg j)) j)))) (else (return `(global scheme-env cons) (list (finalize-quasiquote car-mode car-arg j) (finalize-quasiquote cdr-mode cdr-arg j)) j)))))))) (define (descend-quasiquote-vector x level j return) (descend-quasiquote (vector->list x) level j (lambda (mode arg) (case mode ((quote) (return 'quote x j)) (else (return `(global scheme-env list->vector) (list (finalize-quasiquote mode arg j)) j)))))) (define (interesting-to-quasiquote? x marker) (and (pair? x) (eq? (car x) marker))) ;;;; Scheme syntax table (define (definition? e) ; e must be a core expression (and (pair? e) (eq? (car e) 'define))) (define (preprocess--scheme body st) (let ((exp-list (map (lambda (exp) (preprocess exp st)) body))) (let loop ((e exp-list) (d '())) (if (null? e) (error "no non-definitions in body" body) (let ((exp (core (car e)))) ;Cheat a little (if (not (definition? exp)) (let ((body (preprocess-body e core-syntax-table))) (if (null? d) body (list (preprocess `(letrec ,(reverse d) ,@body) xscheme-syntax-table)))) (loop (cdr e) (cons `(,(cadr exp) ,(preprocessed (caddr exp))) d)))))))) (define xscheme-syntax-table (do ((st (set-nonterminal-handler core-syntax-table ' preprocess--scheme) (add-syntax st (caar z) (lambda (exp st) (preprocess (apply ((cadar z) (lambda (exp) (preprocess exp st))) (cdr exp)) xscheme-syntax-table)))) (z `((and ,rewrite-and) (case ,rewrite-case) (cond ,rewrite-cond) (delay ,rewrite-delay) (do ,rewrite-do) (let ,rewrite-let) ;; (let* ,rewrite-let*) (letrec ,rewrite-letrec) (or ,rewrite-or) (quasiquote ,rewrite-quasiquote)) (cdr z))) ((null? z) st))) (define scheme-syntax-table ;; Eventually flush GLOBAL and COMBINE. xscheme-syntax-table) {;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file enum.scm. ;;;; Enumerations ;;; The expression ;;; (define-enumeration (*)) ;;; will (a) define the variable to name an enumerated type, ;;; and (b) define / ... / to be small ;;; integers. (define-macro (define-enumeration name cases) `(begin (define ,name ',(list->vector cases)) ,@(do ((c cases (cdr c)) (i 0 (+ i 1)) (d '() (cons `(define ,(concatenate-symbol name '/ (car c)) ,i) d))) ((null? c) (reverse d))))) ;;; -*- Mode: Lisp; Syntax: Common-lisp; Package: (PSEUDOSCHEME :USE (LISP) :SHADOW (+ - * / ASSERT ASSOC CASE COMPILE ERROR EVAL LAMBDA LET LET* LOOP MAKE-STRING MAP MEMBER NIL PEEK-CHAR PRINT READ READ-CHAR T WRITE)) -*- ;;; Version of Scheme-48 FEATURES module for use with PSEUDOSCHEME. ;;; Keep in sync with file FEATURES.SCM. (in-package 'pseudoscheme :use '(lisp)) (require "pseudoscheme") (eval-when (lisp:eval lisp:load lisp:compile) (setq *preprocess?* nil)) (shadow '(assert)) ;;; Nonstandard features for PSEUDOSCHEME ;;; (intended for bootstrapping Scheme-48) (export '( ;; Misc. undefined unspecified enforce assert ;; 28-bit arithmetic +& -& *& =& <& <=& >& >=& quotient& remainder& high-bits low-bits adjoin-bits ;; String and symbol stuff string-posq reverse-list->string concatenate-symbol ;; Opaque types in? inject project ;; Tables make-table table-ref table-set! ;; Byte vectors byte-vector? reverse-list->byte-vector make-byte-vector byte-vector-ref byte-vector-set! byte-vector-length ;; Templates make-template template? template-code template-literals template-name ;; ASCII conversion ascii->char char->ascii ;; I/O write-string peek-char )) ;;; Misc. (define (undefined) :undefined) (define unspecified :unspecified) (defmacro enforce (pred val) `(let ((-val- ,val)) (if (,@(if (or (not (symbol? pred)) (char= (char (symbol-name pred) 0) #\.)) '(call) '()) ,pred -val-) -val- (error "enforce failed" ',pred -val-)))) (defmacro assert (truth) `(if (not ,truth) (assertion-failed))) (defun assertion-failed () (error "assertion failed")) ;;; 28-bit integer arithmetic primitives (define[subst] (+& x y) (the (signed-byte 28) (+ (the (signed-byte 28) x) (the (signed-byte 28) y)))) (define[subst] (-& x y) (the (signed-byte 28) (- (the (signed-byte 28) x) (the (signed-byte 28) y)))) (define[subst] (*& x y) (the (signed-byte 28) (* (the (signed-byte 28) x) (the (signed-byte 28) y)))) (define[subst] (=& x y) (= (the (signed-byte 28) x) (the (signed-byte 28) y))) (define[subst] (<& x y) (< (the (signed-byte 28) x) (the (signed-byte 28) y))) (define[subst] (<=& x y) (<= (the (signed-byte 28) x) (the (signed-byte 28) y))) (define[subst] (>& x y) (> (the (signed-byte 28) x) (the (signed-byte 28) y))) (define[subst] (>=& x y) (>= (the (signed-byte 28) x) (the (signed-byte 28) y))) (define[subst] (quotient& x y) (the (signed-byte 28) (quotient (the (signed-byte 28) x) (the (signed-byte 28) y)))) (define[subst] (remainder& x y) (the (signed-byte 28) (remainder (the (signed-byte 28) x) (the (signed-byte 28) y)))) (define[subst] (adjoin-bits high low k) (+& (ash (the (signed-byte 28) high) k) low)) (define[subst] (high-bits n k) (the (signed-byte 28) (ash (the (signed-byte 28) n) (- k)))) (define[subst] (low-bits n k) (the (signed-byte 28) (logand n (the (signed-byte 28) (1- (the (signed-byte 28) (ash 1 k))))))) ;;; String operations (define[subst] (string-posq c s) (position c (the simple-string s))) (define (reverse-list->string l len) (let ((str (make-string len))) (lisp:do ((i (- len 1) (- i 1)) (l l (cdr l))) ((< i 0) str) (string-set! str i (car l))))) (defparameter concatenate-symbol #'concatenate-symbol) (use-method 'concatenate-symbol :function) ;;; Opaque types (defstruct (injection (:print-function print-injection)) thing place) (defun print-injection (obj stream escape?) #-Symbolics (declare (ignore escape?)) #+Symbolics escape? (lisp:let ((place (injection-place obj))) (if (symbol? place) (format stream "#{~a ~s}" (string-capitalize (symbol-name place)) (injection-thing obj)) (format stream "#{Injection ~s ~s}" (injection-thing obj) place)))) (define (in? thing place) (and (injection-p thing) (eql (injection-place thing) place))) (define (inject thing place) (make-injection :thing thing :place place)) (define (project inj place) (cond ((not (injection-p inj)) (lisp:error "not an injection - ~s" `(project ,inj, place))) ((not (eql (injection-place inj) place)) (lisp:error "not in this partition - ~s" `(project ,inj ,place))) (t (injection-thing inj)))) ;;; Tables (define (make-table) (values (make-hash-table))) (define (table-set! table key val) (setf (gethash key table) val)) (define (table-ref table key) (gethash key table nil)) ;;; Byte vectors (define[subst] (byte-vector? obj) (typep obj '(vector (unsigned-byte 8)))) (define (make-byte-vector len) (make-array len :element-type '(unsigned-byte 8))) (define (reverse-list->byte-vector l len) (let ((vec (make-byte-vector len))) (lisp:do ((i (- len 1) (- i 1)) (l l (cdr l))) ((< i 0) vec) (setf (aref vec i) (car l))))) (define[subst] (byte-vector-ref bv k) (aref bv k)) (define[subst] (byte-vector-set! bv k val) (setf (aref bv k) val)) (define[subst] (byte-vector-length bv) (length bv)) ;;; Templates (defstruct (template (:constructor make-template (code literals name)) (:predicate template?) (:copier lisp:nil) (:print-function (lisp:lambda (tem stream depth) depth (format stream "#{Template ~s ~s ~s ~s}" (template-code tem) (template-literals tem) (template-name tem))))) code literals name) (defparameter make-template #'make-template) (use-method 'make-template :function) (defparameter template? #'template?) (use-method 'template? :function) (defparameter template-code #'template-code) (use-method 'template-code :function) (defparameter template-code #'template-code) (use-method 'template-code :function) (defparameter template-literals #'template-literals) (use-method 'template-literals :function) (defparameter template-name #'template-name) (use-method 'template-name :function) ;;; ASCII character conversion (define ascii-chars (string-append "........." (list->string '(#\tab #\newline #\. #\page)) "..................." " !\"#$%&'()*+,-./0123456789:;<=>?" "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_" "`abcdefghijklmnopqrstuvwxyz{|}~")) (define native-chars (let ((table (make-table))) (lisp:do ((a (string->list ascii-chars) (cdr a)) (i 0 (+ i 1)) (least 10000000 (min least (char->integer (car a)))) (greatest -10000000 (max greatest (char->integer (car a))))) ((null? a) (let ((v (make-vector (+ (- greatest least) 1)))) (lisp:do ((i least (+ i 1))) ((> i greatest) (cons least v)) (vector-set! v (- i least) (or (table-ref table i) 'not-an-ascii-character))))) (table-set! table (char->integer (car a)) i)))) (define (char->ascii char) (vector-ref (cdr native-chars) (- (char->integer char) (car native-chars)))) (define (ascii->char n) (string-ref ascii-chars n)) ;;; I/O (define (peek-char &optional (port *standard-input*)) (lisp:peek-char nil port)) (defparameter write-string #'write-string) ;Common Lisp defines this (use-method 'write-string :function) ;;; All done. (eval-when (lisp:eval lisp:load lisp:compile) (setq *preprocess?* t)) U;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file gc.scm. ;;;; Garbage collector ;;; Exports: ;;; time-to-collect? ;;; available? (-> (descriptor) boolean) ;;; collect ;;; collect-and-retry ;;; write-image ;;; read-image ;;; initialize-heap ;;; *hp* ;;; *root* ;;; *filename* ;;; *finished* ;;; Imports: ;;; for-each-open-port ;;; margin ;;; *memory-begin* ;;; *memory-end* (define *hp* 0) (define *root* 0) ;What the GC roots from (define *finished* (undefined)) ;Where the GC returns to (define *newspace-begin* 0) (define *newspace-end* 0) (define *oldspace-begin* 0) (define *oldspace-end* 0) (define *limit* 0) (define (initialize-heap) (set! *newspace-begin* *memory-begin*) (set! *newspace-end* (raw+ *memory-begin* (raw/ (raw- *memory-end* *memory-begin*) 2))) (set! *oldspace-begin* *newspace-end*) (set! *oldspace-end* *memory-end*) (reset-heap-pointer) (set! *root* $unspecified)) (define (reset-heap-pointer) (set! *hp* (raw1+ *newspace-begin*)) (set! *limit* (raw- *newspace-end* (cells->delta margin)))) (define (in-oldspace? descriptor) (and (stored? descriptor) (let ((a (address-after-header descriptor))) (and (raw>= a *oldspace-begin*) (raw< a *oldspace-end*))))) ;;; The following is used in exactly one place, namely the main dispatch ;;; of the evaluator. That's the only place from which the garbage ;;; collector can be called. (define (time-to-collect?) (raw>= *hp* *limit*)) (define *retrying-after-gc?* nil) (define (available? need) (cond ((raw< (raw+ *hp* need) *limit*) (set! *retrying-after-gc?* nil) t) (else nil))) (define (collect-and-retry) (cond (*retrying-after-gc?* (set! *retrying-after-gc?* nil) (set! *exception* exception/heap-overflow) (goto handle-exception)) (else (set! *retrying-after-gc?* t) (goto collect)))) ;;; Collector (define *scan* 0) (define (store-next descriptor) (store! *hp* descriptor) (set! *hp* (raw1+ *hp*))) (define (scan-next) (let ((x (fetch *scan*))) (set! *scan* (raw1+ *scan*)) x)) ;;; Roots from *root*. (define (collect) ;; Flip (let ((b *newspace-begin*)) (set! *newspace-begin* *oldspace-begin*) (set! *oldspace-begin* b)) (let ((e *newspace-end*)) (set! *newspace-end* *oldspace-end*) (set! *oldspace-end* e)) (set! *limit* (raw- *newspace-end* (cells->delta margin))) (set! *hp* *newspace-begin*) ;; Root (store-next *root*) (set! *scan* *newspace-begin*) (goto scan)) (define (scan) (cond ((raw< *scan* *hp*) (let ((thing (fetch *scan*))) (cond ((unboxed-data-header? thing) (set! *scan* (raw+ (raw1+ *scan*) (header-delta thing))) (goto scan)) ((not (in-oldspace? thing)) (set! *scan* (raw1+ *scan*)) (goto scan)) (else (let ((h (object-header thing))) (cond ((stored? h) ;***Broken heart ;; (assert (in-newspace? h) ...) (store! *scan* h) (set! *scan* (raw1+ *scan*)) (goto scan)) (else ;; Copy thing (store-next h) (let ((new (make-stored *hp*))) (object-header-set! thing new);***Break heart (store! *scan* new) (set! *scan* (raw1+ *scan*))) (let ((new-hp (raw+ *hp* (header-delta h)))) (do ((o (address-after-header thing) (raw1+ o))) ((raw>= *hp* new-hp) (goto scan)) (let ((p (fetch o))) (assert (or (unboxed-data-header? h) (not (stored? p)) (in-oldspace? p))) (store-next p))))))))))) ((raw>= *hp* *limit*) (error "out of memory")) (else (set! *root* (fetch *newspace-begin*)) (for-each-open-port (lambda (port replace!) (if (stored? (object-header port)) (replace! (object-header port)) (noisily-close port)))) (computed-goto *finished*)))) ;;;; Write-image and read-image (define level 4) (define *filename* "s48.sus") (define (write-image) (call-with-output-file *filename* (lambda (port) (for-each-open-port (lambda (port replace!) replace! ;; Don't let the restored image get confused by open ports. (noisily-close port))) (write-descriptor endianness port) (write-descriptor level port) (write-descriptor *newspace-begin* port) (write-descriptor *hp* port) (write-descriptor *root* port) (set! *scan* *newspace-begin*) (let loop () (cond ((raw>= *scan* *hp*) (computed-goto *finished*)) (else (let ((d (scan-next))) (write-descriptor d port) (cond (($eq? d the-primitive-header) ;; Write out symbolic name of label. (write (label->name (fixnum->label (scan-next))) port)) ((unboxed-data-header? d) (let ((z (raw+ *scan* (header-delta d)))) (do () ((raw>= *scan* z)) (write-descriptor (scan-next) port)))))))))))) (define (write-descriptor thing port) (write thing port) (newline port)) (define (read-image) (call-with-input-file *filename* (lambda (port) (let* ((old-endianness (read-descriptor port)) (old-level (read-descriptor port)) (old-begin (read-descriptor port)) (old-hp (read-descriptor port)) (old-root (read-descriptor port))) (if (not (=& old-level level)) (error "format of image is incompatible with this version of Scheme system" (list old-level level))) (let* ((delta (-& *newspace-begin* old-begin)) (new-hp (+& old-hp delta)) (new-limit (-& *newspace-end* (cells->delta margin)))) (cond ((raw>= new-hp new-limit) (error "heap not big enough to restore this image" `(>= ,new-hp ,new-limit))) (else (reset-heap-pointer) (initialize-ports) (set! *root* (adjust old-root delta)) (let loop () (cond ((raw>= *hp* new-hp) (computed-goto *finished*)) (else (let ((d (adjust (read-descriptor port) delta))) (store-next d) (cond (($eq? d the-primitive-header) ;; Read symbolic label name. (store-next (label->fixnum (name->label (read port))))) ((unboxed-data-header? d) (let ((z (raw+ *hp* (header-delta d)))) (do () ((raw>= *hp* z)) (let ((thing (read-descriptor port))) (store-next (maybe-reverse-bytes thing old-endianness))))))) (loop)))))))))))) (define (adjust descriptor delta) (cond ((stored? descriptor) (make-stored (raw+ (address-after-header descriptor) delta))) (else descriptor))) (define (maybe-reverse-bytes thing old-endianness) ;; 1 = little, 2 = big (cond ((not (=& endianness old-endianness)) (error "endianness mismatch -- byte reversal not yet implemented" old-endianness endianness))) thing) (define (read-descriptor port) (let ((thing (read port))) (if (eof-object? thing) (error "premature end of file!" `(*scan* = ,*scan*)) thing))) s;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME; -*- ;;; This is file interp.scm. ;;; Requires DEFINE-ENUMERATION macro. ;;;; The interpreter ;;; Imports: ;;; time-to-collect? collect *root* *finished* ;;; perform-primitive-application ;;; Exports: ;;; margin ;;; Note: all instructions must be restartable. That is, exceptions ;;; can't happen after the instruction has performed side-effects. ;;; The following are extremely ephemeral registers; they don't need to ;;; be saved and restored across a GC. (define *nargs* (undefined)) (define *exception* (undefined)) (define *pending-interrupt* interrupt/none) ;Ditto. (define *oldpc* (undefined)) (define *temp* (undefined)) ;;; Stack manipulation (define (push-argument x) (set! *stack* ($cons x *stack*))) (define (pop-argument) (let ((arg ($car *stack*))) (set! *stack* ($cdr *stack*)) arg)) (define (push-interpreter-state pc) (let ((cont ($make-continuation 5))) ($continuation-set! cont 4 *stack*) ($continuation-set! cont 3 *cont*) ($continuation-set! cont 2 *env*) ($continuation-set! cont 1 *template*) ($continuation-set! cont 0 (enter-fixnum pc)) (set! *stack* cont) (set! *cont* cont))) (define (pop-interpreter-state) (let ((cont *cont*)) (set! *pc* (extract-fixnum ($continuation-ref cont 0))) (set! *template* ($continuation-ref cont 1)) (set! *env* ($continuation-ref cont 2)) (set! *cont* ($continuation-ref cont 3)) (set! *stack* ($continuation-ref cont 4)))) ;;; Instruction stream access (define (next-byte) (let ((b ($byte-vector-ref ($template-code *template*) *pc*))) (set! *pc* (+& *pc* 1)) b)) (define (next-delta) (let ((first-byte (next-byte))) (adjoin-bits first-byte (next-byte) bits-per-byte))) (define (next-literal) ($vector-ref ($template-literals *template*) (next-byte))) ;;; INTERPRET is the main instruction dispatch for the interpreter. (define (interpret) (set! *oldpc* *pc*) (cond ((time-to-collect?) (save-registers *root*) (set! *finished* return-to-interpreter-after-gc) (goto collect)) ((>& *pending-interrupt* 0) (goto handle-interrupt)) (else ;; (display-interpreter-state) (computed-goto (vector-ref opcode-dispatch-vector (next-byte)))))) (define (return-to-interpreter-after-gc) (restore-registers *root*) (goto interpret)) ;;;; Opcodes (define (interpret-literal) ;Load a literal into *val*. (set! *val* (next-literal)) (goto interpret)) ;;; Lexical environment creation & access (define (interpret-make-env) ;Set up lexical environment. (let ((nargs (next-byte))) (cond ((not (=& *nargs* nargs)) (set! *exception* exception/wrong-number-of-arguments) (goto handle-exception)) (else (goto really-make-env))))) (define (really-make-env) (cond ((available? (cells->delta (+& 4 *nargs*))) (let ((rib ($make-vector *nargs*))) (do ((i (-& *nargs* 1) (-& i 1))) ((<& i 0)) ($vector-set! rib i (pop-argument))) (set! *env* ($cons rib ($closure-env *val*))) (goto interpret))) (else (set! *finished* really-make-env) (goto collect-and-retry)))) (define (interpret-make-env-rest) (let ((nargs (next-byte))) (cond ((<& *nargs* nargs) (set! *exception* exception/wrong-number-of-arguments) (goto handle-exception)) (else (set! *temp* nargs) (goto really-make-env-rest))))) (define (really-make-env-rest) (cond ((available? (cells->delta (*& (-& *nargs* *temp*) 3))) (do ((i *nargs* (-& i 1)) (l $null ($cons (pop-argument) l))) ((=& i *temp*) (push-argument l) (set! *nargs* (+& *temp* 1)) (goto really-make-env)))) (else (set! *finished* really-make-env-rest) (goto collect-and-retry)))) (define (interpret-lexical) ;Load value of a lexical. (let ((back (next-byte))) (set! *val* ($vector-ref ($list-ref *env* back) (next-byte)))) (cond (($eq? *val* ($undefined)) (set! *exception* exception/undefined-lexical) (goto handle-exception)) (else (goto interpret)))) (define (interpret-set-lexical!) (let ((back (next-byte))) ($vector-set! ($list-ref *env* back) (next-byte) *val*)) (set! *val* $unspecified) (goto interpret)) ;;; Global variable access (define (interpret-user) ;Load a global user variable. (let ((symbol (next-literal))) (set! *val* ($user-value symbol)) (cond (($eq? *val* ($undefined)) (set! *val* symbol) (set! *exception* exception/undefined-free) (goto handle-exception)) (else (goto interpret))))) (define (interpret-set-user!) ($set-user-value! (next-literal) *val*) (set! *val* $unspecified) (goto interpret)) (define (interpret-system) ;Load a global system variable. (let ((symbol (next-literal))) (set! *val* ($system-value symbol)) (cond (($eq? *val* ($undefined)) (set! *val* symbol) (set! *exception* exception/undefined-free) (goto handle-exception)) (else (goto interpret))))) (define (interpret-set-system!) ($set-system-value! (next-literal) *val*) (set! *val* $unspecified) (goto interpret)) ;;; LAMBDA and combinations (define (interpret-make-closure) (set! *val* ($make-closure (next-literal) *env*)) (goto interpret)) (define (interpret-push-argument) ;Push an argument onto the stack. (push-argument *val*) (goto interpret)) (define (interpret-call) ;Perform a non-tail call. (set! *nargs* (next-byte)) (goto perform-application)) (define (interpret-call-return) ;Perform a tail call. (set! *nargs* (next-byte)) (goto perform-application)) ;;; Continuation creation & invocation (define (interpret-make-continuation) ;Start a non-tail call. (let ((delta (next-delta))) (push-interpreter-state (+& *pc* delta)) (goto interpret))) (define (interpret-return) ;Invoke the continuation. (goto really-return)) (define (really-return) (cond (($eq? *cont* $nil) (goto halt-machine)) (else ;; (assert (= *stack* *cont*)) ;; [unless doing a cwcc or returning from a primitive] (pop-interpreter-state) (goto interpret)))) ;;; IF (define (interpret-jump-if-false) (let ((delta (next-delta))) (cond (($false? *val*) (set! *pc* (+& *pc* delta)) (goto interpret)) (else (goto interpret))))) (define (interpret-join) ;Rejoin after conditional (GOTO) (let ((delta (next-delta))) (set! *pc* (+& *pc* delta)) (goto interpret))) (define opcode-dispatch-vector (let ((v (make-vector (vector-length opcode)))) (let ((z (lambda (name proc) (vector-set! v (name->enumerand name opcode) proc)))) (z 'literal interpret-literal) (z 'make-env interpret-make-env) (z 'make-env-rest interpret-make-env-rest) (z 'lexical interpret-lexical) (z 'set-lexical! interpret-set-lexical!) (z 'user interpret-user) (z 'set-user! interpret-set-user!) (z 'system interpret-system) (z 'set-system! interpret-set-system!) (z 'make-closure interpret-make-closure) (z 'push-argument interpret-push-argument) (z 'make-continuation interpret-make-continuation) (z 'call interpret-call) (z 'call-return interpret-call-return) (z 'jump-if-false interpret-jump-if-false) (z 'join interpret-join) (z 'return interpret-return) v))) (define (perform-application) (cond (($primitive? *val*) (goto perform-primitive-application)) (($closure? *val*) (set! *template* ($closure-template *val*)) (set! *pc* 0) (goto interpret)) (($continuation? *val*) (cond ((=& *nargs* 1) (let ((val (pop-argument))) (set! *cont* *val*) (set! *val* val) (goto really-return))) (else (set! *exception* exception/wrong-number-of-arguments) (goto handle-exception)))) (else (set! *exception* exception/bad-procedure) (goto handle-exception)))) (define (return-from-primitive) (goto really-return)) (define (handle-exception) (lisp:break "Exception: ~s" (enumerand->name *exception* exception)) (set! *pc* *oldpc*) ;back out of instruction (let ((state (make-machine-state))) (set! *cont* $nil) (push-argument (enter-fixnum *exception*)) (push-argument state)) (set! *nargs* 2) (set! *val* ($vector-ref *exception-handlers* *exception*)) (goto perform-application)) (define (handle-interrupt) (let ((state (make-machine-state))) (set! *cont* $nil) ;??!! (push-argument *pending-interrupt*) (push-argument *enabled-interrupts*) (push-argument state)) (set! *val* ($vector-ref *interrupt-handlers* *pending-interrupt*)) (set! *nargs* 3) (set! *pending-interrupt* 0) (set! *enabled-interrupts* 0) (goto perform-application)) ;;; MARGIN is the greatest possible amount of space that might get consed ;;; between potential GC's (i.e. between cycles of the interpreter). ;;; The value is used by the storage manager. ;;; --- Is there any scientific way to determine what the value should be? ;;; --- Can GC be invoked as an interrupt? (define margin 20) ;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file io.scm. ;;; [Still to do: transcript-on, transcript-off] ;;;; I/O system ;;; Ports (define (eof-object? obj) (eq? obj eof-object)) (define (call-with-input-file string proc) (let ((port (open-input-file string))) (let ((val (proc port))) (close-input-port port) val))) (define (call-with-output-file string proc) (let ((port (open-output-file string))) (let ((val (proc port))) (close-output-port port) val))) (define *current-input-port* initial-input-port) (define *current-output-port* initial-output-port) (define (current-input-port) *current-input-port*) (define (current-output-port) *current-output-port*) (define (with-input-from-file string thunk) (let ((port (open-input-file string)) (save *current-input-port*)) (set! *current-input-port* port) (let ((val (thunk))) (close-input-port port) (set! *current-input-port* save) val))) (define (with-output-to-file string thunk) (let ((port (open-output-file string)) (save *current-output-port*)) (set! *current-output-port* port) (let ((val (thunk))) (close-output-port port) (set! *current-output-port* save) val))) ;;;; READ (define (read . port-option) (if (null? port-option) (really-read (current-input-port)) (really-read (car port-option)))) (define close-paren (cons 'close-paren '())) (define dot (cons 'dot '())) (define *input-radix* 10) (define (really-read port) (let ((form (sub-read port))) (cond ((eq? form dot) (error "\" . \" in illegal context")) ((eq? form close-paren) (really-read port)) (else form)))) (define (sub-read port) (let ((c (read-char port))) (cond ((eof-object? c) c) ((char-whitespace? c) (sub-read port)) ((char=? c #\() (sub-read-list port)) ((char=? c #\)) close-paren) ((char=? c #\.) dot) ((char=? c #\') (list 'quote (sub-read port))) ((char=? c #\`) (list 'quasiquote (sub-read port))) ((char=? c #\,) (list (cond ((char=? (peek-char port) #\@) (read-char port) 'unquote-splicing) (else 'unquote)) (sub-read port))) ((char=? c #\#) (sub-read-sharpsign port)) ((char=? c #\") (sub-read-string port)) ((char=? c #\;) (sub-read-comment port)) ((char=? c #\-) (if (digit (peek-char port) *input-radix*) (sub-read-signed-number port -1 *input-radix*) (sub-read-symbol port c))) ((char=? c #\+) (if (digit (peek-char port) *input-radix*) (sub-read-signed-number port 1 *input-radix*) (sub-read-symbol port c))) (else (let ((c1 (digit c *input-radix*))) (if c1 (sub-read-number port c1 *input-radix*) (sub-read-symbol port c))))))) (define (sub-read-sharpsign port) (let ((c (read-char port))) (cond ((or (char=? c #\f) (char=? c #\F)) nil) ((or (char=? c #\t) (char=? c #\T)) t) ((char=? c #\\) (let ((c (peek-char port))) (if (char-alphabetic? c) (let ((name (sub-read port))) (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 port))) ((char=? c #\#) `(,(make-system-ref '*output*))) (else (error "unknown # syntax" c))))) (define (sub-read-list port) (let ((form (sub-read port))) (cond ((eof-object? form) form) ((eq? form close-paren) '()) ((eq? form dot) (sub-read-tail port)) (else (cons form (sub-read-list port)))))) (define (sub-read-tail port) (let ((last-form (sub-read port))) (cond ((eof-object? last-form) last-form) ((eq? last-form close-paren) '()) ((eq? last-form dot) (sub-read-tail port)) (else (let ((another-form (sub-read port))) (cond ((eq? another-form close-paren) last-form) ((eq? another-form dot) (cons last-form (sub-read-tail port))) (else (cons last-form (sub-read-list port))))))))) (define (sub-read-signed-number port sign radix) (* sign (sub-read-number port (digit (read-char port) radix) radix))) (define (sub-read-number port n radix) (let ((c (peek-char port))) (let ((v (digit c radix))) (cond (v ;; accept the character (read-char port) (sub-read-number port (+ v (* n radix)) radix)) ;; eat trailing dots on numbers ((and (char=? c #\.) (read-char port) (not (char-whitespace? (peek-char port)))) (error "real numbers are not implemented")) (else n))))) (define (sub-read-string port) (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-symbol port c) (let loop ((l (cons (char-upcase c) '())) (i 1)) (cond ((delimiter? (peek-char port)) (string->symbol (reverse-list->string l i))) (else (loop (cons (char-upcase (read-char port)) l) (+ i 1)))))) (define (sub-read-comment port) (let ((c (read-char port))) (cond ((eof-object? c) c) ; no test with conditions ((char=? c #\newline) (sub-read port)) (else (sub-read-comment port))))) (define (delimiter? c) (or (char-whitespace? c) (char=? c #\() (char=? c #\)) (char=? c #\") (char=? c #\;))) ;(define (reverse-list->string l n) ; (do ((l l (cdr l)) ; (i (- n 1) (- i 1))) ; ((< i 0) (return obj)) ; (string-set! obj i (car l)))) ;;;; 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) (cond ((char=? obj #\space) (write-string "#\\SPACE" port)) ((char=? obj #\newline) (write-string "#\\NEWLINE" port)) (else (write-string "#\\" port) (write-char obj port)))) ((procedure? obj) (write-string "#{Procedure" port) (let ((probe (procedure-name obj))) (if probe (begin (write-char #\space port) (write probe port)))) (write-string "}" port)) (else (write-string "#{" port) (write-string (random-identification-string obj) port) (write-string "}" 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 ((eq? obj unspecified) "Unspecified") ((eq? obj (undefined)) "Undefined") ((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") ((eq? obj user-initial-environment) "User initial environment") ((eq? obj s48-implementation-environment) "Scheme-48 implementation environment") ;; Templates; byte vectors; injections (else "Random object"))) (define (procedure-name obj) (or (closure-name obj) (symbol-with-system-value obj the-symbol-table)))  ;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file prim.scm ;;;; Primitives ;;; This file should define only one procedure used by anyone else, namely ;;; PERFORM-PRIMITIVE-APPLICATION. ;;; Primitives (define (perform-primitive-application) (computed-goto ($primitive-tag *val*))) (define-macro (define-primitive name type-exp-list output-coercion proc-exp) (let ((arg-names '(-arg1- -arg2- -arg3- -arg4- -arg5- -arg6-)) ;etc. (tag-name (concatenate-symbol 'primitive/ name))) `(begin (define (,tag-name) (if (=& *nargs* ,(length type-exp-list)) (let ((-tail- *stack*)) -tail- ,(letrec ((recur (lambda (l a z) (if (null? l) `(,output-coercion (,proc-exp ,@a)) (let ((this-arg (car z))) `(let ((,this-arg ($car -tail-)) (-tail- ($cdr -tail-))) -tail- (,(car l) ,this-arg (lambda (,this-arg) ;success ,(recur (cdr l) (cons this-arg a) (cdr z)))))))))) (recur (reverse type-exp-list) '() arg-names))) (goto wrong-number-of-arguments))) (define-label ',name ,tag-name)))) (define (wrong-number-of-arguments) (set! *exception* exception/wrong-number-of-arguments) (goto handle-exception)) (define (wrong-type-argument) (set! *exception* exception/wrong-type-argument) (goto handle-exception)) ;;; Input coercions (define (argument-type pred coercer) (lambda (x succeed) (if (pred x) (succeed (coercer x)) (goto wrong-type-argument)))) (define (no-coercion x) x) (define any-> (argument-type (lambda (x) x t) no-coercion)) (define fixnum-> (argument-type $fixnum? extract-fixnum)) (define char-> (argument-type $char? extract-char)) (define xstring-> (argument-type $string? extract-string)) (define nonnegative-fixnum-> (argument-type (lambda (n) (and ($fixnum? n) (>=& (extract-fixnum n) 0))) extract-fixnum)) (define pair-or-null-> (argument-type $pair-or-null? no-coercion)) (define pair-> (argument-type $pair? no-coercion)) (define symbol-> (argument-type $symbol? no-coercion)) (define string-> (argument-type $string? no-coercion)) (define vector-> (argument-type $vector? no-coercion)) (define byte-vector-> (argument-type $byte-vector? no-coercion)) (define template-> (argument-type $template? no-coercion)) (define environment-> (argument-type $environment? no-coercion)) (define procedure-> (argument-type $procedure? no-coercion)) (define input-port-> (argument-type $input-port? no-coercion)) (define output-port-> (argument-type $output-port? no-coercion)) (define readable-input-port-> (argument-type $readable-input-port? extract-input-port)) (define writable-output-port-> (argument-type $writable-output-port? extract-output-port)) ;;; Output coercions (define (return val) (set! *val* val) (goto return-from-primitive)) (define (no-return x) x) (define ->any return) (define (->boolean x) (return (enter-boolean x))) (define (->fixnum x) (return (enter-fixnum x))) (define (->fixnum-carefully result) (cond ((target-fixnum? result) (->fixnum result)) (else (set! *exception* exception/arithmetic-exception) (goto handle-exception)))) (define (->unspecified result) result (return $unspecified)) (define (->char c) (return (enter-char c))) (define (->char-or-eof c) (return (if (eof-object? c) $eof-object (enter-char c)))) ;;; The primitives. (define-primitive fixnum? (any->) ->boolean $fixnum?) (define-primitive char? (any->) ->boolean $char?) (define-primitive pair? (any->) ->boolean $pair?) (define-primitive string? (any->) ->boolean $string?) (define-primitive vector? (any->) ->boolean $vector?) (define-primitive symbol? (any->) ->boolean $symbol?) (define-primitive procedure? (any->) ->boolean $procedure?) (define-primitive input-port? (any->) ->boolean $input-port?) (define-primitive output-port? (any->) ->boolean $output-port?) (define-primitive byte-vector? (any->) ->boolean $byte-vector?) (define-primitive eq? (any-> any->) ->boolean $eq?) (define-primitive + (fixnum-> fixnum->) ->fixnum-carefully +) (define-primitive - (fixnum-> fixnum->) ->fixnum-carefully -) (define-primitive * (fixnum-> fixnum->) ->fixnum-carefully *) (define-primitive quotient (fixnum-> fixnum->) ->fixnum-carefully quotient) (define-primitive remainder (fixnum-> fixnum->) ->fixnum-carefully remainder) (define-primitive = (fixnum-> fixnum->) ->boolean =) (define-primitive < (fixnum-> fixnum->) ->boolean <) (define-primitive char->ascii (char->) ->fixnum char->ascii) (define-primitive ascii->char (nonnegative-fixnum->) ->char ascii->char) (define-primitive char=? (char-> char->) ->boolean char=?) (define-primitive char char->) ->boolean char any->) ->any $cons) (define-primitive car (pair->) ->any $car) (define-primitive cdr (pair->) ->any $cdr) (define-primitive set-car! (pair-> any->) ->unspecified $set-car!) (define-primitive set-cdr! (pair-> any->) ->unspecified $set-cdr!) ;;; Common code for MAKE-STRING and MAKE-VECTOR. ;;; If there isn't enough space, we try to GC, and if there isn't enough ;;; after that, we signal a heap-overflow exception. (define (array-maker proc empty) (lambda (n) (cond ((=& n 0) (return (empty))) (else (let ((need (raw1+ (cells->delta n)))) (cond ((available? need) (return (proc n))) (else (set! *finished* perform-primitive-application) (goto collect-and-retry)))))))) (define (indexicate proc length enter) (lambda (thing index) (cond ((<& index (length thing)) (return (enter (proc thing index)))) (else (set! *exception* exception/index-out-of-range) (goto handle-exception))))) (define (indexicate! proc length) (lambda (thing index val) (cond ((<& index (length thing)) (->unspecified (proc thing index val))) (else (set! *exception* exception/index-out-of-range) (goto handle-exception))))) (define-primitive make-vector (nonnegative-fixnum->) no-return (array-maker $make-vector (lambda () *empty-vector*))) (define-primitive vector-length (vector->) ->fixnum $vector-length) (define-primitive vector-ref (vector-> nonnegative-fixnum->) no-return (indexicate $vector-ref $vector-length (lambda (x) x))) (define-primitive vector-set! (vector-> nonnegative-fixnum-> any->) no-return (indexicate! $vector-set! $vector-length)) (define-primitive make-string (nonnegative-fixnum->) no-return (array-maker $make-string (lambda () *empty-string*))) (define-primitive string-length (string->) ->fixnum $string-length) (define-primitive string-ref (string-> nonnegative-fixnum->) no-return (indexicate $string-ref $string-length enter-char)) (define-primitive string-set! (string-> nonnegative-fixnum-> char->) no-return (indexicate! $string-set! $string-length)) (define-primitive string=? (string-> string->) ->boolean $string=?) ;;; Special primitive called by the reader. ;;; Primitive for the sake of speed. Probably should be flushed. (define-primitive reverse-list->string (pair-or-null-> fixnum->) no-return (lambda (l n) (let ((need (raw1+ (bytes->delta n)))) (cond ((available? need) (let ((obj ($make-string n))) (do ((l l ($cdr l)) (i (-& n 1) (-& i 1))) ((<& i 0) (return obj)) ($string-set! obj i (extract-char ($car l)))))) (else (set! *finished* perform-primitive-application) (goto collect-and-retry)))))) (define-primitive make-byte-vector (nonnegative-fixnum->) no-return (array-maker $make-byte-vector (lambda () *empty-byte-vector*))) (define-primitive byte-vector-length (byte-vector->) ->fixnum $byte-vector-length) (define-primitive byte-vector-ref (byte-vector-> nonnegative-fixnum->) no-return (indexicate $byte-vector-ref $byte-vector-length enter-fixnum)) (define-primitive byte-vector-set! (byte-vector-> nonnegative-fixnum-> nonnegative-fixnum->) no-return (indexicate! $byte-vector-set! $byte-vector-length)) (define-primitive symbol->string (symbol->) ->any $symbol->string) (define-primitive intern (string-> pair->) ->any $intern) (define-primitive symbol-with-system-value (any-> pair->) ->any $symbol-with-system-value) (define-primitive call-with-current-continuation (procedure->) no-return (lambda (proc) (push-argument *cont*) (set! *val* proc) (set! *nargs* 1) (goto perform-application))) (define-primitive in? (any-> any->) ->boolean $in?) (define-primitive inject (any-> any->) ->any $inject) (define-primitive project (any-> any->) no-return (lambda (inj type) (cond (($in? inj type) (return ($project inj type))) (else (set! *exception* exception/losing-projection) (goto handle-exception))))) (define-primitive make-template (byte-vector-> vector-> any->) ->any $make-template) (define-primitive make-closure (template-> any->) ->any $make-closure) (define-primitive environment-ref (environment-> symbol->) ->any $environment-ref) (define-primitive environment-set! (environment-> symbol-> any->) ->any $environment-set!) (define (port-opener open) (lambda (string) (open string return (lambda () ;; Ought to GC here before giving up. (set! *exception* exception/out-of-ports) (goto handle-exception))))) (define-primitive open-input-file (string->) no-return (port-opener $open-input-file)) (define-primitive open-output-file (string->) no-return (port-opener $open-output-file)) (define-primitive close-input-port (input-port->) ->unspecified $close-input-port) (define-primitive close-output-port (output-port->) ->unspecified $close-output-port) (define-primitive read-char (readable-input-port->) ->char-or-eof read-char) (define-primitive peek-char (readable-input-port->) ->char-or-eof peek-char) (define-primitive write-char (char-> writable-output-port->) ->unspecified write-char) (define-primitive write-string (xstring-> writable-output-port->) ->unspecified write-string) (define-primitive undefined () ->any $undefined) (define-primitive closure-name (procedure->) ->any (lambda (proc) (cond (($closure? proc) ($template-name ($closure-template proc))) (else $nil)))) (define-primitive suspend (xstring->) no-return (lambda (filename) (set! *val* $unspecified) (save-registers *root*) (set! *filename* filename) (set! *finished* really-suspend) (goto collect))) (define (really-suspend) (set! *finished* return-from-suspend) (goto write-image)) (define (return-from-suspend) (restore-registers *root*) (goto return-from-primitive)) (define-primitive exit () no-return (goto halt-machine)) (define-primitive set-enabled-interrupts! (fixnum->) ->unspecified (lambda (mask) ($set-enabled-interrupts! mask))) (define-primitive proceed-after-exception (vector->) no-return (lambda (m) (restore-registers m) (goto interpret))) ;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME; -*- ;;; This is file regs.scm. ;;;; Interpreter registers ;;; Following is the list of all registers that can possibly need to be ;;; alive across a GC or an exception. Remember that the GC is only called ;;; from the main interpreter dispatch point. ;;; A few very ephemeral registers (like *oldpc*) don't need to be alive ;;; here. (define *template* $unspecified) (define *val* $unspecified) (define *env* $unspecified) (define *cont* $unspecified) (define *stack* $unspecified) (define *pc* -1) (define *enabled-interrupts* 0) (define *exception-handlers* $unspecified) (define *interrupt-handlers* $unspecified) (define *empty-vector* $unspecified) (define *empty-string* $unspecified) (define *symbol-table* $unspecified) (define (save-registers m) (machine-state-set! m register/template *template*) (machine-state-set! m register/val *val*) (machine-state-set! m register/env *env*) (machine-state-set! m register/cont *cont*) (machine-state-set! m register/stack *stack*) (machine-state-set! m register/pc (enter-fixnum *pc*)) (machine-state-set! m register/enabled-interrupts (enter-fixnum *enabled-interrupts*)) (machine-state-set! m register/exception-handlers *exception-handlers*) (machine-state-set! m register/interrupt-handlers *interrupt-handlers*) (machine-state-set! m register/empty-vector *empty-vector*) (machine-state-set! m register/empty-string *empty-string*) (machine-state-set! m register/symbol-table *symbol-table*)) (define (restore-registers m) (set! *template* (machine-state-ref m register/template)) (set! *val* (machine-state-ref m register/val)) (set! *env* (machine-state-ref m register/env)) (set! *cont* (machine-state-ref m register/cont)) (set! *stack* (machine-state-ref m register/stack)) (set! *pc* (extract-fixnum (machine-state-ref m register/pc))) (set! *enabled-interrupts* (extract-fixnum (machine-state-ref m register/enabled-interrupts))) (set! *exception-handlers* (machine-state-ref m register/exception-handlers)) (set! *interrupt-handlers* (machine-state-ref m register/interrupt-handlers)) (set! *empty-vector* (machine-state-ref m register/empty-vector)) (set! *empty-string* (machine-state-ref m register/empty-string)) (set! *symbol-table* (machine-state-ref m register/symbol-table))) (define ($set-enabled-interrupts! mask) (set! *enabled-interrupts* mask)) (define (make-machine-state) (let ((m ($make-vector (vector-length register)))) (save-registers m) m)) (define machine-state-ref $vector-ref) (define machine-state-set! $vector-set!) G;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file run.scm. ;;;; GOTO and $RESUME ;;; Exports: ;;; $resume ;;; goto ;;; computed-goto ;;; halt-machine ;;; Code for actually running the state machine. (define (goto tag) ;(tag) ; If tail-recursion works tag ; If tail-recursion doesn't work ) (define computed-goto goto) (define (run-machine start-tag) (let loop ((tag start-tag)) (cond ((interesting-tag? tag) (write-string "[tag = ") (write tag) (write-string "]") (newline))) (if (eq? tag halt-machine) 'halted (loop (tag))))) (define (interesting-tag? tag) (or (eq? tag collect) (and (eq? tag *finished*) (not (eq? tag halt-machine))) (eq? tag handle-exception) (eq? tag handle-interrupt) )) (define (halt-machine) halt-machine) ;;; This is the main entry point to the entire system, and the only ;;; place that RUN-MACHINE is called other than (define ($resume filename) (initialize-heap) (set! *filename* filename) (set! *finished* return-from-suspend) (run-machine read-image)) ;;; Global namespace (define *known-labels* '()) ;list of (name tag fixnum) (define (label-search key val) (lambda (thing) (let loop ((l *known-labels*)) (if (null? l) (error "unknown label" thing) (let ((z (car l))) (if (eq? thing (key z)) (val z) (loop (cdr l)))))))) (define name->label (label-search car cdr)) (define label->name (label-search cdr car)) (define (define-label name tag) (let ((probe (assq name *known-labels*))) (if probe (set-cdr! probe tag) (set! *known-labels* (cons (cons name tag) *known-labels*))))) (define (for-each-label proc) (for-each (lambda (z) (proc (car z) (cdr z))) *known-labels*) unspecified) (define (label->fixnum label) label) ;Loophole for type checker (define (fixnum->label n) n);;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file stub.scm. ;;;; Virtual machine stub ;;; Scheme-48 virtual machine, embedded in Scheme ;;; This may replace the SM, PRIM, and BOOT files. ;;; ----- DATA ----- (define (enter-fixnum x) x) (define (extract-fixnum x) x) (define (enter-boolean x) x) (define (enter-char x) x) (define (extract-char x) x) (define (extract-string x) x) (define (target-fixnum? x) (integer? x)) (define $eq? eq?) (define $null '()) (define $nil nil) (define $t t) (define $false? not) (define $unspecified unspecified) (define $undefined undefined) (define $eof-object ') (define $fixnum? integer?) (define $char? char?) (define $pair? pair?) (define ($pair-or-null? x) (or (pair? x) (null? x))) (define $cons cons) (define $car car) (define $cdr cdr) (define $set-car! set-car!) (define $set-cdr! set-cdr!) (define $list-ref list-ref) (define $list-tail list-tail) (define $vector? vector?) (define $make-vector make-vector) (define $vector-length vector-length) (define $vector-ref vector-ref) ;for literals (define $vector-set! vector-set!) (define $byte-vector? byte-vector?) (define $make-byte-vector make-byte-vector) (define $byte-vector-length byte-vector-length) (define $byte-vector-ref byte-vector-ref) (define $byte-vector-set! byte-vector-set!) (define $string? string?) (define $make-string make-string) (define $string-length string-length) (define $string-ref string-ref) (define $string-set! string-set!) (define $string=? string=?) (define $symbol? symbol?) (define ($intern string st) st (string->symbol string)) (define ($symbol-with-system-value val st) val st nil) (define $symbol->string symbol->string) (define ($primitive? obj) (and (vector? obj) (eq? (vector-ref obj 0) 'primitive))) (define ($make-primitive tag) (vector 'primitive tag)) (define ($primitive-tag prim) (vector-ref prim 1)) (define ($procedure? descriptor) (or ($primitive? descriptor) ($closure? descriptor) ($continuation? descriptor))) (define $template? template?) (define $make-template make-template) (define $template-code template-code) (define $template-literals template-literals) (define $template-name template-name) (define ($closure? obj) (and (vector? obj) (eq? (vector-ref obj 0) '$closure))) (define ($make-closure template env) (vector '$closure template env)) (define ($closure-template obj) (vector-ref obj 1)) (define ($closure-env obj) (vector-ref obj 2)) (define ($continuation? obj) (in? obj 'continuation)) (define ($make-continuation n) (inject (make-vector n) 'continuation)) (define ($continuation-ref cont i) (vector-ref (project cont 'continuation) i)) (define ($continuation-set! cont i val) (vector-set! (project cont 'continuation) i val)) (define $user-initial-environment (make-table)) (define $s48-implementation-environment (make-table)) (define ($environment? x) (or (eq? x $user-initial-environment) (eq? x $s48-implementation-environment))) (define ($environment-ref env sym) (let ((probe (table-ref env sym))) (if probe (if (eq? probe ') nil probe) (undefined)))) (define ($environment-set! env sym val) (table-set! env sym (or val '))) (define ($user-value symbol) ($environment-ref $user-initial-environment symbol)) (define ($set-user-value! symbol val) ($environment-set! $user-initial-environment symbol val)) (define ($system-value symbol) ($environment-ref $s48-implementation-environment symbol)) (define ($set-system-value! symbol val) ($environment-set! $s48-implementation-environment symbol val)) (define $inject inject) (define $in? in?) (define $project project) (define $input-port? input-port?) (define $output-port? output-port?) (define $readable-input-port? input-port?) (define $writable-output-port? output-port?) (define (raw1+ n) (+ n 4)) ;Ugh. Used in conjunction with array consing. (define (bytes->delta n) n) (define (cells->delta n) (* n 4)) ;;; ----- GC ----- (define *finished* (undefined)) (define (time-to-collect?) nil) (define (collect) (computed-goto *finished*)) (define (available? amount) amount t) (define *root* (undefined)) (define (initialize-heap) 'done) ;(define *memory-size* 10000000000) ;(define *newspace-begin* 0) ;(define *hp* 0) ;(define *newspace-end* *memory-size*) (define *filename* (undefined)) ;(define (read-image) (error "can't resume!")) (define (write-image) (error "can't suspend!")) ;;; ----- VMIO ----- (define $open-input-file open-input-file) (define $open-output-file open-output-file) (define $close-input-port close-input-port) (define $close-output-port close-output-port) (define (extract-input-port x) x) (define (extract-output-port x) x) (define make-initial-input-port current-input-port) (define make-initial-output-port current-output-port) ;;; ----- BOOT ----- ;;; -- Replace definition of ENTER with (define (enter x) x) ;;; ----- DEBUG ----- (define (run exp) (run! exp) *val*) (define (extract x) x);;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file sys.scm. ;;;; LOAD, EVAL, read-eval-print 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 exp env) (let ((cenv (cond ((eq? env user-initial-environment) 'user) ((eq? env s48-implementation-environment) 'system) (else (error "illegal environment argument to EVAL" exp env))))) ((make-closure (compile-top exp cenv) cenv)))) (define *reset* (lambda (ignore) (read-eval-print-loop))) (define *output* (list nil)) (define (output) (car *output*)) (define *current-environment* user-initial-environment) (define *the-non-printing-object* (list '*the-non-printing-object*)) (define (read-eval-print-loop) (call-with-current-continuation (lambda (-reset-) (set! *reset* -reset-) (newline initial-output-port) (write-string "==> " initial-output-port) (let ((form (read initial-input-port))) (cond ((eof-object? form) (write-string "Use (exit) 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))))))))) (read-eval-print-loop)) (define (write-result thing port) (if (not (or (number? thing) (char? thing) (string? thing) (boolean? thing))) (write-char #\' port)) (write thing port)) (define (reset) (*reset* nil)) (define (initialize) (set-enabled-interrupts! 1) ;??? (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 (error message . items) (newline) (display "Error: ") (display message) (for-each (lambda (item) (newline) (display " ") (write item)) items) (break)) (define (break) (read-eval-print-loop)) (define (exit) (halt 0)) ;;;; Exception handlers ;;; Cases to handle in future: ;;; n-ary + * < = etc. ;;; generic arithmetic ;;; (a) wrong type arg to arithmetic primitives ;;; (b) fixnum arithmetic overflow ;;; optional init argument to make-string and make-vector ;;; optional port argument to I/O primitives (vector-fill! exception-handlers (lambda (m n) (error "an error occurred" (enumerand->name n exception)) (proceed-after-exception m))) (vector-set! exception-handlers exception/undefined-free (lambda (m n) (let ((sym (machine-state-ref m register/val))) (error "undefined variable" sym) (proceed-after-exception m)))) (vector-set! exception-handlers exception/bad-procedure (lambda (m n) (let ((proc (machine-state-ref m register/val)) (argvals (get-argvals m))) (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 (m n) (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 (m n) (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] (define machine-state-ref vector-ref) (vector-set! interrupt-handlers interrupt/keyboard (lambda (machine-state enabled-interrupts interrupt) (set-enabled-interrupts! enabled-interrupts) ;Re-enable (display "Interrupt") (break) (proceed-after-exception machine-state))) ;;;; Set up the user's environment (for-each (lambda (name) (environment-set! user-initial-environment name (environment-ref s48-implementation-environment name))) '( ;;---------------- ;; Entries are in alphabetical order. ;; ;; The following are currently ommitted from the list, but should be ;; considered for addition in future. ;; ;; User interface: (there ought to be a command processor) ;; dump reset ;; Very useful things: ;; error eval user-initial-environment ;; Unwritten useful things: ;; pp debug inspect ;; Unimplemented non-essential features: ;; acos angle atan ceiling ;; char-ci<=? char-ci=? char-ci>? ;; char-ready? ;; cos denominator exact->inexact exp expt 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-copy string-fill! ;; tan ;; transcript-on transcript-off ;Important ;; truncate ;;---------------- exit ;User interface s48-implementation-environment ;A necessary and sufficient loophole ;;---------------- * + - / < <= = > >= abs append apply assoc assq assv boolean? caar cadddr caddr cadr call-with-current-continuation call-with-input-file call-with-output-file car cdar cddddr 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? 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? for-each force inexact->exact inexact? input-port? integer->char integer? last-pair length list list->string list->vector list-ref list-tail load ;Should be user interface... 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->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? )) ;;; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME -*- ;;; This is file vmio.scm. ;;;; I/O primitives (define number-of-ports 100) (define *open-ports* (make-vector number-of-ports nil)) (define *open-$ports* (make-vector number-of-ports $nil)) (define (open-new-port opener creater succeed fail) (let ((index (vector-posq nil *open-ports*))) (if index (let ((port (creater index))) (vector-set! *open-ports* index (opener)) (vector-set! *open-$ports* index port) (succeed port)) (fail)))) (define ($open-input-file string succeed fail) (open-new-port (lambda (index) ($make-input-port index string)) (lambda () (open-input-file (extract-string string))) succeed fail)) (define ($open-output-file string succeed fail) (open-new-port (lambda (index) ($make-output-port index string)) (lambda () (open-output-file (extract-string string))) succeed fail)) (define ($close-input-port port) (let ((index ($input-port-index port))) (close-input-port (vector-ref *open-ports* index)) ($set-input-port-index! port -1) (vector-set! *open-ports* index nil) (vector-set! *open-$ports* index $nil))) (define ($close-output-port port) (let ((index ($output-port-index port))) (close-output-port (vector-ref *open-ports* index)) ($set-input-port-index! port -1) (vector-set! *open-ports* index nil) (vector-set! *open-$ports* index $nil))) (define (extract-input-port port) (let ((index ($input-port-index port))) (if (>=& index 0) (vector-ref *open-ports* index) (current-input-port)))) (define (extract-output-port port) (let ((index ($output-port-index port))) (if (>=& index 0) (vector-ref *open-ports* index) (current-output-port)))) (define ($readable-input-port? port) ($input-port? port)) ;Fix later (define ($writable-output-port? port) ($output-port? port)) (define (noisily-close port) (write-string "Port closed: ") (write-string (extract-string (cond (($input-port? port) ($close-input-port port) ($input-port-name port)) (else ($close-output-port port) ($output-port-name port))))) (newline)) (define (for-each-open-port proc) ;For suspend and GC (do ((i 0 (+& i 1))) ((=& i number-of-ports) 'done) (let ((port (vector-ref *open-$ports* i))) (if (not ($eq? port $nil)) (proc port (lambda (new-port) (vector-set! *open-$ports* i new-port))))))) (define (make-initial-input-port) ($make-input-port -2 0)) (define (make-initial-output-port) ($make-output-port -3 0))