├── ps-compiler ├── minor-version-number ├── prescheme │ ├── test │ │ ├── external.scm │ │ ├── integers.scm │ │ ├── values.scm │ │ ├── memory.scm │ │ ├── poly.scm │ │ ├── fact.scm │ │ ├── eval2.scm │ │ ├── hoist.scm │ │ ├── bvector.scm │ │ ├── cell.scm │ │ ├── eval.scm │ │ ├── goto.scm │ │ ├── write.scm │ │ ├── simp.scm │ │ ├── record.scm │ │ ├── boolean.scm │ │ ├── fact.cps │ │ ├── vector.scm │ │ ├── vector2.scm │ │ ├── coerce.scm │ │ ├── letrec.scm │ │ ├── eval3.scm │ │ ├── loop.scm │ │ ├── dispatch2.scm │ │ ├── string.scm │ │ ├── dispatch.scm │ │ ├── package-defs.scm │ │ ├── select.scm │ │ ├── test.scm │ │ ├── fact2.scm │ │ ├── buffer.scm │ │ └── prescheme.h │ ├── unused │ │ ├── record.scm │ │ ├── data.txt │ │ └── Notes │ ├── primop │ │ ├── c-primop.scm │ │ ├── io.scm │ │ ├── c-record.scm │ │ └── scm-record.scm │ └── primitive.scm ├── load-scheme.scm ├── doc │ └── todo.txt ├── compile-gc.scm ├── node │ ├── leftovers.scm │ └── arch.scm ├── compile-vm-no-gc.scm ├── compile-vm.scm ├── util │ ├── z-set.scm │ └── syntax.scm ├── param.scm └── load-ps-compiler.scm ├── scheme ├── env │ ├── version-info.scm │ ├── load-package.scm │ ├── init-defpackage.scm │ ├── list-interface.scm │ ├── basic-command.scm │ └── dispcond.scm ├── debug │ ├── tiny-packages.scm │ ├── low-test-packages.scm │ ├── small-packages.scm │ ├── fact.scm │ ├── bench.scm │ ├── r5-system.scm │ ├── test-methods.scm │ ├── mini-start.scm │ ├── test-generic.scm │ ├── test.scm │ ├── linker.scm │ ├── describe.scm │ ├── link-debug.scm │ ├── wind-test.scm │ ├── level-0.scm │ ├── for-debugging.scm │ ├── thread-socket.scm │ ├── tiny.scm │ ├── spatial-hack.scm │ ├── mini-command.scm │ ├── mini-package.scm │ └── mumble-packages.scm ├── rts │ ├── time.scm │ ├── session.scm │ ├── population.scm │ ├── template.scm │ ├── signal.scm │ ├── lize.scm │ ├── init.scm │ ├── xprim.scm │ ├── sleep.scm │ ├── lock.scm │ ├── number.scm │ ├── eval.scm │ ├── condition.scm │ └── current-port.scm ├── prescheme │ ├── load.scm │ ├── package-defs.scm │ └── interface.scm ├── alt │ ├── environments.scm │ ├── weak.scm │ ├── loophole.scm │ ├── silly.scm │ ├── closure.scm │ ├── table.scm │ ├── init-defpackage.scm │ ├── values.scm │ ├── queue.scm │ ├── code-vector.scm │ ├── contin.scm │ ├── template.scm │ ├── low.scm │ ├── fluid.scm │ ├── features-packages.scm │ ├── low-packages.scm │ ├── pseudoscheme-record.scm │ ├── escape.scm │ ├── locations.scm │ ├── bitwise.scm │ ├── features.scm │ ├── jar-defrecord.scm │ ├── reroot.scm │ ├── bitwise-tests.scm │ └── t-record.scm ├── infix │ ├── sgol-runtime.scm │ └── packages.scm ├── big │ ├── receive.scm │ ├── compose-cont.scm │ ├── placeholder.scm │ ├── destructure.scm │ └── linked-queue.scm ├── vm │ ├── macro-package-defs.scm │ ├── error-util.scm │ ├── external.scm │ ├── s48-package-defs.scm │ ├── vm-utilities.scm │ └── ps-package-defs.scm ├── misc │ ├── getenv.scm │ ├── ilength.scm │ ├── annotate.scm │ ├── load-static.scm │ ├── require.scm │ ├── mail.scm │ ├── test-doodl.scm │ ├── pipe.scm │ ├── integertostring.scm │ └── engine.scm ├── bcomp │ ├── var-util.scm │ ├── thingie.scm │ ├── config.scm │ ├── primop.scm │ ├── read-form.scm │ ├── ddata.scm │ ├── for-reify.scm │ ├── type.scm │ └── optimize.scm ├── link │ └── loadc.scm ├── opt │ └── tst.scm ├── low-packages.scm ├── kali │ ├── channel-hacks.scm │ └── comrade.scm └── link-packages.scm ├── c ├── fake │ ├── strerror.h │ ├── sys-select.h │ ├── sigact.h │ └── strerror.c ├── socket.h ├── fd-io.h ├── io.h ├── scheme48heap.h ├── event.h ├── scheme48vm.h └── prescheme.h ├── KALI.README ├── acconfig.h ├── doc ├── src │ └── latex-stuff.tex ├── package.txt └── scheme48.man ├── emacs └── README └── gdbinit /ps-compiler/minor-version-number: -------------------------------------------------------------------------------- 1 | 5 2 | -------------------------------------------------------------------------------- /scheme/env/version-info.scm: -------------------------------------------------------------------------------- 1 | (define version-info "0.52.1") 2 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/external.scm: -------------------------------------------------------------------------------- 1 | 2 | (define foo 3 | (external (=> (int32 int32) unit) 4 | (lambda (x y) 5 | (display (+ x y))))) 6 | 7 | (define (test) 8 | (foo 3 4)) 9 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/integers.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (main) 4 | (write-number (+ (read-number (current-input-port)) 100) 5 | (current-output-port)) 6 | 0) 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /c/fake/strerror.h: -------------------------------------------------------------------------------- 1 | /* 2 | * If we don't have strerror(), we fake it using sys_nerr and sys_errlist. 3 | */ 4 | #if ! defined(HAVE_STRERROR) 5 | 6 | extern char *strerror(int errnum); 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /c/fake/sys-select.h: -------------------------------------------------------------------------------- 1 | /* 2 | * If we have a sys/select.h, then include it. 3 | */ 4 | #if defined(HAVE_SYS_SELECT_H) 5 | 6 | #include 7 | #include 8 | 9 | #endif 10 | -------------------------------------------------------------------------------- /scheme/debug/tiny-packages.scm: -------------------------------------------------------------------------------- 1 | ; no copyright 2 | 3 | ; (link-simple-system '(debug tiny) 'start tiny-system) 4 | 5 | (define-structure tiny-system (export start) 6 | (define-all-operators) 7 | (files tiny)) 8 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/values.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (sender) 3 | (values 1 2 3 4)) 4 | 5 | (define (receiver a b c d) 6 | (+ a (- b (* c d)))) 7 | 8 | (define (test) 9 | (call-with-values sender receiver)) 10 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/memory.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (test x i) 3 | (let ((m (allocate-memory 10))) 4 | (unsigned-byte-set! (+ m i) x) 5 | (word-set! (+ m i) (+ 1 (word-ref (+ m i)))) 6 | (unsigned-byte-ref (+ m i)))) 7 | -------------------------------------------------------------------------------- /scheme/debug/low-test-packages.scm: -------------------------------------------------------------------------------- 1 | ; no copyright 2 | 3 | ; (link-simple-system '(debug low-test) 'start low-test-system) 4 | 5 | (define-structure low-test-system (export start) 6 | (define-all-operators) 7 | (files low-test)) 8 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/poly.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (identity x) x) ; can't get much more polymorphic than that 3 | 4 | (define (test x) 5 | (cond (#f 6 | (vector-ref (identity (make-vector 3)) 2)) 7 | (else 8 | (+ (identity (+ x 3)) (identity (+ x 2)))))) 9 | 10 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/fact.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define *one* 1) 4 | 5 | (define (fact n) 6 | (let loop ((i n) (r *one*)) 7 | (if (<= *one* i) 8 | (loop (- i *one*) (* i r)) 9 | r))) 10 | 11 | (define (all) 12 | (set! *one* (fact (if (> (fact 10) 100) 10 20)))) 13 | -------------------------------------------------------------------------------- /scheme/debug/small-packages.scm: -------------------------------------------------------------------------------- 1 | ; no copyright 2 | 3 | ; (link-simple-system '(debug small) 'start tiny-system) 4 | 5 | (define-structure small-system (export start) 6 | (define-all-operators) 7 | (usual-transforms and cond do let let* or) 8 | (files (rts defenum) (rts arch) (debug small))) 9 | -------------------------------------------------------------------------------- /scheme/rts/time.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | (define (real-time) 5 | (time (enum time-option real-time) #f)) 6 | 7 | (define (run-time) 8 | (time (enum time-option run-time) #f)) 9 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/eval2.scm: -------------------------------------------------------------------------------- 1 | 2 | (define-local-syntax (define-primitive id nargs) 3 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 4 | `(define (,id . ,args) 5 | (call-primitively ,id . ,args)))) 6 | 7 | (define-primitive ashr 2) 8 | 9 | (define high-bits ashr) 10 | 11 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/hoist.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (foo x y) 4 | (let ((bar (lambda (y) 5 | (let ((baz (lambda (a b) 6 | (foo (- a 2) (+ 3 b))))) 7 | (+ (baz y 1) (baz (+ y 1) 2)))))) 8 | (if (= x 0) 9 | (goto bar 10) 10 | (goto bar 4)))) 11 | 12 | (define (test) 13 | (foo 30 40)) -------------------------------------------------------------------------------- /scheme/prescheme/load.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1997 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; To load Pre-Scheme, do 5 | ; ,exec ,load 6 | 7 | (config) 8 | (load "interface.scm") 9 | (load "package-defs.scm") 10 | -------------------------------------------------------------------------------- /scheme/debug/fact.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; don't copyright this, silly shell script 5 | 6 | 7 | (define (fact n) 8 | (if (= n 0) 9 | 1 10 | (* n (fact (- n 1))))) 11 | -------------------------------------------------------------------------------- /scheme/alt/environments.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; don't put a copyright notice, silly shell script 5 | 6 | (define (*structure-ref struct name) 7 | (eval name (interaction-environment))) 8 | 9 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/bvector.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (test) 3 | (let ((v (make-byte-vector 10)) 4 | (out (current-output-port))) 5 | (write-number (byte-vector-ref v 4) out) 6 | (byte-vector-set! v 5 100) 7 | (write-number (byte-vector-ref v 5) out) 8 | (write-number (byte-vector-word-ref v 4) out))) 9 | 10 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/cell.scm: -------------------------------------------------------------------------------- 1 | 2 | (define *count* 0) 3 | 4 | (define (increment) 5 | (set! *count* (+ *count* 1))) 6 | 7 | (define (value) 8 | *count*) 9 | 10 | (define (test out) 11 | (increment) 12 | (increment) 13 | (write-number (value) out) 14 | (newline out)) 15 | 16 | (test (current-output-port)) 17 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/eval.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (fact n) 4 | (let loop ((i n) (r 1)) 5 | (if (<= i 1) 6 | r 7 | (loop (- i 1) (* i r))))) 8 | 9 | (define facts (make-vector 5)) 10 | 11 | (do ((i 0 (+ i 1))) 12 | ((< 4 i)) 13 | (vector-set! facts i (fact i))) 14 | 15 | (define f4 (vector-ref facts 4)) 16 | 17 | -------------------------------------------------------------------------------- /scheme/alt/weak.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define (make-weak-pointer x) (cons ' x)) 6 | (define weak-pointer-ref cdr) 7 | (define (weak-pointer? x) 8 | (and (pair? x) (eq? (car x) '))) 9 | 10 | -------------------------------------------------------------------------------- /c/fake/sigact.h: -------------------------------------------------------------------------------- 1 | /* 2 | * If we don't have sigaction, we fake it using signal. 3 | */ 4 | #if ! defined(HAVE_SIGACTION) 5 | 6 | struct sigaction { 7 | void (*sa_handler)(); 8 | int sa_mask; 9 | int sa_flags; 10 | }; 11 | 12 | #define sigaction(sig, act, oact) signal((sig), (act)->sa_handler) 13 | #define sigemptyset(ign) 0 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /scheme/infix/sgol-runtime.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define (%unspecific) 6 | (if #f #f)) 7 | 8 | (define (!= x y) 9 | (not (= x y))) 10 | 11 | (define (%tuple . rest) 12 | (list->vector (cons 'tuple rest))) 13 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/goto.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (odd? x) 4 | (cond ((= x 0) 5 | #f) 6 | ; ((= x 100) 7 | ; (foo)) 8 | (else 9 | (goto even? (- x 1))))) 10 | 11 | (define (even? x) 12 | (if (= x 0) 13 | #t 14 | (goto odd? (- x 1)))) 15 | 16 | (define (test x) 17 | (if (odd? (+ x 1)) 18 | (error "an even number" x))) 19 | -------------------------------------------------------------------------------- /scheme/big/receive.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define-syntax receive 6 | (syntax-rules () 7 | ((receive ?vars ?producer . ?body) 8 | (call-with-values (lambda () ?producer) 9 | (lambda ?vars . ?body))))) 10 | -------------------------------------------------------------------------------- /scheme/alt/loophole.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define-syntax loophole 6 | (syntax-rules () 7 | ((loophole ?type ?form) 8 | (begin (lambda () ?type) ;Elicit unbound-variable warnings, etc. 9 | ?form)))) 10 | 11 | -------------------------------------------------------------------------------- /scheme/vm/macro-package-defs.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; VM-ARCHITECTURE is used in a FOR-SYNTAX clause in the VM package definitions. 6 | 7 | (define-structures ((vm-architecture (export stob-data))) 8 | (open scheme enumerated) 9 | (files arch)) 10 | -------------------------------------------------------------------------------- /c/socket.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Procedures exported from socket.c. 3 | * Note, sysdep.h must be included before this file. 4 | */ 5 | #if defined(HAVE_SOCKET) 6 | 7 | extern int internet_stream_socket(void), 8 | socket_bind(int sock, int port), 9 | socket_accept(int sock), 10 | socket_connect(int sock, char *mach, int port), 11 | socket_nodelay(int sock, int nodelay); /* added for Kali */ 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /scheme/misc/getenv.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; ,open primitives 6 | 7 | 8 | (define getenv 9 | (let ((buffer (make-string 2000))) 10 | (lambda (var-name) 11 | (let ((len (vm-extension 26 (cons var-name buffer)))) 12 | (if len 13 | (substring buffer 0 len) 14 | #f))))) 15 | 16 | 17 | -------------------------------------------------------------------------------- /scheme/alt/silly.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | (define (reverse-list->string l n) 7 | ;; Significantly faster than (list->string (reverse l)) 8 | (let ((s (make-string n #\x))) 9 | (let loop ((i (- n 1)) (l l)) 10 | (if (< i 0) s (begin (string-set! s i (car l)) 11 | (loop (- i 1) (cdr l))))))) 12 | -------------------------------------------------------------------------------- /KALI.README: -------------------------------------------------------------------------------- 1 | To make kali, follow the instructions in INSTALL. It has to be 2 | installed some where in your PATH. (Before you do a 3 | make install 4 | you can try it out by running the `go' file in the source directory.) 5 | 6 | Documentation on using Kali can be found in doc/kali.{ps|html}. 7 | 8 | If you have problems building or using Kali, please send mail to 9 | kali-request@research.nj.nec.com 10 | and we'll see if we can be of any help. 11 | 12 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/write.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (test) 3 | (let* ((b (allocate-memory 16)) 4 | (res (read-block (current-input-port) 5 | b 6 | 16 7 | (lambda (okay? eof? got) 8 | (if (or (not okay?) 9 | eof?) 10 | -1 11 | (write-block (current-output-port) 12 | b 13 | got 14 | (lambda (okay? sent) 15 | (if okay? sent -1)))))))) 16 | (deallocate-memory b) 17 | res)) 18 | -------------------------------------------------------------------------------- /ps-compiler/load-scheme.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Load the Scheme front-end 5 | 6 | (config) 7 | (load "interfaces.scm") 8 | (load "package-defs.scm") 9 | (load "scheme-to-c/package-defs.scm") 10 | (load-package 'let-nodes) ; used in FOR-SYNTAX 11 | (load-package 'simp-patterns) ; used in FOR-SYNTAX 12 | (load-package 'scheme-test) 13 | -------------------------------------------------------------------------------- /scheme/vm/error-util.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | (define (error? status) 5 | (not (eq? status (enum errors no-errors)))) 6 | 7 | (define (write-error-string string) 8 | (write-string string (current-error-port))) 9 | 10 | (define (write-error-integer integer) 11 | (write-integer integer (current-error-port))) 12 | 13 | (define (error-newline) 14 | (write-char #\newline (current-error-port))) 15 | -------------------------------------------------------------------------------- /c/fd-io.h: -------------------------------------------------------------------------------- 1 | 2 | #define STDIN_FD() 0 3 | #define STDOUT_FD() 1 4 | #define STDERR_FD() 2 5 | 6 | extern int ps_open_fd(char *in_filename, bool is_input, long *status); 7 | 8 | extern int ps_close_fd(long fd_as_long); 9 | 10 | extern long ps_read_fd(long fd_as_long, char *buf_as_long, long max, bool waitp, 11 | bool *eofp, bool *pending, long *status); 12 | 13 | extern long ps_write_fd(long fd_as_long, char *buf_as_long, long max, 14 | bool *pending, long *status); 15 | 16 | extern long ps_abort_fd_op(long fd_as_long); 17 | -------------------------------------------------------------------------------- /scheme/alt/closure.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | ; Closures 7 | 8 | (define closure-rtd (make-record-type 'closure '(template env))) 9 | (define closure? (record-predicate closure-rtd)) 10 | (define make-closure (record-constructor closure-rtd '(template env))) 11 | (define closure-template (record-accessor closure-rtd 'template)) 12 | (define closure-env (record-accessor closure-rtd 'env)) 13 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/simp.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (foo x y z) 3 | (if (and (= (bitwise-and x 3) 0) 4 | (= (bitwise-and y 3) 0) 5 | (= (bitwise-and z 3) 0)) 6 | (ashl (ashr x 2) 2) 7 | (ashl y (ashr z 2)))) 8 | 9 | (define-local-syntax (define-primitive id nargs) 10 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 11 | `(define (,id . ,args) 12 | (call-primitively ,id . ,args)))) 13 | 14 | (define-primitive = 2) 15 | (define-primitive bitwise-and 2) 16 | (define-primitive ashl 2) 17 | (define-primitive ashr 2) 18 | -------------------------------------------------------------------------------- /scheme/alt/table.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; unworthy of copyright notice 5 | 6 | (define (make-table . hash-procedure-option) (list 'table)) 7 | 8 | (define (table-ref table key) 9 | (let ((probe (assq key (cdr table)))) 10 | (if probe (cdr probe) #f))) 11 | 12 | (define (table-set! table key value) 13 | (let ((probe (assq key (cdr table)))) 14 | (if probe 15 | (set-cdr! probe value) 16 | (set-cdr! table (cons (cons key value) (cdr table)))))) 17 | -------------------------------------------------------------------------------- /c/fake/strerror.c: -------------------------------------------------------------------------------- 1 | /* 2 | * If the system doesn't have a strerror procedure, we provide our own. 3 | * Note, this depends on sys_nerr and sys_errlist being provided. 4 | * If your system doesn't provide that either, you can replace this 5 | * procedure with one that always returns "Unknown error". 6 | */ 7 | #include "sysdep.h" 8 | 9 | 10 | extern int sys_nerr; 11 | extern char *sys_errlist[]; 12 | 13 | 14 | char * 15 | strerror(int errnum) 16 | { 17 | if ((0 <= errnum) 18 | && (errnum < sys_nerr)) 19 | return (sys_errlist[errnum]); 20 | else 21 | return ("Unknown error"); 22 | } 23 | -------------------------------------------------------------------------------- /c/io.h: -------------------------------------------------------------------------------- 1 | extern FILE *ps_open_input_file(char *, long *); 2 | extern FILE *ps_open_output_file(char *, long *); 3 | extern long ps_close(FILE *); 4 | extern char ps_read_char(FILE *, char *, long *, char); 5 | extern long ps_read_integer(FILE *, char *, long *); 6 | extern long ps_write_char(char, FILE *); 7 | extern long ps_write_integer(long, FILE *); 8 | extern long ps_write_string(char *, FILE *); 9 | extern long ps_read_block(FILE *, char *, long, char *, long *); 10 | extern long ps_write_block(FILE *, char *, long); 11 | extern char *ps_error_string(long); 12 | extern void ps_error(char *, long count, ...); 13 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/unused/record.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | ; (make-record 'type-id) 4 | ; (record-ref 'type-id 'field-id) 5 | ; (record-set! 'type-id 'field-id) 6 | 7 | (define-polymorphic-scheme-primop make-record allocate 8 | (lambda (call) 9 | (get-record-type (literal-value (node-ref call 0))))) 10 | 11 | (define-polymorphic-scheme-primop record-ref read 12 | (lambda (call) 13 | (record-field-type 14 | (get-record-type-field (get-record-type (literal-value (node-ref call 1))) 15 | (literal-value (node-ref call 2)))))) 16 | 17 | (define-scheme-primop record-set! write type/unit) 18 | -------------------------------------------------------------------------------- /ps-compiler/doc/todo.txt: -------------------------------------------------------------------------------- 1 | There is a question about the simplifier for -. 2 | Also, should (- x x) be checked for? 3 | 4 | Join substitute is not quite right: might have (some-test cont1 cont2 V ) 5 | where V is being tested. As it stands we'll duplicate . Should check 6 | that it is either small or contains no references to V (in which case we lift 7 | it with the conts). 8 | 9 | Need to come up with good numbers for the maximum size of procs and jumps 10 | that should be duplicated. 11 | 12 | Can join-substitute move stuff above a test? 13 | 14 | Pre-Scheme type checker dies on (car '()) if a LET has more variables 15 | than values. 16 | -------------------------------------------------------------------------------- /scheme/alt/init-defpackage.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; This file should be loaded into the bootstrap linker before any use 6 | ; of DEFINE-STRUCTURE. Compare with env/init-defpackage.scm. 7 | 8 | (define-reflective-tower-maker 9 | (lambda (clauses names) 10 | (let ((env (interaction-environment))) 11 | (delay 12 | (begin (if (not (null? clauses)) 13 | (warn "a FOR-SYNTAX clause appears in a package being linked by the cross-linker" 14 | `(for-syntax ,@clauses))) 15 | (cons eval env)))))) 16 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/record.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define-data-type list 4 | (pair? (cons car cdr) 5 | (car integer car set-car!) 6 | (cdr list cdr set-cdr!)) 7 | (null? null)) 8 | 9 | (define (member? list x) 10 | (let loop ((list list)) 11 | (cond ((null? list) 12 | #f) 13 | ((= x (car list)) 14 | #t) 15 | (else 16 | (loop (cdr list)))))) 17 | 18 | (define (reverse! list) 19 | (if (or (null? list) 20 | (null? (cdr list))) 21 | list 22 | (let loop ((list list) (prev null)) 23 | (let ((next (cdr list))) 24 | (set-cdr! list prev) 25 | (if (null? next) 26 | list 27 | (loop next list)))))) 28 | -------------------------------------------------------------------------------- /scheme/vm/external.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define (fake-it name) 6 | (lambda args 7 | (display "Call to ") 8 | (display (cons name args)) 9 | (newline) 10 | 0)) 11 | 12 | (define extended-vm (fake-it 'extended-vm)) 13 | (define lookup-external-name (fake-it 'lookup-external-name)) 14 | (define call-external-value (fake-it 'call-external-value)) 15 | (define schedule-interrupt (fake-it 'schedule-interrupt)) 16 | 17 | (define (real-time) 0) 18 | (define (run-time) 0) 19 | (define (cheap-time) 0) 20 | 21 | -------------------------------------------------------------------------------- /scheme/alt/values.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Multiple return values 6 | 7 | (define multiple-value-token (vector 'multiple-value-token)) 8 | 9 | (define (values . things) 10 | (if (and (pair? things) 11 | (null? (cdr things))) 12 | (car things) 13 | (cons multiple-value-token things))) 14 | 15 | (define (call-with-values producer consumer) 16 | (let ((things (producer))) 17 | (if (and (pair? things) 18 | (eq? (car things) multiple-value-token)) 19 | (apply consumer (cdr things)) 20 | (consumer things)))) 21 | -------------------------------------------------------------------------------- /scheme/bcomp/var-util.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | (define (number-of-required-args formals) 5 | (do ((l formals (cdr l)) 6 | (i 0 (+ i 1))) 7 | ((not (pair? l)) i))) 8 | 9 | (define (n-ary? formals) 10 | (cond ((null? formals) #f) 11 | ((pair? formals) (n-ary? (cdr formals))) 12 | (else #t))) 13 | 14 | (define (normalize-formals formals) 15 | (cond ((null? formals) 16 | '()) 17 | ((pair? formals) 18 | (cons (car formals) 19 | (normalize-formals (cdr formals)))) 20 | (else 21 | (list formals)))) 22 | 23 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/boolean.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | (define (test in out) 5 | (write-string '"Type in two numbers: " out) 6 | (let* ((i (read-integer in)) 7 | (j (read-integer in))) 8 | (write-string '"A = " out) 9 | (write-integer i out) 10 | (newline out) 11 | (write-string '"B = " out) 12 | (write-integer j out) 13 | (newline out) 14 | (write-string (if (and (< i j) 15 | (or (= (remainder i '2) '0) 16 | (= (remainder j '2) '0))) 17 | '"A < B and A or B is even" 18 | '"A >= B or A and B are both odd") 19 | out) 20 | (newline out) 21 | '0)) 22 | 23 | (test (current-input-port) (current-output-port)) 24 | -------------------------------------------------------------------------------- /scheme/bcomp/thingie.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; A thingie (placecard?) is used to hold a spot for a location that is to be 5 | ; found later. The compiler sticks them in templates and the module system 6 | ; later replaces them with locations. 7 | ; 8 | ; We can't use (BEGIN ...) for this trivial package because it is loaded 9 | ; by flatload, which can't handle them. 10 | 11 | (define-record-type thingie :thingie 12 | (make-thingie binding name want-type) 13 | thingie? 14 | (binding thingie-binding) 15 | (name thingie-name) 16 | (want-type thingie-want-type)) 17 | 18 | -------------------------------------------------------------------------------- /c/scheme48heap.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Externally visible objects defined in scheme48heap.c. 3 | */ 4 | extern long available(void); 5 | extern void begin_collection(void); 6 | extern long do_gc(long, long*); 7 | extern void end_collection(void); 8 | extern long find_all(long); 9 | extern long find_all_records(long); 10 | extern long gc_count(void); 11 | extern long heap_size(void); 12 | extern char image_writing_okayP(void); 13 | extern long trace_locationsB(char *, char *); 14 | extern long trace_stob_contentsB(long); 15 | extern long trace_value(long); 16 | extern long write_image(long, FILE *, void(*)(void)); 17 | 18 | 19 | extern char * heap_limits(char **, char **, char **, char **); /* Kali Code */ 20 | -------------------------------------------------------------------------------- /scheme/link/loadc.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Cf. alt/config.scm 6 | 7 | (define (load-configuration filename . rest) 8 | (let ((save filename)) 9 | (dynamic-wind (lambda () (set! *source-file-name* filename)) 10 | (lambda () 11 | (apply load filename rest)) 12 | (lambda () (set! *source-file-name* save))))) 13 | (define (%file-name%) *source-file-name*) 14 | (define *source-file-name* "") 15 | 16 | 17 | ; ? 18 | 19 | (define-syntax structure-ref 20 | (syntax-rules () 21 | ((structure-ref ?struct ?name) 22 | (*structure-ref ?struct '?name)))) 23 | -------------------------------------------------------------------------------- /ps-compiler/compile-gc.scm: -------------------------------------------------------------------------------- 1 | (config '(load "../scheme/vm/macro-package-defs.scm")) 2 | (load-package 'vm-architecture) 3 | (in 'forms '(run (set! *duplicate-lambda-size* 30))) 4 | (in 'simplify-let '(run (set! *duplicate-lambda-size* 15))) 5 | (in 'prescheme-compiler 6 | '(run (prescheme-compiler 7 | '(allocation heap heap-init 8 | heap-internal) ; Kali code 9 | '("../scheme/vm/interfaces.scm" 10 | "../scheme/vm/ps-package-defs.scm" 11 | "../scheme/vm/package-defs.scm") 12 | 's48-heap-init 13 | "../scheme/vm/scheme48heap.c" 14 | '(header "#include \"scheme48vm.h\"") 15 | '(copy (heap walk-over-type-in-area)) 16 | '(integrate (real-copy-object trace-locations!))))) 17 | -------------------------------------------------------------------------------- /scheme/debug/bench.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Tiny benchmarking image. 5 | 6 | ; This returns the result of calling recursive FIB on its first argument. 7 | 8 | (define (start arg in out error) 9 | (fib (string->integer (vector-ref arg 0)))) 10 | 11 | (define (string->integer s) 12 | (letrec ((loop (lambda (i r) 13 | (if (= i (string-length s)) 14 | r 15 | (loop (+ i 1) 16 | (+ (- (char->ascii (string-ref s i)) 17 | (char->ascii #\0)) 18 | (* 10 r))))))) 19 | (loop 0 0))) 20 | 21 | (define (fib n) 22 | (if (< n 2) 23 | 1 24 | (+ (fib (- n 1)) (fib (- n 2))))) 25 | -------------------------------------------------------------------------------- /scheme/alt/queue.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Queues 5 | 6 | (define (make-queue) 7 | (cons '() '())) 8 | 9 | (define (queue-empty? q) 10 | (and (null? (car q)) 11 | (null? (cdr q)))) 12 | 13 | (define (enqueue! q obj) 14 | (set-car! q (cons obj (car q)))) 15 | 16 | (define (dequeue! q) 17 | (normalize-queue! q) 18 | (let ((head (car (cdr q)))) 19 | (set-cdr! q (cdr (cdr q))) 20 | head)) 21 | 22 | (define (normalize-queue! q) 23 | (if (null? (cdr q)) 24 | (begin (set-cdr! q (reverse (car q))) 25 | (set-car! q '())))) 26 | 27 | (define (queue-head q) 28 | (normalize-queue! q) 29 | (car (cdr q))) 30 | -------------------------------------------------------------------------------- /scheme/debug/r5-system.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Link script. 6 | 7 | (define (link-revised^5-system) 8 | (let ((structures-to-open (struct-list scheme))) 9 | (link-reified-system structures-to-open 10 | 'revised^5 11 | `(start ',(map car structures-to-open)) 12 | initial-system 13 | for-reification 14 | ;; Extra stuff (from more-packages.scm) 15 | disclosers 16 | package-mutation shadowing 17 | bignums ratnums floatnums 18 | ))) 19 | 20 | (define scheme (make-scheme environments evaluation)) 21 | 22 | (define initial-system 23 | (make-initial-system scheme (make-mini-command scheme))) 24 | -------------------------------------------------------------------------------- /scheme/alt/code-vector.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Code-vectors implemented as vectors. 5 | 6 | (define *code-vector-marker* (list '*code-vector-marker*)) 7 | 8 | (define (make-code-vector len init) 9 | (let ((t (make-vector (+ len 1) init))) 10 | (vector-set! t 0 *code-vector-marker*) 11 | t)) 12 | 13 | (define (code-vector? obj) 14 | (and (vector? obj) 15 | (> (vector-length obj) 0) 16 | (eq? (vector-ref obj 0) *code-vector-marker*))) 17 | 18 | (define (code-vector-length t) (- (vector-length t) 1)) 19 | (define (code-vector-ref t i) (vector-ref t (+ i 1))) 20 | (define (code-vector-set! t i x) (vector-set! t (+ i 1) x)) 21 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/fact.cps: -------------------------------------------------------------------------------- 1 | (FORM 0 random okay #f 2 | () 3 | 4 | (P #f_0 (c_1) 5 | (LET* (((loop_2) (allocate 'single-set 'ptr)) 6 | (() (set-contents loop_2 'cell '0 '0 ^loop_3))) 7 | (jump 0 (contents loop_2 'cell '0 '0) '5 '1))) 8 | 9 | (J loop_3 (i_4 r_5) 10 | (LET* (((c_6)* ^c_7)) 11 | (test 2 ^g_8 ^g_9 (less? '1 i_4)))) 12 | 13 | (C g_8 () 14 | (return 0 c_6 '#f)) 15 | 16 | (C g_9 () 17 | (return 0 c_6 '#t)) 18 | 19 | (C c_7 (v_10) 20 | (test 2 ^g_11 ^g_12 v_10)) 21 | 22 | (C g_11 () 23 | (unknown-return 0 c_1 '1 r_5)) 24 | 25 | (C g_12 () 26 | (jump 0 (contents loop_2 'cell '0 '0) (subtract i_4 '1) (multiply i_4 r_5)))) 27 | 28 | -------------------------------------------------------------------------------- /scheme/alt/contin.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Continuations implemented as vectors. 6 | 7 | (define *continuation-marker* (list '*continuation-marker*)) 8 | 9 | (define (make-continuation len init) 10 | (let ((c (make-vector (+ len 1) init))) 11 | (vector-set! c 0 *continuation-marker*) 12 | c)) 13 | 14 | (define (continuation? obj) 15 | (and (vector? obj) 16 | (> (vector-length obj) 0) 17 | (eq? (vector-ref obj 0) *continuation-marker*))) 18 | 19 | (define (continuation-length c) (- (vector-length c) 1)) 20 | (define (continuation-ref c i) (vector-ref c (+ i 1))) 21 | (define (continuation-set! c i x) (vector-set! c (+ i 1) x)) 22 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/vector.scm: -------------------------------------------------------------------------------- 1 | 2 | ; Oops - this is polymorphic! 3 | 4 | (define (vector+length-fill! v length x) 5 | (do ((i 0 (+ i 1))) 6 | ((>= i length)) 7 | (vector-set! v i x))) 8 | 9 | (define *v* (unassigned)) 10 | 11 | (define (test x) 12 | (set! *v* (make-vector 10)) 13 | (vector+length-fill! *v* 10 3) 14 | (vector-ref *v* x)) 15 | 16 | ;(define (find-port-index) 17 | ; (let loop ((i 0)) 18 | ; (cond ((>= i 10) 19 | ; -1) 20 | ; ((= 3 (vector-ref *v* i)) 21 | ; i) 22 | ; (else (loop (+ i 1)))))) 23 | ; 24 | ;(define (foo) 25 | ; (let loop ((i (find-port-index))) 26 | ; (if (>= i 5) 27 | ; (let ((v *v*)) 28 | ; (bar) 29 | ; (vector-set! v i (baz))) 30 | ; (loop (find-port-index))))) 31 | -------------------------------------------------------------------------------- /scheme/alt/template.scm: -------------------------------------------------------------------------------- 1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*- 2 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 3 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 4 | 5 | 6 | ; Templates implemented as vectors. 7 | 8 | (define *template-marker* (list '*template-marker*)) 9 | 10 | (define (make-template len init) 11 | (let ((t (make-vector (+ len 1) init))) 12 | (vector-set! t 0 *template-marker*) 13 | t)) 14 | 15 | (define (template? obj) 16 | (and (vector? obj) 17 | (> (vector-length obj) 0) 18 | (eq? (vector-ref obj 0) *template-marker*))) 19 | 20 | (define (template-length t) (- (vector-length t) 1)) 21 | (define (template-ref t i) (vector-ref t (+ i 1))) 22 | (define (template-set! t i x) (vector-set! t (+ i 1) x)) 23 | -------------------------------------------------------------------------------- /c/event.h: -------------------------------------------------------------------------------- 1 | enum event_enum { KEYBOARD_INTERRUPT_EVENT, IO_COMPLETION_EVENT, ALARM_EVENT, 2 | ERROR_EVENT, NO_EVENT }; 3 | extern int get_next_event(long *ready_fd, long *status); 4 | 5 | extern bool add_pending_fd(int fd, bool is_input); 6 | extern bool remove_fd(int fd); 7 | extern long schedule_alarm_interrupt(long delta); 8 | extern long run_time(long *mseconds); 9 | extern long real_time(long *mseconds); 10 | extern int wait_for_event(long max_wait, bool is_minutes); 11 | 12 | 13 | /* these are here only for the CHEAP_TIME() macro */ 14 | #define TICKS_PER_SECOND 1000 /* clock resolution */ 15 | #define POLLS_PER_SECOND 20 /* how often we poll */ 16 | #define TICKS_PER_POLL (TICKS_PER_SECOND / POLLS_PER_SECOND) 17 | 18 | extern long current_time; 19 | #define CHEAP_TIME() (current_time * TICKS_PER_POLL) 20 | -------------------------------------------------------------------------------- /acconfig.h: -------------------------------------------------------------------------------- 1 | /* 2 | * HAVE_SIGACTION is defined iff sigaction() is available. 3 | */ 4 | #undef HAVE_SIGACTION 5 | 6 | /* 7 | * HAVE_STRERROR is defined iff the standard libraries provide strerror(). 8 | */ 9 | #undef HAVE_STRERROR 10 | 11 | /* 12 | * NLIST_HAS_N_NAME is defined iff a struct nlist has an n_name member. 13 | * If it doesn't then we assume it has an n_un member which, in turn, 14 | * has an n_name member. 15 | */ 16 | #undef NLIST_HAS_N_NAME 17 | 18 | /* 19 | * HAVE_SYS_SELECT_H is defined iff we have the include file sys/select.h. 20 | */ 21 | #undef HAVE_SYS_SELECT_H 22 | 23 | /* 24 | * USCORE is defined iff C externals are prepended with an underscore. 25 | */ 26 | #undef USCORE 27 | 28 | @BOTTOM@ 29 | 30 | #include "fake/sigact.h" 31 | #include "fake/strerror.h" 32 | #include "fake/sys-select.h" 33 | -------------------------------------------------------------------------------- /ps-compiler/node/leftovers.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Identifying values called by primops 6 | 7 | ; Is NODE the value being called by a primop? 8 | 9 | (define (procedure-node? node) 10 | (let ((primop (call-primop (node-parent node)))) 11 | (and (primop-procedure? primop) 12 | (eq? (primop-call-index (call-primop (node-parent node))) 13 | (node-index node))))) 14 | 15 | ; Get the node called at CALL. 16 | 17 | (define (called-procedure-node call) 18 | (cond ((and (primop-procedure? (call-primop call)) 19 | (primop-call-index (call-primop call))) 20 | => (lambda (i) 21 | (call-arg call i))) 22 | (else '#f))) 23 | 24 | 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/primop/c-primop.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1994 Richard Kelsey. See file COPYING. 2 | 3 | 4 | ; Code generation for primops. 5 | 6 | (define-record-type c-primop :c-primop 7 | (make-c-primop simple? generate) 8 | c-primop? 9 | (simple? c-primop-simple?) 10 | (generate c-primop-generate)) 11 | 12 | (define (simple-c-primop? primop) 13 | (c-primop-simple? (primop-code-data primop))) 14 | 15 | (define (primop-generate-c primop call port indent) 16 | ((c-primop-generate (primop-code-data primop)) 17 | call port indent)) 18 | 19 | (define-syntax define-c-generator 20 | (lambda (exp r$ c$) 21 | (destructure (((ignore id simple? generate) exp)) 22 | `(set-primop-code-data! 23 | (,(r$ 'get-prescheme-primop) ',id) 24 | (,(r$ 'make-c-primop) 25 | ,simple? 26 | ,generate 27 | ))))) 28 | 29 | 30 | -------------------------------------------------------------------------------- /scheme/opt/tst.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | (define-structure primitives (make-compiler-base)) 7 | 8 | ; "Level 1" 9 | 10 | (define-structures ((scheme-level-1 scheme-level-1-interface) 11 | (scheme-level-1-internal scheme-level-1-internal-interface) 12 | (bitwise bitwise-interface) 13 | (util util-interface) 14 | (signals signals-interface) 15 | (features features-interface) 16 | (ascii ascii-interface) 17 | (structure-refs (export structure-ref))) 18 | (open primitives) 19 | (usual-transforms) 20 | (optimize auto-integrate) 21 | (files (rts base) 22 | (rts util) 23 | (rts signal) 24 | (rts number) 25 | (rts lize) ; Rationalize 26 | )) 27 | 28 | -------------------------------------------------------------------------------- /scheme/alt/low.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Portable versions of low-level things that would really like to rely 6 | ; on the Scheme 48 VM or on special features provided by the byte code 7 | ; compiler. 8 | 9 | (define (vector-unassigned? v i) #f) 10 | 11 | (define (flush-the-symbol-table!) #f) 12 | 13 | (define maybe-open-input-file open-input-file) 14 | (define maybe-open-output-file open-output-file) 15 | 16 | 17 | ; Suppress undefined export warnings. 18 | 19 | (define-syntax %file-name% 20 | (syntax-rules () 21 | ((%file-name%) ""))) 22 | 23 | (define-syntax structure-ref 24 | (syntax-rules () 25 | ((structure-ref ?struct ?name) 26 | (error "structure-ref isn't implemented" '?struct '?name)))) 27 | -------------------------------------------------------------------------------- /scheme/debug/test-methods.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define-generic g &g) 6 | 7 | (define-method &g ((x :number)) 'win) 8 | 9 | (define-method &g ((n :integer)) 10 | (if (= n 13) 11 | (next-method) 12 | 'ok)) 13 | 14 | (define-method &g ((s :symbol)) 15 | (if (= s 13) 16 | (next-method) 17 | 'ok)) 18 | 19 | ; (g 1/2) => 'win 20 | ; (g 10) => 'ok 21 | ; (g 13) => 'win 22 | 23 | 24 | (define-generic elt &elt) 25 | 26 | (define-method &elt ((x :vector) y) 27 | (vector-ref x y)) 28 | 29 | (define-method &elt ((x :string) y) 30 | (string-ref x y)) 31 | 32 | (define-method &elt ((x :list) y) 33 | (list-ref x y)) 34 | 35 | ; Generic length 36 | 37 | ; (define-generic-function glength ((s :sequence))) 38 | 39 | -------------------------------------------------------------------------------- /scheme/env/load-package.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | (define (ensure-loaded . structs) 5 | (force-output (current-output-port)) ; avoid interleaved output 6 | (let ((out (current-noise-port))) 7 | (for-each (lambda (package) 8 | (display #\[ out) 9 | (display (package-name package) out) 10 | (with-interaction-environment package 11 | (lambda () 12 | (invoke-closure 13 | (make-closure (compile-package package) 14 | (package-uid package))))) 15 | (set-package-loaded?! package #t) 16 | (walk-population check-structure 17 | (package-clients package)) 18 | (display #\] out) 19 | (newline out)) 20 | (collect-packages structs 21 | (lambda (package) 22 | (not (package-loaded? package))))))) 23 | 24 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/vector2.scm: -------------------------------------------------------------------------------- 1 | 2 | (define-local-syntax (define-primitive id nargs) 3 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 4 | `(define (,id . ,args) 5 | (call-primitively ,id . ,args)))) 6 | 7 | (define-primitive + 2) 8 | (define-primitive - 2) 9 | (define-primitive * 2) 10 | (define-primitive < 2) 11 | 12 | (define-primitive make-vector 2) 13 | (define-primitive pointer-add 2) 14 | 15 | (define (vector-ref vec index) 16 | (call-primitively contents (pointer-add vec index))) 17 | 18 | (define (vector-set! vec index value) 19 | (call-primitively set-contents! (pointer-add vec index) value)) 20 | 21 | (define (cons x y) 22 | (let ((p (make-vector 2 0))) 23 | (vector-set! p 0 x) 24 | (vector-set! p 1 y) 25 | p)) 26 | 27 | (define (car p) 28 | (vector-ref p 0)) 29 | 30 | (define (cdr p) 31 | (vector-ref p 1)) 32 | 33 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/coerce.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define-local-syntax (define-primitive id nargs) 4 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 5 | `(define (,id . ,args) 6 | (call-primitively ,id . ,args)))) 7 | 8 | (define-primitive make-byte-vector 1) 9 | (define-primitive null-pointer? 1) 10 | 11 | (define (byte-vector-ref vec index) 12 | (call-primitively byte-contents-int8 (pointer-add vec index))) 13 | 14 | (define (byte-vector-set! vec index value) 15 | (call-primitively byte-set-contents-int8! (pointer-add vec index) value)) 16 | 17 | (define (pointer->integer x) 18 | (call-primitively coerce x '(pointer int8) 'int32)) 19 | 20 | (define (integer->pointer x) 21 | (call-primitively coerce x 'int32 '(pointer int8))) 22 | 23 | (define (test) 24 | (let ((bv (make-byte-vector 10))) 25 | (if (null-pointer? bv) 26 | 100 27 | (pointer->integer bv)))) -------------------------------------------------------------------------------- /scheme/debug/mini-start.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Start up a system that has reified packages. 5 | ; COMMAND-PROCESSOR might be either the miniature one or the real one. 6 | 7 | (define (start structs-thunk) 8 | (usual-resumer 9 | (lambda (arg) 10 | (initialize-interaction-environment! (structs-thunk)) 11 | (command-processor #f arg)))) 12 | 13 | (define (initialize-interaction-environment! structs) 14 | (let ((scheme (cdr (assq 'scheme structs)))) 15 | (let ((tower (delay (cons eval (scheme-report-environment 5))))) 16 | (set-interaction-environment! 17 | (make-simple-package (map cdr structs) #t tower 'interaction)) 18 | (set-scheme-report-environment! 19 | 5 20 | (make-simple-package (list scheme) #t tower 'r5rs))))) 21 | -------------------------------------------------------------------------------- /scheme/debug/test-generic.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define g-methods (make-method-table 'g)) 6 | 7 | (define g (make-generic g-methods)) 8 | 9 | (define foo-family (make-family 'foo 1)) 10 | 11 | (define-method g-methods foo-family 12 | (lambda (x) 13 | (if (even? x) 14 | 'win 15 | (fail)))) 16 | 17 | (define bar-family (make-family 'bar 2)) ;More specific 18 | 19 | (define-method g-methods bar-family 20 | (lambda (x) 21 | (case x 22 | ((1 3 5) 'ok) 23 | (else (fail))))) 24 | 25 | (define-method g-methods (make-family 'baz 2) ;Same priority as bar-family 26 | (lambda (x) 27 | (case x 28 | ((3) 'great) 29 | (else (fail))))) 30 | 31 | ; (g 0) => 'win 32 | ; (g 1) => 'ok 33 | ; (g 3) => 'great 34 | ; (g 9) => error 35 | 36 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/letrec.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (t1) 3 | (let loop ((x 1)) 4 | (if (g x) 5 | (loop (h x)) 6 | x))) 7 | 8 | (define (t2) 9 | (let loop ((x 1)) 10 | (if (g x) x y))) 11 | 12 | (define (t3) 13 | (letrec ((loop (lambda (x) 14 | (if #t x (loop x))))) 15 | (loop 4))) 16 | 17 | (define (t4) 18 | (letrec ((loop (lambda (x) 19 | (if #t x (loop x)))) 20 | (loop2 (lambda (x) 21 | (if x x (loop2 x))))) 22 | (loop 4))) 23 | 24 | (define (t5) 25 | (letrec ((loop (lambda (x) 26 | (if #t x (loop x)))) 27 | (loop2 (lambda (x) 28 | (if x x (loop2 x))))) 29 | (g (loop 4) (loop2 5)))) 30 | 31 | (define (t6 y) 32 | (letrec ((loop (if y 33 | (lambda (x) 5) 34 | (lambda (x) 6)))) 35 | (loop 4))) 36 | 37 | (define (t7 y) 38 | (letrec ((loop (if y 39 | (lambda (x) 5) 40 | (lambda (x) (loop 6))))) 41 | (loop 4))) 42 | 43 | -------------------------------------------------------------------------------- /scheme/bcomp/config.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; For DEFINE-STRUCTURE macro 6 | 7 | (define (make-a-package opens-thunk accesses-thunk tower 8 | dir clauses name) 9 | (make-package opens-thunk accesses-thunk 10 | #t ;unstable 11 | tower 12 | dir 13 | clauses 14 | #f 15 | name)) 16 | 17 | (define (loser . rest) 18 | (error "init-defpackage! neglected")) 19 | 20 | (define interface-of structure-interface) 21 | 22 | (define *verify-later!* (lambda (thunk) #f)) 23 | 24 | (define (verify-later! thunk) 25 | (*verify-later!* thunk)) 26 | 27 | (define (set-verify-later! proc) 28 | (set! *verify-later!* proc)) 29 | 30 | (define (note-name! thing name) 31 | (cond ((interface? thing) 32 | (note-interface-name! thing name)) 33 | ((structure? thing) 34 | (note-structure-name! thing name))) 35 | thing) 36 | -------------------------------------------------------------------------------- /scheme/rts/session.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | ; Session data 4 | 5 | ; The initializers are saved in images. 6 | 7 | (define *session-data-initializers* '()) 8 | 9 | (define (make-session-data-slot! init) 10 | (let ((slot (length *session-data-initializers*))) 11 | (set! *session-data-initializers* (cons init *session-data-initializers*)) 12 | (if (vector? (session-data)) 13 | (set-session-data! (list->vector 14 | (reverse 15 | (cons init 16 | (reverse (vector->list (session-data)))))))) 17 | slot)) 18 | 19 | (define (session-data-ref slot) 20 | (vector-ref (session-data) slot)) 21 | 22 | (define (session-data-set! slot value) 23 | (vector-set! (session-data) slot value)) 24 | 25 | (define (initialize-session-data!) 26 | (set-session-data! (list->vector (reverse *session-data-initializers*)))) 27 | -------------------------------------------------------------------------------- /c/scheme48vm.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #define SMALL_MULTIPLY(x,y) ((x) * (y)) 5 | 6 | #define bool char /* boolean type */ 7 | #define TRUE (0 == 0) 8 | #define FALSE (! TRUE) 9 | #define NO_ERRORS 0 /* extension to errno.h */ 10 | 11 | typedef long scheme_value; 12 | 13 | extern scheme_value extended_vm(long, scheme_value), 14 | lookup_external_name(char *, char *); 15 | 16 | #include "scheme48heap.h" 17 | #include "event.h" 18 | #include "fd-io.h" 19 | 20 | 21 | /* 22 | * The following are hand-written macro versions of procedures 23 | * in scheme48heap.c. 24 | */ 25 | 26 | extern char *ShpS, 27 | *SlimitS; 28 | 29 | #define AVAILABLEp(cells) (ShpS + ((cells)<<2) < SlimitS) 30 | 31 | 32 | static char *HHallocate_temp; 33 | 34 | #define ALLOCATE_SPACE(type, len) \ 35 | (HHallocate_temp = ShpS, \ 36 | ShpS += ((len)+3) & ~3, \ 37 | HHallocate_temp) 38 | 39 | 40 | #define WRITE_BARRIER(address, value) ((void)0) 41 | -------------------------------------------------------------------------------- /scheme/alt/fluid.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Fluid variables 6 | 7 | (define (make-fluid val) 8 | (vector ' val)) 9 | 10 | (define (fluid f) (vector-ref f 1)) 11 | 12 | (define (set-fluid! f val) 13 | (vector-set! f 1 val)) 14 | 15 | (define (let-fluid f val thunk) 16 | (let ((swap (lambda () (let ((temp (fluid f))) 17 | (set-fluid! f val) 18 | (set! val temp))))) 19 | (dynamic-wind swap thunk swap))) 20 | 21 | (define (let-fluids . args) ;Kind of gross 22 | (let loop ((args args) 23 | (swap (lambda () #f))) 24 | (if (null? (cdr args)) 25 | (dynamic-wind swap (car args) swap) 26 | (loop (cddr args) 27 | (let ((f (car args)) 28 | (val (cadr args))) 29 | (lambda () 30 | (swap) 31 | (let ((temp (fluid f))) 32 | (set-fluid! f val) 33 | (set! val temp)))))))) 34 | 35 | -------------------------------------------------------------------------------- /ps-compiler/compile-vm-no-gc.scm: -------------------------------------------------------------------------------- 1 | (config '(load "../scheme/vm/macro-package-defs.scm")) 2 | (load-package 'vm-architecture) 3 | (in 'forms '(run (set! *duplicate-lambda-size* 30))) 4 | (in 'simplify-let '(run (set! *duplicate-lambda-size* 15))) 5 | (in 'prescheme-compiler 6 | '(run (prescheme-compiler 7 | 'interpreter 8 | '("../scheme/vm/interfaces.scm" 9 | "../scheme/vm/ps-package-defs.scm" 10 | "../scheme/vm/package-defs.scm" 11 | "../scheme/vm/no-gc-package-defs.scm") 12 | 'scheme48-init 13 | "../scheme/vm/scheme48vm.c" 14 | '(header "#include \"scheme48vm.h\"") 15 | '(copy (fixnum-arithmetic quotient-carefully) 16 | (interpreter push-continuation-on-stack)) 17 | '(no-copy (interpreter interpret 18 | restart 19 | application-exception 20 | handle-interrupt 21 | uuo 22 | collect-saving-temp))))) 23 | ; '(shadow ((interpreter restart) 24 | ; (interpreter *val* *code-pointer*) 25 | ; (stack *stack* *env*)))))) 26 | -------------------------------------------------------------------------------- /scheme/alt/features-packages.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | ; The following several packages have Scheme-implementation-specific 7 | ; variants that are much better for one reason or another than 8 | ; the generic versions defined here. 9 | 10 | (define-structures ((signals signals-interface) 11 | (handle (export ignore-errors)) 12 | (features features-interface)) 13 | (open scheme-level-2) 14 | (files features)) 15 | 16 | (define-structure records records-interface 17 | (open scheme-level-2 signals) 18 | (files record)) 19 | 20 | (define-structure ascii (export ascii->char char->ascii) 21 | (open scheme-level-2 signals) 22 | (files ascii)) 23 | 24 | (define-structure bitwise bitwise-interface 25 | (open scheme-level-2 signals) 26 | (files bitwise)) 27 | 28 | (define-structure code-vectors code-vectors-interface 29 | (open scheme-level-1) 30 | (files code-vectors)) 31 | -------------------------------------------------------------------------------- /ps-compiler/compile-vm.scm: -------------------------------------------------------------------------------- 1 | (config '(load "../scheme/vm/macro-package-defs.scm")) 2 | (load-package 'vm-architecture) 3 | (in 'forms '(run (set! *duplicate-lambda-size* 30))) 4 | (in 'simplify-let '(run (set! *duplicate-lambda-size* 15))) 5 | (in 'prescheme-compiler 6 | '(run (prescheme-compiler 7 | '(interpreter heap-init) 8 | '("../scheme/vm/interfaces.scm" 9 | "../scheme/vm/ps-package-defs.scm" 10 | "../scheme/vm/package-defs.scm") 11 | 'scheme48-init 12 | "../scheme/vm/scheme48vm.c" 13 | '(header "#include \"scheme48vm.h\"") 14 | '(copy (heap walk-over-type-in-area) 15 | (fixnum-arithmetic quotient-carefully)) 16 | '(no-copy (interpreter interpret 17 | application-exception 18 | handle-interrupt 19 | uuo 20 | collect-saving-temp 21 | do-gc)) 22 | '(integrate (copy-next do-gc) 23 | (copy-object do-gc)) 24 | '(shadow ((interpreter do-gc) (heap *hp*)) 25 | ((interpreter restart) 26 | (interpreter *val* *code-pointer*) 27 | (stack *stack* *env*)))))) 28 | -------------------------------------------------------------------------------- /scheme/infix/packages.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Infix stuff 5 | 6 | (define-structure tokenizer (export make-tokenizer-table 7 | set-up-usual-tokenization! 8 | set-char-tokenization! 9 | tokenize) 10 | (open scheme records signals defpackage ascii) 11 | (access primitives) 12 | (files tokenize)) 13 | 14 | (define-structure pratt (export toplevel-parse 15 | parse 16 | make-operator 17 | make-lexer-table set-char-tokenization! 18 | lexer-ttab define-keyword define-punctuation 19 | prsmatch comma-operator delim-error erb-error 20 | if-operator 21 | then-operator else-operator parse-prefix 22 | parse-nary parse-infix 23 | parse-matchfix end-of-input-operator 24 | port->stream) 25 | (open scheme records signals tokenizer tables) 26 | (files pratt)) 27 | 28 | (define-structure sgol (export sgol-read sgol-repl) 29 | (open scheme signals pratt) 30 | (files sgol)) 31 | -------------------------------------------------------------------------------- /scheme/alt/low-packages.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Alternate implementations of the low-structures. 5 | ; Cf. low-structures-interface in ../packages.scm and ../alt-structures.scm. 6 | 7 | ; Most of the low-structures are assumed to be inherited or obtained 8 | ; elsewhere (probably from a running Scheme 48). This only defines 9 | ; structures that export privileged operations. 10 | 11 | (define-structure escapes escapes-interface 12 | (open scheme-level-2 define-record-types signals) 13 | (files escape)) 14 | 15 | (define-structures ((primitives primitives-interface) 16 | (primitives-internal (export maybe-handle-interrupt 17 | raise-exception 18 | get-exception-handler 19 | ?start))) 20 | (open scheme-level-2 21 | define-record-types 22 | bitwise ;Only for re-export 23 | features ;Only for re-export 24 | signals 25 | ;; templates -- unneeded now? 26 | ) 27 | (files primitives 28 | weak 29 | contin)) 30 | -------------------------------------------------------------------------------- /scheme/misc/ilength.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Integer-length, a la Common Lisp, written in portable Scheme. 6 | 7 | (define-syntax cons-stream 8 | (syntax-rules () 9 | ((cons-stream head tail) 10 | (cons head (delay tail))))) 11 | (define head car) 12 | (define (tail s) (force (cdr s))) 13 | 14 | (define integer-length 15 | (let () 16 | (define useful 17 | (let loop ((p 256) (n 4)) 18 | (cons-stream (cons p n) 19 | (loop (* p p) (* n 2))))) 20 | (define (recur n) 21 | (if (< n 16) 22 | (vector-ref '#(0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4) n) 23 | (let loop ((s useful) (prev 16)) 24 | (let ((z (head s))) 25 | (if (< n (car z)) 26 | (+ (cdr z) (recur (quotient n prev))) 27 | (loop (tail s) (car z))))))) 28 | (define (integer-length n) 29 | (if (exact? n) 30 | (if (< n 0) 31 | (recur (- -1 n)) 32 | (recur n)) 33 | (integer-length (inexact->exact n)))) 34 | integer-length)) 35 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/eval3.scm: -------------------------------------------------------------------------------- 1 | 2 | (define-local-syntax (define-primitive id nargs) 3 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 4 | `(define (,id . ,args) 5 | (call-primitively ,id . ,args)))) 6 | 7 | (define-primitive ashl 2) 8 | (define-primitive ashr 2) 9 | (define-primitive = 2) 10 | (define-primitive bitwise-and 2) 11 | 12 | (define (input-type pred coercer) ;Alonzo wins 13 | (lambda (f) (f pred coercer))) 14 | 15 | (define (input-type-predicate type) (type (lambda (x y) y x))) 16 | (define (input-type-coercion type) (type (lambda (x y) x y))) 17 | 18 | (define (no-coercion x) x) 19 | 20 | (define (odd? x) 21 | (= 1 (bitwise-and x 1))) 22 | 23 | (define (extract-odd x) 24 | (ashr x 1)) 25 | 26 | (define any-> (input-type (lambda (x) x #t) no-coercion)) 27 | (define odd-> (input-type odd? extract-odd)) 28 | 29 | (define (test x y) 30 | (if (and ((input-type-predicate any->) x) 31 | ((input-type-predicate odd->) y)) 32 | (let ((a ((input-type-coercion any->) x)) 33 | (b ((input-type-coercion odd->) y))) 34 | (+ a b)) 35 | x)) 36 | 37 | -------------------------------------------------------------------------------- /scheme/alt/pseudoscheme-record.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | (define make-record-type #'scheme-translator::make-record-type) 5 | (define record-constructor #'scheme-translator::record-constructor) 6 | (define record-accessor #'scheme-translator::record-accessor) 7 | (define record-modifier #'scheme-translator::record-modifier) 8 | (define record-predicate #'scheme-translator::record-predicate) 9 | (define define-record-discloser #'scheme-translator::define-record-discloser) 10 | 11 | (define (record-type? x) 12 | (lisp:if (scheme-translator::record-type-descriptor-p x) #t #f)) 13 | (define record-type-field-names #'scheme-translator::rtd-field-names) 14 | (define record-type-name #'scheme-translator::rtd-identification) 15 | 16 | ; Internal record things, for inspector or whatever 17 | (define disclose-record #'scheme-translator::disclose-record) 18 | (define record-type #'scheme-translator::record-type) 19 | (define (record? x) (lisp:if (scheme-translator::record-type x) #t #f)) 20 | 21 | -------------------------------------------------------------------------------- /scheme/bcomp/primop.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Primops. 5 | 6 | (define-record-type primop :primop 7 | (make-primop name type closed compilator) 8 | primop? 9 | (name primop-name) 10 | (type primop-type) 11 | (closed primop-closed) 12 | (compilator primop-compilator)) 13 | 14 | (define-record-discloser :primop 15 | (lambda (primop) 16 | `(primop ,(primop-name primop)))) 17 | 18 | (define primop-table (make-symbol-table)) 19 | 20 | ; This is used to add definitions of the primitives to a package. 21 | 22 | (define (walk-primops proc) 23 | (table-walk (lambda (name primop) 24 | (proc name (primop-type primop) primop)) 25 | primop-table)) 26 | 27 | (define (define-compiler-primitive name type compilator closed) 28 | (table-set! primop-table 29 | name 30 | (make-primop name (or type value-type) closed compilator))) 31 | 32 | (define (get-primop name) 33 | (or (table-ref primop-table name) 34 | (error "unknown compiler primitive" name))) 35 | -------------------------------------------------------------------------------- /scheme/debug/test.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; ,config ,load debug/test.scm 6 | 7 | (define-structure testing (export (test :syntax) lost?) 8 | (open scheme signals handle conditions) 9 | (begin 10 | 11 | (define *lost?* #f) 12 | (define (lost?) *lost?*) 13 | 14 | (define (run-test string compare want thunk) 15 | (let ((result 16 | (call-with-current-continuation 17 | (lambda (k) 18 | (with-handler (lambda (condition punt) 19 | (if (error? condition) 20 | (k condition) 21 | (punt))) 22 | thunk))))) 23 | (if (not (compare want result)) 24 | (begin (display "Test ") (write string) (display " failed.") (newline) 25 | (display "Wanted ") (write want) 26 | (display ", but got ") (write result) (display ".") 27 | (newline) 28 | (set! *lost?* #t))))) 29 | 30 | (define-syntax test 31 | (syntax-rules () 32 | ((test ?string ?compare ?want ?exp) 33 | (run-test ?string ?compare ?want (lambda () ?exp))))) 34 | 35 | )) 36 | -------------------------------------------------------------------------------- /scheme/rts/population.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | 7 | (define (make-population) 8 | (list ')) 9 | 10 | (define (add-to-population! x pop) 11 | (if (not x) (error "can't put #f in a population")) 12 | (if (not (weak-memq x (cdr pop))) 13 | (set-cdr! pop (cons (make-weak-pointer x) (cdr pop))))) 14 | 15 | (define (weak-memq x weaks) 16 | (if (null? weaks) 17 | #f 18 | (if (eq? x (weak-pointer-ref (car weaks))) 19 | weaks 20 | (weak-memq x (cdr weaks))))) 21 | 22 | (define (population-reduce cons nil pop) 23 | (do ((l (cdr pop) (cdr l)) 24 | (prev pop l) 25 | (m nil (let ((w (weak-pointer-ref (car l)))) 26 | (if w 27 | (cons w m) 28 | (begin (set-cdr! prev (cdr l)) 29 | m))))) 30 | ((null? l) m))) 31 | 32 | (define (population->list pop) 33 | (population-reduce cons '() pop)) 34 | 35 | (define (walk-population proc pop) 36 | (population-reduce (lambda (thing junk) (proc thing)) 37 | #f 38 | pop)) 39 | -------------------------------------------------------------------------------- /scheme/vm/s48-package-defs.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define-structures ((vm-utilities vm-utilities-interface)) 6 | (open prescheme) 7 | (files vm-utilities) 8 | (begin 9 | ; (define-syntax assert 10 | ; (lambda (exp rename compare) 11 | ; 0)) 12 | (define (assert x) 13 | (if (not x) 14 | (error "assertion failed"))) 15 | )) 16 | 17 | (define-structures ((external external-interface)) 18 | (open scheme) 19 | (for-syntax (open scheme signals)) ; for error 20 | (files external)) 21 | 22 | (define-structures ((channel-io channel-interface) 23 | (events event-interface)) 24 | (open scheme big-scheme ps-memory structure-refs ports) 25 | (access prescheme 26 | i/o) ; current-error-port 27 | (files s48-channel)) 28 | 29 | ; The number of usable bits in a small integer. 30 | 31 | (define-structures ((system-spec (export useful-bits-per-word))) 32 | (open prescheme) 33 | (begin 34 | (define useful-bits-per-word 30) ; in Scheme 48 35 | )) 36 | 37 | -------------------------------------------------------------------------------- /scheme/alt/escape.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | ; For an explanation, see comments in rts/low.scm. 7 | 8 | ; The debugger invokes EXTRACT-CONTINUATION on a "native" continuation 9 | ; as obtained by PRIMITIVE-CWCC in order to get a VM continuation. 10 | ; The distinction between native and VM continuations is useful when 11 | ; debugging a program running under a VM that's different from 12 | ; whatever machine is running the debugger. 13 | 14 | (define-record-type escape :escape 15 | (make-escape proc) 16 | (proc escape-procedure)) 17 | 18 | (define (with-continuation esc thunk) 19 | (if esc 20 | ((escape-procedure esc) thunk) 21 | (let ((answer (thunk))) 22 | (signal 'vm-return answer) ;#f means halt 23 | (call-error "halt" answer)))) 24 | 25 | (define (primitive-cwcc proc) 26 | (call-with-current-continuation 27 | (lambda (done) 28 | ((call-with-current-continuation 29 | (lambda (k) 30 | (call-with-values 31 | (lambda () 32 | (proc (make-escape k))) 33 | done))))))) 34 | -------------------------------------------------------------------------------- /ps-compiler/node/arch.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; These are all of the primitives that are known to the compiler. 6 | 7 | ; The enumeration is needed by the expander for LET-NODES so it ends up 8 | ; being loaded into two separate packages. 9 | 10 | (define-enumeration primop 11 | ( 12 | ; Nontrivial Primops 13 | call ; see below 14 | tail-call 15 | return 16 | jump 17 | throw 18 | 19 | unknown-call 20 | unknown-tail-call 21 | unknown-return 22 | 23 | dispatch ; (dispatch ... ) 24 | let ; (let . ) 25 | letrec1 ; (letrec1 (lambda (x v1 v2 ...) 26 | letrec2 ; (letrec2 x ...))) 27 | 28 | cell-set! 29 | global-set! 30 | 31 | undefined-effect ; (undefined-effect . ) 32 | 33 | ; Trivial Primops 34 | make-cell 35 | cell-ref 36 | global-ref 37 | 38 | ; Environment stuff, these are both trivial 39 | closure 40 | env-ref 41 | )) 42 | -------------------------------------------------------------------------------- /scheme/alt/locations.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Locations 6 | 7 | (define location-rtd 8 | (make-record-type 'location '(id defined? contents))) 9 | 10 | (define-record-discloser location-rtd 11 | (lambda (l) `(location ,(location-id l)))) 12 | 13 | (define make-undefined-location 14 | (let ((make (record-constructor location-rtd 15 | '(id defined? contents)))) 16 | (lambda (id) 17 | (make id #f '*empty*)))) 18 | 19 | (define location? (record-predicate location-rtd)) 20 | (define location-id (record-accessor location-rtd 'id)) 21 | (define set-location-id! (record-modifier location-rtd 'id)) 22 | (define location-defined? (record-accessor location-rtd 'defined?)) 23 | (define contents (record-accessor location-rtd 'contents)) 24 | 25 | (define set-defined?! (record-modifier location-rtd 'defined?)) 26 | 27 | (define (set-location-defined?! loc ?) 28 | (set-defined?! loc ?) 29 | (if (not ?) 30 | (set-contents! loc '*empty*))) 31 | 32 | (define set-contents! (record-modifier location-rtd 'contents)) 33 | -------------------------------------------------------------------------------- /scheme/misc/annotate.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | ; Derived from 7 | ; (lambda (x y) (cons (car x) (cdr x))) 8 | 9 | (define annotate-procedure 10 | (lap annotate-procedure () 11 | 0 (check-nargs= 2) 12 | 2 (make-env 2) 13 | 4 (local0 2) 14 | 6 (stored-object-ref closure 0) 15 | 9 (push) 16 | 10 (local0 2) 17 | 12 (stored-object-ref closure 1) 18 | (push) 19 | (local0 1) 20 | 15 (make-stored-object 3 closure) 21 | 18 (return))) 22 | 23 | ; Derived from 24 | ; (lambda (x) (if (< 2 (vector-length x)) (vector-ref x 2) #f)) 25 | 26 | (define procedure-annotation 27 | (lap procedure-anotation () 28 | 0 (check-nargs= 1) 29 | 2 (make-env 1) 30 | 4 (literal '2) 31 | 6 (push) 32 | 7 (local0 1) 33 | 9 (stored-object-length closure) 34 | 11 (<) 35 | 12 (jump-if-false (=> 23)) 36 | 15 (local0 1) 37 | 20 (stored-object-ref closure 2) 38 | 22 (return) 39 | 23 (false) 40 | 24 (return))) 41 | -------------------------------------------------------------------------------- /scheme/bcomp/read-form.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; The value of $NOTE-FILE-PACKAGE is called whenever a file is loaded into 5 | ; a package. env/debug.scm uses this to associate packages with files so 6 | ; that code stuffed to the REPL will be eval'ed in the correct package. 7 | ; 8 | ; Is there any point in having this be a fluid? 9 | 10 | (define $note-file-package 11 | (make-fluid (lambda (filename package) 12 | (values)))) 13 | 14 | (define (read-forms pathname package) 15 | (let* ((filename (namestring pathname #f *scheme-file-type*)) 16 | (truename (translate filename))) 17 | (call-with-input-file truename 18 | (lambda (port) 19 | ((fluid $note-file-package) filename package) 20 | (let ((o-port (current-noise-port))) 21 | (display truename o-port) 22 | (force-output o-port) 23 | (really-read-forms port)))))) 24 | 25 | (define (really-read-forms port) 26 | (let loop ((forms '())) 27 | (let ((form (read port))) 28 | (if (eof-object? form) 29 | (reverse forms) 30 | (loop (cons form forms)))))) 31 | 32 | 33 | -------------------------------------------------------------------------------- /scheme/vm/vm-utilities.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define (adjoin-bits high low k) 6 | (+ (shift-left high k) low)) 7 | 8 | (define (low-bits n k) 9 | (bitwise-and n (- (shift-left 1 k) 1))) 10 | 11 | (define high-bits arithmetic-shift-right) 12 | 13 | (define unsigned-high-bits logical-shift-right) 14 | 15 | (define (digit? ch) 16 | (let ((ch (char->ascii ch))) 17 | (and (>= ch (char->ascii #\0)) 18 | (<= ch (char->ascii #\9))))) 19 | 20 | (define (vector+length-fill! v length x) 21 | (do ((i 0 (+ i 1))) 22 | ((>= i length)) 23 | (vector-set! v i x))) 24 | 25 | (define (error? status) 26 | (not (eq? status (enum errors no-errors)))) 27 | 28 | (define (write-error-string string) 29 | (write-string string (current-error-port))) 30 | 31 | (define (write-error-integer integer) 32 | (write-integer integer (current-error-port))) 33 | 34 | (define (write-error-newline) 35 | (write-char #\newline (current-error-port))) 36 | 37 | (define (error-message string) 38 | (write-error-string string) 39 | (write-error-newline)) 40 | -------------------------------------------------------------------------------- /scheme/rts/template.scm: -------------------------------------------------------------------------------- 1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*- 2 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 3 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 4 | 5 | ; Somewhat redundant with vm/istruct.scm. Fix this some day. 6 | 7 | ; Templates 8 | ; Templates are made only by the compiler. 9 | 10 | ;(define make-template make-vector) 11 | 12 | ;(define (template? obj) 13 | ; (and (vector? obj) 14 | ; (>= (vector-length obj) template-overhead) 15 | ; (code-vector? (template-code obj)) 16 | ; )) 17 | 18 | ;(define template-length vector-length) 19 | ;(define template-ref vector-ref) 20 | ;(define template-set! vector-set!) 21 | 22 | (define template-overhead 3) ; Kali modification 23 | 24 | (define (template-code tem) (template-ref tem 0)) 25 | (define (template-info tem) (template-ref tem 1)) 26 | (define (template-id tem) (template-ref tem 2)) ; Kali code 27 | (define (set-template-code! tem cv) (template-set! tem 0 cv)) 28 | (define (set-template-info! tem info) (template-set! tem 1 info)) 29 | (define (set-template-id! tem id) (template-set! tem 2 id)) ; Kali code 30 | 31 | -------------------------------------------------------------------------------- /scheme/debug/linker.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define (link-simple-system filename resumer-exp . structs) 6 | (link-system structs (lambda () resumer-exp) filename)) 7 | 8 | (define (link-reified-system some filename make-resumer-exp . structs) 9 | (link-system (append structs (map cdr some)) 10 | (lambda () 11 | (display "Reifying") (newline) 12 | `(,make-resumer-exp 13 | (lambda () 14 | ,(reify-structures some 15 | (lambda (loc) loc) 16 | `(lambda (loc) loc))))) 17 | filename)) 18 | 19 | 20 | (define (link-system structs make-resumer filename) 21 | (for-each ensure-loaded structs) 22 | (let* ((p (make-simple-package structs eval #f)) 23 | (r (eval (make-resumer) p))) 24 | ;; (check-package p) 25 | r)) 26 | 27 | ;(define (check-package p) 28 | ; (let ((names (undefined-variables p))) 29 | ; (if (not (null? names)) 30 | ; (begin (display "Undefined: ") 31 | ; (write names) (newline))))) 32 | 33 | (define-syntax struct-list 34 | (syntax-rules () 35 | ((struct-list name ...) (list (cons 'name name) ...)))) 36 | -------------------------------------------------------------------------------- /scheme/env/init-defpackage.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; This file has to be loaded into the initial-image before any use of 6 | ; DEFINE-STRUCTURE. Compare with alt/init-defpackage.scm. 7 | 8 | ; The procedure given to DEFINE-REFLECTIVE-TOWER-MAKER is called when 9 | ; a DEFINE-STRUCTURE form is evaluated. 10 | 11 | (define-reflective-tower-maker 12 | (let ((environment-macro-eval 13 | (*structure-ref compiler-envs 'environment-macro-eval)) 14 | (make-simple-interface 15 | (*structure-ref interfaces 'make-simple-interface)) 16 | (env (interaction-environment))) 17 | (lambda (clauses id) 18 | (if (null? clauses) 19 | ;; (make-reflective-tower eval (list scheme) id) 20 | (environment-macro-eval (package->environment env)) 21 | (delay 22 | (let ((package (eval `(a-package ,(if id 23 | `(for-syntax ,id) 24 | '(for-syntax)) 25 | ,@clauses) 26 | env))) 27 | (ensure-loaded (make-structure package 28 | (lambda () 29 | (make-simple-interface #f '())) 30 | 'for-syntax)) 31 | (cons eval package))))))) 32 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/loop.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (xodd? 10) 4 | (xodd? 5) 5 | 6 | (define-local-syntax (define-primitive id nargs) 7 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 8 | `(define (,id . ,args) 9 | (call-primitively ,id . ,args)))) 10 | 11 | (define-primitive + 2) 12 | (define-primitive - 2) 13 | (define-primitive * 2) 14 | (define-primitive < 2) 15 | (define-primitive = 2) 16 | 17 | (define (xodd? x) 18 | (cond ((= 0 x) 19 | #f) 20 | ((< 100 x) ; efficiency hack 21 | (goto odd? (- x 100))) 22 | ((< 1000 x) ; efficiency hack 23 | (goto xodd? (- x 100))) 24 | (else 25 | (goto xeven? (- x 1))))) 26 | 27 | (define (xeven? x) 28 | (cond ((= 0 x) 29 | #t) 30 | ((< 100 x) ; efficiency hack 31 | (goto xeven? (- x 100))) 32 | (else 33 | (goto xodd? (- x 1))))) 34 | 35 | 36 | (define (odd? x) 37 | (cond ((= 0 x) 38 | #f) 39 | ((< 100 x) ; efficiency hack 40 | (goto odd? (- x 100))) 41 | (else 42 | (goto even? (- x 1))))) 43 | 44 | (define (even? x) 45 | (cond ((= 0 x) 46 | #t) 47 | ((< 100 x) ; efficiency hack 48 | (goto even? (- x 100))) 49 | (else 50 | (goto odd? (- x 1))))) 51 | 52 | 53 | -------------------------------------------------------------------------------- /scheme/rts/signal.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ;;;; Signalling conditions 6 | 7 | ; I don't like the term "signal," but that's the one Gnu Emacs Lisp, 8 | ; Common Lisp, and Dylan use, so it's probably best to stick with it. 9 | 10 | 11 | (define make-condition cons) 12 | 13 | (define (signal type . stuff) 14 | (signal-condition (make-condition type stuff))) 15 | 16 | ; Warn 17 | 18 | (define (warn message . irritants) 19 | (signal-condition (make-condition 'warning (cons message irritants)))) 20 | 21 | 22 | ; Syntax errors 23 | 24 | (define (syntax-error . rest) ; Must return a valid expression. 25 | (signal-condition (make-condition 'syntax-error rest)) 26 | ''syntax-error) 27 | 28 | 29 | ; "Call error" - this means that the condition's "stuff" (cdr) is of 30 | ; the form (message procedure . args), and should be displayed appropriately. 31 | ; Proceeding from such an error should return the value that the call 32 | ; to the procedure on the args should have returned. 33 | 34 | (define (call-error message proc . args) 35 | (signal-condition (make-condition 'call-error 36 | (cons message (cons proc args))))) 37 | -------------------------------------------------------------------------------- /scheme/rts/lize.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Simplest rational within an interval. Copied from IEEE P1178/D4 nimpl.tex. 6 | 7 | (define (rationalize x e) 8 | (let ((e (abs e))) 9 | (simplest-rational (- x e) (+ x e)))) 10 | 11 | (define (simplest-rational x y) 12 | (define (simplest-rational-internal x y) 13 | ;; assumes 0 < X < Y 14 | (let ((fx (floor x)) 15 | (fy (floor y))) 16 | (cond ((not (< fx x)) 17 | fx) 18 | ((= fx fy) 19 | (+ fx 20 | (/ 1 (simplest-rational-internal 21 | (/ 1 (- y fy)) 22 | (/ 1 (- x fx)))))) 23 | (else 24 | (+ 1 fx))))) 25 | ;; Do some juggling to satisfy preconditions of simplest-rational-internal. 26 | (cond ((not (< x y)) 27 | (if (rational? x) x (error "(rationalize 0)" x))) 28 | ((positive? x) 29 | (simplest-rational-internal x y)) 30 | ((negative? y) 31 | (- 0 (simplest-rational-internal (- 0 y) (- 0 x)))) 32 | (else 33 | (if (and (exact? x) (exact? y)) 34 | 0 35 | (exact->inexact 0))))) 36 | 37 | -------------------------------------------------------------------------------- /scheme/misc/load-static.scm: -------------------------------------------------------------------------------- 1 | ; -*- Mode: Scheme; -*- 2 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 3 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 4 | 5 | ; ,exec ,load misc/load-static.scm 6 | ; (do-it 100000 "debug/little.image" "debug/little-heap.c") 7 | 8 | (translate "=scheme48/" "./") 9 | 10 | (config 11 | (lambda () 12 | (load "vm/ps-interface.scm") 13 | (load "vm/interfaces.scm") 14 | (load "vm/package-defs.scm" "vm/s48-package-defs.scm"))) 15 | 16 | (load-package 'bigbit) 17 | ; The following is for struct's (for-syntax ...) clause 18 | ; (load-package 'destructuring) 19 | 20 | (load-package 'heap) 21 | (in 'heap 22 | (lambda () 23 | (run '(define (newspace-begin) *newspace-begin*)) 24 | (run '(define (heap-pointer) *hp*)) 25 | (structure 'heap-extra 26 | '(export newspace-begin 27 | heap-pointer 28 | header-a-units 29 | d-vector? 30 | stob-type)))) 31 | 32 | (config '(run (define-structure static (export do-it) 33 | (open scheme heap memory data stob struct 34 | heap-extra 35 | vm-architecture 36 | formats 37 | enumerated 38 | signals) 39 | (files (misc static))))) 40 | 41 | (load-package 'static) 42 | (user '(open static)) 43 | 44 | -------------------------------------------------------------------------------- /scheme/misc/require.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | (define-syntax require 7 | (syntax-rules (quote) 8 | ((require '(name1 name2 ...)) 9 | (*require '(name1 name2 ...))))) 10 | 11 | (define (*require interface-id) 12 | (let ((start-thunk 13 | (case (car interface-id) 14 | ((scheme-48) 15 | (let ((p (config-package))) 16 | (lambda () p))) 17 | ((scheme-library-1) 18 | (let* ((p (config-package)) 19 | (thunk 20 | (lambda () 21 | (environment-ref p 'scheme-library-1)))) 22 | (ensure-loaded (thunk)) 23 | (thunk))) 24 | (else 25 | (error "unrecognized interface identifier" interface-id))))) 26 | (package-open! (interaction-environment) 27 | (let loop ((names (cdr interface-id)) 28 | (thunk start-thunk)) 29 | (if (null? names) 30 | thunk 31 | (let ((new-thunk 32 | (lambda () 33 | (let ((source (thunk))) 34 | (if (package? source) 35 | (environment-ref source 36 | (car names)) 37 | (*structure-ref source 38 | (car names))))))) 39 | (ensure-loaded (new-thunk)) 40 | (loop (cdr names) 41 | new-thunk))))))) 42 | -------------------------------------------------------------------------------- /scheme/misc/mail.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | ; Mailboxes (to be used with the threads package) 7 | 8 | (define (make-mailbox) 9 | (vector (make-lock) (make-queue) (make-queue))) 10 | 11 | (define (mailbox-lock mbx) (vector-ref mbx 0)) 12 | (define (mailbox-messages mbx) (vector-ref mbx 1)) 13 | (define (mailbox-readers mbx) (vector-ref mbx 2)) 14 | 15 | (define (mailbox-empty? mbx) 16 | (queue-empty? (mailbox-readers mbx))) 17 | 18 | (define (mailbox-write mbx message) 19 | (with-lock (mailbox-lock mbx) 20 | (lambda () 21 | (if (queue-empty? (mailbox-readers mbx)) 22 | (enqueue! (mailbox-messages mbx) message) 23 | (condvar-set! (dequeue! (mailbox-readers mbx)) message))))) 24 | 25 | (define (mailbox-read mbx) 26 | ((with-lock (mailbox-lock mbx) 27 | (lambda () 28 | (if (queue-empty? (mailbox-messages mbx)) 29 | (let ((cv (make-condvar))) 30 | (enqueue! (mailbox-readers mbx) cv) 31 | ;; The condvar-ref *must* happen after lock is released, 32 | ;; otherwise deadlock will result. 33 | (lambda () (condvar-ref cv))) 34 | (let ((message (dequeue! (mailbox-messages mbx)))) 35 | (lambda () message))))))) 36 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/primop/io.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1994 Richard Kelsey. See file COPYING. 2 | 3 | 4 | ;(define-scheme-primop cast-to-long) 5 | 6 | (define-scheme-primop stdin type/input-port) 7 | (define-scheme-primop stdout type/output-port) 8 | (define-scheme-primop stderr type/output-port) 9 | 10 | (define-nonsimple-scheme-primop read-char io) 11 | (define-nonsimple-scheme-primop peek-char io) 12 | (define-nonsimple-scheme-primop read-integer io) 13 | 14 | (define type/status type/integer) 15 | 16 | (define-nonsimple-scheme-primop write-char io) 17 | 18 | (define-scheme-primop write-string io type/status) 19 | (define-scheme-primop write-integer io type/status) 20 | (define-scheme-primop force-output io type/status) 21 | 22 | (define-nonsimple-scheme-primop open-input-file) 23 | (define-nonsimple-scheme-primop open-output-file) 24 | 25 | (define-scheme-primop close-input-port io type/status) 26 | (define-scheme-primop close-output-port io type/status) 27 | 28 | (define-scheme-primop abort io type/unit) 29 | 30 | (define-nonsimple-scheme-primop error io) 31 | 32 | (define-scheme-primop error-string type/string) 33 | 34 | (define-scheme-primop call-external-value io type/integer) 35 | 36 | (define-nonsimple-scheme-primop read-block io) 37 | (define-scheme-primop write-block io type/status) 38 | 39 | -------------------------------------------------------------------------------- /scheme/misc/test-doodl.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; ((method () 1)) => 1 6 | ; ((method () 1) 2) => error 7 | 8 | ; ((method (x) 1) 2) => 1 9 | ; ((method ((x )) 1) 2) => error 10 | 11 | ; ((method ((x )) 1) 'foo) => 1 12 | ; ((method ((x )) (next-method)) 'foo) => error 13 | 14 | 15 | 16 | (define-generic-function elt ((s ))) 17 | 18 | (define-method elt ((x ) y) 19 | (vector-ref x y)) 20 | 21 | ; (elt '#(a b c) 1) => b 22 | 23 | (define-method elt ((x ) y) 24 | (string-ref x y)) 25 | 26 | (define-method elt ((x ) y) 27 | (list-ref x y)) 28 | 29 | 30 | ; Setters 31 | 32 | (define-generic-function (setter elt) 33 | (thing index new-value)) 34 | 35 | (define-method (setter elt) ((x ) i z) 36 | (vector-set! x i z)) 37 | 38 | ; (let ((v (vector 1 2 3))) (set (elt v 1) 'foo) v) => '#(1 foo 3) 39 | 40 | 41 | ; Classes 42 | 43 | (define-class () a b) 44 | 45 | ; (a (make )) => '*uninitialized* 46 | ; (let ((m (make ))) (set (a m) 'foo) (a m)) => 'foo 47 | 48 | (define-method initialize ((m ) z) 49 | (set (a m) z)) 50 | 51 | ; (a (make 3)) => 3 52 | 53 | 54 | -------------------------------------------------------------------------------- /scheme/rts/init.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; System entry and exit 5 | 6 | ; Entry point from OS executive. Procedures returned by USUAL-RESUMER 7 | ; are suitable for use as the second argument to WRITE-IMAGE. 8 | 9 | (define (usual-resumer entry-point) 10 | (lambda (resume-arg in out error) 11 | (initialize-rts in out error 12 | (lambda () 13 | (entry-point (vector->list resume-arg)))))) 14 | 15 | (define (initialize-rts in out error thunk) 16 | (initialize-session-data!) 17 | (initialize-dynamic-state!) 18 | (initialize-output-port-list!) 19 | (initialize-exceptions! current-error-port write-string 20 | (lambda () 21 | (initialize-interrupts! 22 | spawn-on-root 23 | (lambda () 24 | (initialize-i/o (input-channel->port in) 25 | (output-channel->port out) 26 | (output-channel->port error 0) ; zero-length buffer 27 | (lambda () 28 | (with-threads 29 | (lambda () 30 | (root-scheduler thunk 31 | 200 ; thread quantum, in msec 32 | 300)))))))))) ; port-flushing quantum 33 | 34 | ; Add the full/empty buffer handlers. 35 | 36 | (initialize-i/o-handlers! define-exception-handler signal-exception) 37 | -------------------------------------------------------------------------------- /scheme/debug/describe.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define (describe x) 6 | (if (and (stob? x) 7 | (< (stob-type x) least-b-vector-type)) 8 | (let ((tag (string-append (number->string x) ": ")) 9 | (len (bytes->cells (stob-length-in-bytes x)))) 10 | (do ((i -1 (+ i 1))) 11 | ((= i len)) 12 | (describe-1 (stob-ref x i) tag))) 13 | (describe-1 x ""))) 14 | 15 | 16 | 17 | (define (describe-1 x addr) 18 | (cond ((fixnum? x) (display " fixnum ") (write (extract-fixnum x))) 19 | ((header? x) 20 | (display addr) 21 | (if (immutable-header? x) 22 | (display " immutable")) 23 | (display " header ") 24 | (let ((type (header-type x))) 25 | (if (< type stob-count) 26 | (write (vector-ref stob type)) 27 | (write type))) 28 | (display " ") 29 | (write (header-length-in-bytes x))) 30 | ((immediate? x) 31 | (cond (else 32 | (display " immediate ") 33 | (let ((type (immediate-type x))) 34 | (if (< type imm-count) 35 | (write (vector-ref imm type)) 36 | (write type))) 37 | (display " ") 38 | (write (immediate-info x))))) 39 | ((stob? x) 40 | (display " stob ") (write x)) 41 | (else (display " ? ") (write x))) 42 | (newline)) 43 | -------------------------------------------------------------------------------- /ps-compiler/util/z-set.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Sets of integers implemented as integers. 6 | 7 | (define (make-empty-integer-set) 8 | 0) 9 | 10 | (define (add-to-integer-set set integer) 11 | (bitwise-ior set (arithmetic-shift 1 integer))) 12 | 13 | (define integer-set-chunk-size 24) 14 | (define word-mask (- (arithmetic-shift 1 integer-set-chunk-size) 1)) 15 | 16 | ; The nested loop reduces the amount of bignum arithmetic needed (and reduces 17 | ; the time by as much as a factor of 10). 18 | 19 | (define (map-over-integer-set proc set) 20 | (do ((set set (arithmetic-shift set (- integer-set-chunk-size))) 21 | (i 0 (+ i integer-set-chunk-size)) 22 | (l '() (do ((set (bitwise-and set word-mask) (arithmetic-shift set -1)) 23 | (j 0 (+ j 1)) 24 | (l l (if (odd? set) 25 | (cons (proc (+ i j)) l) 26 | l))) 27 | ((or (= 0 set) (>= j integer-set-chunk-size)) 28 | l)))) 29 | ((= 0 set) 30 | (reverse l)))) 31 | 32 | (define integer-set-and bitwise-and) 33 | (define integer-set-ior bitwise-ior) 34 | (define integer-set-not bitwise-not) 35 | 36 | (define (integer-set-subtract set1 set2) 37 | (bitwise-and set1 (bitwise-not set2))) 38 | 39 | (define integer-set-equal? =) -------------------------------------------------------------------------------- /scheme/alt/bitwise.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Bitwise operators written in vanilla Scheme. 5 | ; Written for clarity and simplicity, not for speed. 6 | 7 | ; No need to use these in Scheme 48 since Scheme 48's virtual machine 8 | ; provides fast machine-level implementations. 9 | 10 | 11 | (define (bitwise-not i) 12 | (- -1 i)) 13 | 14 | (define (bitwise-and x y) 15 | (cond ((= x 0) 0) 16 | ((= x -1) y) 17 | (else 18 | (+ (* (bitwise-and (arithmetic-shift x -1) 19 | (arithmetic-shift y -1)) 20 | 2) 21 | (* (modulo x 2) (modulo y 2)))))) 22 | 23 | (define (bitwise-ior x y) 24 | (bitwise-not (bitwise-and (bitwise-not x) 25 | (bitwise-not y)))) 26 | 27 | (define (bitwise-xor x y) 28 | (bitwise-and (bitwise-not (bitwise-and x y)) 29 | (bitwise-ior x y))) 30 | 31 | (define (bitwise-eqv x y) 32 | (bitwise-not (bitwise-xor x y))) 33 | 34 | 35 | (define (arithmetic-shift n m) 36 | (floor (* n (expt 2 m)))) 37 | 38 | 39 | (define (count-bits x) ; Count 1's in the positive 2's comp rep 40 | (let ((x (if (< x 0) (bitwise-not x) x))) 41 | (do ((x x (arithmetic-shift x 1)) 42 | (result 0 (+ result (modulo x 2)))) 43 | ((= x 0) result)))) 44 | 45 | ;(define (integer-length integer) ...) ;? 46 | -------------------------------------------------------------------------------- /scheme/debug/link-debug.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | 7 | ; Stuff for debugging new images: 8 | 9 | (define (ev form package) 10 | (invoke-template (compile-form form package) 11 | (package-uid package))) 12 | 13 | ; If desired, this definition of invoke-template can be replaced by 14 | ; something that starts up a different virtual machine. 15 | 16 | (define (invoke-template template env . args) 17 | (apply (make-closure template env) 18 | args)) 19 | 20 | ; Utility for tracking down uses of variables 21 | 22 | (define (who-uses name proc) 23 | (let recur ((tem (closure-template proc)) 24 | (path '())) 25 | (let loop ((i 0)) 26 | (if (< i (template-length tem)) 27 | (let ((thing (template-ref tem i)) 28 | (down (lambda (tem) 29 | (recur tem (cons (or (template-ref tem 1) i) path))))) 30 | (cond ((template? thing) 31 | (down thing)) 32 | ((location? thing) 33 | (if (eq? (location-name thing) name) 34 | (begin (write path) (newline)))) 35 | ((closure? thing) 36 | (down (closure-template thing)))) 37 | (loop (+ i 1))))))) 38 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/dispatch2.scm: -------------------------------------------------------------------------------- 1 | 2 | (define-local-syntax (define-primitive id nargs) 3 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 4 | `(define (,id . ,args) 5 | (call-primitively ,id . ,args)))) 6 | 7 | (define-primitive + 2) 8 | (define-primitive - 2) 9 | (define-primitive * 2) 10 | (define-primitive < 2) 11 | 12 | (define-primitive make-vector 2) 13 | (define-primitive pointer-add 2) 14 | (define-primitive contents 1) 15 | (define-primitive set-contents! 2) 16 | 17 | (define *current-input-port* 18 | (call-primitively stdin)) 19 | 20 | (define *current-output-port* 21 | (call-primitively stdout)) 22 | 23 | (define (current-input-port) 24 | *current-input-port*) 25 | 26 | (define (current-output-port) 27 | *current-output-port*) 28 | 29 | (define (vector-ref vec index) 30 | (contents (pointer-add vec index))) 31 | 32 | (define (vector-set! vec index value) 33 | (set-contents! (pointer-add vec index) value)) 34 | 35 | (define (default y) y) 36 | 37 | (define do-it (make-vector 5 default)) 38 | 39 | (define (add-entry i k) 40 | (vector-set! do-it i (lambda (x) (+ x k)))) 41 | 42 | (add-entry 0 1) 43 | ;(add-entry 1 1) 44 | (add-entry 2 3) 45 | (add-entry 3 4) 46 | (add-entry 4 4) 47 | 48 | (define (test x) 49 | ((vector-ref do-it x) 5)) 50 | 51 | (define (main) 52 | (write-number (test (read-number (current-input-port))) 53 | (current-output-port))) 54 | 55 | 56 | -------------------------------------------------------------------------------- /scheme/debug/wind-test.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | " 6 | The correct output looks something like this: 7 | 8 | wind-1 f: 1 9 | wind-2 f: 2 10 | before-throw-out f: 3 11 | unwind-2 f: 2 12 | unwind-1 f: 1 13 | after-throw-out f: top 14 | wind-1 f: 1 15 | wind-2 f: 2 16 | after-throw-in f: 3 17 | unwind-2 f: 2 18 | unwind-1 f: 1 19 | done f: top 20 | " 21 | 22 | (define (wind-test) 23 | (let* ((f (make-fluid 'top)) 24 | (report (lambda (foo) 25 | (write foo) 26 | (display " f: ") 27 | (write (fluid f)) 28 | (newline)))) 29 | ((call-with-current-continuation 30 | (lambda (k1) 31 | (let-fluid f 1 32 | (lambda () 33 | (dynamic-wind 34 | (lambda () (report 'wind-1)) 35 | (lambda () 36 | (let-fluid f 2 37 | (lambda () 38 | (dynamic-wind 39 | (lambda () (report 'wind-2)) 40 | (lambda () 41 | (let-fluid f 3 42 | (lambda () 43 | (report 'before-throw-out) 44 | (call-with-current-continuation 45 | (lambda (k2) 46 | (k1 (lambda () 47 | (report 'after-throw-out) 48 | (k2 #f))))) 49 | (report 'after-throw-in) 50 | (lambda () (report 'done))))) 51 | (lambda () (report 'unwind-2)))))) 52 | (lambda () (report 'unwind-1)))))))))) 53 | 54 | -------------------------------------------------------------------------------- /scheme/vm/ps-package-defs.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define-structures ((vm-utilities vm-utilities-interface)) 6 | (open prescheme) 7 | (files vm-utilities) 8 | (begin 9 | (define-syntax assert 10 | (lambda (exp rename compare) 11 | 0)) 12 | )) 13 | 14 | (define-structures ((external external-interface)) 15 | (open prescheme) 16 | (begin 17 | (define extended-vm 18 | (external "extended_vm" (=> (integer integer) integer))) 19 | (define lookup-external-name 20 | (external "lookup_external_name" (=> (address address) boolean))) 21 | (define schedule-interrupt 22 | (external "schedule_alarm_interrupt" (=> (integer) integer))) 23 | (define cheap-time 24 | (external "CHEAP_TIME" (=> () integer))) 25 | (define real-time 26 | (external "real_time" (=> () integer integer))) 27 | (define run-time 28 | (external "run_time" (=> () integer integer))))) 29 | 30 | (define-structures ((channel-io channel-interface) 31 | (events event-interface)) 32 | (open prescheme) 33 | (files ps-channel)) 34 | 35 | ; The number of usable bits in a small integer. 36 | 37 | (define-structures ((system-spec (export useful-bits-per-word))) 38 | (open prescheme) 39 | (begin 40 | (define useful-bits-per-word 32) ; when compiled 41 | )) 42 | 43 | -------------------------------------------------------------------------------- /scheme/debug/level-0.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Redefinitions of some usual Scheme things so as to make the new 6 | ; exception system kick in when it needs to. 7 | 8 | (define (number? n) 9 | (or ((structure-ref true-scheme number?) n) 10 | (extended-number? n))) 11 | 12 | ;(define (integer? n) 13 | ; (if ((structure-ref true-scheme number?) n) 14 | ; ((structure-ref true-scheme integer?) n) 15 | ; (and (extended-number? n) 16 | ; ... raise exception ...))) 17 | 18 | (define (+ x y) ((structure-ref true-scheme +) x y)) 19 | (define (* x y) ((structure-ref true-scheme *) x y)) 20 | (define (- x y) ((structure-ref true-scheme -) x y)) 21 | (define (/ x y) ((structure-ref true-scheme /) x y)) 22 | (define (= x y) ((structure-ref true-scheme =) x y)) 23 | (define (< x y) ((structure-ref true-scheme <) x y)) 24 | (define (make-vector x y) ((structure-ref true-scheme make-vector) x y)) 25 | (define (make-string x y) ((structure-ref true-scheme make-string) x y)) 26 | (define (apply x y) ((structure-ref true-scheme apply) x y)) 27 | 28 | (define (read-char x) ((structure-ref true-scheme read-char) x)) 29 | (define (peek-char x) ((structure-ref true-scheme peek-char) x)) 30 | (define (char-ready? x) ((structure-ref true-scheme char-ready?) x)) 31 | (define (write-char x y) ((structure-ref true-scheme write-char) x y)) 32 | -------------------------------------------------------------------------------- /scheme/rts/xprim.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Hairier exceptions & interrupts. 5 | ; Enable generic arithmetic, informative error messages, etc. 6 | 7 | ; Deal with optional arguments, etc. to primitives. 8 | ; This is not necessarily the cleanest way to do this, and certainly not 9 | ; the most efficient, but for the time being it's the most expedient. 10 | 11 | ; We don't want to depend on tables. But if we did, we might do this: 12 | ;(define (closure-hash closure) 13 | ; (let ((cv (vector-ref (closure-template closure) 0))) ;template-ref 14 | ; (do ((h 0 (+ h (code-vector-ref cv i))) 15 | ; (i (- (code-vector-length cv) 1) (- i 1))) 16 | ; ((< i 0) h)))) 17 | ;(define wna-handlers (make-table closure-hash)) 18 | 19 | ;(define-exception-handler (enum op check-nargs=) 20 | ; (lambda (opcode reason proc args) 21 | ; (let ((probe (assq proc *wna-handlers*))) 22 | ; (if probe 23 | ; ((cdr probe) args) 24 | ; (signal-exception opcode reason proc args))))) 25 | 26 | (define *wna-handlers* '()) 27 | 28 | (define (define-wna-handler proc handler) 29 | (set! *wna-handlers* (cons (cons proc handler) *wna-handlers*))) 30 | 31 | (define op/check-nargs= (enum op protocol)) ; temporary hack 32 | 33 | (define (wna-lose proc args) 34 | (signal-exception op/check-nargs= #f proc args)) ; lost our reason 35 | 36 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/string.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (xwrite-string string out) 4 | (let ((len (string-length string))) 5 | (do ((i 0 (+ i 1))) 6 | ((>= i len)) 7 | (write-char (string-ref string (- len (+ i 1))) out)) 8 | (newline out))) 9 | 10 | (define (write-string string out) 11 | (let ((len (string-length string))) 12 | (do ((i 0 (+ i 1))) 13 | ((>= i len)) 14 | (write-char (string-ref string i) out)) 15 | (newline out))) 16 | 17 | (define a-string "Hello sailor...") 18 | 19 | (define (test) 20 | (let* ((in (current-input-port)) 21 | (out (current-output-port)) 22 | (len (ashr (read-number in) 2)) 23 | (string (make-string len))) 24 | (let loop ((i 0)) 25 | (if (< i len) 26 | (ps-read-char in 27 | (lambda (ch) 28 | (string-set! string i ch) 29 | (loop (+ i 1))) 30 | (lambda () 31 | (unassigned))))) 32 | (write-string string out) 33 | (xwrite-string string out) 34 | (deallocate string) 35 | (write-string a-string out) 36 | (xwrite-string a-string out))) 37 | 38 | (define (read-number port) 39 | (let loop ((r 0)) 40 | (ps-read-char port 41 | (lambda (ch) 42 | (cond ((digit? ch) 43 | (loop (+ (- (char->ascii ch) (char->ascii #\0)) 44 | (* r 10)))) 45 | (else r))) 46 | (lambda () 0)))) 47 | 48 | (define (digit? ch) 49 | (let ((ch (char->ascii ch))) 50 | (and (>= ch (char->ascii #\0)) 51 | (<= ch (char->ascii #\9))))) 52 | 53 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/primop/c-record.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define-c-generator make-record #t 6 | (lambda (args) 7 | (bug "no eval method for MAKE-RECORD")) 8 | (lambda (call depth) 9 | (reconstruct-make-record call depth)) 10 | (lambda (call port indent) 11 | (let ((type (node-type call))) 12 | (write-c-coercion type port) 13 | (format port "malloc(sizeof(") 14 | (display-c-type (pointer-type-to type) #f port) 15 | (format port ") * ") 16 | (c-value (call-arg call 0) port) 17 | (format port ")")))) 18 | 19 | (define (reconstruct-make-record call depth) 20 | (let* ((args (call-exp-args call)) 21 | (arg-types (call-arg-types (cdr args) depth)) 22 | (record-type (quote-exp-value (car args))) 23 | (type (record-type-type record-type)) 24 | (maker-type (record-type-maker-type record-type))) 25 | (unify! maker-type (make-arrow-type arg-types type)) 26 | type)) 27 | 28 | (define-c-scheme-primop make-record 29 | 'allocate 30 | (lambda (call) 31 | (record-type-type (literal-value (node-ref call 0)))) 32 | default-simplifier) 33 | 34 | (define-scheme-primop record-ref 35 | 'read 36 | (lambda (call) 37 | (record-slot-type (literal-value (node-ref call 0)))) 38 | default-simplifier) 39 | 40 | (define-scheme-primop record-set! 41 | 'write 42 | (lambda (call) type/unit) 43 | default-simplifier) 44 | -------------------------------------------------------------------------------- /ps-compiler/param.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Parameterizing the compiler. 6 | 7 | (define lookup-primop 'unset-compiler-parameter) 8 | (define lookup-imported-variable 'unset-compiler-parameter) 9 | 10 | (define type/unknown 'unset-compiler-parameter) 11 | (define type-eq? 'unset-compiler-parameter) 12 | 13 | (define lambda-node-type 'unset-compiler-parameter) 14 | 15 | (define true-value 'unset-compiler-parameter) 16 | (define false-value 'unset-compiler-parameter) 17 | 18 | (define determine-lambda-protocol 'unset-compiler-parameter) 19 | (define determine-continuation-protocol 'unset-compiler-parameter) 20 | 21 | (define (set-compiler-parameter! name value) 22 | (case name 23 | ((lookup-primop) 24 | (set! lookup-primop value)) 25 | ((lookup-imported-variable) 26 | (set! lookup-imported-variable value)) 27 | ((type/unknown) 28 | (set! type/unknown value)) 29 | ((type-eq?) 30 | (set! type-eq? value)) 31 | ((lambda-node-type) 32 | (set! lambda-node-type value)) 33 | ((true-value) 34 | (set! true-value value)) 35 | ((false-value) 36 | (set! false-value value)) 37 | ((determine-lambda-protocol) 38 | (set! determine-lambda-protocol value)) 39 | ((determine-continuation-protocol) 40 | (set! determine-continuation-protocol value)) 41 | (else 42 | (error "unknown compiler parameter ~S ~S" name value)))) 43 | 44 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/dispatch.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (fact n) 3 | (let loop ((i n) (r 1)) 4 | (if (<= i 1) 5 | r 6 | (loop (- i 1) (* i r))))) 7 | 8 | (define (default y) y) 9 | 10 | (define do-it (make-vector 5)) 11 | 12 | (do ((i 0 (+ i 1))) 13 | ((>= i 5)) 14 | (vector-set! do-it i default)) 15 | 16 | (define (add-entry i k) 17 | (let ((f (fact k))) 18 | (vector-set! do-it i (lambda (x) (+ x f))))) 19 | 20 | (add-entry 0 1) 21 | ;(add-entry 1 1) 22 | (add-entry 2 3) 23 | (add-entry 3 4) 24 | (add-entry 4 4) 25 | 26 | (define (test x) 27 | ((vector-ref do-it x) 5)) 28 | 29 | (define (main) 30 | (write-number (test (read-number (current-input-port))) 31 | (current-output-port))) 32 | 33 | (define (digit? ch) 34 | (let ((ch (char->ascii ch))) 35 | (and (>= ch (char->ascii #\0)) 36 | (<= ch (char->ascii #\9))))) 37 | 38 | (define (read-number port) 39 | (let loop ((r 0)) 40 | (ps-read-char port 41 | (lambda (ch) 42 | (cond ((digit? ch) 43 | (loop (+ (- (char->ascii ch) (char->ascii #\0)) 44 | (* r 10)))) 45 | (else r))) 46 | (lambda () 0)))) 47 | 48 | (define (write-number x port) 49 | (really-write-number (cond ((< x 0) 50 | (write-char #\- port) 51 | (- 0 x)) 52 | (else 53 | x)) 54 | port) 55 | (newline port)) 56 | 57 | (define (really-write-number x port) 58 | (if (>= x 10) 59 | (really-write-number (quotient x 10) port)) 60 | (write-char (ascii->char (+ (remainder x 10) 61 | (char->ascii #\0))) 62 | port)) 63 | -------------------------------------------------------------------------------- /scheme/low-packages.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Things provided by the byte compiler / VM, together with a few 6 | ; things with rather sensitive definitions (low.scm). 7 | 8 | (define-structures ((scheme-level-0 scheme-level-0-interface) 9 | (primitives primitives-interface) 10 | (bitwise bitwise-interface) 11 | (closures closures-interface) 12 | (code-vectors code-vectors-interface) 13 | (write-images (export write-image)) ;for linker 14 | (source-file-names (export (%file-name% :syntax))) 15 | (loopholes (export (loophole :syntax))) 16 | (low-level low-level-interface) 17 | (escapes escapes-interface) 18 | (vm-exposure vm-exposure-interface) 19 | (ascii ascii-interface) 20 | (locations locations-interface) 21 | (channels channels-interface) 22 | (ports ports-interface) 23 | (signals signals-interface) 24 | (debug-messages (export debug-message)) 25 | (silly (export reverse-list->string)) 26 | (code-quote (export (code-quote :syntax))) 27 | (proxy-internals proxy-internals-interface) ; Kali code 28 | (address-space-internals ; Kali code 29 | address-space-internals-interface) ; Kali code 30 | (structure-refs (export (structure-ref :syntax)))) 31 | (define-all-operators) ; Primitive Scheme, in the LSC paper 32 | (usual-transforms and cond do let let* or) 33 | (files (rts low) 34 | (rts signal)) 35 | (optimize auto-integrate)) 36 | 37 | -------------------------------------------------------------------------------- /scheme/prescheme/package-defs.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1997 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | (define-structures ((prescheme prescheme-interface) 5 | (ps-memory ps-memory-interface) 6 | (memory-debug (export reinitialize-memory)) 7 | (ps-receive ps-receive-interface) 8 | (external-constants (export make-external-constant 9 | external-constant? 10 | external-constant-enum-name 11 | external-constant-name 12 | external-constant-c-string))) 13 | (open scheme code-vectors bitwise ascii primitives signals enumerated 14 | structure-refs 15 | define-record-types 16 | bigbit) ; make sure that bignum bitwise operations are loaded 17 | (access scheme) 18 | (optimize auto-integrate) 19 | (begin 20 | ; What we will get in C on many machines 21 | (define pre-scheme-integer-size 32)) 22 | (files ps-defenum prescheme memory)) 23 | 24 | ;(define-structure byte-vectors byte-vector-interface 25 | ; (open scheme code-vectors) 26 | ; (optimize auto-integrate) 27 | ; (files byte-vector)) 28 | ; 29 | ;(define-interface byte-vector-interface 30 | ; (export make-byte-vector 31 | ; byte-vector? 32 | ; byte-vector-ref byte-vector-set! 33 | ; signed-byte-vector-ref signed-byte-vector-set! 34 | ; byte-vector-ref32 byte-vector-set32! 35 | ; signed-byte-vector-ref32 signed-byte-vector-set32!)) 36 | ; 37 | ;(define-structure xmemory ps-memory-interface 38 | ; (open scheme byte-vectors signals enumerated bitwise) 39 | ; (files simple-memory)) -------------------------------------------------------------------------------- /scheme/bcomp/ddata.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Stuff moved from segment.scm 6/5/93 6 | ; Some of that stuff moved to state.scm 4/28/95 7 | 8 | ; Debug-data records are for communicating information from the 9 | ; compiler to various debugging tools. 10 | 11 | ; An environment map has the form 12 | ; #(pc-before pc-after #(name ...) (env-map ...)) 13 | ; where the two pc's delimit the region of code that executes in this 14 | ; environment. The names indicate which variables become bound at 15 | ; pc-before, and the list of env-maps is for inferior (deeper) 16 | ; environments. 17 | 18 | ; pc-in-parent gives the pc of a make-closure instruction in the code 19 | ; for this template's superior (outer) lambda-expression. 20 | 21 | ; Source is in the form of an a-list mapping pc's used in continuations 22 | ; to pairs of the form (i . expression), indicating that the continuation 23 | ; is returning the value of i'th subexpression in the source expression. 24 | 25 | (define-record-type debug-data :debug-data 26 | (make-debug-data uid name parent pc-in-parent env-maps source) 27 | debug-data? 28 | (uid debug-data-uid) 29 | (name debug-data-name) 30 | (parent debug-data-parent) 31 | (pc-in-parent debug-data-pc-in-parent) 32 | (env-maps debug-data-env-maps set-debug-data-env-maps!) 33 | (source debug-data-source set-debug-data-source!)) 34 | 35 | (define-record-discloser :debug-data 36 | (lambda (dd) 37 | (list 'debug-data (debug-data-uid dd) (debug-data-name dd)))) 38 | -------------------------------------------------------------------------------- /ps-compiler/load-ps-compiler.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; -*- Mode: Scheme; -*- 5 | 6 | ; To load the Pre-Scheme compiler into Scheme 48: 7 | ; ,exec ,load load-ps-compiler.scm 8 | ; It needs a larger than default sized heap. 4000000 is big enough to 9 | ; load the pre-scheme compiler but not big enough to compile the VM, 10 | ; 12000000 is enough to compile the VM. 11 | ; 12 | ; compile-vm.exec is an exec script to compile the Scheme 48 virtual machine. 13 | ; 14 | ; This requires that Pre-Scheme already be loaded. 15 | 16 | (user '(run (let ((minor-number (call-with-input-file 17 | "minor-version-number" 18 | (lambda (in) 19 | (read in))))) 20 | (newline) 21 | (newline) 22 | (display "Pre-Scheme compiler version 0.") 23 | (display minor-number) 24 | (newline) 25 | (display "Copyright (c) 1994 by Richard Kelsey.") 26 | (newline) 27 | (display "Copyright (c) 1997 by NEC Research Institute.") 28 | (newline) 29 | (display "Please report bugs to pre-scheme@martigny.ai.mit.edu.") 30 | (newline) 31 | (newline)))) 32 | 33 | 34 | (config) 35 | (structure 'reflective-tower-maker 36 | '(export-reflective-tower-maker)) 37 | (load "interfaces.scm") 38 | (load "package-defs.scm") 39 | (load "prescheme/interfaces.scm") 40 | (load "prescheme/package-defs.scm") 41 | (load-package 'let-nodes) ; used in FOR-SYNTAX 42 | (load-package 'simp-patterns) ; used in FOR-SYNTAX 43 | (load-package 'prescheme-compiler) 44 | -------------------------------------------------------------------------------- /scheme/env/list-interface.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; ,open interfaces packages meta-types sort syntactic 6 | ; ,config scheme 7 | 8 | (define (list-interface thing) 9 | (cond ((structure? thing) 10 | (list-interface-1 (structure-interface thing) 11 | (lambda (name) 12 | (let ((x (structure-lookup thing name #t))) 13 | (if (binding? x) 14 | (binding-type x) 15 | #f))))) 16 | ((interface? thing) 17 | (list-interface-1 thing (lambda (name) 18 | (interface-ref thing name)))) 19 | (else '?))) 20 | 21 | (define (list-interface-1 int lookup) 22 | (let ((l '())) 23 | (for-each-declaration (lambda (name type) 24 | (if (not (memq name l)) ;compound signatures... 25 | (set! l (cons name l)))) 26 | int) 27 | (for-each (lambda (name) 28 | (write name) 29 | (display (make-string 30 | (max 0 (- 25 (string-length 31 | (symbol->string name)))) 32 | #\space)) 33 | (write-char #\space) 34 | (write (careful-type->sexp (lookup name))) ;( ...) 35 | (newline)) 36 | (sort-list l (lambda (name1 name2) 37 | (stringstring name1) 38 | (symbol->string name2))))))) 39 | 40 | (define (careful-type->sexp thing) 41 | (cond ((not thing) 'undefined) 42 | ((or (symbol? thing) (null? thing) (number? thing)) 43 | thing) ;? 44 | ((pair? thing) ;e.g. (variable #{Type :value}) 45 | (cons (careful-type->sexp (car thing)) 46 | (careful-type->sexp (cdr thing)))) 47 | (else (type->sexp thing #t)))) 48 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/primitive.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1994 Richard Kelsey. See file COPYING. 2 | 3 | ; Eval'ing and type-checking code for primitives. 4 | 5 | (define-record-type primitive 6 | (id ; for debugging & making tables 7 | arg-predicates ; predicates for checking argument types 8 | eval ; evaluation function 9 | source ; close-compiled source (if any) 10 | expander ; convert call to one using primops 11 | expands-in-place? ; does the expander expand the definition in-line? 12 | inference-rule ; type inference rule 13 | ) 14 | ()) 15 | 16 | (define make-primitive primitive-maker) 17 | 18 | (define-record-discloser type/primitive 19 | (lambda (primitive) 20 | (list 'primitive (primitive-id primitive)))) 21 | 22 | (define (eval-primitive primitive args) 23 | (cond ((not (primitive? primitive)) 24 | (user-error "error while evaluating: ~A is not a procedure" primitive)) 25 | ((args-okay? args (primitive-arg-predicates primitive)) 26 | (apply (primitive-eval primitive) args)) 27 | (else 28 | (user-error "error while evaluating: type error ~A" 29 | (cons (primitive-id primitive) args))))) 30 | 31 | ; PREDICATES is a (possibly improper) list of predicates that should match 32 | ; ARGS. 33 | 34 | (define (args-okay? args predicates) 35 | (cond ((atom? predicates) 36 | (if predicates 37 | (every? predicates args) 38 | #t)) 39 | ((null? args) 40 | #f) 41 | ((car predicates) 42 | (and ((car predicates) (car args)) 43 | (args-okay? (cdr args) (cdr predicates)))) 44 | (else 45 | (args-okay? (cdr args) (cdr predicates))))) 46 | 47 | -------------------------------------------------------------------------------- /scheme/alt/features.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; This is file features.scm. 6 | ; Synchronize any changes with all the other *-features.scm files. 7 | 8 | ; These definitions should be quite portable to any Scheme implementation. 9 | ; Assumes Revised^5 Report Scheme, for EVAL and friends. 10 | 11 | 12 | ; SIGNALS 13 | 14 | (define (error message . irritants) 15 | (display-error-message "Error: " message irritants) 16 | (an-error-occurred-now-what?)) 17 | 18 | (define (warn message . irritants) 19 | (display-error-message "Warning: " message irritants)) 20 | 21 | (define (display-error-message heading message irritants) 22 | (display heading) 23 | (display message) 24 | (newline) 25 | (let ((spaces (list->string 26 | (map (lambda (c) #\space) (string->list heading))))) 27 | (for-each (lambda (irritant) 28 | (display spaces) 29 | (write irritant) 30 | (newline)) 31 | irritants))) 32 | 33 | ; Linker also needs SIGNAL, SYNTAX-ERROR, CALL-ERROR 34 | 35 | ; FEATURES 36 | 37 | (define (force-output port) #f) 38 | 39 | (define current-noise-port current-output-port) 40 | 41 | (define (string-hash s) 42 | (let ((n (string-length s))) 43 | (do ((i 0 (+ i 1)) 44 | (h 0 (+ h (char->ascii (string-ref s i))))) 45 | ((>= i n) h)))) 46 | 47 | (define (make-immutable! thing) #f) 48 | (define (immutable? thing) #f) 49 | (define (unspecific) (if #f #f)) 50 | 51 | 52 | ; BITWISE -- use alt/bitwise.scm (!) 53 | ; ACII -- use alt/ascii.scm 54 | ; CODE-VECTORS -- use alt/code-vectors.scm 55 | -------------------------------------------------------------------------------- /doc/src/latex-stuff.tex: -------------------------------------------------------------------------------- 1 | 2 | % Latex macros for The Scheme of Things 3 | 4 | \newcommand{\ev}{\hbox{$\longrightarrow$}} 5 | \newcommand{\asterisk}{\hbox{$\ast$}} 6 | \newcommand{\foo}{\discretionary{}{}{}} 7 | \newcommand{\var}[1]{\hbox{\em{}#1}} 8 | \newcommand{\piece}[1]{\subsubsection*{#1}} 9 | \newcommand{\syn}[1]{\hbox{$\langle$\rm#1$\rangle$}} 10 | \newcommand{\xform}{\hbox{$\Longrightarrow$}} 11 | \newcommand{\etc}{$\ldots$} 12 | \newcommand{\ok}{\discretionary{}{}{}} 13 | 14 | \newcommand{\separator}{ 15 | \vspace{1ex} 16 | \begin{center} 17 | \noindent \asterisk\hspace{1em}\asterisk\hspace{1em}\asterisk 18 | \end{center} 19 | \vspace{1ex}} 20 | 21 | 22 | % ----------------------------------------------------------------------------- 23 | %% doframeit draws a box around it argument by manipulating boxes. It 24 | %% is used in the frame environments. 25 | %% 26 | %% Rene' Seindal (seindal@diku.dk) Fri Feb 12 16:03:07 1988 27 | %% added \fboxrule and \fboxsep to \doframeit 28 | 29 | \def\doframeit#1{\vbox{% 30 | \hrule height\fboxrule 31 | \hbox{% 32 | \vrule width\fboxrule \kern\fboxsep 33 | \vbox{\kern\fboxsep #1\kern\fboxsep }% 34 | \kern\fboxsep \vrule width\fboxrule }% 35 | \hrule height\fboxrule }} 36 | 37 | %% The frameit and Frameit environments formats text within a single 38 | %% Anything can be framed, including verbatim text. 39 | 40 | \def\frameit{\smallskip \advance \linewidth by -7.5pt \setbox0=\vbox \bgroup 41 | \strut \ignorespaces } 42 | 43 | \def\endframeit{\ifhmode \par \nointerlineskip \fi \egroup 44 | \doframeit{\box0}} 45 | % ----------------------------------------------------------------------------- 46 | -------------------------------------------------------------------------------- /scheme/rts/sleep.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1997 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Sleeping for N milliseconds. 5 | 6 | (define (sleep n) 7 | (let ((queue (make-thread-queue))) ; only one entry, but it must be a queue 8 | (disable-interrupts!) 9 | (enqueue-thread! queue (current-thread)) 10 | (set! *dozers* 11 | (insert (cons (+ (real-time) n) queue) 12 | *dozers* 13 | (lambda (frob1 frob2) 14 | (< (car frob1) (car frob2))))) 15 | (block))) 16 | 17 | (define *dozers* '()) ; List of (wakeup-time . queue) 18 | 19 | (define (insert x l <) 20 | (cond ((null? l) (list x)) 21 | ((< x (car l)) (cons x l)) 22 | (else (cons (car l) (insert x (cdr l) <))))) 23 | 24 | ; Called by root scheduler, so won't be interrupted. 25 | ; This returns two values, a boolean that indicates if any threads were 26 | ; woken and the time until the next sleeper wakes. We have to check for 27 | ; threads that have been started for some other reason. 28 | 29 | (define (wake-some-threads) 30 | (if (null? *dozers*) 31 | (values #f #f) 32 | (let ((time (real-time))) 33 | (let loop ((dozers *dozers*) (woke? #f)) 34 | (if (null? dozers) 35 | (begin 36 | (set! *dozers* '()) 37 | (values woke? #f)) 38 | (let ((next (car dozers))) 39 | (cond ((thread-queue-empty? (cdr next)) 40 | (loop (cdr dozers) woke?)) 41 | ((< time (car next)) 42 | (set! *dozers* dozers) 43 | (values woke? (- (car next) time))) 44 | (else 45 | (make-ready (dequeue-thread! (cdr next))) 46 | (loop (cdr dozers) #t))))))))) 47 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/package-defs.scm: -------------------------------------------------------------------------------- 1 | 2 | (define-structures ((fact (export *one* fact all))) 3 | (open prescheme) 4 | (files fact)) 5 | 6 | (define-structures ((list (export test))) 7 | (open prescheme ps-memory) 8 | (files list)) 9 | 10 | (define-structures ((dispatch (export main))) 11 | (open prescheme) 12 | (files dispatch)) 13 | 14 | (define-structures ((vector (export test))) 15 | (open prescheme) 16 | (files vector)) 17 | 18 | (define-structures ((string (export test))) 19 | (open prescheme) 20 | (files string)) 21 | 22 | (define-structures ((goto (export test odd?))) 23 | (open prescheme) 24 | (files goto)) 25 | 26 | (define-structures ((external (export test))) 27 | (open prescheme) 28 | (files external)) 29 | 30 | (define-structures ((eval (export f4))) 31 | (open prescheme) 32 | (files eval)) 33 | 34 | (define-structures ((memory (export test))) 35 | (open prescheme) 36 | (files memory)) 37 | 38 | (define-structures ((poly (export test))) 39 | (open prescheme) 40 | (files poly)) 41 | 42 | (define-structures ((select (export test))) 43 | (open prescheme) 44 | (files select)) 45 | 46 | (define-structures ((hoist (export test))) 47 | (open prescheme) 48 | (files hoist)) 49 | 50 | (define-structures ((record (export init cons member? reverse!))) 51 | (open prescheme ps-record-types) 52 | (files record)) 53 | 54 | (define-structures ((buffer (export port->stream stream-read-char))) 55 | (open prescheme) 56 | (files buffer)) 57 | 58 | (define-structures ((values (export test))) 59 | (open prescheme) 60 | (files values)) 61 | 62 | (define-structures ((write (export test))) 63 | (open prescheme) 64 | (files write)) 65 | 66 | -------------------------------------------------------------------------------- /c/prescheme.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include "io.h" 3 | 4 | #define PS_READ_CHAR(PORT,RESULT,EOFP,STATUS) \ 5 | { \ 6 | FILE * TTport = PORT; \ 7 | int TTchar; \ 8 | if (EOF == (TTchar = getc(TTport))) \ 9 | RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==1);\ 10 | else { \ 11 | RESULT = TTchar; \ 12 | EOFP = 0; \ 13 | STATUS = 0; } \ 14 | } 15 | 16 | #define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS) \ 17 | { \ 18 | FILE * TTport = PORT; \ 19 | int TTchar; \ 20 | if (EOF == (TTchar = getc(TTport))) \ 21 | RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==0);\ 22 | else { \ 23 | RESULT = TTchar; \ 24 | ungetc(RESULT, TTport); \ 25 | EOFP = 0; \ 26 | STATUS = 0; } \ 27 | } 28 | 29 | #define PS_READ_INTEGER(PORT,RESULT,EOFP,STATUS) \ 30 | RESULT = ps_read_integer(PORT,&EOFP,&STATUS); 31 | 32 | #define PS_WRITE_CHAR(CHAR,PORT,STATUS) \ 33 | { \ 34 | FILE * TTport = PORT; \ 35 | char TTchar = CHAR; \ 36 | if (EOF == putc(TTchar,TTport)) \ 37 | STATUS = ps_write_char(TTchar,TTport); \ 38 | else { \ 39 | STATUS = 0; } \ 40 | } 41 | 42 | 43 | /* C shifts may not work if the amount is greater than the machine word size */ 44 | /* Patched by JAR 6/6/93 */ 45 | 46 | #define PS_SHIFT_RIGHT(X,Y,RESULT) \ 47 | { \ 48 | long TTx = X, TTy = Y; \ 49 | RESULT = TTy >= 32 ? (TTx < 0 ? -1 : 0) : TTx >> TTy; \ 50 | } 51 | 52 | #define PS_SHIFT_LEFT(X,Y,RESULT) \ 53 | { \ 54 | long TTy = Y; \ 55 | RESULT = TTy >= 32 ? 0 : X << TTy; \ 56 | } 57 | 58 | extern long TTreturn_value, TTrun_machine(); 59 | 60 | -------------------------------------------------------------------------------- /scheme/big/compose-cont.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | 7 | (define (compose-continuation proc cont) 8 | (primitive-cwcc 9 | (lambda (k) 10 | (with-continuation cont ;(if cont cont null-continuation) 11 | (lambda () 12 | (proc (primitive-cwcc 13 | (lambda (k2) (with-continuation k (lambda () k2)))))))))) 14 | 15 | 16 | ; Old definition that relies on details of VM architecture: 17 | 18 | ;(define null-continuation #f) 19 | 20 | ;(define null-continuation (make-continuation 4 #f)) ;temp kludge 21 | ;(continuation-set! null-continuation 1 0) 22 | ;(continuation-set! null-continuation 2 23 | ; ;; op/trap = 140 24 | ; (segment-data->template (make-code-vector 1 140) #f '())) 25 | 26 | ;(put 'primitive-cwcc 'scheme-indent-hook 0) 27 | ;(put 'with-continuation 'scheme-indent-hook 1) 28 | 29 | ;(define compose-continuation 30 | ; (let ((tem 31 | ; (let ((cv (make-code-vector 6 0))) 32 | ; (code-vector-set! cv 0 op/push) ;push return value 33 | ; (code-vector-set! cv 1 op/local) ;fetch procedure 34 | ; (code-vector-set! cv 3 1) ;over = 1 35 | ; (code-vector-set! cv 4 op/call) 36 | ; (code-vector-set! cv 5 1) ;one argument 37 | ; (segment-data->template cv 0 '())))) 38 | ; (lambda (proc parent-cont) 39 | ; (let ((cont (make-continuation 4 #f))) 40 | ; (continuation-set! cont 0 parent-cont) 41 | ; (continuation-set! cont 1 0) ;pc 42 | ; (continuation-set! cont 2 tem) ;template 43 | ; (continuation-set! cont 3 (vector #f proc)) ;environment 44 | ; cont)))) 45 | 46 | -------------------------------------------------------------------------------- /scheme/misc/pipe.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Scheme analogues of Posix popen() and pclose() library calls. 5 | 6 | (define (call-with-mumble-pipe input?) 7 | (lambda (command proc) 8 | (call-with-values pipe 9 | (lambda (pipe-for-read pipe-for-write) 10 | (let ((winner (if input? pipe-for-read pipe-for-write)) 11 | (loser (if input? pipe-for-write pipe-for-read)) 12 | (pid (fork))) 13 | (if (= pid 0) 14 | (dynamic-wind 15 | (lambda () #f) 16 | (lambda () 17 | (close winner) 18 | (let ((foo (if input? 1 0))) 19 | (close foo) 20 | (if (not (= (dup loser) foo)) 21 | (error "dup lost" loser foo))) 22 | (execv "/bin/sh" 23 | (vector "sh" "-c" command))) 24 | (lambda () (exit 1)))) 25 | ;; (write `(pid = ,pid)) (newline) 26 | (close loser) 27 | (let* ((channel (open-channel winner 28 | (if input? 29 | (enum open-channel-option 30 | raw-input-channel) 31 | (enum open-channel-option 32 | raw-output-channel)))) 33 | (port (if input? 34 | (input-channel->port channel 1024) 35 | (output-channel->port channel 1024)))) 36 | (call-with-values (lambda () (proc port)) 37 | (lambda vals 38 | (if input? 39 | (close-input-port port) 40 | (close-output-port port)) 41 | ;; (display "Waiting.") (newline) 42 | (call-with-values (lambda () (waitpid pid 0)) 43 | (lambda (pid status) 44 | ;; (write `(status = ,status)) (newline) 45 | (apply values vals))))))))))) 46 | 47 | (define call-with-input-pipe 48 | (call-with-mumble-pipe #t)) 49 | 50 | (define call-with-output-pipe 51 | (call-with-mumble-pipe #f)) 52 | 53 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/unused/data.txt: -------------------------------------------------------------------------------- 1 | 2 | (define-data-type list 3 | (null? null) 4 | (pair? 5 | (cons car cdr) 6 | (car type car set-car!) 7 | (cdr pair cdr set-cdr!))) 8 | 9 | => 10 | 11 | (define null 0) 12 | cons etc. as before 13 | 14 | Type as before, except that LIST is defined to be a datatype 15 | that includes NULL and PAIRs. NULL and PAIRs are defined to 16 | be subtypes of LISTs. How do pairs and null get injected into 17 | lists? 18 | 19 | What about polymorphism? Ignore it for now. 20 | 21 | Note that setters have a problem with destructuring - they don't work. 22 | 23 | (if (bar? baz) 24 | ... 25 | ...) 26 | 27 | Need temporary type bindings, a la LET. Env and type env? 28 | Have to do shallow binding, the infer code doesn't use environments. 29 | 30 | Hacks like 31 | 32 | (if (bar? baz) 33 | (error ...)) 34 | ... baz is not a bar ... 35 | 36 | won't work. 37 | 38 | ---------------- 39 | 40 | New plan. Use functions for pattern matching, with a suitable macro. 41 | 42 | (define-data-type list delistify match-list 43 | (null? null) 44 | (pair? 45 | (cons car cdr) 46 | (car type car set-car!) 47 | (cdr pair cdr set-cdr!))) 48 | 49 | Defines null as 0 and pairs as before. 50 | NULL? and PAIR? are only available at load time. There is also a 51 | deconstructor DELISTIFY: [b list, [] -> a , [b, b list] -> a] -> a 52 | 53 | (define (map f l) 54 | (delistify l 55 | (lambda () 56 | null) 57 | (lambda (car cdr) 58 | (cons (f car) (map f cdr))))) 59 | 60 | Or, with syntax, 61 | 62 | (define (map f l) 63 | (match-list l 64 | ((null) 65 | null) 66 | ((cons car cdr) 67 | (cons (f car) (map f cdr))))) 68 | 69 | This requires no change at all for the type checker. Hee Wack! 70 | 71 | 72 | 73 | 74 | -------------------------------------------------------------------------------- /scheme/bcomp/for-reify.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Things used by the expression returned by REIFY-STRUCTURES. 5 | ; Cf. link/reify.scm. 6 | 7 | (define (operator name type-exp) 8 | (get-operator name (sexp->type type-exp #t))) 9 | 10 | (define (primop name) 11 | (get-primop name)) 12 | 13 | (define (simple-interface names types) 14 | (make-simple-interface #f 15 | (map (lambda (name type) 16 | (list name (sexp->type type #t))) 17 | (vector->list names) 18 | (vector->list types)))) 19 | 20 | (define (package names locs get-location uid) 21 | (let ((end (vector-length names)) 22 | (p (make-package list list ;(lambda () '()) 23 | #f #f "" '() 24 | uid #f))) 25 | (set-package-loaded?! p #t) 26 | (do ((i 0 (+ i 1))) 27 | ((= i end)) 28 | (let* ((name (vector-ref names i)) 29 | (probe (package-lookup p name))) 30 | (if (not (binding? probe)) 31 | (package-define! p 32 | name 33 | usual-variable-type 34 | (get-location (vector-ref locs i)) 35 | #f)))) 36 | (make-table-immutable! (package-definitions p)) 37 | p)) 38 | 39 | (define (transform names+proc env type-exp source name) 40 | (make-transform names+proc env (sexp->type type-exp #t) source name)) 41 | 42 | (define (package-define-static! package name static) 43 | (package-define! package 44 | name 45 | (cond ((transform? static) 46 | (transform-type static)) 47 | ((primop? static) 48 | (primop-type static)) 49 | ((operator? static) 50 | (operator-type static)) 51 | ((structure? static) 52 | structure-type) 53 | (else 54 | (error "unknown kind of static value" static))) 55 | #f 56 | static)) 57 | -------------------------------------------------------------------------------- /scheme/debug/for-debugging.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; -------------------- 6 | 7 | ; Fake interrupt and exception system. 8 | ; This needs to be reconciled with alt/primitives.scm. 9 | 10 | (define (with-exceptions thunk) 11 | (with-handler 12 | (lambda (c punt) 13 | (cond ((and (exception? c) 14 | (procedure? (get-exception-handler))) 15 | (handle-exception-carefully c)) 16 | ((interrupt? c) 17 | (if (not (deal-with-interrupt c)) 18 | (punt))) 19 | ;; ((vm-return? c) 20 | ;; (vm-return (cadr c))) 21 | (else 22 | (punt)))) 23 | thunk)) 24 | 25 | (define (handle-exception-carefully c) 26 | (display "(Exception: ") (write c) (display ")") (newline) 27 | (noting-exceptional-context c 28 | (lambda () 29 | (raise-exception (exception-opcode c) 30 | (exception-arguments c))))) 31 | 32 | (define (noting-exceptional-context c thunk) 33 | (call-with-current-continuation 34 | (lambda (k) 35 | ;; Save for future inspection, just in case. 36 | (set! *exceptional-context* (cons c k)) 37 | (thunk)))) 38 | 39 | (define *exceptional-context* #f) 40 | 41 | (define (deal-with-interrupt c) 42 | (noting-exceptional-context c 43 | (lambda () 44 | (maybe-handle-interrupt 45 | (if (and (pair? (cdr c)) (integer? (cadr c))) 46 | (cadr c) 47 | (enum interrupt keyboard)))))) 48 | 49 | ; (define (poll-for-interrupts) ...) 50 | 51 | 52 | ; Get the whole thing started 53 | 54 | (define (?start-with-exceptions entry-point arg) 55 | (with-exceptions 56 | (lambda () 57 | (?start entry-point arg)))) 58 | 59 | (define (in struct form) 60 | (eval form (structure-package struct))) 61 | -------------------------------------------------------------------------------- /scheme/alt/jar-defrecord.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; This is JAR's define-record-type, which doesn't resemble Richard's. 6 | 7 | ; There's no implicit name concatenation, so it can be defined 8 | ; entirely using syntax-rules. Example: 9 | ; (define-record-type foo :foo 10 | ; (make-foo x y) 11 | ; foo? - predicate name is optional 12 | ; (x foo-x) 13 | ; (y foo-y) 14 | ; (z foo-z set-foo-z!)) 15 | 16 | (define-syntax define-record-type 17 | (syntax-rules () 18 | ((define-record-type ?id ?type 19 | (?constructor ?arg ...) 20 | (?field . ?field-stuff) 21 | ...) 22 | (begin (define ?type (make-record-type '?id '(?field ...))) 23 | (define ?constructor (record-constructor ?type '(?arg ...))) 24 | (define-accessors ?type (?field . ?field-stuff) ...))) 25 | ((define-record-type ?id ?type 26 | (?constructor ?arg ...) 27 | ?pred 28 | ?more ...) 29 | (begin (define-record-type ?id ?type 30 | (?constructor ?arg ...) 31 | ?more ...) 32 | (define ?pred (record-predicate ?type)))))) 33 | 34 | ; Straightforward version 35 | (define-syntax define-accessors 36 | (syntax-rules () 37 | ((define-accessors ?type ?field-spec ...) 38 | (begin (define-accessor ?type . ?field-spec) ...)))) 39 | 40 | (define-syntax define-accessor 41 | (syntax-rules () 42 | ((define-accessor ?type ?field ?accessor) 43 | (define ?accessor (record-accessor ?type '?field))) 44 | ((define-accessor ?type ?field ?accessor ?modifier) 45 | (begin (define ?accessor (record-accessor ?type '?field)) 46 | (define ?modifier (record-modifier ?type '?field)))) 47 | ((define-accessor ?type ?field) 48 | (begin)))) 49 | -------------------------------------------------------------------------------- /scheme/bcomp/type.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; The types. 6 | 7 | (define :syntax 8 | (loophole :type syntax-type)) 9 | 10 | (define :values 11 | (loophole :type any-values-type)) 12 | 13 | (define :arguments 14 | (loophole :type any-arguments-type)) 15 | 16 | (define :value 17 | (loophole :type value-type)) 18 | 19 | (define procedure 20 | (loophole (proc (:type :type) :type) 21 | (lambda (dom cod) (procedure-type dom cod #t)))) 22 | 23 | ; Use the definitions of PROC and SOME-VALUES from the meta-types module 24 | 25 | 26 | ; Various base types 27 | 28 | (define :boolean (loophole :type boolean-type)) 29 | (define :char (loophole :type char-type)) 30 | (define :null (loophole :type null-type)) 31 | (define :unspecific (loophole :type unspecific-type)) 32 | 33 | (define :number (loophole :type number-type)) 34 | (define :complex (loophole :type complex-type)) 35 | (define :real (loophole :type real-type)) 36 | (define :rational (loophole :type rational-type)) 37 | (define :integer (loophole :type integer-type)) 38 | (define :exact-integer (loophole :type exact-integer-type)) 39 | 40 | (define :pair (loophole :type pair-type)) 41 | (define :string (loophole :type string-type)) 42 | (define :symbol (loophole :type symbol-type)) 43 | (define :vector (loophole :type vector-type)) 44 | (define :procedure (loophole :type any-procedure-type)) 45 | 46 | ; Temporary 47 | (define :input-port :value) 48 | (define :output-port :value) 49 | 50 | (define :error (loophole :type error-type)) 51 | (define :escape (loophole :type escape-type)) 52 | 53 | (define :structure (loophole :type structure-type)) 54 | (define :type (loophole :type value-type)) 55 | -------------------------------------------------------------------------------- /scheme/alt/reroot.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; A state space is a tree with the state at the root. Each node other 6 | ; than the root is a triple , represented in 7 | ; this implementation as a structure ((before . after) . parent). 8 | ; Moving from one state to another means re-rooting the tree by pointer 9 | ; reversal. 10 | 11 | (define *here* (list #f)) 12 | 13 | (define original-cwcc call-with-current-continuation) 14 | 15 | (define (call-with-current-continuation proc) 16 | (let ((here *here*)) 17 | (original-cwcc (lambda (cont) 18 | (proc (lambda results 19 | (reroot! here) 20 | (apply cont results))))))) 21 | 22 | (define (dynamic-wind before during after) 23 | (let ((here *here*)) 24 | (reroot! (cons (cons before after) here)) 25 | (call-with-values during 26 | (lambda results 27 | (reroot! here) 28 | (apply values results))))) 29 | 30 | (define (reroot! there) 31 | (if (not (eq? *here* there)) 32 | (begin (reroot! (cdr there)) 33 | (let ((before (caar there)) 34 | (after (cdar there))) 35 | (set-car! *here* (cons after before)) 36 | (set-cdr! *here* there) 37 | (set-car! there #f) 38 | (set-cdr! there '()) 39 | (set! *here* there) 40 | (before))))) 41 | 42 | ; ----- 43 | ; 44 | ;(define r #f) (define s #f) (define (p x) (write x) (newline)) 45 | ;(define (tst) 46 | ; (set! r *here*) 47 | ; (set! s (cons (cons (lambda () (p 'in)) (lambda () (p 'out))) *here*)) 48 | ; (reroot! s)) 49 | ; 50 | ; 51 | ;(define (check) ;Algorithm invariants 52 | ; (if (not (null? (cdr *here*))) 53 | ; (error "confusion #1")) 54 | ; (if (car *here*) 55 | ; (error "confusion #2"))) 56 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/unused/Notes: -------------------------------------------------------------------------------- 1 | 2 | Need to check for multiple (effectively) identical closures. 3 | node-equal? 4 | 5 | Flatten needs to do something about shared strings and byte-vectors. 6 | 7 | Do SET! globals need to be treated differently? Will C allow the following? 8 | int f( int x ) { ... } 9 | main() { f = ... } 10 | 11 | Check what happens if a name->enumerand or enumerand->name survives loading. 12 | 13 | CALL-WITH-VALUES needs to simplify to two calls (so that the known-call 14 | stuff works) even when it doesn't know what the type is (because of 15 | polymorphism; we don't resimplify when types change). 16 | (call-with-values cont a b) 17 | => 18 | (unknown-call (lambda (res:tuple) 19 | (unknown-call cont 'tuple-args b res)) 20 | 'tuple-result 21 | a) 22 | Need tuple-args-goto as well. The protocol stuff has to do the right thing. 23 | When the tuple type is determined RES has to change in both places. 24 | Actually, it can just expand into this. The type stuff will work out. 25 | For now I am not going to allow polymorphic use of call-with-values. 26 | All of this is much like Scheme. 27 | 28 | Non-tail-recursive named-LETS appear to break things. 29 | 30 | CALL-WITH-VALUES and VALUES are only allowed in call position, and the 31 | second argument to CALL-WITH-VALUES must be a lambda form. 32 | 33 | STOB->NODE in form.scm needs to look for substobs. 34 | Or does flatten flatten non-shared structures? 35 | 36 | Pointer comparisons need to be done using unsigned longs. 37 | => Pre-Scheme needs unsigned comparisons u=, u<, etc. 38 | 39 | Primitives do not appear to check the argument count! 40 | 41 | Channel library may be doable as externals, including decoding 42 | the events. 43 | 44 | Tail-called forms that return multiple values? 45 | 46 | MAX and other primitives need to check number-of-args when type checking. 47 | -------------------------------------------------------------------------------- /scheme/big/placeholder.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | ; Placeholders (single-assignment cells for use with threads) 4 | 5 | (define-record-type placeholder :placeholder 6 | (really-make-placeholder queue id) 7 | placeholder? 8 | (queue placeholder-queue set-placeholder-queue!) ; #f means VALUE has been set 9 | (value placeholder-real-value set-placeholder-value!) 10 | (id placeholder-id)) 11 | 12 | (define-record-discloser :placeholder 13 | (lambda (placeholder) 14 | (cons 'placeholder 15 | (if (placeholder-id placeholder) 16 | (list (placeholder-id placeholder)) 17 | '())))) 18 | 19 | (define (make-placeholder . id-option) 20 | (really-make-placeholder (make-thread-queue) 21 | (if (null? id-option) #f (car id-option)))) 22 | 23 | (define (placeholder-value placeholder) 24 | (with-interrupts-inhibited 25 | (lambda () 26 | (if (placeholder-queue placeholder) 27 | (begin 28 | (enqueue-thread! (placeholder-queue placeholder) 29 | (current-thread)) 30 | (block))) 31 | (placeholder-real-value placeholder)))) 32 | 33 | (define (placeholder-set! placeholder value) 34 | (let ((waiters (with-interrupts-inhibited 35 | (lambda () 36 | (let ((queue (placeholder-queue placeholder))) 37 | (cond (queue 38 | (set-placeholder-value! placeholder value) 39 | (set-placeholder-queue! placeholder #f) 40 | (do ((waiters '() (cons (dequeue-thread! queue) 41 | waiters))) 42 | ((thread-queue-empty? queue) 43 | waiters))) 44 | (else #f))))))) 45 | (if waiters 46 | (for-each make-ready waiters) 47 | (if (not (eq? value (placeholder-value placeholder))) 48 | (error "placeholder is already assigned" 49 | placeholder 50 | value))))) 51 | -------------------------------------------------------------------------------- /scheme/rts/lock.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | ; Locks (= semaphores) 4 | 5 | ; Each lock has: 6 | ; The owning thread's uid, or #f if not locked. The uid can be used 7 | ; to aid debugging without introducing the overhead of a weak pointer 8 | ; to the actual thread (a non-weak pointer would introduce an unfortunate 9 | ; circularity involving the locks and finalizers of ports). 10 | ; A queue of waiting threads 11 | 12 | (define-record-type lock :lock 13 | (really-make-lock owner-uid queue uid) 14 | lock? 15 | (owner-uid lock-owner-uid set-lock-owner-uid!) 16 | (queue lock-queue) 17 | (uid lock-uid)) ; for debugging 18 | 19 | (define *lock-uid* 0) 20 | 21 | (define (make-lock) 22 | (let ((uid *lock-uid*)) 23 | (set! *lock-uid* (+ uid 1)) 24 | (really-make-lock #f (make-thread-queue) uid))) 25 | 26 | (define (obtain-lock lock) 27 | (with-interrupts-inhibited 28 | (lambda () 29 | (if (lock-owner-uid lock) 30 | (begin 31 | (enqueue-thread! (lock-queue lock) (current-thread)) 32 | (block)) 33 | (set-lock-owner-uid! lock (thread-uid (current-thread))))))) 34 | 35 | (define (maybe-obtain-lock lock) 36 | (with-interrupts-inhibited 37 | (lambda () 38 | (if (lock-owner-uid lock) 39 | #f 40 | (begin 41 | (set-lock-owner-uid! lock (thread-uid (current-thread))) 42 | #t))))) 43 | 44 | ; Returns #t if the lock has no new owner. 45 | 46 | (define (release-lock lock) 47 | (with-interrupts-inhibited 48 | (lambda () 49 | (let ((queue (lock-queue lock))) 50 | (if (thread-queue-empty? queue) 51 | (begin 52 | (set-lock-owner-uid! lock #f) 53 | #t) 54 | (let ((next (dequeue-thread! queue))) 55 | (set-lock-owner-uid! lock (thread-uid next)) 56 | (make-ready next) 57 | #f)))))) 58 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/select.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (test) 3 | (let ((in (current-input-port)) 4 | (out (current-output-port)) 5 | (s1 (make-port-set)) 6 | (s2 (make-port-set))) 7 | (let loop ((i 0)) 8 | (cond ((char-ready? in) 9 | (got-char in out i) 10 | (loop 0)) 11 | (else 12 | (clear-port-set! s1) 13 | (clear-port-set! s2) 14 | (add-to-port-set! s1 in) 15 | (case (find-ready-ports s1 s2 #f) 16 | ((0) 17 | (loop (+ i 1))) 18 | ((1) 19 | (cond ((port-set-member? s1 in) 20 | (got-char in out i) 21 | (loop 0)) 22 | (else 23 | (write-string "not in port set" out) 24 | (newline out)))) 25 | (else 26 | (write-string "funny port count " out)))))))) 27 | 28 | (define (got-char in out i) 29 | (write-string "Got " out) 30 | (ps-read-char in 31 | (lambda (char) 32 | (write-number-no-newline (ascii->char char) out)) 33 | (lambda () 34 | (write-string "EOF!" out))) 35 | (write-string " after " out) 36 | (write-number i out)) 37 | 38 | ; Printing integers 39 | 40 | ; Return 10**n such that 10**n <= x < 10**(n+1) 41 | 42 | (define (integer-mask x) 43 | (do ((x x (quotient x 10)) 44 | (mask 1 (* mask 10))) 45 | ((< x 10) mask))) 46 | 47 | ; Write positive integer X out to PORT 48 | 49 | (define (write-number x port) 50 | (write-number-no-newline x port) 51 | (write-char '#\newline port)) 52 | 53 | (define (write-number-no-newline x port) 54 | (let ((x (cond ((< x 0) 55 | (write-char '#\- port) 56 | (- 0 x)) 57 | (else 58 | x)))) 59 | (let loop ((x x) (mask (integer-mask x))) 60 | (let ((digit (quotient x mask))) 61 | (write-char (ascii->char (+ digit (char->ascii '#\0))) port) 62 | (if (> mask 1) 63 | (loop (remainder x mask) (quotient mask 10))))))) 64 | 65 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /scheme/alt/bitwise-tests.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Lost: (ARITHMETIC-SHIFT 5 27) => -402653184 [wanted 671088640.] 6 | ; Lost: (ARITHMETIC-SHIFT 5 28) => 268435456 [wanted 1342177280.] 7 | 8 | 9 | (define (testit name proc x y z) 10 | (let ((result (proc x y))) 11 | (if (not (= result z)) 12 | (begin (display "Lost: ") 13 | (write `(,name ,x ,y)) 14 | (display " => ") 15 | (write result) 16 | (display " [wanted ") 17 | (write z) 18 | (display "]") 19 | (newline))))) 20 | 21 | (define most-positive-fixnum 22 | (let ((n (arithmetic-shift 2 27))) (+ n (- n 1)))) 23 | 24 | (define (test-left-shifts x) 25 | (let ((crossover (arithmetic-shift 2 27))) 26 | (do ((y 0 (+ y 1)) 27 | (z x (* z (if (>= z crossover) 2. 2)))) 28 | ((= y 34)) 29 | (testit 'arithmetic-shift arithmetic-shift x y z)))) 30 | 31 | (test-left-shifts 5) 32 | (test-left-shifts -5) 33 | 34 | (define (test-right-shifts x) 35 | (do ((y 0 (- y 1)) 36 | (z x (quotient z 2))) 37 | ((= y -34)) 38 | (testit 'arithmetic-shift arithmetic-shift x y z))) 39 | 40 | (test-right-shifts (* 5 (expt 2 36))) 41 | (test-right-shifts (* -5 (expt 2 36))) 42 | 43 | (define (bit1? x) 44 | (if (< x 0) 45 | (even? (quotient (- -1 x) 2)) 46 | (odd? (quotient x 2)))) 47 | 48 | (define (try-truth-table name proc predicate) 49 | (do ((x -4 (+ x 1))) 50 | ((= x 4)) 51 | (do ((y -4 (+ y 1))) 52 | ((= y 4)) 53 | (testit name proc x y 54 | (+ (if (predicate (odd? x) (odd? y)) 1 0) 55 | (if (predicate (bit1? x) (bit1? y)) 2 0) 56 | (if (predicate (negative? x) (negative? y)) -4 0)))))) 57 | 58 | (try-truth-table 'bitwise-and bitwise-and (lambda (a b) (and a b))) 59 | (try-truth-table 'bitwise-ior bitwise-ior (lambda (a b) (or a b))) 60 | -------------------------------------------------------------------------------- /scheme/debug/thread-socket.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Code to check the interaction between threads and sockets. 6 | 7 | (define (run-server) 8 | (with-multitasking server)) 9 | 10 | (define (server) 11 | (call-with-values socket-server 12 | (lambda (port-number accept) 13 | (display "Port number is ") (write port-number) (newline) 14 | (let loop () 15 | (call-with-values accept 16 | (lambda (i-port o-port) 17 | (spawn (service i-port o-port)) 18 | (loop))))))) 19 | 20 | (define (service i-port o-port) 21 | (lambda () 22 | (let loop ((total 0)) 23 | (let ((next (read i-port))) 24 | (cond ((eof-object? next) 25 | (close-input-port i-port) 26 | (close-output-port o-port)) 27 | (else 28 | (let ((total (+ total next))) 29 | (write total o-port) 30 | (newline o-port) 31 | (loop total)))))))) 32 | 33 | (define (run-users machine port-number . data) 34 | (with-multitasking 35 | (lambda () 36 | (do ((i 0 (+ i 1)) 37 | (d data (cdr d))) 38 | ((null? d)) 39 | (let ((l (car d))) 40 | (spawn (lambda () 41 | (user (make-name i) (car l) (cadr l) machine port-number)))))))) 42 | 43 | (define (make-name i) 44 | (list->string (list (string-ref "ABCDEFGHIJKLMNOPQRSTUVWXYZ" i)))) 45 | 46 | (define (user id count delay machine port-number) 47 | (call-with-values 48 | (lambda () 49 | (socket-client machine port-number)) 50 | (lambda (i-port o-port) 51 | (let loop ((count count)) 52 | (cond ((= 0 count) 53 | (close-input-port i-port) 54 | (close-output-port o-port)) 55 | (else 56 | (write 1 o-port) 57 | (newline o-port) 58 | (for-each display (list id " got " (read i-port))) 59 | (newline) 60 | (sleep delay) 61 | (loop (- count 1)))))))) 62 | -------------------------------------------------------------------------------- /scheme/rts/number.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; This is file number.scm. 5 | 6 | 7 | ;;;; Numbers 8 | 9 | (define (inexact? n) (not (exact? n))) 10 | 11 | (define (modulo x y) 12 | (let ((r (remainder x y))) 13 | (if (> y 0) 14 | (if (< r 0) 15 | (+ r y) 16 | r) 17 | (if (> r 0) 18 | (+ r y) 19 | r)))) 20 | 21 | (define (ceiling x) 22 | (- 0 (floor (- 0 x)))) ;floor is primitive 23 | 24 | (define (truncate x) 25 | (if (< x 0) 26 | (ceiling x) 27 | (floor x))) 28 | 29 | (define (round x) 30 | (let* ((x+1/2 (+ x (/ 1 2))) 31 | (r (floor x+1/2))) 32 | (if (and (= r x+1/2) 33 | (odd? r)) 34 | (- r 1) 35 | r))) 36 | 37 | ; GCD 38 | 39 | (define (gcd . integers) 40 | (reduce (lambda (x y) 41 | (cond ((< x 0) (gcd (- 0 x) y)) 42 | ((< y 0) (gcd x (- 0 y))) 43 | ((< x y) (euclid y x)) 44 | (else (euclid x y)))) 45 | 0 46 | integers)) 47 | 48 | (define (euclid x y) 49 | (if (= y 0) 50 | (if (and (inexact? y) 51 | (exact? x)) 52 | (exact->inexact x) 53 | x) 54 | (euclid y (remainder x y)))) 55 | 56 | ; LCM 57 | 58 | (define (lcm . integers) 59 | (reduce (lambda (x y) 60 | (let ((g (gcd x y))) 61 | (cond ((= g 0) g) 62 | (else (* (quotient (abs x) g) (abs y)))))) 63 | 1 64 | integers)) 65 | 66 | ; Exponentiation. 67 | 68 | (define (expt x n) 69 | (if (and (integer? n) (exact? n)) 70 | (if (>= n 0) 71 | (raise-to-integer-power x n) 72 | (/ 1 (raise-to-integer-power x (- 0 n)))) 73 | (exp (* n (log x))))) 74 | 75 | (define (raise-to-integer-power x n) 76 | (if (= n 0) 77 | 1 78 | (let loop ((s x) (i n) (a 1)) ;invariant: a * s^i = x^n 79 | (let ((a (if (odd? i) (* a s) a)) 80 | (i (quotient i 2))) 81 | (if (= i 0) 82 | a 83 | (loop (* s s) i a)))))) 84 | -------------------------------------------------------------------------------- /scheme/debug/tiny.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Tiny image and simple I/O test system 5 | 6 | ; This prints `Hello' and the first command argument, if any, then reads 7 | ; a line from standard input and prints it to standard output. 8 | 9 | (define (start arg in out error-out) 10 | (write-string "Hello " out) 11 | (if (vector? arg) 12 | (if (< 0 (vector-length arg)) 13 | (write-string (vector-ref arg 0) out))) 14 | (newline out) 15 | (write-string (read-string in) out) 16 | (newline out) 17 | 0) 18 | 19 | (define (write-string string . channel-option) ; test n-ary procedures 20 | (channel-maybe-write string 21 | 0 22 | (string-length string) 23 | (car channel-option))) 24 | 25 | (define (newline channel) 26 | (write-string " 27 | " channel)) 28 | 29 | (define (read-string in) 30 | ((lambda (buffer) 31 | (letrec ((loop (lambda (have) 32 | ((lambda (got) 33 | (if (eq? got (eof-object)) 34 | "eof" 35 | ((lambda (len) 36 | (if len 37 | ((lambda (string) 38 | (copy-string! buffer string len) 39 | string) 40 | (make-string len #\space)) 41 | (loop (+ have got)))) 42 | (has-newline buffer have got)))) 43 | (channel-maybe-read buffer have (- 80 have) #f in))))) 44 | (loop 0))) 45 | (make-string 80 #\space))) 46 | 47 | (define (has-newline string start count) 48 | (letrec ((loop (lambda (i) 49 | (if (= i count) 50 | #f 51 | (if (char=? #\newline 52 | (string-ref string (+ start i))) 53 | (+ start i) 54 | (loop (+ i 1))))))) 55 | (loop 0))) 56 | 57 | (define (copy-string! from to count) 58 | (letrec ((loop (lambda (i) 59 | (if (< i count) 60 | (begin 61 | (string-set! to i (string-ref from i)) 62 | (loop (+ i 1))))))) 63 | (loop 0))) 64 | -------------------------------------------------------------------------------- /scheme/rts/eval.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; This file contains things that tie together the compiler and the 6 | ; run-time system. 7 | 8 | ; EVAL 9 | 10 | (define (eval form package) 11 | (compile-and-run (list form) package #f #f)) 12 | 13 | ; LOAD-INTO - load file into package. 14 | 15 | (define (load-into filename package) 16 | (really-load-into filename package #f)) 17 | 18 | ; Evaluate forms as if they came from the given file. 19 | 20 | (define (eval-from-file forms package filename) 21 | (if filename 22 | ((fluid $note-file-package) 23 | filename package)) 24 | (compile-and-run forms package filename #t)) 25 | 26 | ; LOAD 27 | 28 | (define (load filename . package-option) 29 | (let ((package (if (null? package-option) 30 | (interaction-environment) 31 | (car package-option)))) 32 | (really-load-into filename package #t))) 33 | 34 | ;---------------- 35 | 36 | (define (really-load-into filename package note-undefined?) 37 | (force-output (current-output-port)) ; just to make the output nice 38 | (let ((forms (read-forms filename package))) 39 | (newline (current-noise-port)) ; READ-FORMS prints the filename 40 | (compile-and-run forms 41 | package 42 | filename 43 | note-undefined?))) 44 | 45 | (define (compile-and-run forms package maybe-filename note-undefined?) 46 | (let* ((env (if maybe-filename 47 | (bind-source-file-name maybe-filename 48 | (package->environment package)) 49 | (package->environment package))) 50 | (template (compile-forms (map (lambda (form) 51 | (lambda () (expand-form form env))) 52 | (scan-forms forms env)) 53 | maybe-filename 54 | #f))) 55 | (link! template package note-undefined?) 56 | (invoke-closure 57 | (make-closure template 58 | (package-uid package))))) 59 | 60 | 61 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/test.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (test x) 4 | (cond ((= x 1) 5 | (goto raise-exception 2)) 6 | ((= x 2) 7 | (goto raise-exception1 2 0)) 8 | ((= x 3) 9 | (goto raise-exception 3)) 10 | ((= x 4) 11 | (goto raise-exception1 4 0)))) 12 | 13 | (define *code-pointer* 0) 14 | (define *stack* 0) 15 | 16 | (define (push x) 17 | (vector-set! *stack* 0 x) 18 | (set! *stack* (- *stack* 4))) 19 | 20 | (define (fetch-byte address) 21 | (byte-vector-ref address 0)) 22 | 23 | (define (current-opcode code-args) 24 | (fetch-byte (- *code-pointer* (+ code-args 1)))) 25 | 26 | (define (start-exception args) 27 | (push (current-opcode args))) 28 | 29 | (define (raise-exception args) 30 | (start-exception args) 31 | (goto raise 0)) 32 | 33 | (define (raise-exception1 args a1) 34 | (start-exception args) 35 | (push a1) 36 | (goto raise 1)) 37 | 38 | (define (raise n) 39 | (goto test n)) 40 | 41 | (define-local-syntax (define-primitive id nargs) 42 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 43 | `(define (,id . ,args) 44 | (call-primitively ,id . ,args)))) 45 | 46 | (define-local-syntax (define-effect-primitive id nargs) 47 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 48 | `(define (,id . ,args) 49 | (call-primitively ,id . ,args) 50 | (call-primitively undefined-value)))) 51 | 52 | (define-primitive + 2) 53 | (define-primitive - 2) 54 | (define-primitive * 2) 55 | (define-primitive < 2) 56 | (define-primitive = 2) 57 | 58 | (define-primitive quotient 2) 59 | (define-primitive remainder 2) 60 | 61 | (define (unassigned) (call-primitively undefined-value)) 62 | 63 | (define (byte-vector-ref vec index) 64 | (call-primitively byte-contents (+ vec index))) 65 | 66 | (define (byte-vector-set! vec index value) 67 | (call-primitively byte-set-contents! (+ vec index) value)) 68 | 69 | (define (vector-set! vec index value) 70 | (call-primitively set-contents! (+ vec (* index 4)) value)) 71 | -------------------------------------------------------------------------------- /emacs/README: -------------------------------------------------------------------------------- 1 | Date: Thu, 9 Jul 92 13:26:05 HKT 2 | From: shivers@csd.hku.hk (Olin G. Shivers) 3 | To: jar@cs.cornell.edu 4 | In-Reply-To: Jonathan Rees's message of Wed, 8 Jul 92 22:15:22 -0400 <9207090215.AA00991@sindri.cs.cornell.edu> 5 | Subject: cmulisp 6 | 7 | It's also in Ozan's repository, but I don't know how up-to-date it is. 8 | It's always useful to list his repository as a possible location, tho. 9 | -Olin 10 | 11 | /afs/cs.cmu.edu/user/shivers/lib/Readme: 12 | This directory contains the following subdirectories: 13 | emacs Gnu emacs packages. 14 | papers My papers, in .dvi and postscript form. 15 | tex LaTeX packages. 16 | All of these files can be anonymously ftp'd. 17 | -Olin 18 | July 3, 1991 19 | 20 | =============================================================================== 21 | Directions for anonymous ftp: 22 | 1. ftp to any CMU machine with access to the /afs network file system. 23 | Almost any machine will do; some possibilities are: 24 | cs.cmu.edu 128.2.222.173 25 | a.gp.cs.cmu.edu 128.2.242.7 26 | f.gp.cs.cmu.edu 128.2.250.164 27 | h.gp.cs.cmu.edu 128.2.254.156 28 | k.gp.cs.cmu.edu 128.2.254.137 29 | 30 | 2. login as anonymous 31 | You are supposed to provide username@host as the password. The CMU 32 | ftp demon actually checks to ensure there's an "@" in the password. 33 | So you can't just say "foo"; you have to say "foo@bar". 34 | 35 | 3. cd /afs/cs.cmu.edu/user/shivers/lib 36 | CMU ftp restricts the directories you can access anonymously, 37 | so you must cd straight to the .../lib directory or its descendants. 38 | 4. If you are transfering .dvi or other binary files, set the file transfer 39 | mode to raw binary with one of the following commands: 40 | type image 41 | type binary 42 | image 43 | binary 44 | If you don't do this, the files may be garbled. 45 | 5. Use dir or ls to list the directory. 46 | 6. Transfer the files you want. 47 | 48 | -------------------------------------------------------------------------------- /scheme/misc/integertostring.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ;Date: Mon, 24 Jan 94 15:10:30 -0500 6 | ;To: jar@ai.mit.edu 7 | ;Subject: integer->string 8 | ;From: kelsey@research.nj.nec.com 9 | ;Sender: kelsey@research.nj.nec.com 10 | ; 11 | ; 12 | ;I have gotten tired of waiting for bignums to print out. 13 | ;Here is a somewhat more complex and faster version of integer->string. 14 | ; 15 | ;Converting 10**100 to a string: 16 | ; Current: 0.44 seconds 17 | ; This: 0.12 seconds 18 | ; This using integer-divide: 0.06 seconds 19 | ; 20 | ;There is no overwhelming reason to use this, but here it is. 21 | 22 | 23 | (define integer->string 24 | (let () 25 | 26 | (define (integer->string n radix) 27 | 28 | (define (small-integer->magnitude n l) 29 | (if (= n 0) 30 | l 31 | (small-integer->magnitude (quotient n radix) 32 | (cons (integer->digit (remainder n radix)) 33 | l)))) 34 | 35 | (define (integer->magnitude n) 36 | (let ((rrrr (* (* radix radix) (* radix radix)))) 37 | 38 | (let recur ((n n) (l '())) 39 | (if (< n rrrr) 40 | (small-integer->magnitude n l) 41 | (do ((i 4 (- i 1)) 42 | (n0 (remainder n rrrr) (quotient n0 radix)) 43 | (l l (cons (integer->digit (remainder n0 radix)) l))) 44 | ((= 0 i) 45 | (recur (quotient n rrrr) l))))))) 46 | 47 | (let ((magnitude (cond ((= n 0) '(#\0)) 48 | ((< n 1000000) 49 | (small-integer->magnitude (abs n) '())) 50 | (else 51 | (integer->magnitude (abs n)))))) 52 | (list->string (if (>= n 0) 53 | magnitude 54 | (cons #\- magnitude))))) 55 | 56 | (define (integer->digit n) 57 | (ascii->char (+ n (if (< n 10) 58 | zero 59 | a-minus-10)))) 60 | 61 | (define zero (char->ascii #\0)) 62 | (define a-minus-10 (- (char->ascii #\a) 10)) 63 | 64 | integer->string)) 65 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/primop/scm-record.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | (define-complex-primitive (make-record symbol?) 6 | (lambda (type) 7 | (bug "no evaluator for MAKE-RECORD")) 8 | (lambda (args node depth return?) 9 | (let ((type-id (cadr (node-form (car args))))) 10 | (make-pointer-type (get-record-type type-id)))) 11 | #f ; no closed form 12 | (lambda (args type) 13 | (make-primop-call-node (get-prescheme-primop 'make-record) args type))) 14 | 15 | (define-complex-primitive (record-ref any? ; no RECORD? available 16 | symbol? symbol?) 17 | (lambda (thing type field) 18 | (bug "no evaluator for RECORD-REF")) 19 | (lambda (args node depth return?) 20 | (let ((type-id (cadr (node-form (cadr args)))) 21 | (field-id (cadr (node-form (caddr args))))) 22 | (let ((record-type (make-pointer-type (get-record-type type-id))) 23 | (field-type (record-field-type 24 | (get-record-type-field type-id field-id)))) 25 | (check-arg-type args 0 record-type depth node) 26 | field-type))) 27 | #f ; no closed form 28 | (lambda (args type) 29 | (make-primop-call-node (get-prescheme-primop 'record-ref) args type))) 30 | 31 | (define-complex-primitive (record-set! any? ; no RECORD? available 32 | any? symbol? symbol?) 33 | (lambda (thing value type field) 34 | (bug "no evaluator for RECORD-SET!")) 35 | (lambda (args node depth return?) 36 | (let ((type-id (cadr (node-form (caddr args)))) 37 | (field-id (cadr (node-form (cadddr args))))) 38 | (let ((record-type (make-pointer-type (get-record-type type-id))) 39 | (field-type (record-field-type 40 | (get-record-type-field type-id field-id)))) 41 | (check-arg-type args 0 record-type depth node) 42 | (check-arg-type args 1 field-type depth node) 43 | type/unit))) 44 | #f ; no closed form 45 | (lambda (args type) 46 | (make-primop-call-node (get-prescheme-primop 'record-set!) args type))) 47 | 48 | -------------------------------------------------------------------------------- /gdbinit: -------------------------------------------------------------------------------- 1 | # 2 | # Commands useful for debugging the Scheme48 VM. 3 | # 4 | 5 | #Set a breakpoint at label "raise". 6 | #Obtain the proper line number using "egrep -n raise: scheme48vm.c". 7 | break scheme48vm.c:5227 8 | 9 | display/i $pc 10 | 11 | define pcont 12 | echo template id = \ 13 | output *(long *)((*(long *)(($ & ~3) + 8) & ~3) + 4) / 4 14 | echo \npc = \ 15 | output (*(long *)(($ & ~3) + 4) / 4) 16 | echo \nparent = \ 17 | output *(long *)($ & ~3) 18 | echo \nenv = \ 19 | output *(long *)(($ & ~3) + 12) 20 | echo \ncount = \ 21 | output *(long *)(($ & ~3) - 4) >> 10 22 | echo \n 23 | end 24 | # 25 | document pcont 26 | Print $ as a continuation. 27 | end 28 | 29 | 30 | define parent 31 | print *(long *)($ & ~3) 32 | pcont 33 | end 34 | # 35 | document parent 36 | Select parent continuation. 37 | end 38 | 39 | 40 | define preview 41 | set $cont = ScontS 42 | preview-loop 43 | end 44 | # 45 | define preview-loop 46 | output $cont 47 | echo \040 48 | output *(long *)((*(long *)(($cont & ~3) + 8) & ~3) + 4) / 4 49 | echo \n 50 | set $cont = *(long *)($cont & ~3) 51 | preview-loop 52 | end 53 | # 54 | document preview 55 | Display Scheme stack trace. Look up the template uids in the .debug file. 56 | end 57 | 58 | 59 | define show-header 60 | echo Header length:\ 61 | output $hdr >> 8 62 | echo \ type:\040 63 | output ($hdr & 127) >> 2 64 | echo \ tag:\040 65 | output $hdr & 3 66 | echo \n 67 | end 68 | 69 | define look 70 | output ($ - Snewspace_beginS) 71 | echo :\n 72 | set $hdr = *(long *)($ - 7) 73 | show-header 74 | output *(long *)($ - 3) 75 | echo \n 76 | output *(long *)($ + 1) 77 | echo \n 78 | output *(long *)($ + 5) 79 | echo \n 80 | end 81 | 82 | define go0 83 | print *(long *)($ - 3) 84 | end 85 | 86 | define bytes 87 | set $foo = RScode_pointerS 88 | output (int)*(unsigned char *)($foo + 0) 89 | echo \040 90 | output (int)*(unsigned char *)($foo + 1) 91 | echo \040 92 | output (int)*(unsigned char *)($foo + 2) 93 | echo \040 94 | output (int)*(unsigned char *)($foo + 3) 95 | echo \040 96 | output (int)*(unsigned char *)($foo + 4) 97 | echo \n 98 | end 99 | -------------------------------------------------------------------------------- /scheme/env/basic-command.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; run 6 | 7 | (define-command-syntax 'run "" "evaluate an expression" '(expression)) 8 | 9 | (define (run exp) 10 | (evaluate-and-select exp (environment-for-commands))) 11 | 12 | ; exit-when-done 13 | 14 | (define-command-syntax 'exit-when-done "[]" 15 | "leave Scheme after all threads finish" 16 | '(&opt expression)) 17 | 18 | (define (exit-when-done . exp-option) 19 | (let ((status (if (null? exp-option) 20 | 0 21 | (eval (car exp-option) (environment-for-commands))))) 22 | (terminate-command-processor! status))) 23 | 24 | (define-command-syntax 'exit 25 | "[]" 26 | "leave Scheme now" 27 | '(&opt expression)) 28 | 29 | (define (exit . exp-option) 30 | (let ((status (if (null? exp-option) 31 | 0 32 | (eval (car exp-option) (environment-for-commands))))) 33 | (scheme-exit-now status))) 34 | 35 | ; go 36 | 37 | (define-command-syntax 'go "" "leave Scheme via tail recursion" 38 | '(expression)) 39 | 40 | (define (go exp) 41 | (let ((env (environment-for-commands))) 42 | (exit-command-processor (lambda () (eval exp env))))) 43 | 44 | ; load 45 | 46 | (define-command-syntax 'load " ..." 47 | "load Scheme source file(s)" 48 | '(&rest filename)) 49 | 50 | (define (load . filenames) 51 | (let ((env (environment-for-commands))) 52 | ;; (with-interaction-environment env 53 | ;; (lambda () 54 | (noting-undefined-variables env 55 | (lambda () 56 | (for-each (lambda (filename) 57 | (load-into filename env)) 58 | filenames)))));; )) 59 | 60 | ; help 61 | 62 | (define ? help) 63 | 64 | (define-command-syntax 'help 65 | "[]" 66 | "list all commands, or give help on a specific command" 67 | '(&opt name)) 68 | 69 | (define-command-syntax '? "[]" "same as ,help" '(&opt name)) 70 | -------------------------------------------------------------------------------- /scheme/kali/channel-hacks.scm: -------------------------------------------------------------------------------- 1 | (define open-input-channel 2 | (lambda (name) 3 | (open-channel name 4 | (enum channel-status-option input)))) 5 | 6 | (define open-output-channel 7 | (lambda (name) 8 | (open-channel name 9 | (enum channel-status-option output)))) 10 | 11 | (define channel->fd 12 | channel-os-index) 13 | 14 | (define make-channel-non-blocking! 15 | (lambda (channel) 16 | (vm-extension 214 17 | (channel-os-index channel)))) 18 | 19 | ; This really should be smaller on Linux, but only costs space. 20 | (define bufsiz 21 | (* 8 (expt 2 10))) 22 | 23 | (define fd->input-port 24 | (lambda (fd) 25 | (input-channel->port 26 | (open-channel fd 27 | (enum channel-status-option 28 | input)) 29 | bufsiz))) 30 | 31 | ; Note, the result of fd->output-port is non-blocking and does 32 | ; NOT automatically flush buffered output. 33 | (define fd->output-port 34 | (lambda (fd) 35 | (let ((chan 36 | (open-channel fd 37 | (enum channel-status-option 38 | output)))) 39 | (make-channel-non-blocking! chan) 40 | (output-channel->port chan bufsiz #F)))) 41 | 42 | ; Given a channel associated to a file descriptor which is a TCP/IP 43 | ; socket, set the TCP_NODELAY appropriately. 44 | ; Note, file descriptors which share an origin (e.g., dup'd file 45 | ; descriptors) share a TCP_NODELAY mode, and thus setting one will 46 | ; set the other. 47 | (define set-tcp-nodelay! 48 | (lambda (channel nodelay?) 49 | (vm-extension 300 50 | (cons (channel-os-index channel) 51 | nodelay?)))) 52 | 53 | ; Given a file descriptor, return input and output channels associated 54 | ; to it. 55 | (define fd->channels 56 | (lambda (fd) 57 | (let ((out-fd 58 | (duplicate-fd fd))) 59 | (values 60 | (open-channel fd 61 | (enum channel-status-option input)) 62 | (open-channel out-fd 63 | (enum channel-status-option output)))))) 64 | 65 | ; Given a file descriptor, dup it. 66 | (define duplicate-fd 67 | (lambda (fd) 68 | (vm-extension 29 fd))) 69 | -------------------------------------------------------------------------------- /scheme/alt/t-record.scm: -------------------------------------------------------------------------------- 1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*- 2 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 3 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 4 | 5 | 6 | ; This is file t-record.scm. 7 | ; Synchronize any changes with the other *record.scm files. 8 | 9 | ;;;; Records 10 | 11 | (define make-record-type 12 | (let ((make-stype (*value t-standard-env 'make-stype)) 13 | (crawl-exhibit (*value t-standard-env 'crawl-exhibit)) 14 | (exhibit-structure (*value t-standard-env 'exhibit-structure)) 15 | (structure-type (*value t-standard-env 'structure-type)) 16 | (object-hash (*value t-standard-env 'object-hash)) 17 | (print (*value t-standard-env 'print)) 18 | (format (*value t-standard-env 'format))) 19 | (lambda (id names) 20 | (letrec ((rtd 21 | (make-stype id names 22 | (#[syntax object] #f 23 | ((crawl-exhibit self) 24 | (exhibit-structure self)) 25 | ((print self port) 26 | (format port "#{Record~_~S~_~S}" id (object-hash self))) 27 | ((structure-type self) rtd))))) 28 | rtd)))) 29 | 30 | (define record-predicate (*value t-standard-env 'stype-predicator)) 31 | 32 | (define record-accessor (*value t-standard-env 'stype-selector)) 33 | 34 | (define (record-modifier rtd name) 35 | (setter (record-accessor rtd name))) 36 | 37 | (define (record-constructor rtd names) 38 | (let ((number-of-inits (length names)) 39 | (modifiers (map (lambda (name) (record-modifier rtd name)) 40 | names)) 41 | (make ((*value t-implementation-env 'stype-constructor) rtd))) 42 | (lambda values 43 | (let ((record (make))) 44 | (let loop ((vals values) 45 | (ups modifiers)) 46 | (cond ((null? vals) 47 | (if (null? ups) 48 | record 49 | (error "too few arguments to record constructor" 50 | values type-id names))) 51 | ((null? ups) 52 | (error "too many arguments to record constructor" 53 | values type-id names)) 54 | (else 55 | ((car ups) record (car vals)) 56 | (loop (cdr vals) (cdr ups))))))))) 57 | 58 | (define (define-record-discloser rtd proc) 'unimplemented) 59 | -------------------------------------------------------------------------------- /scheme/kali/comrade.scm: -------------------------------------------------------------------------------- 1 | ; A comrade is a Kali process with no REPL. 2 | ; 3 | ; The idea is to provide Kali as a service. 4 | ; - add a line to /etc/inetd.conf to start comrades 5 | ; - add a line to /etc/services to get the port number 6 | ; - make a comrade image that talks to stdin and stdout, telling them 7 | ; the port on which it is listening for connections. Stdout should 8 | ; be redirected to stderr. 9 | 10 | (define (start-comrade port-number) 11 | (run-threads (make-comrade-event-handler 12 | (lambda () 13 | (start-server (lambda (server-port) 14 | (write-number-to-port-number server-port 15 | port-number))))))) 16 | 17 | (define (write-number-to-port-number n port-number) 18 | (let ((channel (open-channel port-number (enum channel-status-option input))) 19 | (string (number->string n))) 20 | (channel-write string 0 (string-length string) channel) 21 | (close-channel channel))) 22 | 23 | (define comrade-quantum 200) ; thread quantum in msec 24 | 25 | (define (make-comrade-event-handler initial-thunk) 26 | (let ((runnable (make-thread-queue)) 27 | (thread-count (make-counter))) 28 | (increment-counter! thread-count) 29 | (exclusively-enqueue-thread! 30 | runnable 31 | (make-thread initial-thunk dynamic-env-link 'comrade-server) 32 | '()) 33 | (save-base-fluid-env! (with-handler report-handler dynamic-env)) 34 | (round-robin-event-handler runnable 35 | comrade-quantum 36 | dynamic-env-link 37 | thread-count 38 | (lambda args #f) ; we handle no events 39 | propogate-upcall ; or upcalls 40 | wait))) 41 | 42 | (define report-handler 43 | (lambda (c next-handler) 44 | (for-each display 45 | `(#\newline 46 | "HCC: in report-handler." 47 | #\newline 48 | " c: " ,c 49 | #\newline 50 | " next-handler: " ,next-handler 51 | #\newline 52 | " (error? c): " ,(error? c) 53 | #\newline 54 | " (interrupt? c): " ,(interrupt? c) 55 | #\newline 56 | " (current-thread): " ,(current-thread) 57 | #\newline)) 58 | (force-output (current-output-port)) 59 | (next-handler))) 60 | 61 | -------------------------------------------------------------------------------- /scheme/debug/spatial-hack.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; load into initial image 6 | 7 | (init-defpackage! eval 8 | (lambda () 9 | (delay (make-simple-package (list scheme-level-1) 10 | #t (delay #f) 'for-syntax)))) 11 | 12 | (define-structures ((assembler (export (lap syntax)))) 13 | (open scheme-level-2 compiler architecture 14 | signals ;error 15 | enumerated ;name->enumerand 16 | code-vectors 17 | locations) ;location? 18 | (specials lap) 19 | (files (env assem))) 20 | 21 | (ensure-loaded assembler) 22 | 23 | (define-structures ((spatial (export space init-space))) 24 | (open scheme-level-2 architecture primitives packages) 25 | (files (debug space))) 26 | 27 | (ensure-loaded spatial) 28 | 29 | ((*structure-ref spatial 'init-space) eval assembler) 30 | 31 | (define-interface define-record-types-interface 32 | (export (define-record-type syntax) 33 | define-record-discloser)) 34 | (define-structures ((define-record-types define-record-types-interface)) 35 | (open scheme-level-1 record) 36 | (files (rts jar-defrecord))) 37 | (define-interface queue-interface 38 | (export make-queue enqueue! dequeue! queue-empty? 39 | queue? queue->list queue-length delete-from-queue!)) 40 | (define-structures ((queues queue-interface)) 41 | (open scheme-level-1 define-record-types signals) 42 | (files (big queue)) 43 | (optimize auto-integrate)) 44 | (define-structure traverse 45 | (export traverse-depth-first traverse-breadth-first trail 46 | set-leaf-predicate! usual-leaf-predicate) 47 | (open scheme-level-2 48 | primitives ; ? 49 | queues table 50 | bitwise locations closures code-vectors 51 | features ; string-hash 52 | low-level) ; flush-the-symbol-table! 53 | (files (env traverse))) 54 | 55 | (ensure-loaded traverse) 56 | 57 | (define foo 58 | (make-simple-package (list scheme-level-2 59 | spatial traverse vm-exposure) 60 | eval (delay #f) 'foo)) 61 | 62 | ; (define command-processor (*structure-ref command 'command-processor)) 63 | 64 | ; (set-interaction-environment! foo) 65 | -------------------------------------------------------------------------------- /scheme/debug/mini-command.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Miniature command processor. 6 | 7 | (define (command-processor ignore args) 8 | (let ((in (current-input-port)) 9 | (out (current-output-port)) 10 | (err (current-error-port)) 11 | (batch? (member "batch" args))) 12 | (let loop () 13 | ((call-with-current-continuation 14 | (lambda (go) 15 | (with-handler 16 | (lambda (c punt) 17 | (cond ((or (error? c) (interrupt? c)) 18 | (display-condition c err) 19 | (go (if batch? 20 | (lambda () 1) 21 | loop))) 22 | ((warning? c) 23 | (display-condition c err)) 24 | (else (punt)))) 25 | (lambda () 26 | (if (not batch?) 27 | (display "- " out)) 28 | (let ((form (read in))) 29 | (cond ((eof-object? form) 30 | (newline out) 31 | (go (lambda () 0))) 32 | ((and (pair? form) (eq? (car form) 'unquote)) 33 | (case (cadr form) 34 | ((load) 35 | (mini-load in) 36 | (go loop)) 37 | ((go) 38 | (let ((form (read in))) 39 | (go (lambda () 40 | (eval form (interaction-environment)))))) 41 | (else (error "unknown command" (cadr form))))) 42 | (else 43 | (call-with-values 44 | (lambda () (eval form (interaction-environment))) 45 | (lambda results 46 | (for-each (lambda (result) 47 | (write result out) 48 | (newline out)) 49 | results) 50 | (go loop)))))))))))))) 51 | 52 | (define (mini-load in) 53 | (let ((c (peek-char in))) 54 | (cond ((char=? c #\newline) (read-char in) #t) 55 | ((char-whitespace? c) (read-char in) (mini-load in)) 56 | (else 57 | (let ((filename (read-string in char-whitespace?))) 58 | (load filename) 59 | (mini-load in)))))) 60 | 61 | (define (read-string port delimiter?) 62 | (let loop ((l '()) (n 0)) 63 | (let ((c (peek-char port))) 64 | (cond ((or (eof-object? c) 65 | (delimiter? c)) 66 | (list->string (reverse l))) 67 | (else 68 | (loop (cons (read-char port) l) (+ n 1))))))) 69 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/fact2.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (foo) 4 | (fact 10) 5 | (fact 20)) 6 | 7 | (foo) 8 | (foo) 9 | (fact 5) 10 | 11 | (define *one* (unassigned)) 12 | 13 | (define-local-syntax (define-primitive id nargs) 14 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 15 | `(define (,id . ,args) 16 | (call-primitively ,id . ,args)))) 17 | 18 | (define-local-syntax (define-effect-primitive id nargs) 19 | (let ((args (reverse (list-tail '(z y x) (- '3 nargs))))) 20 | `(define (,id . ,args) 21 | (call-primitively ,id . ,args) 22 | (call-primitively undefined-value)))) 23 | 24 | (define-primitive + 2) 25 | (define-primitive - 2) 26 | (define-primitive * 2) 27 | (define-primitive < 2) 28 | 29 | ;(define-primitive quotient 2) 30 | ;(define-primitive remainder 2) 31 | 32 | (define-primitive char->ascii 1) 33 | (define-primitive ascii->char 1) 34 | 35 | (define-effect-primitive write-char 2) 36 | 37 | (define (unassigned) (call-primitively undefined-value)) 38 | 39 | (define (byte-vector-ref vec index) 40 | (call-primitively byte-contents (ptr+ vec index))) 41 | 42 | (define (byte-vector-set! vec index value) 43 | (call-primitively byte-set-contents! (ptr+ vec index) value)) 44 | 45 | (define (vector-set! vec index value) 46 | (call-primitively set-contents! (ptr+ vec (* index 4)) value)) 47 | 48 | ;(write-number-no-newline 102 port) 49 | 50 | ;(define (write-number-no-newline x port) 51 | ; (let ((x (cond ((< x 0) 52 | ; (write-char '#\- port) 53 | ; (- 0 x)) 54 | ; (else 55 | ; x)))) 56 | ; (let loop ((x x) (mask foo)) 57 | ; (let ((digit (quotient x mask))) 58 | ; (write-char (ascii->char (+ digit (char->ascii '#\0))) port) 59 | ; (if (< mask 1) 60 | ; (loop (remainder x mask) (quotient mask 10))))))) 61 | 62 | (define (fact n) 63 | (let loop ((i n) (r *one*)) 64 | (if (<= *one* i) 65 | (loop (- i *one*) (* i r)) 66 | r))) 67 | 68 | ;(define (poobah x) 69 | ; (+ x (* x (+ x (* x *two*))))) 70 | 71 | ;(define *two* 2) 72 | 73 | (define (<= x y) 74 | (not (< y x))) 75 | 76 | (define (not x) 77 | (if x #f #t)) 78 | 79 | (define (identity x) 80 | x) 81 | 82 | (define (two x) 83 | 2) -------------------------------------------------------------------------------- /ps-compiler/util/syntax.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Syntax used by the compiler 6 | 7 | ; Subrecords 8 | ; 9 | ; SUPER is the name of the existing record 10 | ; SUB is the name of the subrecord 11 | ; SLOT is the name of the slot to use in the existing sturcture 12 | ; STUFF is the usual stuff from DEFINE-RECORD-TYPE 13 | 14 | (define-syntax define-subrecord 15 | (lambda (form rename compare) 16 | (let ((super (cadr form)) 17 | (sub (caddr form)) 18 | (slot (cadddr form)) 19 | (stuff (cddddr form))) 20 | (let ((access-names (map (lambda (spec) 21 | (if (pair? spec) (car spec) spec)) 22 | (append (car stuff) (cadr stuff)))) 23 | (set-names (append (filter-map (lambda (spec) 24 | (if (pair? spec) (car spec) #f)) 25 | (car stuff)) 26 | (map (lambda (spec) 27 | (if (pair? spec) (car spec) spec)) 28 | (cadr stuff))))) 29 | `(begin (define-record-type ,sub . ,stuff) 30 | ,@(map (lambda (name) 31 | `(define ,(concatenate-symbol super '- name) 32 | (lambda (v) 33 | (,(concatenate-symbol sub '- name) 34 | (,slot v))))) 35 | access-names) 36 | ,@(map (lambda (name) 37 | `(define ,(concatenate-symbol 'set- super '- name '!) 38 | (lambda (v n) 39 | (,(concatenate-symbol 'set- sub '- name '!) 40 | (,slot v) 41 | n)))) 42 | set-names)))))) 43 | 44 | ;(define-syntax define-simple-record-type 45 | ; (lambda (form rename compare) 46 | ; (let ((name (cadr form)) 47 | ; (slots (cddr form))) 48 | ; `(begin (define-record-type ,name ,slots ()) 49 | ; (define ,(concatenate-symbol 'make- name) 50 | ; ,(concatenate-symbol name '- 'maker)))))) 51 | 52 | ; Nothing actually local about it... 53 | 54 | (define-syntax define-local-syntax 55 | (lambda (form rename compare) 56 | (let ((pattern (cadr form)) 57 | (body (cddr form))) 58 | `(,(rename 'define-syntax) ,(car pattern) 59 | (,(rename 'lambda) (form rename compare) 60 | (,(rename 'destructure) ((,(cdr pattern) 61 | (,(rename 'cdr) form))) 62 | . ,body)))))) 63 | -------------------------------------------------------------------------------- /scheme/misc/engine.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Christopher P. Haynes and Daniel P. Friedman. 5 | ; Engines build process abstractions. 6 | ; 1984 ACM Symposium on Lisp and Functional Programming, pages 18-24. 7 | 8 | ; This is incompatible with the threads package. 9 | 10 | ; ,open primitives interrupts 11 | 12 | (define interrupt/alarm (enum interrupt alarm)) 13 | 14 | (define (run thunk interval when-done when-timeout) 15 | (let ((save (vector-ref interrupt-handlers interrupt/alarm))) 16 | (let ((finish 17 | (call-with-current-continuation 18 | (lambda (k) 19 | (vector-set! interrupt-handlers 20 | interrupt/alarm 21 | (lambda (tem ei) 22 | (set-enabled-interrupts! ei) 23 | (call-with-current-continuation 24 | (lambda (resume) 25 | (k (lambda () 26 | (when-timeout (lambda () 27 | (resume #f))))))))) 28 | (schedule-interrupt interval *exponent* #f) 29 | (call-with-values thunk 30 | (lambda vals 31 | (let ((time-remaining (schedule-interrupt 0 0 #f))) 32 | (lambda () 33 | (apply when-done time-remaining vals))))))))) 34 | (vector-set! interrupt-handlers 35 | interrupt/alarm 36 | save) 37 | (finish)))) 38 | 39 | (define *exponent* -3) 40 | 41 | (define-syntax engine 42 | (syntax-rules () 43 | ((engine ?E) (%engine (lambda () ?E))))) 44 | 45 | (define (%engine thunk) 46 | (lambda (ticks done out) 47 | (run thunk 48 | ticks 49 | (lambda (ticks val) 50 | (done val ticks)) 51 | (lambda (new-thunk) 52 | (out (%engine new-thunk)))))) 53 | 54 | 55 | ; Example from the LFP '84 paper (verbatim) 56 | 57 | ;(define-syntax rec 58 | ; (syntax-rules () ((rec ?X ?E) (letrec ((?X ?E)) ?X)))) 59 | ; 60 | ;(define complete 61 | ; (lambda (eng) 62 | ; ((rec loop 63 | ; (lambda (eng count) 64 | ; (eng 1000 65 | ; (lambda (val ticks-left) 66 | ; (cons val 67 | ; (+ (- 1000 ticks-left) 68 | ; count))) 69 | ; (lambda (eng) 70 | ; (loop eng (+ count 1000)))))) 71 | ; eng 0))) 72 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/buffer.scm: -------------------------------------------------------------------------------- 1 | 2 | ; (port->stream port type) -> stream or error value 3 | ; ( 4 | ; 5 | ; 6 | ; 7 | 8 | 9 | (define-record-type stream 10 | make-stream 11 | (port port) 12 | (type int8u) 13 | (buffer int32) ; pointer the start of the buffer 14 | (size int32) 15 | (loc int32) ; pointer to the next char to be read or the next slot to 16 | ; be written 17 | (limit int32)) ; end of the available characters 18 | 19 | (define buffer-size 1024) 20 | 21 | (define (port->stream port type) 22 | (let ((buffer (allocate-memory buffer-size)) 23 | (stream (make-stream))) 24 | (if (or (null-memory? buffer) 25 | (null-pointer? stream)) 26 | (error "out of memory")) 27 | (set-stream-port! stream port) 28 | (set-stream-type! stream type) 29 | (set-stream-buffer! stream buffer) 30 | (set-stream-size! stream buffer-size) 31 | (set-stream-loc! stream buffer) 32 | (set-stream-limit! stream buffer) 33 | buffer)) 34 | 35 | (define (stream-read-char stream) 36 | (let ((loc (stream-loc stream))) 37 | (cond ((< loc (stream-limit stream)) 38 | (let ((ch (unsigned-byte-ref loc))) 39 | (set-stream-loc! stream (+ 1 (stream-loc stream))) 40 | ch)) 41 | (else 42 | (let* ((buffer (stream-buffer stream)) 43 | (count (read-block (stream-port stream) 44 | buffer 45 | (stream-size stream)))) 46 | (cond ((= count 0) ; EOF 47 | 0) 48 | (else 49 | (set-stream-loc! stream (+ buffer 1)) 50 | (set-stream-limit! stream (+ buffer count)) 51 | (unsigned-byte-ref buffer)))))))) 52 | 53 | ; this will need to be PCLUSR'd. 54 | 55 | (define (stream-write-char stream char) 56 | (let ((loc (stream-loc stream))) 57 | (cond ((< loc (stream-limit stream)) 58 | (unsigned-byte-set! loc char) 59 | (set-stream-loc! stream (+ 1 (stream-loc stream)))) 60 | (else 61 | (let* ((buffer (stream-buffer stream)) 62 | (count (write-block (stream-port stream) 63 | buffer 64 | (stream-limit stream)))) 65 | (cond ((= count 0) ; EOF 66 | 0) 67 | (else 68 | (set-stream-loc! stream (+ buffer 1)) 69 | (set-stream-limit! stream (+ buffer count)) 70 | (unsigned-byte-ref buffer)))))))) 71 | -------------------------------------------------------------------------------- /scheme/rts/condition.scm: -------------------------------------------------------------------------------- 1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*- 2 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 3 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 4 | 5 | 6 | ; This is file condition.scm. 7 | 8 | ;;;; Condition hierarchy 9 | 10 | ; General design copied from gnu emacs. 11 | 12 | (define *condition-types* '()) 13 | 14 | (define (condition-supertypes type) 15 | (assq type *condition-types*)) 16 | 17 | (define (define-condition-type type supertypes) 18 | (set! *condition-types* 19 | (cons (cons type (apply append 20 | (map (lambda (sup) 21 | (or (condition-supertypes sup) 22 | (error "unrecognized condition type" 23 | sup))) 24 | supertypes))) 25 | *condition-types*))) 26 | 27 | (define (condition-predicate name) 28 | (lambda (c) 29 | (and (pair? c) 30 | (let ((probe (condition-supertypes (car c)))) 31 | (if probe 32 | (if (memq name probe) #t #f) 33 | #f))))) 34 | 35 | (define (condition? x) 36 | (and (pair? x) 37 | (list? x) 38 | (condition-supertypes (car x)))) 39 | (define condition-type car) 40 | (define condition-stuff cdr) 41 | 42 | 43 | ; Errors 44 | 45 | (define-condition-type 'error '()) 46 | (define error? (condition-predicate 'error)) 47 | 48 | (define-condition-type 'call-error '(error)) 49 | (define call-error? (condition-predicate 'call-error)) 50 | 51 | (define-condition-type 'read-error '(error)) 52 | (define read-error? (condition-predicate 'read-error)) 53 | 54 | ; Exceptions 55 | 56 | (define-condition-type 'exception '(error)) 57 | (define exception? (condition-predicate 'exception)) 58 | (define exception-opcode cadr) 59 | (define exception-reason caddr) 60 | (define exception-arguments cdddr) 61 | 62 | (define (make-exception opcode reason args) 63 | (make-condition 'exception (cons opcode (cons reason args)))) 64 | 65 | 66 | ; Warnings 67 | 68 | (define-condition-type 'warning '()) 69 | (define warning? (condition-predicate 'warning)) 70 | 71 | (define-condition-type 'syntax-error '(warning)) 72 | (define syntax-error? (condition-predicate 'syntax-error)) 73 | 74 | 75 | ; Interrupts 76 | 77 | (define-condition-type 'interrupt '()) 78 | (define interrupt? (condition-predicate 'interrupt)) 79 | -------------------------------------------------------------------------------- /scheme/debug/mini-package.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Miniature package system. This links mini-eval up to the output of 6 | ; the package reifier. 7 | 8 | (define (package names locs get-location uid) ;Reified package 9 | (lambda (name) 10 | (let loop ((i (- (vector-length names) 1))) 11 | (if (< i 0) 12 | (error "unbound" name) 13 | (if (eq? name (vector-ref names i)) 14 | (contents (get-location (vector-ref locs i))) 15 | (loop (- i 1))))))) 16 | 17 | (define (make-simple-package opens foo1 foo2 name) 18 | 19 | (define bindings 20 | (list (cons '%%define%% 21 | (lambda (name val) 22 | (set! bindings (cons (cons name val) bindings)))))) 23 | 24 | (lambda (name) 25 | (let ((probe (assq name bindings))) 26 | (if probe 27 | (cdr probe) 28 | (let loop ((opens opens)) 29 | (if (null? opens) 30 | (error "unbound" name) 31 | (if (memq name (structure-interface (car opens))) 32 | ((structure-package (car opens)) name) 33 | (loop (cdr opens))))))))) 34 | 35 | ; Structures 36 | 37 | (define (make-structure package interface . name-option) 38 | (cons package (vector->list interface))) 39 | 40 | (define structure-interface cdr) 41 | (define structure-package car) 42 | 43 | 44 | ; Things used by reification forms 45 | 46 | (define (operator name type-exp) 47 | `(operator ,name ,type-exp)) 48 | 49 | (define (simple-interface names type) names) 50 | 51 | ; Etc. 52 | 53 | (define (transform . rest) (cons 'transform rest)) 54 | (define (usual-transform . rest) 55 | (cons 'usual-transform rest)) 56 | 57 | (define (transform-for-structure-ref . rest) 58 | (cons 'transform-for-structure-ref rest)) 59 | (define (inline-transform . rest) 60 | (cons 'inline-transform rest)) 61 | (define (primop . rest) 62 | (cons 'primop rest)) 63 | 64 | (define (package-define-static! package name op) 'lose) 65 | 66 | ; -------------------- 67 | ; ??? 68 | 69 | ; (define (integrate-all-primitives! . rest) 'lose) 70 | 71 | ;(define (package-lookup p name) 72 | ; ((p '%%lookup-operator%%) name)) 73 | 74 | ;(define (package-ensure-defined! p name) 75 | ; (package-define! p name (make-location 'defined name))) 76 | 77 | -------------------------------------------------------------------------------- /scheme/big/destructure.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; This is a destructuring version of LET. 5 | ; (DESTRUCTURE (( ) ...) body ...) 6 | ; The patterns can be: 7 | ; identifiers, which are bound to the corresponding part of the value 8 | ; lists of patterns (including dotted pairs) 9 | ; vectors of patterns 10 | ; 11 | ; Bug (?): (destructure (((a) '(1 2))) ...) works. The code does not check 12 | ; to see if there are more elements than the minimum number required. 13 | 14 | (define-syntax destructure 15 | (lambda (form rename compare) 16 | (let ((specs (cadr form)) 17 | (body (cddr form)) 18 | (%car (rename 'car)) 19 | (%cdr (rename 'cdr)) 20 | (%vref (rename 'vector-ref)) 21 | (%let* (rename 'let*)) 22 | (gensym (lambda (i) 23 | (rename (string->symbol 24 | (string-append "x" (number->string i)))))) 25 | (atom? (lambda (x) (not (pair? x))))) 26 | (letrec ((expand-pattern 27 | (lambda (pattern value i) 28 | (cond ((or (not pattern) (null? pattern)) 29 | '()) 30 | ((vector? pattern) 31 | (let ((xvalue (if (atom? value) 32 | value 33 | (gensym i)))) 34 | `(,@(if (eq? value xvalue) '() `((,xvalue ,value))) 35 | ,@(expand-vector pattern xvalue i)))) 36 | ((atom? pattern) 37 | `((,pattern ,value))) 38 | (else 39 | (let ((xvalue (if (atom? value) 40 | value 41 | (gensym i)))) 42 | `(,@(if (eq? value xvalue) '() `((,xvalue ,value))) 43 | ,@(expand-pattern (car pattern) 44 | `(,%car ,xvalue) 45 | (+ i 1)) 46 | ,@(if (null? (cdr pattern)) 47 | '() 48 | (expand-pattern (cdr pattern) 49 | `(,%cdr ,xvalue) 50 | (+ i 1))))))))) 51 | (expand-vector 52 | (lambda (vec xvalue i) 53 | (do ((j (- (vector-length vec) 1) (- j 1)) 54 | (ps '() (append (expand-pattern (vector-ref vec j) 55 | `(,%vref ,xvalue ,j) 56 | (+ i 1)) 57 | ps))) 58 | ((< j 0) ps))))) 59 | (do ((specs specs (cdr specs)) 60 | (res '() (append (expand-pattern (caar specs) (cadar specs) 0) 61 | res))) 62 | ((null? specs) 63 | `(,%let* ,res . ,body))))))) 64 | 65 | -------------------------------------------------------------------------------- /scheme/prescheme/interface.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. 2 | 3 | (define-interface prescheme-interface 4 | (export ((if begin lambda letrec quote set! 5 | define define-syntax let-syntax 6 | and cond case do let let* or 7 | quasiquote 8 | ;syntax-rules 9 | ) :syntax) ; no delay 10 | ;; letrec-syntax -- not yet implemented 11 | 12 | (goto :syntax) 13 | (external :syntax) 14 | 15 | ((define-enumeration define-external-enumeration enum) :syntax) 16 | ((name->enumerand enumerand->name) :syntax) ; loadtime only 17 | 18 | not 19 | 20 | eq? 21 | + - * = < ; / 22 | <= > >= 23 | abs 24 | expt 25 | quotient remainder 26 | ; floor numerator denominator 27 | ; real-part imag-part 28 | ; exp log sin cos tan asin acos atan sqrt 29 | ; angle magnitude make-polar make-rectangular 30 | min max 31 | char=? charchar char->ascii 57 | 58 | shift-left arithmetic-shift-right logical-shift-right 59 | bitwise-and bitwise-ior bitwise-xor bitwise-not 60 | unspecific 61 | error 62 | )) 63 | 64 | ; memory (malloc and free) 65 | 66 | (define-interface ps-memory-interface 67 | (export allocate-memory 68 | deallocate-memory 69 | 70 | unsigned-byte-ref unsigned-byte-set! 71 | word-ref word-set! 72 | 73 | address? 74 | null-address null-address? 75 | 76 | address+ address- address-difference 77 | address= address< address<= address> address>= 78 | address->integer integer->address 79 | 80 | copy-memory! memory-equal? 81 | 82 | char-pointer->string char-pointer->nul-terminated-string 83 | 84 | read-block write-block)) 85 | 86 | (define-interface ps-receive-interface 87 | (export receive)) 88 | 89 | -------------------------------------------------------------------------------- /scheme/big/linked-queue.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; This file is no longer used. 5 | 6 | ; Queues implemented as doubly linked lists (because the thread package needs 7 | ; to delete queue entries quickly). 8 | 9 | ; The exported procedures are those of the simpler queue package, with the 10 | ; addition of DELETE-QUEUE-ENTRY!. ENQUEUE! returns a queue-entry which can 11 | ; then be passed to DELETE-QUEUE-ENTRY! to remove the thing from the queue. 12 | 13 | (define-record-type q-entry :q-entry 14 | (make-q-entry data prev next) 15 | q-entry? 16 | (data q-entry-data) 17 | (prev q-entry-prev set-q-entry-prev!) 18 | (next q-entry-next set-q-entry-next!)) 19 | 20 | (define queue? q-entry?) 21 | 22 | (define (make-queue) 23 | (let ((e (make-q-entry #f #f #f))) 24 | (set-q-entry-prev! e e) 25 | (set-q-entry-next! e e) 26 | e)) 27 | 28 | (define (queue-empty? q) 29 | (eq? (q-entry-next q) q)) 30 | 31 | (define (enqueue! q thing) 32 | (let* ((prev (q-entry-prev q)) 33 | (e (make-q-entry thing prev q))) 34 | (set-q-entry-prev! q e) 35 | (set-q-entry-next! prev e) 36 | e)) 37 | 38 | (define (queue-head q) 39 | (let ((e (q-entry-next q))) 40 | (if (eq? q e) ;(queue-empty? q) 41 | (error "empty queue" q) 42 | (q-entry-data e)))) 43 | 44 | (define (dequeue! q) 45 | (let ((e (q-entry-next q))) 46 | (cond ((eq? q e) ;(queue-empty? q) 47 | (error "empty queue" q)) 48 | (else 49 | (set-q-entry-next! q (q-entry-next e)) 50 | (set-q-entry-prev! (q-entry-next q) q) 51 | (q-entry-data e))))) 52 | 53 | (define (delete-queue-entry! e) 54 | (let ((next (q-entry-next e)) 55 | (prev (q-entry-prev e))) 56 | (set-q-entry-next! prev next) 57 | (set-q-entry-prev! next prev))) 58 | 59 | (define (queue->list q) 60 | (do ((e (q-entry-prev q) (q-entry-prev e)) 61 | (l '() (cons (q-entry-data e) l))) 62 | ((eq? q e) l))) 63 | 64 | (define (queue-length q) 65 | (do ((e (q-entry-prev q) (q-entry-prev e)) 66 | (l 0 (+ l 1))) 67 | ((eq? q e) l))) 68 | 69 | (define (delete-from-queue! q v) 70 | (let loop ((e (q-entry-next q))) 71 | (cond ((eq? e q)) 72 | ((eq? (q-entry-data e) v) 73 | (delete-queue-entry! e)) 74 | (else 75 | (loop (q-entry-next e)))))) 76 | -------------------------------------------------------------------------------- /scheme/env/dispcond.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | 6 | ; Displaying conditions 7 | 8 | (define display-condition 9 | (let ((display display) (newline newline)) 10 | (lambda (c port) 11 | (if (ignore-errors (lambda () 12 | (newline port) 13 | (really-display-condition c port) 14 | #f)) 15 | (begin (display "" port) 16 | (newline port)))))) 17 | 18 | (define (really-display-condition c port) 19 | (let* ((stuff (disclose-condition c)) 20 | (stuff (if (and (list? stuff) 21 | (not (null? stuff)) 22 | (symbol? (car stuff))) 23 | stuff 24 | (list 'condition stuff)))) 25 | (display-type-name (car stuff) port) 26 | (if (not (null? (cdr stuff))) 27 | (begin (display ": " port) 28 | (let ((message (cadr stuff))) 29 | (if (string? message) 30 | (display message port) 31 | (limited-write message port *depth* *length*))) 32 | (let ((spaces 33 | (make-string (+ (string-length 34 | (symbol->string (car stuff))) 35 | 2) 36 | #\space))) 37 | (for-each (lambda (irritant) 38 | (newline port) 39 | (display spaces port) 40 | (limited-write irritant port *depth* *length*)) 41 | (cddr stuff))))) 42 | (newline port))) 43 | 44 | (define *depth* 5) 45 | (define *length* 6) 46 | 47 | (define-generic disclose-condition &disclose-condition) 48 | 49 | (define-method &disclose-condition (c) c) 50 | 51 | 52 | 53 | (define (limited-write obj port max-depth max-length) 54 | (let recur ((obj obj) (depth 0)) 55 | (if (and (= depth max-depth) 56 | (not (or (boolean? obj) 57 | (null? obj) 58 | (number? obj) 59 | (symbol? obj) 60 | (char? obj) 61 | (string? obj)))) 62 | (display "#" port) 63 | (call-with-current-continuation 64 | (lambda (escape) 65 | (recurring-write obj port 66 | (let ((count 0)) 67 | (lambda (sub) 68 | (if (= count max-length) 69 | (begin (display "---" port) 70 | (write-char 71 | (if (or (pair? obj) (vector? obj)) 72 | #\) 73 | #\}) 74 | port) 75 | (escape #t)) 76 | (begin (set! count (+ count 1)) 77 | (recur sub (+ depth 1)))))))))))) 78 | 79 | -------------------------------------------------------------------------------- /scheme/bcomp/optimize.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1998 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Optimizers 5 | 6 | (define optimizers-table (make-table)) 7 | 8 | (define (set-optimizer! name opt) 9 | (table-set! optimizers-table name opt)) 10 | 11 | (define (get-optimizer names) 12 | (lambda (forms package) 13 | (apply-optimizers (map (lambda (name) 14 | (or (table-ref optimizers-table name) 15 | (begin 16 | (signal 'note 17 | "optional optimization pass not invoked" 18 | name) 19 | (lambda (forms) forms)))) 20 | names) 21 | forms 22 | package))) 23 | 24 | (define (apply-optimizers optimizers forms package) 25 | (fold (lambda (optimizer forms) 26 | (optimizer forms package)) 27 | optimizers 28 | forms)) 29 | 30 | ;---------------- 31 | ; The following is all for Kali and isn't currently used. 32 | ; 33 | ; List of optimization passes that are always used. 34 | 35 | (define *standard-optimizer-names* '()) 36 | 37 | ; The default optimizer for the REPL, EVAL, etc. 38 | 39 | (define (default-standard-optimizer forms filename p) 40 | forms) 41 | 42 | ; The optimizer for the REPL, EVAL etc. 43 | 44 | (define *standard-optimizer* default-standard-optimizer) 45 | 46 | ; Set the optimizers that are used for all compilations. 47 | ; 48 | ; Don't use the normal expand optimizer for the REPL because it saves type 49 | ; information which may become inaccurate (because we don't have the whole 50 | ; source yet). 51 | ; 52 | ; Optimizers take a list of nodes and a package and return a similar list. 53 | 54 | (define (set-standard-optimizers! . optimizer-names) 55 | (set! *standard-optimizer-names* optimizer-names) 56 | (set! *standard-optimizer* (get-optimizers optimizer-names))) 57 | 58 | (define (get-optimizers names) 59 | (map (lambda (name) 60 | (or (table-ref optimizers-table name) 61 | (error "standard optimizer not found" name))) 62 | names)) 63 | 64 | ; The standard optimizer has to convert a list of forms into the format the 65 | ; optimizers expect and then convert the result back into a list of forms. 66 | 67 | (define (make-standard-optimizer optimizer-names) 68 | (let ((optimizers (get-optimizers optimizer-names))) 69 | (lambda (forms package) 70 | (apply-optimizers optimizers forms package)))) 71 | 72 | -------------------------------------------------------------------------------- /scheme/link-packages.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; Static linker. Doesn't work very well this way (debug info is 6 | ; screwed up), so it's probably better to continue using linker.image 7 | ; instead. 8 | 9 | (define-structure linker linker-interface 10 | (open scheme-level-2 11 | compiler write-images 12 | debuginfo 13 | segments ;with-fresh-compiler-state 14 | packages 15 | packages-internal ;set-package-integrate?! 16 | names ;name->symbol 17 | scan-package ;collect-packages 18 | compile-packages ;compile-package 19 | reification 20 | closures ;make closure to pass to write-image 21 | filenames 22 | debug-data ;with-fresh-compiler-state 23 | locations 24 | tables fluids signals util) 25 | (files (link link))) 26 | 27 | (define-structure reification (export reify-structures) 28 | (open scheme-level-2 29 | packages 30 | packages-internal ;? 31 | usual-macros ;find-free-names-in-syntax-rules 32 | names bindings 33 | meta-types ;usual-variable-type 34 | locations 35 | primops 36 | tables records 37 | signals ;error 38 | features ;force-output 39 | util ;filter 40 | inline) ;name->extrinsic 41 | (files (link reify))) 42 | 43 | ; Database of procedure names 'n' stuff. 44 | ; (copy in more-packages.scm ...) 45 | 46 | (define-structure debuginfo debuginfo-interface 47 | (open scheme-level-2 48 | tables 49 | debug-data 50 | packages 51 | packages-internal 52 | syntactic 53 | segments ;debug-data-table 54 | features) ;make-immutable! 55 | (files (env debuginfo))) 56 | 57 | 58 | ; Mumble. 59 | 60 | (define-structure flatloading (export flatload all-file-names) 61 | (open scheme packages packages-internal filenames) 62 | (files (env flatload))) 63 | 64 | (define-structure loadc (export load-configuration 65 | ;; (structure-ref :syntax) 66 | ) 67 | (open scheme 68 | environments ; *structure-ref 69 | syntactic ; $source-file-name 70 | fluids) 71 | (files (link loadc))) 72 | 73 | 74 | ; Everything. 75 | 76 | (define-structure link-config (export ) ;dummy structure... 77 | (open scheme-level-2 78 | linker 79 | defpackage 80 | types 81 | analysis 82 | loadc 83 | flatloading 84 | interfaces 85 | signals) ;warn 86 | ;; (files (alt init-defpackage.scm)) -- or (env ...), depending 87 | ) 88 | -------------------------------------------------------------------------------- /scheme/rts/current-port.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | ; Current input, output, error, and noise ports. 5 | 6 | ; These two ports are needed by the VM for the READ-CHAR and WRITE-CHAR 7 | ; opcodes. 8 | (define $current-input-port (enum current-port-marker current-input-port)) 9 | (define $current-output-port (enum current-port-marker current-output-port)) 10 | 11 | (define $current-error-port (make-fluid #f)) 12 | (define $current-noise-port (make-fluid #f)) ; defaults to the error port 13 | 14 | (define (current-input-port) 15 | (fluid $current-input-port)) 16 | 17 | (define (current-output-port) 18 | (fluid $current-output-port)) 19 | 20 | (define (current-error-port) 21 | (fluid $current-error-port)) 22 | 23 | (define (current-noise-port) 24 | (fluid $current-noise-port)) 25 | 26 | (define (initialize-i/o input output error thunk) 27 | (with-current-ports input output error thunk)) 28 | 29 | (define (with-current-ports in out error thunk) 30 | (let-fluids $current-input-port in 31 | $current-output-port out 32 | $current-error-port error 33 | $current-noise-port error 34 | thunk)) 35 | 36 | (define (call-with-current-input-port port thunk) 37 | (let-fluid $current-input-port port thunk)) 38 | 39 | (define (call-with-current-output-port port thunk) 40 | (let-fluid $current-output-port port thunk)) 41 | 42 | (define (call-with-current-noise-port port thunk) 43 | (let-fluid $current-noise-port port thunk)) 44 | 45 | (define (silently thunk) 46 | (call-with-current-noise-port (make-null-output-port) thunk)) 47 | 48 | ;---------------- 49 | ; Procedures with default port arguments. 50 | 51 | (define (newline . port-option) 52 | (write-char #\newline (output-port-option port-option))) 53 | 54 | (define (char-ready? . port-option) 55 | (real-char-ready? (input-port-option port-option))) 56 | 57 | (define (output-port-option port-option) 58 | (cond ((null? port-option) (current-output-port)) 59 | ((null? (cdr port-option)) (car port-option)) 60 | (else (error "write-mumble: too many arguments" port-option)))) 61 | 62 | (define (input-port-option port-option) 63 | (cond ((null? port-option) (current-input-port)) 64 | ((null? (cdr port-option)) (car port-option)) 65 | (else (error "read-mumble: too many arguments" port-option)))) 66 | 67 | -------------------------------------------------------------------------------- /ps-compiler/prescheme/test/prescheme.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #define PS_READ_CHAR(PORT,RESULT,EOFP,STATUS) \ 4 | { \ 5 | FILE * TTport = PORT; \ 6 | int TTchar; \ 7 | if (EOF == (TTchar = getc(TTport))) \ 8 | RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==1);\ 9 | else { \ 10 | RESULT = TTchar; \ 11 | EOFP = 0; \ 12 | STATUS = 0; } \ 13 | } 14 | 15 | #define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS) \ 16 | { \ 17 | FILE * TTport = PORT; \ 18 | int TTchar; \ 19 | if (EOF == (TTchar = getc(TTport))) \ 20 | RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==0);\ 21 | else { \ 22 | RESULT = TTchar; \ 23 | ungetc(RESULT, TTport); \ 24 | EOFP = 0; \ 25 | STATUS = 0; } \ 26 | } 27 | 28 | #define PS_READ_INTEGER(PORT,RESULT,EOFP,STATUS) \ 29 | RESULT = ps_read_integer(PORT,&EOFP,&STATUS); 30 | 31 | #define PS_WRITE_CHAR(CHAR,PORT,STATUS) \ 32 | { \ 33 | FILE * TTport = PORT; \ 34 | char TTchar = CHAR; \ 35 | if (EOF == putc(TTchar,TTport)) \ 36 | STATUS = ps_write_char(TTchar,TTport); \ 37 | else { \ 38 | STATUS = 0; } \ 39 | } 40 | 41 | extern FILE *ps_open_input_file(unsigned char *, long *); 42 | extern FILE *ps_open_output_file(unsigned char *, long *); 43 | extern long ps_close(FILE *); 44 | extern char ps_read_char(FILE *, unsigned char *, long *, char); 45 | extern long ps_read_integer(FILE *, unsigned char *, long *); 46 | extern long ps_write_char(char, FILE *); 47 | extern long ps_write_integer(long, FILE *); 48 | extern long ps_write_string(unsigned char *, FILE *); 49 | extern long ps_read_block(FILE *, char *, long, unsigned char *, long *); 50 | extern long ps_write_block(FILE *, char *, long); 51 | extern unsigned char *ps_error_string(long); 52 | extern void ps_error(unsigned char *, ...); 53 | 54 | /* C shifts may not work if the amount is greater than the machine word size */ 55 | /* Patched by JAR 6/6/93 */ 56 | 57 | #define PS_SHIFT_RIGHT(X,Y,RESULT) \ 58 | { \ 59 | long TTx = X, TTy = Y; \ 60 | RESULT = TTy >= 32 ? (TTx < 0 ? -1 : 0) : TTx >> TTy; \ 61 | } 62 | 63 | #define PS_SHIFT_LEFT(X,Y,RESULT) \ 64 | { \ 65 | long TTy = Y; \ 66 | RESULT = TTy >= 32 ? 0 : X << TTy; \ 67 | } 68 | 69 | extern long TTreturn_value, TTrun_machine(); 70 | 71 | -------------------------------------------------------------------------------- /scheme/debug/mumble-packages.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 2 | ; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING. 3 | 4 | 5 | ; This is for version 0.28 6 | ; We define these two because they aren't reified: 7 | ; scheme-level-0 8 | ; silly 9 | 10 | ; We redefine these two so as not to compromise the security of the 11 | ; built-in exception and interrupt systems: 12 | ; primitives 13 | ; signals 14 | 15 | 16 | ; Suppose you have just done "make image" to build the scheme48 heap image. 17 | ; Suppose that the linker produces an initial.image, but that when that 18 | ; image is resumed you get the error 19 | ; exception handler is not a closure 20 | ; This is not informative. To find out what really happened, you have 21 | ; two choices: 22 | ; (1) Run the image under the VM running in Scheme. 23 | ; (2) Run the image using the following handy dandy tool. 24 | ; For choice (2), you would do something like the following: 25 | ; 26 | ; ,translate =scheme48/ ./ 27 | ; ,config ,load debug/mumble-packages.scm 28 | ; ,in link-config 29 | ; y 30 | ; ;; Cf. Makefile rule for initial.image 31 | ; ,load interfaces.scm packages.scm debug/fix-low.scm 32 | ; (flatload initial-structures) 33 | ; ,load initial.scm 34 | ; (define test (link-initial-system)) 35 | 36 | ; primitives-internal 37 | ; ,open ## 38 | 39 | ; Replacement for the structure defined in link-packages.scm 40 | (define-structure linker (export link-simple-system 41 | link-reified-system 42 | (struct-list :syntax)) 43 | (open scheme 44 | packages ;make-simple-package 45 | reification 46 | ensures-loaded 47 | ) ; (enum interrupt keyboard) 48 | (files linker)) 49 | 50 | ; Copied from link-packages.scm 51 | (define-structure loadc (export load-configuration 52 | (structure-ref :syntax)) 53 | (open scheme 54 | environments ; *structure-ref 55 | fluids) 56 | (files ((".." link) loadc))) 57 | 58 | ; Replacement for the structure defined in link-packages.scm 59 | 60 | (define-structure link-config (export ) ;dummy structure... 61 | (open scheme 62 | linker 63 | ;; low-structures 64 | ;; start-debugging 65 | defpackage 66 | types 67 | analysis 68 | structure-refs ;the real one 69 | loadc ;defines structure-ref, but not the one we want 70 | flatloading 71 | ensures-loaded 72 | interfaces) 73 | (access built-in-structures) 74 | (begin 0)) 75 | -------------------------------------------------------------------------------- /doc/package.txt: -------------------------------------------------------------------------------- 1 | -- this file is probably obsolete -- 2 | 3 | The package system interface. Much too complicated. 4 | 5 | Signatures 6 | 7 | make-simple-signature 8 | make-compound-signature 9 | signature? 10 | signature-ref 11 | signature-walk 12 | 13 | Structures 14 | 15 | make-structure 16 | structure? 17 | structure-signature 18 | structure-package 19 | structure-name 20 | 21 | Packages 22 | 23 | make-package 24 | make-simple-package ;start.scm 25 | 26 | Lookup and definition operations 27 | 28 | package-lookup 29 | package-lookup-type ;comp.scm 30 | package-find-location ;rts/env.scm 31 | package-lookup-location ;segment.scm 32 | probe-package 33 | package-check-assigned 34 | package-check-variable 35 | 36 | package-define! 37 | package-define-type! ;hmm. 38 | package-ensure-defined! 39 | 40 | Things needed by the form/file/package scanner 41 | 42 | for-each-definition ;for integrate-all-primitives! 43 | package-accesses ;for scan-package 44 | package-clauses ;for scan-package 45 | package-file-name ;for scan-package 46 | package-opens ;for scan-package 47 | package-evaluator ;for define-syntax 48 | package-for-syntax ;for define-syntax 49 | 50 | Miscellaneous 51 | 52 | $note-undefined ;eval.scm 53 | noting-undefined-variables ;eval.scm, etc. 54 | package-uid ;eval.scm 55 | set-shadow-action! ;eval.scm 56 | verify-later! ;for the define-structures macro 57 | reset-packages-state! ;Makefile - for linker 58 | initialize-reified-package! ;for reification 59 | transform-for-structure-ref ;for reification ? 60 | 61 | Inessential (for package mutation, programming environment) 62 | 63 | check-structure 64 | package-integrate? ;env/debug.scm 65 | set-package-integrate?! ;env/debug.scm 66 | package-loaded? ;env/load-package.scm 67 | set-package-loaded?! ;env/load-package.scm 68 | package-name ;env/command.scm 69 | package-name-table ;env/debuginfo.scm 70 | package-open! ;env/debug.scm 71 | package-system-sentinel ;env/command.scm 72 | package-unstable? ;env/pacman.scm 73 | package? ;env/command.scm 74 | undefined-variables ;env/debug.scm 75 | 76 | Location names (also inessential) 77 | 78 | flush-location-names 79 | location-name 80 | location-name-table 81 | location-package-name 82 | -------------------------------------------------------------------------------- /doc/scheme48.man: -------------------------------------------------------------------------------- 1 | .TH LS48 1 2 | .\" File scheme48.man: Manual page template for Scheme 48. 3 | .\" Replace LS48 with the name of your default image and LLIB with the 4 | .\" directory containing scheme48vm and default image. 5 | .SH NAME 6 | LS48 \- a Scheme interpreter 7 | .SH SYNOPSIS 8 | .B LS48 9 | [-i image] [-h heapsize] [-a argument] 10 | .SH DESCRIPTION 11 | .B LS48 12 | is an implementation of the Scheme programming language as described in 13 | the 14 | .I "Revised^4 Report on the Algorithmic Language Scheme." 15 | A runnable system requires two parts, an executable program that implements 16 | the Scheme 48 virtual machine, and an image that is used to initialize 17 | the store of the virtual machine. 18 | .B LS48 19 | is a shell script that starts the virtual machine with an image that runs 20 | in a Scheme command loop. 21 | .PP 22 | The 23 | .B LS48 24 | command loop reads Scheme expressions, 25 | evaluates them, and prints their results. 26 | It also executes commands, which are identified by an initial comma character. 27 | Type the command 28 | .I ,help 29 | to receive a list of available commands. 30 | .PP 31 | The 32 | .B \-h 33 | option causes 34 | .IR heapsize 35 | words to be allocated for both semispaces of the copying garbage 36 | collector. One word is four bytes. Cons cells are currently 3 words, 37 | so if you want to make sure you can allocate, say, a million cons 38 | cells, you should specify 39 | .B \-h 40 | 6000000 (actually a little more, to account for the initial heap 41 | image and breathing room). 42 | .PP 43 | The 44 | .I ,dump 45 | and 46 | .I ,build 47 | commands put heap images in files. 48 | The 49 | .B \-i 50 | option causes the initial heap image to be taken from file 51 | .IR image . 52 | The 53 | .B \-a 54 | option causes a list of strings to be passed as the argument 55 | to an image generated using the 56 | .I ,build 57 | command. The first argument to 58 | .I ,build 59 | is a procedure that is passed 60 | the arguments following 61 | .B \-a 62 | and which should return an integer (which is the 63 | return value of the Scheme 48 process). 64 | .PP 65 | .nf 66 | > ,build (lambda (a) (display a) (newline) 0) foo.image 67 | > ,exit 68 | $ LS48 -i foo.image -a mumble 69 | mumble 70 | $ 71 | .PP 72 | .fi 73 | .SH FILES 74 | .TP 40 75 | .B LLIB/scheme48vm 76 | the virtual machine. 77 | .TP 78 | .B LLIB/LS48.image 79 | the default image. 80 | .SH BUGS 81 | Procedure calls with more than 63 explicit arguments might not work. 82 | --------------------------------------------------------------------------------