├── LICENSE
├── README.md
└── src
    ├── _loader.lisp
    ├── alpha.pso
    ├── alpha.scm
    ├── bootit.scm
    ├── builtin.pso
    ├── builtin.scm
    ├── classes.pso
    ├── classes.scm
    ├── classify.pso
    ├── classify.scm
    ├── clever.lisp
    ├── closed.pso
    ├── core.lisp
    ├── custom.lisp
    ├── defrecord.scm
    ├── derive.pso
    ├── derive.scm
    ├── emit.pso
    ├── emit.scm
    ├── eval.lisp
    ├── fixup.sh
    ├── form.pso
    ├── form.scm
    ├── generate.pso
    ├── generate.scm
    ├── jar-defrecord.scm
    ├── kludge.lisp
    ├── list.pso
    ├── list.scm
    ├── loadit.lisp
    ├── module.pso
    ├── module.scm
    ├── node.pso
    ├── node.scm
    ├── p-record.pso
    ├── p-record.scm
    ├── p-utils.pso
    ├── p-utils.scm
    ├── pack.lisp
    ├── pseudo.lisp
    ├── pseudoscheme-features.scm
    ├── pseudoscheme-record.scm
    ├── purify.lisp
    ├── read.pso
    ├── read.scm
    ├── readwrite.lisp
    ├── reify.pso
    ├── reify.scm
    ├── rts.lisp
    ├── rules.pso
    ├── rules.scm
    ├── s48-socket.scm
    ├── s48-table.scm
    ├── s48-threads.scm
    ├── schemify.pso
    ├── schemify.scm
    ├── sicp.scm
    ├── spack.lisp
    ├── ssig.pso
    ├── ssig.scm
    ├── strategy.pso
    ├── strategy.scm
    ├── translate.pso
    ├── translate.scm
    ├── translator.files
    ├── version.pso
    ├── version.scm
    ├── write.pso
    └── write.scm


/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright 1986-2005 Jonathan A. Rees. All rights reserved.
 2 | 
 3 | Redistribution and use in source and binary forms, with or without
 4 | modification, are permitted provided that the following conditions are
 5 | met:
 6 | 
 7 |    1. Redistributions of source code must retain the above copyright
 8 |       notice, this list of conditions and the following disclaimer.
 9 | 
10 |    2. Redistributions in binary form must reproduce the above
11 |       copyright notice, this list of conditions and the following
12 |       disclaimer in the documentation and/or other materials provided
13 |       with the distribution.
14 | 
15 | THIS SOFTWARE IS PROVIDED BY <COPYRIGHT HOLDER> ''AS IS'' AND ANY
16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
18 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> OR
19 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
20 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
21 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
22 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
24 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
25 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
26 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # Pseudoscheme - Scheme to Common Lisp
 2 | 
 3 | Pseudoscheme is an implementation of Scheme on top of Common Lisp.  It
 4 | lacks upward continuations and full tail recursion (some special cases
 5 | are supported for loops) - thus the "pseudo".  Otherwise the language
 6 | implemented is [Revised^4 Scheme report
 7 | Scheme](https://dspace.mit.edu/handle/1721.1/6424).
 8 | 
 9 | Pseudocheme consists primarily of a Scheme to Common Lisp translator
10 | that is written in Scheme.  To obtain a version of the translator that
11 | runs in Common Lisp, it is applied to itself.  That is the origin of
12 | the `.pso` (Pseudoscheme output or object) files in the distribution.
13 | 
14 | ## How to use
15 | 
16 | To load, assuming cwd is the pseudoscheme src dir.
17 | 
18 | ```lisp
19 | (load "loadit.lisp")
20 | (load-pseudoscheme)
21 | ```
22 | 
23 | The main issue running it in slime is the readtable. To make it work, 
24 | change to the scheme package in the listener then use the scheme package.
25 | 
26 | ```lisp
27 | (setq *readtable* ps::roadblock-readtable)
28 | (in-package :scheme)
29 | ```
30 | Then use slime eval functions in the buffer you are editing in. 
31 | `slime-load-file` doesn't work (yet).
32 | 
33 | (Looks like `ps:enter-scheme` should work to set `*package*` and
34 | `*readtable*`, and `ps:exit-scheme` to restore them to their 
35 | previous values.  See `eval.lisp`.)
36 | 
37 | ## Acknowledgments
38 | 
39 | Thanks to
40 |  * Alan Ruttenberg for updates in 2019
41 |  * Zach Beane for prodding in 2011 (version 2.13b)
42 |  * Oleg Trott for updates in 2005? (version 2.13a)
43 |  * Hannu Koivisto for updates in ... when, maybe 2001? (2.13)
44 |  * many others over the years
45 | 
46 | ## History
47 | 
48 | This repository was initially populated in December 2019 from version
49 | 2.13b, accessed from https://mumble.net/~jar/pseudoscheme/ - see that
50 | page for more information.
51 | 
52 | The code was originally written around 1985 by Jonathan Rees.  It ran
53 | on the [Symbolics Lisp Machines](https://en.wikipedia.org/wiki/Lisp_machine),
54 | and later in [VAX LISP](https://en.wikipedia.org/wiki/Vax_Common_Lisp),
55 | [Lucid Common Lisp](https://en.wikipedia.org/wiki/Lucid_Inc.),
56 | and other Common
57 | Lisp implementations.  Pseudoscheme incubated 
58 | [Scheme 48](http://s48.org/) (1986),
59 | standard [Scheme macros](http://3e8.org/pub/pdf-t1/macros_that_work.pdf)
60 | (1989), and 
61 | [CSRVL Mobot Scheme](https://mumble.net/~jar/pubs/scheme-mobile-robots.pdf)
62 | (1991).
63 | 
64 | ## To do
65 | 
66 |  * It needs to be updated for modern Common Lisp implementations. Much of the system building and bootstrap infrastructure could probably be replaced by features provided by [ASDF](https://common-lisp.net/project/asdf/).
67 |  * The `.pso` files ought to be moved out of the `src` directory because they are not really source files.
68 | 


--------------------------------------------------------------------------------
/src/_loader.lisp:
--------------------------------------------------------------------------------
 1 | ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER -*-
 2 | ;;;
 3 | ;;; Load Pseudoscheme.
 4 | 
 5 | (in-package "CL-USER")
 6 | 
 7 | (defvar pseudoscheme-directory
 8 |   (merge-pathnames "pseudo\\" load-utils:*support-directory*))
 9 | 
10 | (load (merge-pathnames "loadit.lisp" pseudoscheme-directory))
11 | (with-compilation-unit ()
12 |   (load-pseudoscheme))
13 | (ps:benchmark-mode)
14 | 
15 | ; Use Common Lisp reader so that CL package prefix notation works in Scheme.
16 | (setq ps:*scheme-read* #'ps:scheme-read-using-commonlisp-reader)
17 | 
18 | ; See file pseudo/foo.lisp for suggestions on other things to load
19 | ; & how to load them (records, etc.).
20 | 
21 | (setf (get :scheme 'load-utils:load-file)
22 |       #'(lambda (merged-path &key (compile load-utils:*compile-p*))
23 | 	  (ps:scheme-load 
24 | 	   merged-path
25 | 	   (revised^4-scheme:interaction-environment)
26 | 	   :compile-if-necessary compile)))
27 | 
28 | (with-compilation-unit ()
29 | 
30 | #+LispWorks
31 | (eval-when (:execute :compile-toplevel :load-toplevel)
32 |   (require "comm")) ;TCP support needed for sockets
33 | 
34 | (mapc #'(lambda (filename)
35 | 	  (ps:scheme-load (merge-pathnames filename pseudoscheme-directory)
36 | 			  (revised^4-scheme:interaction-environment)
37 | 			  :compile-if-necessary load-utils:*compile-p*))
38 |       '("pseudoscheme-record"
39 | 	"pseudoscheme-features"
40 | 	"s48-socket" ;"socket"
41 | 	"s48-table"
42 | 	"s48-threads"))
43 | 
44 | (let ((ps:*scheme-read* revised^4-scheme::scheme-read))
45 |   (ps:scheme-load (merge-pathnames "jar-defrecord" pseudoscheme-directory)
46 | 		  (revised^4-scheme:interaction-environment)))
47 | 
48 | )
49 | 


--------------------------------------------------------------------------------
/src/alpha.scm:
--------------------------------------------------------------------------------
  1 | ; File alpha.scm -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; See file COPYING
  3 | 
  4 | ;;;; Alpha-conversion
  5 | 
  6 | ; Contexts
  7 | 
  8 | (define (note-context! context node)
  9 |   (context node))
 10 | 
 11 | (define value-context     set-value-refs!)
 12 | (define procedure-context set-proc-refs!)
 13 | (define lvalue-context	  set-assigned!)
 14 | (define define-context	  (lambda (var) var 'define-context))
 15 | (define top-level-context (lambda (var) var 'top-level-context))
 16 | 
 17 | (define (lose context)  ;Ugh.   (let ((f (lambda () 1))) ((begin (foo) f)))
 18 |   context ;lose
 19 |   value-context)
 20 | 
 21 | (define @free-variables (make-fluid '()))
 22 | 
 23 | 
 24 | ; Top-level entry point.
 25 | 
 26 | (define (alpha-top form s-env)
 27 |   (alpha form s-env top-level-context))
 28 | 
 29 | ; Alphatization of a single scheme expression
 30 | 
 31 | (define @where (make-fluid '<top>))
 32 | 
 33 | (define (alpha form s-env context)
 34 |   (call-with-values (lambda () (classify form s-env))
 35 |     (lambda (class form s-env)
 36 |       ((vector-ref alphatizers class) form s-env context))))
 37 | 
 38 | (define alphatizers
 39 |   (make-vector number-of-classes
 40 | 	       (lambda (form s-env context)
 41 | 		 (error "don't know how to alphatize this class"
 42 | 			form))))
 43 | 
 44 | (define (define-alphatizer class proc)
 45 |   (vector-set! alphatizers class proc))
 46 | 
 47 | (define-alphatizer class/literal
 48 |   (lambda (exp s-env context)
 49 |     s-env context			;ignored
 50 |     (make-constant exp #f)))
 51 | 
 52 | (define-alphatizer class/name
 53 |   (lambda (exp s-env context)
 54 |     (let ((denotation (lookup s-env exp)))
 55 |       (cond ((node? denotation)
 56 | 	     (if (local-variable? denotation)
 57 | 		 (note-context! context denotation)
 58 | 		 (let ((free (fluid @free-variables)))
 59 | 		   (if (not (memq denotation free))
 60 | 		       (set-fluid! @free-variables (cons denotation free)))))
 61 | 	     denotation)
 62 | 	    (else
 63 | 	     (alpha (syntax-error "syntactic keyword in invalid position" exp)
 64 | 		    s-env context))))))
 65 | 
 66 | (define-alphatizer class/application
 67 |   (lambda (exp s-env context)
 68 |     context				;ignored
 69 |     (make-call (alpha (car exp) s-env procedure-context)
 70 | 	       (map (lambda (arg) (alpha arg s-env value-context))
 71 | 		    (cdr exp)))))
 72 | 
 73 | 
 74 | ; The primitive special forms.
 75 | 
 76 | (define-alphatizer class/quote
 77 |   (lambda (exp s-env context)
 78 |     s-env context			;ignored
 79 |     (make-constant (strip (cadr exp)) #t)))
 80 | 
 81 | (define-alphatizer class/lambda
 82 |   (lambda (exp s-env context)
 83 |     (if (not (eq? context procedure-context))
 84 | 	;; Not very accurate.  Improve later.
 85 | 	(for-each-local set-closed-over!
 86 | 			s-env))
 87 |     (let ((s-env (rename-vars (proper-listify (cadr exp)) s-env)))
 88 |       (make-lambda (new-names (cadr exp) s-env)
 89 | 		   (alpha-body (cddr exp) s-env value-context)))))
 90 | 
 91 | (define-alphatizer class/letrec
 92 |   (lambda (exp s-env context)
 93 |     (let* ((specs (cadr exp))
 94 | 	   (vars (map car specs))
 95 | 	   (s-env (rename-vars vars s-env))
 96 | 	   (new-vars (new-names vars s-env)))
 97 |       (make-letrec new-vars
 98 | 		   (map (lambda (spec)
 99 | 			  (alpha (cadr spec) s-env value-context))
100 | 			specs)
101 | 		   (alpha-body (cddr exp) s-env (lose context))))))
102 | 
103 | (define (alpha-body forms s-env context)
104 |   (call-with-values (lambda () (scan-body forms s-env))
105 |     (lambda (specs exps s-env)
106 |       (if (null? specs)
107 | 	  (alpha-beginify exps s-env context)
108 | 	  (let ((new-vars (map (lambda (spec)
109 | 				 (make-local-variable (car spec)))
110 | 			       specs)))
111 | 	    (for-each (lambda (spec var)
112 | 			(define! s-env (car spec) var))
113 | 		      specs
114 | 		      new-vars)
115 | 	    (make-letrec new-vars
116 | 			 (map (lambda (spec)
117 | 				(alpha (cadr spec) (caddr spec) value-context))
118 | 			      specs)
119 | 			 (alpha-beginify exps s-env (lose context))))))))
120 | 
121 | (define-alphatizer class/if
122 |   (lambda (exp s-env context)
123 |     (let ((test (alpha (cadr exp) s-env value-context))
124 | 	  (con  (alpha (caddr exp) s-env (lose context)))
125 | 	  (alt (alpha (let ((tail (cdddr exp)))
126 | 			(if (null? tail)
127 | 			    'ps:unspecific
128 | 			    (car tail)))
129 | 		      s-env
130 | 		      (lose context))))
131 |       (make-if test con alt))))
132 | 
133 | (define-alphatizer class/set!
134 |   (lambda (exp s-env context)
135 |     context				;ignored
136 |     (let ((lhs (alpha (cadr exp) s-env lvalue-context)))
137 |       (if (variable? lhs)
138 | 	  (make-set! lhs
139 | 		     (alpha (caddr exp) s-env value-context))
140 | 	  (alpha (syntax-error "invalid SET!" exp) s-env context)))))
141 | 
142 | (define-alphatizer class/begin
143 |   (lambda (exp s-env context)
144 |     (if (null? (cdr exp))
145 | 	(begin (if (not (eq? context top-level-context))
146 | 		   (note "(begin) disallowed in this context" exp))
147 | 	       (alpha 'ps:unspecific s-env context))
148 | 	(alpha-beginify (cdr exp) s-env context))))
149 | 
150 | (define (alpha-beginify exp-list s-env context)
151 |   (cond ((null? (cdr exp-list))
152 | 	 (alpha (car exp-list) s-env context))
153 | 	(else
154 | 	 (make-begin
155 | 	  (alpha (car exp-list)
156 | 		 s-env
157 | 		 (if (eq? context top-level-context)
158 | 		     context
159 | 		     value-context))
160 | 	  (alpha-beginify (cdr exp-list)
161 | 			  s-env
162 | 			  (if (eq? context top-level-context)
163 | 			      context
164 | 			      (lose context)))))))
165 | 
166 | (define-alphatizer class/define
167 |   (lambda (form s-env context)
168 |     (cond ((eq? context top-level-context)
169 | 	   (let ((var (ensure-defined s-env (define-form-lhs form))))
170 | 	     ;; (set-status! var 'defined)
171 | 	     (let-fluid @where (program-variable-name var)
172 | 			(lambda ()
173 | 			  (make-define var
174 | 				       (alpha (define-form-rhs form)
175 | 					      s-env value-context))))))
176 | 	  (else
177 | 	   (alpha (syntax-error "(define ...) disallowed in this context" form)
178 | 		  s-env context)))))
179 | 
180 | (define-alphatizer class/define-syntax
181 |   (lambda (form s-env context)
182 |     (cond ((eq? context top-level-context)
183 | 	   (process-define-syntax form s-env) ;side effect
184 | 	   (make-call (alpha 'ps:%define-syntax! s-env value-context)
185 | 		      (list (make-constant (cdr form) #t))))
186 | 	  (else 
187 | 	   (alpha (syntax-error
188 | 		   "(define-syntax ...) disallowed in this context" form)
189 | 		  s-env context)))))
190 | 
191 | (define (initialize-core-syntax env)
192 |   (define! env 'lambda	      (make-special-operator class/lambda))
193 |   (define! env 'letrec	      (make-special-operator class/letrec))
194 |   (define! env 'if	      (make-special-operator class/if))
195 |   (define! env 'quote	      (make-special-operator class/quote))
196 |   (define! env 'begin	      (make-special-operator class/begin))
197 |   (define! env 'set!	      (make-special-operator class/set!))
198 |   (define! env 'let-syntax    (make-special-operator class/let-syntax))
199 |   (define! env 'letrec-syntax (make-special-operator class/letrec-syntax))
200 |   (define! env 'define	      (make-special-operator class/define))
201 |   (define! env 'define-syntax (make-special-operator class/define-syntax)))
202 | 
203 | 
204 | ; Revised^4 environment
205 | 
206 | (define revised^4-scheme-env
207 |   (make-program-env 'revised^4-scheme '()))
208 | 
209 | (initialize-core-syntax revised^4-scheme-env)
210 | 
211 | (define revised^4-scheme-structure
212 |   (make-structure 'revised^4-scheme	;Exports everything
213 | 		  revised^4-scheme-interface
214 | 		  revised^4-scheme-env))
215 | 
216 | (define (built-in name)
217 |   (program-env-lookup revised^4-scheme-env name))
218 | 
219 | 
220 | ; Utilities:
221 | 
222 | (define (read-file filename)
223 |   (call-with-input-file filename
224 |     (lambda (i-port)
225 |       (let loop ((l '()))
226 | 	(let ((form (read i-port)))
227 | 	  (cond ((eof-object? form) (reverse l))
228 | 		(else
229 | 		 (loop (cons form l)))))))))
230 | 
231 | (define (note msg node)
232 |   (newline)
233 |   (display "** ")
234 |   (display msg)
235 |   (if node
236 |       (begin (display ": ")
237 | 	     (write (let-fluid @where '<note>
238 | 			       (lambda ()
239 | 				 (schemify-top node))))
240 | 	     (newline)
241 | 	     (display "   Location: ")
242 | 	     (write (fluid @where))))
243 |   (newline))
244 | 
245 | (define (syntax-error msg form)
246 |   (note msg form)
247 |   `(ps:scheme-error ',msg ',form))
248 | 
249 | ; Code generation utilities:
250 | 
251 | ; Unique id's
252 | 
253 | (define @unique-id (make-fluid 0))
254 | 
255 | (define (with-uid-reset thunk)
256 |   (let-fluid @unique-id 0 thunk))
257 | 
258 | (define (generate-uid)
259 |   (let ((uid (fluid @unique-id)))
260 |     (set-fluid! @unique-id (+ uid 1))
261 |     uid))
262 | 
263 | (define (make-name-from-uid name uid)  ;Best if it's not a legal Scheme symbol.
264 |   (intern
265 |    (string-append "."
266 | 		  (name->string name)
267 | 		  "."
268 | 		  (number->string uid ))
269 |    (fluid @target-package)))
270 | 
271 | (define (rename-vars names s-env)
272 |   (bind names (map make-local-variable names) s-env))
273 | 
274 | (define (new-names bvl env)
275 |   (map-bvl (lambda (var)
276 | 	     (lookup env var))
277 | 	   bvl))
278 | 
279 | (define (car-is? thing x)  ;useful for peephole optimizers
280 |   (and (pair? thing)
281 |        (eq? (car thing) x)))
282 | 


--------------------------------------------------------------------------------
/src/bootit.scm:
--------------------------------------------------------------------------------
  1 | ; File bootit.scm / -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; Copyright (c) 1991-1994 Jonathan Rees / See file COPYING
  3 | 
  4 | ; Bootstrapping a new Pseudoscheme
  5 | 
  6 | ; You must do (SETQ *USE-SCHEME-READ* NIL) before loading Pseudoscheme
  7 | ; in order for this to work!
  8 | 
  9 | ; In a Scheme-in-Common-Lisp implementation, load this file and do
 10 | ; (bootit).  This compiles and loads the translator, then invokes
 11 | ; the translator to translate itself.
 12 | 
 13 | ; Ultimately it would be nice to be able to boot from a Scheme that's
 14 | ; not Common-Lisp based, but that would require a fair amount of
 15 | ; hacking: e.g. all the routines in p-utils.scm would have to be rewritten.
 16 | 
 17 | (define *pseudoscheme-directory* #f)
 18 | 
 19 | (define (bootit . dir-option)
 20 |   (cond ((not (null? dir-option))
 21 | 	 (set! *pseudoscheme-directory* (lisp:pathname (car dir-option))))
 22 | 	((not *pseudoscheme-directory*)
 23 | 	 (set! *pseudoscheme-directory*
 24 | 	       (lisp:make-pathname :name 'lisp:nil
 25 | 				   :type 'lisp:nil
 26 | 				   :defaults
 27 | 				     lisp:*default-pathname-defaults*))))
 28 |   (boot-initialize)
 29 |   (load-untranslated-translator)
 30 |   (fix-reader-if-necessary)
 31 |   (translate-run-time)
 32 |   (translate-translator))
 33 | 
 34 | (define clever-load #f)
 35 | 
 36 | (define (boot-initialize)
 37 |   ;; For LISP:LOAD to work, we need for *PACKAGE* to be bound to
 38 |   ;; something other than the SCHEME package.  Since all these files start
 39 |   ;; with IN-PACKAGE forms, it doesn't matter which package in particular, as
 40 |   ;; long as it contains IN-PACKAGE and DEFPACKAGE.
 41 |   (lisp:let ((lisp:*package* (or (lisp:find-package "USER")
 42 | 				 (lisp:make-package "USER"))))
 43 | 
 44 |     ;; Create the PS package
 45 |     (lisp:load (pseudo-pathname "pack"))
 46 | 
 47 |     ;; Get clever file loader
 48 |     (lisp:load (pseudo-pathname "clever") :verbose 'lisp:nil)
 49 |     (set! clever-load
 50 | 	  (lisp:symbol-function
 51 | 	   (lisp:intern "CLEVER-LOAD"
 52 | 			(lisp:find-package "CLEVER-LOAD"))))
 53 | 
 54 |     ;; Fix SCHEME package if necessary
 55 | ;    (clever-load (pseudo-pathname "purify") :compile-if-necessary #t)
 56 | ;    (lisp:funcall (lisp:symbol-function
 57 | ;                   (lisp:intern "FIX-SCHEME-PACKAGE-IF-NECESSARY"
 58 | ;                                (lisp:find-package "SCHEME-PURIFY")))
 59 | ;                  (lisp:symbol-package 'askdjfh))
 60 |     ))
 61 | 
 62 | 
 63 | (define (pseudo-pathname name)
 64 |   (lisp:make-pathname :name (filename-preferred-case name)
 65 | 		      :defaults *pseudoscheme-directory*))
 66 | 
 67 | (define (filename-preferred-case name)
 68 |   #+unix (lisp:string-downcase name)
 69 |   #-unix (lisp:string-upcase name)
 70 |   )
 71 | 
 72 | (define *scheme-file-type*     (filename-preferred-case "scm"))
 73 | (define *translated-file-type* (filename-preferred-case "pso"))
 74 | (define *boot-file-type*       (filename-preferred-case "boot"))
 75 | 
 76 | ; Make sure the host system understands that files foo.boot are
 77 | ; compiled.
 78 | 
 79 | #+Lucid
 80 | (if (not (member *boot-file-type*
 81 | 		 lucid::*load-binary-pathname-types*))
 82 |     (lisp:setq lucid::*load-binary-pathname-types*
 83 | 	       (append lucid::*load-binary-pathname-types*
 84 | 		       (list *boot-file-type*))))
 85 | 
 86 | #+Symbolics
 87 | (begin
 88 |   (fs:define-canonical-type :boot-bin #,*boot-file-type*)
 89 | 
 90 |   (lisp:setq fs:*auxiliary-loadable-file-types*
 91 | 	(cons '(:boot-bin :load-stream-function
 92 | 			  si:load-binary-file-internal)
 93 | 	      (lisp:remove :boot-bin fs:*auxiliary-loadable-file-types*
 94 | 			   :key #'car)))
 95 | 
 96 |   (lisp:setf (lisp:get :boot-bin :binary-file-byte-size)
 97 | 	     (lisp:get :bin :binary-file-byte-size)))
 98 | 
 99 | (define translator-files #f)
100 | 
101 | ; ----- Load the translator into Scheme
102 | 
103 | (define (load-untranslated-translator)
104 |   ;; Make sure we perform integrations!
105 |   (lisp:if (lisp:fboundp 'benchmark-mode)
106 | 	   (benchmark-mode))
107 |   (set! translator-files
108 | 	(call-with-input-file (pseudo-pathname "translator.files") read))
109 |   (for-each load-scheme translator-files)
110 |   'done)
111 | 
112 | (define (load-scheme file)
113 |   (clever-load (pseudo-pathname file)
114 | 	       :source-type *scheme-file-type*
115 | 	       :object-type *boot-file-type*
116 | 	       :compile-if-necessary #t))
117 | 
118 | ; ----- Translating the run-time system
119 | 
120 | (define (translate-run-time)
121 |   ;; In principle, there could be more stuff here.
122 |   (write-closed-definitions
123 |      revised^4-scheme-structure
124 |      (lisp:make-pathname :type *translated-file-type*
125 | 			 :defaults (pseudo-pathname "closed")))
126 |   (for-each (lambda (f)
127 | 	      (translate-a-file f revised^4-scheme-env))
128 | 	    '(;; These are both optional.  Cf. load-run-time in loadit.scm.
129 | 	      "read"
130 | 	      "write"
131 | 	      )))
132 | 
133 | ; ----- Translating the translator
134 | 
135 | (define (translate-translator)
136 |   (let ((env (make-program-env 'scheme-translator
137 | 			       (list revised^4-scheme-structure))))
138 |     (for-each (lambda (f)
139 | 		(translate-a-file f env))
140 | 	      translator-files)
141 | 
142 |     (write-defpackages (list revised^4-scheme-structure
143 | 			     scheme-translator-structure)
144 | 		       "spack.lisp")
145 |     'done))
146 | 
147 | (define (translate-a-file f env)
148 |   (let ((f (pseudo-pathname f)))
149 |     (really-translate-file
150 |      (lisp:make-pathname :type *scheme-file-type* :defaults f)
151 |      (lisp:make-pathname :type *translated-file-type* :defaults f)
152 |      env)))
153 | 
154 | 
155 | ; Make sure that quote and backquote read in properly.  Careful, this
156 | ; may cause them to stop working in the Scheme from which we're
157 | ; bootstrapping.  It should be done after the translator is loaded,
158 | ; but before the translator starts to read any files.
159 | 
160 | ; This is probably no longer needed.
161 | 
162 | (define (fix-reader-if-necessary)
163 |   (if (not (eq? (car ''foo) 'quote))
164 |       (lisp:set-macro-character
165 |         #\'
166 | 	(lambda (stream c)
167 | 	  (list ''quote (lisp:read stream 'lisp:t 'lisp:nil 'lisp:t)))))
168 |   (if (not (eq? (car '`(foo)) 'quasiquote))
169 |       (begin (lisp:set-macro-character
170 | 	      #\`
171 | 	      (lambda (stream c)
172 | 		(list ''quasiquote
173 | 		      (lisp:read stream 'lisp:t 'lisp:nil 'lisp:t))))
174 | 	     (lisp:set-macro-character
175 | 	      #\,
176 | 	      (lambda (stream c)
177 | 		(let* ((following-char
178 | 			(lisp:peek-char 'lisp:nil stream
179 | 					'lisp:t 'lisp:nil 'lisp:t))
180 | 		       (marker (cond ((char=? following-char #\@)
181 | 				      (lisp:read-char stream)
182 | 				      'unquote-splicing)
183 | 				     (else
184 | 				      'unquote))))
185 | 		  (list marker
186 | 			(lisp:read stream 'lisp:t 'lisp:nil 'lisp:t))))))))
187 | 


--------------------------------------------------------------------------------
/src/classes.pso:
--------------------------------------------------------------------------------
 1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
 2 | 
 3 | ; This file was generated by Pseudoscheme 2.12
 4 | ;  running in CMU Common Lisp 16-Aug-1993
 5 | ;  from file /zu/jar/pseudo/classes.scm
 6 | 
 7 | (ps:in-package "SCHEME-TRANSLATOR")
 8 | (BEGIN-TRANSLATED-FILE)
 9 | (LOCALLY (DECLARE (SPECIAL CLASS/LITERAL)) (SETQ CLASS/LITERAL 0))
10 | (SET-FUNCTION-FROM-VALUE 'CLASS/LITERAL 'SCHEME::CLASS/LITERAL)
11 | (LOCALLY (DECLARE (SPECIAL CLASS/NAME)) (SETQ CLASS/NAME 1))
12 | (SET-FUNCTION-FROM-VALUE 'CLASS/NAME 'SCHEME::CLASS/NAME)
13 | (LOCALLY (DECLARE (SPECIAL CLASS/APPLICATION)) (SETQ CLASS/APPLICATION 2))
14 | (SET-FUNCTION-FROM-VALUE 'CLASS/APPLICATION 'SCHEME::CLASS/APPLICATION)
15 | (LOCALLY (DECLARE (SPECIAL CLASS/LAMBDA)) (SETQ CLASS/LAMBDA 3))
16 | (SET-FUNCTION-FROM-VALUE 'CLASS/LAMBDA 'SCHEME::CLASS/LAMBDA)
17 | (LOCALLY (DECLARE (SPECIAL CLASS/LETREC)) (SETQ CLASS/LETREC 4))
18 | (SET-FUNCTION-FROM-VALUE 'CLASS/LETREC 'SCHEME::CLASS/LETREC)
19 | (LOCALLY (DECLARE (SPECIAL CLASS/IF)) (SETQ CLASS/IF 5))
20 | (SET-FUNCTION-FROM-VALUE 'CLASS/IF 'SCHEME::CLASS/IF)
21 | (LOCALLY (DECLARE (SPECIAL CLASS/QUOTE)) (SETQ CLASS/QUOTE 6))
22 | (SET-FUNCTION-FROM-VALUE 'CLASS/QUOTE 'SCHEME::CLASS/QUOTE)
23 | (LOCALLY (DECLARE (SPECIAL CLASS/BEGIN)) (SETQ CLASS/BEGIN 7))
24 | (SET-FUNCTION-FROM-VALUE 'CLASS/BEGIN 'SCHEME::CLASS/BEGIN)
25 | (LOCALLY (DECLARE (SPECIAL CLASS/SET!)) (SETQ CLASS/SET! 8))
26 | (SET-FUNCTION-FROM-VALUE 'CLASS/SET! 'SCHEME::CLASS/SET!)
27 | (LOCALLY (DECLARE (SPECIAL CLASS/LET-SYNTAX)) (SETQ CLASS/LET-SYNTAX 9))
28 | (SET-FUNCTION-FROM-VALUE 'CLASS/LET-SYNTAX 'SCHEME::CLASS/LET-SYNTAX)
29 | (LOCALLY (DECLARE (SPECIAL CLASS/LETREC-SYNTAX)) (SETQ CLASS/LETREC-SYNTAX 10))
30 | (SET-FUNCTION-FROM-VALUE 'CLASS/LETREC-SYNTAX 'SCHEME::CLASS/LETREC-SYNTAX)
31 | (LOCALLY (DECLARE (SPECIAL CLASS/DEFINE)) (SETQ CLASS/DEFINE 11))
32 | (SET-FUNCTION-FROM-VALUE 'CLASS/DEFINE 'SCHEME::CLASS/DEFINE)
33 | (LOCALLY (DECLARE (SPECIAL CLASS/DEFINE-SYNTAX)) (SETQ CLASS/DEFINE-SYNTAX 12))
34 | (SET-FUNCTION-FROM-VALUE 'CLASS/DEFINE-SYNTAX 'SCHEME::CLASS/DEFINE-SYNTAX)
35 | (LOCALLY (DECLARE (SPECIAL NUMBER-OF-CLASSES)) (SETQ NUMBER-OF-CLASSES 13))
36 | (SET-FUNCTION-FROM-VALUE 'NUMBER-OF-CLASSES 'SCHEME::NUMBER-OF-CLASSES)
37 | 


--------------------------------------------------------------------------------
/src/classes.scm:
--------------------------------------------------------------------------------
 1 | 
 2 | ; Classes for the classifier
 3 | 
 4 | (define class/literal       0)
 5 | (define class/name	    1)
 6 | (define class/application   2)
 7 | 
 8 | (define class/lambda	    3)
 9 | (define class/letrec	    4)
10 | (define class/if	    5)
11 | (define class/quote	    6)
12 | (define class/begin	    7)
13 | (define class/set!	    8)
14 | (define class/let-syntax    9)
15 | (define class/letrec-syntax 10)
16 | 
17 | (define class/define	    11)
18 | (define class/define-syntax 12)
19 | 
20 | (define number-of-classes   13)
21 | 


--------------------------------------------------------------------------------
/src/clever.lisp:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLEVER-LOAD; -*-
  2 | ; File clever.lisp / See file COPYING
  3 | 
  4 | ; This is really too clever for its own good.  Should phase it out.
  5 | 
  6 | (in-package "CLEVER-LOAD")
  7 | 
  8 | (export '(clever-load
  9 | 	  *compile-if-necessary-p*))
 10 | 
 11 | (eval-when (eval load compile)
 12 |   (when (find-if #'(lambda (feature)
 13 | 		     (and (symbolp feature)
 14 | 			  (string= (symbol-name feature) "DEC")))
 15 | 		 *features*)
 16 |     (pushnew ':DEC *features*)))
 17 | 
 18 | (eval-when (eval load compile)
 19 |   (when (find-if #'(lambda (feature)
 20 | 		     (and (symbolp feature)
 21 | 			  (string= (symbol-name feature) "VMS")))
 22 | 		 *features*)
 23 |     (pushnew ':VMS *features*)))
 24 | 
 25 | ; File loader
 26 | 
 27 | #|| ;something like this ought to work...
 28 | (defconstant local-file-type
 29 |   (macrolet ((my-file-type () `',(pathname-type *load-truename*)))
 30 |     (my-file-type)))
 31 | ||#
 32 | 
 33 | (defun source-file-type (pathname)
 34 |   pathname
 35 |   (or #+Symbolics (car (zl:send pathname
 36 | 				':types-for-canonical-type
 37 | 				':lisp))
 38 |       #+ABCL "lisp"
 39 |       #+(and :DEC :Ultrix) "lsp"
 40 |       #+:VMS "LSP"
 41 |       #+:ccl "LISP"			;Coral
 42 |       #+allegro "lisp" ;or cl ... hmm.
 43 |       "lisp"				;For Unix, Exploder, and anyone else
 44 |       ))
 45 | 
 46 | (defun object-file-type (pathname)
 47 |   pathname
 48 |   (or #+Symbolics (car (zl:send pathname
 49 | 				':types-for-canonical-type
 50 | 				si:*default-binary-file-type*))
 51 |       #+Explorer  "xld"
 52 |       #+(and :DEC :Ultrix) "fas"
 53 |       #+(and :DEC :VMS) "FAS"
 54 |       #+Lucid (car lucid::*load-binary-pathname-types*)  ;?
 55 |       #+KCL "o"
 56 |       #+:ccl "FASL"			;Coral
 57 |       #+LispWorks "fsl"
 58 |       #+allegro "fasl"
 59 |       #+(and cmu hpux) "hpf"
 60 |       #+abcl "abcl"
 61 |       ))   ;(or) => nil otherwise
 62 | 
 63 | (defvar *compile-if-necessary-p* nil)
 64 | 
 65 | (defvar *debug* nil)
 66 | 
 67 | (defun clever-load (filespec &rest keys
 68 | 			     &key source-type
 69 | 				  object-type
 70 | 				  (compile-if-necessary
 71 | 				       *compile-if-necessary-p*)
 72 | 				  (verbose :not-very)
 73 | 				  (message "")
 74 | 			     &allow-other-keys)
 75 |   (let* ((path (merge-pathnames (if (symbolp filespec)
 76 | 				    (symbol-name filespec)
 77 | 				    filespec)
 78 | 				(make-pathname :type nil
 79 | 					       :defaults *default-pathname-defaults*)))
 80 | 	 (source-type (or source-type (source-file-type path)))
 81 | 	 (object-type (or object-type (object-file-type path))))
 82 |     (when *debug*
 83 |       (format *debug-io*
 84 | 	      "~&Clever-load: path = ~s, keys = ~s~%"
 85 | 	      path keys))
 86 |     (flet ((load-it (path)
 87 | 	     (apply #'load
 88 | 		    path
 89 | 		    :verbose (cond ((eq verbose :not-very)
 90 | 				    (format t "~&Loading ~A ~A~%"
 91 | 					    (namestring path)
 92 | 					    message)
 93 | 				    nil)
 94 | 				   (t
 95 | 				    (format t "~&Loading ~A~%"
 96 | 					    message)
 97 | 				    verbose))
 98 | 		    :allow-other-keys t
 99 | 		    keys))
100 | 	   (compile-it (src obj)
101 | 	     (apply #'compile-file src
102 | 		    :output-file obj
103 | 		    #+:DEC :listing #+:DEC t
104 | 		    :allow-other-keys t
105 | 		    keys)))
106 | 	(cond ((and (pathname-type path)	;No ifs, ands, or buts
107 | 		    (not (eq (pathname-type path) :unspecific)))
108 | 	       (when *debug*
109 | 		 (format *debug-io*
110 | 			 "~&Pathname has a type - ~S~%"
111 | 			 (pathname-type path)))
112 | 	       (load-it (truename path)))
113 | 	      ((or (not source-type) (not object-type))
114 | 	       (when *debug*
115 | 		 (format *debug-io*
116 | 			 "~&No known source or object type~%"))
117 | 	       (when compile-if-necessary
118 | 		 (cerror "Load file ~S without checking to see whether ~
119 | 			  it needs to be compiled."
120 | 			 "CLEVER-LOAD improperly configured -- it doesn't ~
121 | 			  have necessary file type information."
122 | 			 (namestring path)))
123 | 	       (load-it path))
124 | 	      (t
125 | 	       (let* ((src (make-pathname :type source-type
126 | 					  :defaults path))
127 | 		      (src? (probe-file src))
128 | 		      (obj (make-pathname :type object-type
129 | 					  :defaults path))
130 | 		      (obj? (probe-file obj)))
131 | 		 (cond ((not src?)
132 | 			(warn "~A not found, attempting to load ~A."
133 | 			      (namestring src) (namestring obj))
134 | 			(load-it (or obj? obj)))
135 | 		       ((not obj?)
136 | 			(cond (compile-if-necessary
137 | 			       (when *debug*
138 | 				 (format *debug-io*
139 | 					 "~&No object.  Compiling ~s to ~s.~%"
140 | 					 src obj))
141 | 			       (compile-it src obj)
142 | 			       (load-it obj))
143 | 			      (t
144 | 			       (when *debug*
145 | 				 (format *debug-io*
146 | 					 "~&No object.  Loading source ~s.~%"
147 | 					 src))
148 | 			       (load-it src?))))
149 | 		       ((let ((obj-date (file-write-date obj?))
150 | 			      (src-date (file-write-date src?)))
151 | 			  (or (not obj-date)
152 | 			      (not src-date)
153 | 			      (>= obj-date src-date)))
154 | 			(when *debug*
155 | 			  (format *debug-io*
156 | 				  "~&Object up to date.  Loading ~s.~%"
157 | 				  obj))
158 | 			(load-it obj?))
159 | 		       (compile-if-necessary
160 | 			(when *debug*
161 | 			  (format *debug-io*
162 | 				 "~&Object out of date.  Compiling ~s to ~s.~%"
163 | 				  src obj))
164 | 			(compile-it src obj)
165 | 			(load-it obj))
166 | 		       (t
167 | 			(format *error-output*
168 | 				"~&There is an object file ~A,~
169 | 				 ~%but loading source because it's newer.~%"
170 | 				(namestring obj?))
171 | 			(load-it src?)))))))))
172 | 
173 | 


--------------------------------------------------------------------------------
/src/core.lisp:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: PS; -*-
  2 | ; File core.lisp / See file COPYING
  3 | 
  4 | ;;;; Pseudoscheme run-time system
  5 | 
  6 | (in-package "PS")
  7 | 
  8 | ; The Scheme booleans
  9 | ;   - must be self-evaluating
 10 | ;   - must have invertible read/print syntax
 11 | ;   - must be uniquely created
 12 | ;   - can't be symbols without slowing down Scheme's SYMBOL? predicate
 13 | ;   - similarly for numbers, pairs, etc.
 14 | ; What values are self-evaluating Common Lisp objects with a read/print
 15 | ; syntax that aren't used for anything in Scheme?  ...
 16 | ; There aren't any.
 17 | ; So, we use symbols, and slow down the SYMBOL? predicate.
 18 | 
 19 | (defparameter false 'false)  ;You can set this to 'nil if you want
 20 | (defparameter true  't)
 21 | 
 22 | (proclaim '(inline truep true? scheme-symbol-p))
 23 | 
 24 | ; Convert Scheme boolean to Lisp boolean.
 25 | ;  E.g. (lisp:if (truep foo) ...)
 26 | 
 27 | (defun truep (scheme-test)
 28 |   (not (eq scheme-test false)))
 29 | 
 30 | ; Convert Lisp boolean to Scheme boolean.
 31 | ;  E.g. (cons (true? (lisp:numberp x)) ...)
 32 | ; This assumes that the argument is never the empty list.
 33 | 
 34 | (defun true? (cl-test) (or cl-test false))
 35 | 
 36 | (defun scheme-symbol-p (x)
 37 |   (declare (optimize (safety 0)))	;compilers are stupid
 38 |   (and (symbolp x) (not (eq (car (symbol-plist x)) 'not-a-symbol))))
 39 | 
 40 | (setf (get true  'not-a-symbol) t)
 41 | (setf (get false 'not-a-symbol) t)
 42 | (setf (get nil   'not-a-symbol) t)	;used for Scheme's empty list
 43 | 
 44 | ;
 45 | 
 46 | (defparameter scheme-package (find-package "SCHEME"))
 47 | 
 48 | #+Symbolics
 49 | (pushnew scheme-package si:*reasonable-packages*)
 50 | 
 51 | 
 52 | ; ----- Photons
 53 | 
 54 | ; "A `photon' is an object that PRIN1's as if it had been PRINC'ed."
 55 | ; 					  -- KMP
 56 | 
 57 | (defstruct (photon (:constructor make-photon (string-or-function))
 58 | 		   (:copier nil)
 59 | 		   (:print-function print-photon))
 60 |   string-or-function)
 61 | 
 62 | (defun print-photon (photon stream escape?)
 63 |   (declare (ignore escape?))
 64 |   (let ((z (photon-string-or-function photon)))
 65 |     (if (stringp z)
 66 | 	(princ z stream)
 67 | 	(funcall z stream))))
 68 | 
 69 | ; Miscellaneous objects
 70 | 
 71 | (defvar unspecific (make-photon "#{Unspecific}"))
 72 | (defvar unassigned  (make-photon "#{Unassigned}"))
 73 | (defvar eof-object  (make-photon "#{End-of-file}"))
 74 | 
 75 | ; PROCEDURE?
 76 | 
 77 | (defparameter closures-might-be-conses-p
 78 |   #+Lucid nil  ;suppress message about compiler optimizations
 79 |   #-Lucid
 80 |   (or (consp (eval '#'(lambda (x) x)))	;VAX LISP 2.1
 81 |       (consp (let ((g (gensym)))
 82 | 	       (eval `(progn (defun ,g () 0) #',g)))) ;Symbolics
 83 |       (consp (compile nil '(lambda (x) x))) ;just for kicks
 84 |       (consp (funcall (compile nil '(lambda (x) ;VAX LISP 2.2
 85 | 				      #'(lambda () (prog1 x (incf x)))))
 86 | 		      0))))
 87 | 
 88 | (defun procedurep (obj)
 89 |   (and (functionp obj)
 90 |        (not (symbolp obj))
 91 |        (or (not (consp obj))
 92 | 	   closures-might-be-conses-p)))
 93 | 
 94 | ; Mumble
 95 | 
 96 | (proclaim '(inline booleanp char-whitespace-p output-port-p))
 97 | 
 98 | (defun booleanp (obj)
 99 |   (or (eq obj true)
100 |       (eq obj false)))
101 | 
102 | (defun char-whitespace-p (char)
103 |   (or (char= char #\space)
104 |       (not (graphic-char-p char))))
105 | 
106 | (defun input-port-p (obj)
107 |   (and (streamp obj)
108 |        (input-stream-p obj)
109 |        t))
110 | 
111 | (defun output-port-p (obj)
112 |   (and (streamp obj)
113 |        (output-stream-p obj)
114 |        t))
115 | 
116 | ;This function is new in CLtL II / ANSI.
117 | #-ansi-cl
118 | (defun realp (obj)
119 |   (and (numberp obj)
120 |        (not (complexp obj))))
121 | 
122 | ; Auxiliary for SET!
123 | 
124 | (defun set!-aux (name value CL-sym)
125 |   (case (get CL-sym 'defined)
126 |     ((:assignable))
127 |     ((:not-assignable)
128 |      (cerror "Assign it anyhow"
129 | 	     "Variable ~S isn't supposed to be SET!"
130 | 	     (or name CL-sym)))
131 |     ((nil)
132 |      (warn "SET! of undefined variable ~S" (or name CL-sym))))
133 |   (setf (symbol-value CL-sym) value)
134 |   (if (procedurep value)
135 |       (setf (symbol-function CL-sym) value)
136 |       (fmakunbound CL-sym))
137 |   unspecific)
138 | 
139 | ; Auxiliary for lambda-expression-containing top-level forms on Symbolics
140 | 
141 | (defmacro at-top-level (&rest forms)
142 |   #+LISPM
143 |   (let ((g (gentemp "[TOP]")));;!?!?
144 |     `(progn (defun ,g () ,@forms)
145 | 	    (prog1 (,g)
146 | 	      (fmakunbound ',g))))
147 |   #-LISPM
148 |   `(progn ,@forms))
149 | 
150 | ; Auxiliary for copying &rest variables on Symbolics
151 | 
152 | (defmacro maybe-fix-&rest-parameter (rest-var)
153 |   #+LISPM
154 |   `(setq ,rest-var (copy-list ,rest-var))
155 |   #-LISPM
156 |   (progn rest-var ;ignored
157 | 	 `nil))
158 | 
159 | (defvar *scheme-read*)
160 | (defvar *scheme-write*)
161 | (defvar *scheme-display*)
162 | 
163 | (defvar *define-syntax!*
164 |   #'(lambda (name+exp) (declare (ignore name+exp)) 'define-syntax))
165 | 
166 | (defmacro %define-syntax! (name+exp)
167 |   `(eval-when (load)
168 |      (funcall *define-syntax!* ,name+exp)))
169 | 
170 | 
171 | ; These also appear in loadit.lisp
172 | (defun filename-preferred-case (name)
173 |   #+unix (string-downcase name)
174 |   #-unix (string-upcase name)
175 |   )
176 | (defvar *translated-file-type* (filename-preferred-case "pso"))
177 | 
178 | ; Prelude on all translated files
179 | 
180 | (defmacro begin-translated-file ()
181 |   `(progn (eval-when (eval compile load)
182 | 	    (setq *readtable* cl-readtable))
183 | 	  (check-target-package)))
184 | 
185 | (defparameter cl-readtable (copy-readtable nil))
186 | 
187 | (defvar *target-package* nil)
188 | 
189 | (defun check-target-package ()
190 |   (when (and *target-package*
191 | 	     (not (eq *target-package* *package*)))
192 |     (warn "Translate-time package ~A differs from attempted load-time package ~A"
193 | 	  (package-name *package*)
194 | 	  (package-name *target-package*))))
195 | 
196 | ; Auxiliaries for top-level DEFINE
197 | 
198 | (defun set-value-from-function (CL-sym &optional name) ;Follows a DEFUN
199 |   (setf (symbol-value CL-sym) (symbol-function CL-sym))
200 |   (after-define CL-sym name))
201 | 
202 | (defun really-set-function (CL-sym value)
203 |   (cond ((procedurep value)
204 | 	 #+Lucid
205 | 	 (lcl:define-function CL-sym value)
206 | 	 #-Lucid
207 | 	 (setf (symbol-function CL-sym) value))
208 | 	(t
209 | 	 (fmakunbound CL-sym))))
210 | 
211 | (defun set-function-from-value (CL-sym &optional name) ;Follows a SETQ
212 |   (let ((value (symbol-value CL-sym)))
213 |     (really-set-function CL-sym value)
214 |     #+Symbolics
215 |     (scl:record-source-file-name CL-sym (if (procedurep value) 'defun 'defvar))
216 |     (after-define CL-sym name)))
217 | 
218 | ; Follows (SETQ *FOO* ...)
219 | 
220 | (defun set-forwarding-function (CL-sym &optional name)
221 |   (setf (symbol-function CL-sym)
222 | 	#'(lambda (&rest args)
223 | 	    (apply (symbol-value CL-sym) args)))
224 |   (after-define CL-sym name))
225 | 
226 | (defun after-define (CL-sym name)
227 |   (setf (get CL-sym 'defined) t)
228 |   (when name
229 |     (make-photon #'(lambda (port)
230 | 		     (let ((*package* scheme-package))
231 | 		       (format port "~S defined." name))))))
232 | 
233 | ; EQUAL?
234 | 
235 | ; Differs from Common Lisp EQUAL in that it descends into vectors.
236 | ; This is here instead of in rts.lisp because it's an auxiliary for
237 | ; open-coding MEMBER and ASSOC, and the rule is that all auxiliaries
238 | ; are in the PS package (not REVISED^4-SCHEME).
239 | 
240 | (defun scheme-equal-p (obj1 obj2)
241 |   (cond ((eql obj1 obj2) t)
242 |         ((consp obj1)			;pair?
243 |          (and (consp obj2)
244 | 	      (scheme-equal-p (car obj1) (car obj2))
245 | 	      (scheme-equal-p (cdr obj1) (cdr obj2))))
246 | 	((simple-string-p obj1)		;string?
247 | 	 (and (simple-string-p obj2)
248 | 	      (string= (the simple-string obj1)
249 | 		       (the simple-string obj2))))
250 | 	((simple-vector-p obj1)
251 | 	 (and (simple-vector-p obj2)
252 | 	      (let ((z (length (the simple-vector obj1))))
253 | 		(declare (fixnum z))
254 | 		(and (= z (length (the simple-vector obj2)))
255 | 		     (do ((i 0 (+ i 1)))
256 | 			 ((= i z) t)
257 | 		       (declare (fixnum i))
258 | 		       (when (not (scheme-equal-p
259 | 				   (aref (the simple-vector obj1) i)
260 | 				   (aref (the simple-vector obj2) i)))
261 | 			 (return nil)))))))
262 |         (t nil)))
263 | 
264 | ; Handy things.
265 | 
266 | ; ERROR, WARN, SYNTAX-ERROR (nonstandard)
267 | 
268 | (defun scheme-error (message &rest irritants)
269 |   (signal-scheme-condition #'error message irritants))
270 | 
271 | (defun scheme-warn (message &rest irritants)
272 |   (signal-scheme-condition #'warn message irritants))
273 | 
274 | (defun signal-scheme-condition (fun message irritants)
275 |   (if (or (not (stringp message))
276 | 	  (find #\~ message))
277 |       (apply fun message irritants)
278 |       (apply fun
279 | 	     (apply #'concatenate
280 | 		    'string
281 | 		    (if (stringp message) "~a" "~s")
282 | 		    (mapcar #'(lambda (irritant)
283 | 				(declare (ignore irritant))
284 | 				"~%  ~s")
285 | 			    irritants))
286 | 	     message
287 | 	     irritants)))
288 | 
289 | #+LispM
290 | (setf (get 'scheme-error :error-reporter) t)  ;Thanks to KMP
291 | 
292 | ; PP (nonstandard)
293 | 
294 | (defun pp (obj &optional (port *standard-input*))
295 |   (let ((*print-pretty* t)
296 | 	(*print-length* nil)
297 | 	(*print-level* nil))
298 |     (format port "~&")
299 |     (print obj port)
300 |     (values)))
301 | 


--------------------------------------------------------------------------------
/src/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 knows about the implementation of records and creates the various
 6 | ; accessors, mutators, etc. directly instead of calling the procedures
 7 | ; from the record structure.  This is done to allow the optional auto-inlining
 8 | ; optimizer to inline the accessors, mutators, etc.
 9 | 
10 | ; LOOPHOLE is used to get a little compile-time type checking (in addition to
11 | ; the usual complete run-time checking).
12 | 
13 | (define-syntax define-record-type    ;same as in jar-defrecord.scm
14 |   (syntax-rules ()
15 |     ((define-record-type ?id ?type
16 |        (?constructor ?arg ...)
17 |        (?field . ?field-stuff)
18 |        ...)
19 |      (begin (define ?type (make-record-type '?id '(?field ...)))
20 | 	    (define-constructor ?constructor ?type
21 | 	      ((?arg :value) ...)
22 | 	      (?field ...))
23 | 	    (define-accessors ?type (?field . ?field-stuff) ...)))
24 |     ((define-record-type ?id ?type
25 |        (?constructor ?arg ...)
26 |        ?pred
27 |        ?more ...)
28 |      (begin (define-record-type ?id ?type
29 | 	      (?constructor ?arg ...)
30 | 	      ?more ...)
31 | 	    (define ?pred
32 | 	      (lambda (x)
33 | 		(and (record? x)
34 | 		     (eq? ?type (record-ref x 0)))))))))
35 | 
36 | ; (define-constructor <id> <type> ((<arg> <arg-type>)*) (<field-name>*))
37 | 
38 | (define-syntax define-constructor
39 |   (lambda (e r c)
40 |     (let ((%record (r 'record))
41 | 	  (%begin (r 'begin))
42 | 	  (%lambda (r 'lambda))
43 | 	  (%loophole (r 'loophole))
44 | 	  (%proc (r 'proc))
45 | 	  (%unspecific (r 'unspecific))
46 | 	  (name (cadr e))
47 | 	  (type (caddr e))
48 | 	  (args (map car (cadddr e)))
49 | 	  (arg-types (map cadr (cadddr e)))
50 | 	  (fields (caddr (cddr e))))
51 |       (define (mem? name list)
52 | 	(cond ((null? list)        #f)
53 | 	      ((c name (car list)) #t)
54 | 	      (else
55 | 	       (mem? name (cdr list)))))
56 |       `(define ,name
57 | 	 (,%loophole (,%proc ,arg-types ,type)
58 | 		     (,%lambda ,args
59 | 			       (,%record ,type . ,(map (lambda (field)
60 | 							 (if (mem? field args)
61 | 							     field
62 | 							     (list %unspecific)))
63 | 						       fields)))))))
64 |   (record begin lambda loophole proc unspecific))
65 | 
66 | (define-syntax define-accessors
67 |   (lambda (e r c)
68 |     (let ((%define-accessor (r 'define-accessor))
69 | 	  (%begin (r 'begin))
70 | 	  (type (cadr e))
71 | 	  (field-specs (cddr e)))
72 |       (do ((i 1 (+ i 1))
73 | 	   (field-specs field-specs (cdr field-specs))
74 | 	   (ds '()
75 | 	       (cons `(,%define-accessor ,type ,i ,@(cdar field-specs))
76 | 		     ds)))
77 | 	  ((null? field-specs)
78 | 	   `(,%begin ,@ds)))))
79 |   (define-accessor begin))
80 | 
81 | (define-syntax define-accessor
82 |   (syntax-rules ()
83 |     ((define-accessor ?type ?index ?accessor)
84 |      (define ?accessor
85 |        (loophole (proc (?type) :value)
86 | 		 (lambda (r)
87 | 		   (checked-record-ref (loophole :record r) ?type ?index)))))
88 |     ((define-accessor ?type ?index ?accessor ?modifier)
89 |      (begin (define-accessor ?type ?index ?accessor)
90 | 	    (define ?modifier
91 | 	      (loophole (proc (?type :value) :unspecific)
92 | 			(lambda (r new)
93 | 			  (checked-record-set! (loophole :record r) ?type ?index new))))))
94 |     ((define-accessor ?type ?index)
95 |      (begin))))
96 | 


--------------------------------------------------------------------------------
/src/derive.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File derive.scm / See file COPYING
  3 | 
  4 | ;;;; Macro expanders for standard derived expression types
  5 | 
  6 | (define (define-usual-syntax name expander)
  7 |   (program-env-define! revised^4-scheme-env
  8 | 		       name
  9 | 		       (make-macro (lambda (form r c)
 10 | 				     (apply expander r c (cdr form)))
 11 | 				   revised^4-scheme-env)))
 12 | 
 13 | ; syntax-rules is defined elsewhere
 14 | 
 15 | (program-env-define! revised^4-scheme-env
 16 | 		     'syntax-rules
 17 | 		     (make-macro rewrite-syntax-rules revised^4-scheme-env))
 18 | 
 19 | ; The expanders:
 20 | ;  r = rename
 21 | ;  c = compare
 22 | 
 23 | (define-usual-syntax 'and
 24 |   (lambda (r c . conjuncts)
 25 |     c ;ignored
 26 |     (if (null? conjuncts)
 27 | 	#t
 28 | 	(let recur ((first (car conjuncts)) (rest (cdr conjuncts)))
 29 | 	  (if (null? rest)
 30 | 	      first
 31 | 	      `(,(r 'and-aux) ,first
 32 | 		  (,(r 'lambda) () ,(recur (car rest) (cdr rest)))))))))
 33 | 
 34 | (define-usual-syntax 'or
 35 |   (lambda (r c . disjuncts)
 36 |     c ;ignored
 37 |     (if (null? disjuncts)
 38 | 	#f
 39 | 	(let recur ((first (car disjuncts)) (rest (cdr disjuncts)))
 40 | 	  (if (null? rest)
 41 | 	      first
 42 | 	      `(,(r 'or-aux) ,first
 43 | 		  (,(r 'lambda) () ,(recur (car rest) (cdr rest)))))))))
 44 | 
 45 | 
 46 | ; (case key ((a b) x) ((c) y) (else z))
 47 | ;  ==>  (case-aux key
 48 | ;		  '((a b) (c))
 49 | ;		  (lambda () z)
 50 | ;		  (lambda () x)
 51 | ;		  (lambda () y))
 52 | 
 53 | (define-usual-syntax 'case
 54 |   (lambda (r c key . clauses)
 55 |     (let ((form-result
 56 | 	   (lambda (else-thunk thunks key-lists)
 57 | 	     `(,(r 'case-aux) ,key
 58 | 			(,(r 'quote) ,(reverse key-lists))
 59 | 			,else-thunk
 60 | 			,@(reverse thunks)))))
 61 |       (let loop ((cs clauses) (thunks '()) (key-lists '()))
 62 | 	(if (null? cs)
 63 | 	    (form-result `(,(r 'lambda) () ,(r 'unspecific))
 64 | 			 thunks key-lists)
 65 | 	    (let* ((clause (car cs))
 66 | 		   (key-list (car clause))
 67 | 		   (body (cdr clause)))
 68 | 	      (if (c key-list (r 'else))
 69 | 		  (form-result `(,(r 'lambda) () ,@body) thunks key-lists)
 70 | 		  (loop (cdr cs)
 71 | 			(cons `(,(r 'lambda) () ,@body) thunks)
 72 | 			(cons key-list key-lists)))))))))
 73 | 
 74 | (define-usual-syntax 'cond
 75 |   (lambda (r c . clauses)
 76 |     (let recur ((clauses clauses))
 77 |       (if (null? clauses)
 78 | 	  (r 'unspecific)
 79 | 	  (process-cond-clause r c
 80 | 			       (car clauses)
 81 | 			       (recur (cdr clauses)))))))
 82 | 
 83 | ; Auxiliary also used by DO
 84 | 
 85 | (define (process-cond-clause r c clause rest)
 86 |   (cond ((null? (cdr clause))
 87 | 	 `(,(r 'or-aux) ,(car clause)
 88 | 		  (,(r 'lambda) () ,rest)))
 89 | 	((c (car clause) (r 'else))
 90 | 	 `(,(r 'begin) ,@(cdr clause)))
 91 | 	((c (cadr clause) (r '=>))
 92 | 	 `(,(r '=>-aux) ,(car clause)
 93 | 		  (,(r 'lambda) () ,(caddr clause))
 94 | 		  (,(r 'lambda) () ,rest)))
 95 | 	(else
 96 | 	 `(,(r 'if) ,(car clause)
 97 | 	      (,(r 'begin) ,@(cdr clause))
 98 | 	      ,rest))))
 99 | 
100 | (define-usual-syntax 'delay
101 |   (lambda (r c thing)
102 |     c ;ignored
103 |     `(,(r 'make-promise) (,(r 'lambda) () ,thing))))
104 | 
105 | (define-usual-syntax 'do
106 |   (lambda (r c specs end . body)
107 |     c ;ignored
108 |     (let ((loop (r 'loop)))
109 |       `(,(r 'letrec) ((,loop
110 | 		       (,(r 'lambda)
111 | 			,(map car specs)
112 | 			,(process-cond-clause
113 | 			  r c
114 | 			  end
115 | 			  `(,(r 'begin) ,@body
116 | 					(,loop ,@(map (lambda (y)
117 | 							(if (null? (cddr y))
118 | 							    (car y)
119 | 							    (caddr y)))
120 | 						      specs)))))))
121 | 		     (,loop ,@(map cadr specs))))))
122 | 
123 | (define-usual-syntax 'let
124 |   (lambda (r c specs . body)
125 |     c ;ignored
126 |     (cond ((name? specs)
127 | 	   (let ((tag specs)
128 | 		 (specs (car body))
129 | 		 (body (cdr body)))
130 | 	     `(,(r 'letrec) ((,tag (,(r 'lambda) ,(map car specs) ,@body)))
131 | 			    (,tag ,@(map cadr specs)))))
132 | 	  (else
133 | 	   `((,(r 'lambda) ,(map car specs) ,@body)
134 | 	     ,@(map cadr specs))))))
135 | 
136 | (define-usual-syntax 'let*
137 |   (lambda (r c specs . body)
138 |     c ;ignored
139 |     (let recur ((specs specs))
140 |       (if (null? specs)
141 | 	  `(,(r 'let) () ,@body)
142 | 	  (let ((name (car (car specs)))
143 | 		(val-exp (cadr (car specs))))
144 | 	    `(,(r 'let) ((,name ,val-exp))
145 | 	       ,(recur (cdr specs))))))))
146 | 
147 | ;;;; Quasiquote
148 | 
149 | (define-usual-syntax 'quasiquote
150 |   (lambda (r c x)
151 |     c ;ignored
152 |     (qq-descend x 1 r)))
153 | 
154 | (define (qq-descend x level r)
155 |   (cond ((vector? x)
156 | 	 (qq-descend-vector x level r))
157 | 	((not (pair? x))
158 | 	 (make-quotation x r))
159 | 	((qq-interesting? x 'quasiquote)
160 | 	 (qq-descend-pair x (+ level 1) r))
161 | 	((qq-interesting? x 'unquote)
162 | 	 (if (= level 1)
163 | 	     (cadr x)
164 | 	     (qq-descend-pair x (- level 1) r)))
165 | 	((qq-interesting? x 'unquote-splicing)
166 | 	 (if (= level 1)
167 | 	     (error ",@ in illegal position" x)
168 | 	     (qq-descend-pair x (- level 1) r)))
169 |         (else
170 | 	 (qq-descend-pair x level r))))
171 | 
172 | (define (qq-descend-pair x level r)
173 |   (let ((d-exp (qq-descend (cdr x) level r)))
174 |     (if (and (qq-interesting? (car x) 'unquote-splicing)
175 | 	     (= level 1))
176 | 	(let ((sc (cadr (car x))))
177 | 	  (cond ((and (quotation? d-exp r)
178 | 		      (null? (quotation-value d-exp)))
179 | 		 sc)
180 | 		(else
181 | 		 `(,(r 'append) ,sc ,d-exp))))
182 | 	(let ((a-exp (qq-descend (car x) level r)))
183 | 	  (cond ((and (quotation? a-exp r)
184 | 		      (quotation? d-exp r))
185 | 		 (make-quotation x r))
186 | 		((and (quotation? d-exp r)
187 | 		      (eq? (quotation-value d-exp) '()))
188 | 		 `(,(r 'list) ,a-exp))
189 | 		((qq-interesting? d-exp 'list)
190 | 		 `(,(r 'list) ,a-exp ,@(cdr d-exp)))
191 | 		;;+++ Ought to use auxiliary CONS* procedure, for more
192 | 		;; readable output
193 | 		(else
194 | 		 `(,(r 'cons) ,a-exp ,d-exp)))))))
195 | 
196 | (define (qq-descend-vector x level r)
197 |   (let ((result (qq-descend (vector->list x) level r)))
198 |     (if (quotation? result r)
199 | 	(make-quotation x r)
200 | 	`(,(r 'list->vector) ,result))))
201 | 
202 | (define (qq-interesting? x marker)
203 |   (and (pair? x)
204 |        (eq? (car x) marker)
205 |        (pair? (cdr x))
206 |        (null? (cddr x))))
207 | 
208 | (define (quotation? x r)
209 |   (qq-interesting? x (r 'quote)))
210 | 
211 | (define quotation-value cadr)
212 | 
213 | (define (make-quotation value r)
214 |   `(,(r 'quote) ,value))
215 | 


--------------------------------------------------------------------------------
/src/emit.pso:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2 | 
  3 | ; This file was generated by Pseudoscheme 2.12
  4 | ;  running in CMU Common Lisp 16-Aug-1993
  5 | ;  from file /zu/jar/pseudo/emit.scm
  6 | 
  7 | (ps:in-package "SCHEME-TRANSLATOR")
  8 | (BEGIN-TRANSLATED-FILE)
  9 | (LOCALLY
 10 |  (DECLARE (SPECIAL @TARGET-PACKAGE))
 11 |  (SETQ @TARGET-PACKAGE (MAKE-FLUID FALSE)))
 12 | (SET-FUNCTION-FROM-VALUE '@TARGET-PACKAGE 'SCHEME::@TARGET-PACKAGE)
 13 | (LOCALLY
 14 |  (DECLARE (SPECIAL @TRANSLATING-TO-FILE?))
 15 |  (SETQ @TRANSLATING-TO-FILE? (MAKE-FLUID FALSE)))
 16 | (SET-FUNCTION-FROM-VALUE '@TRANSLATING-TO-FILE? 'SCHEME::@TRANSLATING-TO-FILE?)
 17 | (DEFUN EMIT-PROGRAM-VARIABLE-SET! (VAR CL-SYM RHS-CODE)
 18 |   (IF (TRUEP (MUTABLE-PROGRAM-VARIABLE? VAR))
 19 |       (CONS 'SETQ (CONS CL-SYM (LIST RHS-CODE)))
 20 |       (CONS 'SET!-AUX
 21 |             (CONS (CONS 'QUOTE (LIST (PROGRAM-VARIABLE-NAME VAR)))
 22 |                   (CONS RHS-CODE (LIST (CONS 'QUOTE (LIST CL-SYM))))))))
 23 | (SET-VALUE-FROM-FUNCTION 'EMIT-PROGRAM-VARIABLE-SET!
 24 |                          'SCHEME::EMIT-PROGRAM-VARIABLE-SET!)
 25 | (DEFUN SUBSTITUTE-AND-PEEP (ALIST CL-FORM)
 26 |   (IF (SCHEME-SYMBOL-P CL-FORM)
 27 |       (LET ((PROBE (TRUE? (ASSOC CL-FORM ALIST :TEST #'EQ))))
 28 |         (IF (TRUEP PROBE) (CDR PROBE) CL-FORM))
 29 |       (IF (CONSP CL-FORM)
 30 |           (LET ((YOW
 31 |                  (MAPCAR #'(LAMBDA (Z) (SUBSTITUTE-AND-PEEP ALIST Z)) CL-FORM)))
 32 |             (CASE (CAR YOW)
 33 |               ((FUNCALL) (FUNCALLIFY (CADR YOW) (CDDR YOW)))
 34 |               (OTHERWISE YOW))))))
 35 | (SET-VALUE-FROM-FUNCTION 'SUBSTITUTE-AND-PEEP 'SCHEME::SUBSTITUTE-AND-PEEP)
 36 | (DEFUN INSERT-&REST (L)
 37 |   (IF (NULL (CDR L)) (CONS '&REST L) (CONS (CAR L) (INSERT-&REST (CDR L)))))
 38 | (SET-VALUE-FROM-FUNCTION 'INSERT-&REST 'SCHEME::INSERT-&REST)
 39 | (DEFUN CL-EXTERNALIZE-LOCALS (VARS ENV)
 40 |   (MAPCAR #'(LAMBDA (VAR) (CL-EXTERNALIZE-LOCAL (LOCAL-VARIABLE-NAME VAR) ENV))
 41 |           VARS))
 42 | (SET-VALUE-FROM-FUNCTION 'CL-EXTERNALIZE-LOCALS 'SCHEME::CL-EXTERNALIZE-LOCALS)
 43 | (DEFUN CL-EXTERNALIZE-LOCAL (NAME ENV)
 44 |   (IF (TRUEP (QUALIFIED-SYMBOL? NAME))
 45 |       NAME
 46 |       (IF (TRUEP (NAME-IN-USE? NAME ENV))
 47 |           (IN-TARGET-PACKAGE (MAKE-NAME-FROM-UID NAME (GENERATE-UID)))
 48 |           (IN-TARGET-PACKAGE (NAME->SYMBOL NAME)))))
 49 | (SET-VALUE-FROM-FUNCTION 'CL-EXTERNALIZE-LOCAL 'SCHEME::CL-EXTERNALIZE-LOCAL)
 50 | (DEFUN GENERATION-ENV (FREE-VARS)
 51 |   (DECLARE (SPECIAL PROGRAM-VARIABLE-NAME))
 52 |   (MAPCAR PROGRAM-VARIABLE-NAME FREE-VARS))
 53 | (SET-VALUE-FROM-FUNCTION 'GENERATION-ENV 'SCHEME::GENERATION-ENV)
 54 | (DEFUN BIND-VARIABLES (VARS NEW-NAMES ENV)
 55 |   (MAPC #'(LAMBDA (VAR NEW-NAME) (SET-SUBSTITUTION! VAR NEW-NAME))
 56 |         VARS
 57 |         NEW-NAMES)
 58 |   (GBIND VARS ENV))
 59 | (SET-VALUE-FROM-FUNCTION 'BIND-VARIABLES 'SCHEME::BIND-VARIABLES)
 60 | (DEFUN BIND-FUNCTIONS (VARS NEW-NAMES ENV)
 61 |   (MAPC
 62 |    #'(LAMBDA (VAR NEW-NAME)
 63 |        (SET-SUBSTITUTION! VAR (CONS 'SCHEME::FUN (LIST NEW-NAME))))
 64 |    VARS
 65 |    NEW-NAMES)
 66 |   (GBIND VARS ENV))
 67 | (SET-VALUE-FROM-FUNCTION 'BIND-FUNCTIONS 'SCHEME::BIND-FUNCTIONS)
 68 | (DEFUN GBIND (VARS ENV)
 69 |   (DECLARE (SPECIAL LOCAL-VARIABLE-NAME))
 70 |   (APPEND (MAPCAR LOCAL-VARIABLE-NAME VARS) ENV))
 71 | (SET-VALUE-FROM-FUNCTION 'GBIND 'SCHEME::GBIND)
 72 | (LOCALLY (DECLARE (SPECIAL NAME-IN-USE? MEMQ)) (SETQ NAME-IN-USE? MEMQ))
 73 | (SET-FUNCTION-FROM-VALUE 'NAME-IN-USE? 'SCHEME::NAME-IN-USE?)
 74 | (DEFUN MUTABLE-PROGRAM-VARIABLE? (VAR)
 75 |   (LET ((NAME (PROGRAM-VARIABLE-NAME VAR)))
 76 |     (IF (NOT (TRUEP (QUALIFIED-SYMBOL? NAME)))
 77 |         (LET ((S (SYMBOL->STRING NAME)))
 78 |           (LET ((N (LENGTH (THE SIMPLE-STRING S))))
 79 |             (LET ()
 80 |               (IF (>= N 3)
 81 |                   (IF (CHAR= (CHAR (THE SIMPLE-STRING S) 0) #\*)
 82 |                       (TRUE? (CHAR= (CHAR (THE SIMPLE-STRING S) (- N 1)) #\*))
 83 |                       FALSE)
 84 |                   FALSE))))
 85 |         FALSE)))
 86 | (SET-VALUE-FROM-FUNCTION 'MUTABLE-PROGRAM-VARIABLE?
 87 |                          'SCHEME::MUTABLE-PROGRAM-VARIABLE?)
 88 | (DEFUN IN-TARGET-PACKAGE (SYM)
 89 |   (DECLARE (SPECIAL @TARGET-PACKAGE @TRANSLATING-TO-FILE?))
 90 |   (IF (TRUEP (FLUID @TRANSLATING-TO-FILE?))
 91 |       (CHANGE-PACKAGE SYM (FLUID @TARGET-PACKAGE))
 92 |       SYM))
 93 | (SET-VALUE-FROM-FUNCTION 'IN-TARGET-PACKAGE 'SCHEME::IN-TARGET-PACKAGE)
 94 | (DEFUN CHANGE-PACKAGE (SYM PACKAGE)
 95 |   (IF (AND (TRUEP PACKAGE) (NOT (TRUEP (QUALIFIED-SYMBOL? SYM))))
 96 |       (INTERN-RENAMING-PERHAPS (SYMBOL->STRING SYM) PACKAGE)
 97 |       SYM))
 98 | (SET-VALUE-FROM-FUNCTION 'CHANGE-PACKAGE 'SCHEME::CHANGE-PACKAGE)
 99 | (DEFUN PROGNIFY (FORM-LIST)
100 |   (IF (NULL (CDR FORM-LIST)) (CAR FORM-LIST) (CONS 'PROGN FORM-LIST)))
101 | (SET-VALUE-FROM-FUNCTION 'PROGNIFY 'SCHEME::PROGNIFY)
102 | (DEFUN DEPROGNIFY (CL-FORM)
103 |   (IF (TRUEP (CAR-IS? CL-FORM 'PROGN)) (CDR CL-FORM) (LIST CL-FORM)))
104 | (SET-VALUE-FROM-FUNCTION 'DEPROGNIFY 'SCHEME::DEPROGNIFY)
105 | (DEFUN DEANDIFY (CL-FORM)
106 |   (IF (TRUEP (CAR-IS? CL-FORM 'AND)) (CDR CL-FORM) (LIST CL-FORM)))
107 | (SET-VALUE-FROM-FUNCTION 'DEANDIFY 'SCHEME::DEANDIFY)
108 | (DEFUN DEORIFY (CL-FORM)
109 |   (IF (TRUEP (CAR-IS? CL-FORM 'OR)) (CDR CL-FORM) (LIST CL-FORM)))
110 | (SET-VALUE-FROM-FUNCTION 'DEORIFY 'SCHEME::DEORIFY)
111 | (DEFUN FUNCALLIFY (FUN ARGS)
112 |   (IF (TRUEP (CAR-IS? FUN 'FUNCTION))
113 |       (LET ((.FUN.0 (CADR FUN)))
114 |         (IF
115 |          (AND (TRUEP (CAR-IS? .FUN.0 'LAMBDA))
116 |               (NOT (MEMBER '&REST (CADR .FUN.0) :TEST #'EQ))
117 |               (= (LENGTH (CADR .FUN.0)) (LENGTH ARGS)))
118 |          (LETIFY (MAPCAR #'LIST (CADR .FUN.0) ARGS) (PROGNIFY (CDDR .FUN.0)))
119 |          (CONS .FUN.0 ARGS)))
120 |       (CONS 'FUNCALL (CONS FUN ARGS))))
121 | (SET-VALUE-FROM-FUNCTION 'FUNCALLIFY 'SCHEME::FUNCALLIFY)
122 | (DEFUN LETIFY (SPECS BODY)
123 |   (IF (NULL SPECS) BODY (CONS 'LET (CONS SPECS (DEPROGNIFY BODY)))))
124 | (SET-VALUE-FROM-FUNCTION 'LETIFY 'SCHEME::LETIFY)
125 | (DEFUN SHARP-QUOTE-LAMBDA? (.EXP)
126 |   (IF (TRUEP (CAR-IS? .EXP 'FUNCTION)) (CAR-IS? (CADR .EXP) 'LAMBDA) FALSE))
127 | (SET-VALUE-FROM-FUNCTION 'SHARP-QUOTE-LAMBDA? 'SCHEME::SHARP-QUOTE-LAMBDA?)
128 | (LOCALLY
129 |  (DECLARE (SPECIAL @CL-VARIABLE-REFERENCES))
130 |  (SETQ @CL-VARIABLE-REFERENCES (MAKE-FLUID 'SCHEME::DONT-ACCUMULATE)))
131 | (SET-FUNCTION-FROM-VALUE '@CL-VARIABLE-REFERENCES
132 |                          'SCHEME::@CL-VARIABLE-REFERENCES)
133 | (DEFUN NOTING-VARIABLE-REFERENCES (THUNK)
134 |   (DECLARE (SPECIAL @CL-VARIABLE-REFERENCES))
135 |   (LET-FLUID @CL-VARIABLE-REFERENCES 'NIL THUNK))
136 | (SET-VALUE-FROM-FUNCTION 'NOTING-VARIABLE-REFERENCES
137 |                          'SCHEME::NOTING-VARIABLE-REFERENCES)
138 | (DEFUN LOCALLY-SPECIALIZE (FORM-LIST)
139 |   (DECLARE (SPECIAL @CL-VARIABLE-REFERENCES PROGRAM-VARIABLE-CL-SYMBOL))
140 |   (LET ((VARS (FLUID @CL-VARIABLE-REFERENCES)))
141 |     (IF
142 |      (OR (NULL VARS)
143 |          (AND (CONSP FORM-LIST)
144 |               (CONSP (CAR FORM-LIST))
145 |               (MEMBER (CAAR FORM-LIST) '(DEFUN DEFSTRUCT DEFTYPE) :TEST #'EQ)))
146 |      FORM-LIST
147 |      (LIST
148 |       (CONS 'LOCALLY
149 |             (CONS
150 |              (CONS 'DECLARE
151 |                    (LIST
152 |                     (CONS 'SPECIAL (MAPCAR PROGRAM-VARIABLE-CL-SYMBOL VARS))))
153 |              FORM-LIST))))))
154 | (SET-VALUE-FROM-FUNCTION 'LOCALLY-SPECIALIZE 'SCHEME::LOCALLY-SPECIALIZE)
155 | (DEFUN EMIT-TOP-LEVEL (CODE)
156 |   (DECLARE (SPECIAL @LAMBDA-ENCOUNTERED?))
157 |   (IF (TRUEP (FLUID @LAMBDA-ENCOUNTERED?))
158 |       (CONS 'AT-TOP-LEVEL CODE)
159 |       (PROGNIFY CODE)))
160 | (SET-VALUE-FROM-FUNCTION 'EMIT-TOP-LEVEL 'SCHEME::EMIT-TOP-LEVEL)
161 | (LOCALLY (DECLARE (SPECIAL CONT/VALUE)) (SETQ CONT/VALUE '(SCHEME::CONT/VALUE)))
162 | (SET-FUNCTION-FROM-VALUE 'CONT/VALUE 'SCHEME::CONT/VALUE)
163 | (LOCALLY
164 |  (DECLARE (SPECIAL CONT/RETURN))
165 |  (SETQ CONT/RETURN '(SCHEME::CONT/RETURN)))
166 | (SET-FUNCTION-FROM-VALUE 'CONT/RETURN 'SCHEME::CONT/RETURN)
167 | (LOCALLY (DECLARE (SPECIAL CONT/TEST)) (SETQ CONT/TEST '(SCHEME::CONT/TEST)))
168 | (SET-FUNCTION-FROM-VALUE 'CONT/TEST 'SCHEME::CONT/TEST)
169 | (LOCALLY
170 |  (DECLARE (SPECIAL CONT/IGNORE))
171 |  (SETQ CONT/IGNORE '(SCHEME::CONT/IGNORE)))
172 | (SET-FUNCTION-FROM-VALUE 'CONT/IGNORE 'SCHEME::CONT/IGNORE)
173 | (LOCALLY (DECLARE (SPECIAL CONTINUATION-TYPE)) (SETQ CONTINUATION-TYPE #'CAR))
174 | (SET-FUNCTION-FROM-VALUE 'CONTINUATION-TYPE 'SCHEME::CONTINUATION-TYPE)
175 | (DEFUN DELIVER-VALUE-TO-CONT (RESULT-EXP CONT)
176 |   (CASE (CONTINUATION-TYPE CONT)
177 |     ((SCHEME::CONT/VALUE SCHEME::CONT/IGNORE) RESULT-EXP)
178 |     ((SCHEME::CONT/RETURN) (CONS 'RETURN (LIST RESULT-EXP)))
179 |     ((SCHEME::CONT/TEST) (VALUE-FORM->TEST-FORM RESULT-EXP))
180 |     (OTHERWISE (.ERROR "unrecognized continuation" CONT))))
181 | (SET-VALUE-FROM-FUNCTION 'DELIVER-VALUE-TO-CONT 'SCHEME::DELIVER-VALUE-TO-CONT)
182 | (DEFUN DELIVER-TEST-TO-CONT (TEST-EXP CONT)
183 |   (CASE (CONTINUATION-TYPE CONT)
184 |     ((SCHEME::CONT/TEST SCHEME::CONT/IGNORE) TEST-EXP)
185 |     ((SCHEME::CONT/RETURN)
186 |      (CONS 'RETURN (LIST (TEST-FORM->VALUE-FORM TEST-EXP))))
187 |     ((SCHEME::CONT/VALUE) (TEST-FORM->VALUE-FORM TEST-EXP))
188 |     (OTHERWISE (.ERROR "unrecognized continuation" CONT))))
189 | (SET-VALUE-FROM-FUNCTION 'DELIVER-TEST-TO-CONT 'SCHEME::DELIVER-TEST-TO-CONT)
190 | (DEFUN TEST-FORM->VALUE-FORM (CL-FORM) (CONS 'TRUE? (LIST CL-FORM)))
191 | (SET-VALUE-FROM-FUNCTION 'TEST-FORM->VALUE-FORM 'SCHEME::TEST-FORM->VALUE-FORM)
192 | (DEFUN VALUE-FORM->TEST-FORM (CL-FORM)
193 |   (IF (TRUEP (CAR-IS? CL-FORM 'TRUE?))
194 |       (CADR CL-FORM)
195 |       (CONS 'TRUEP (LIST CL-FORM))))
196 | (SET-VALUE-FROM-FUNCTION 'VALUE-FORM->TEST-FORM 'SCHEME::VALUE-FORM->TEST-FORM)
197 | 


--------------------------------------------------------------------------------
/src/emit.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File emit.scm / See file COPYING
  3 | 
  4 | ;;;; Common Lisp code emission utilities
  5 | 
  6 | ; This is intimately tied up with the GENERATE module, but is
  7 | ; separated for the purpose of producing alternate implementations of
  8 | ; GENERATE with different internal calling conventions.  Thus GENERATE
  9 | ; may know a lot about this module, but not vice versa.
 10 | 
 11 | 
 12 | ; If @TARGET-PACKAGE is #f, leave unqualified program (top-level)
 13 | ; variables in the SCHEME package.  Otherwise, intern them in the
 14 | ; target package.
 15 | 
 16 | (define @target-package (make-fluid #f))
 17 | 
 18 | 
 19 | ; @TRANSLATING-TO-FILE? This controls a number of inconsequential code
 20 | ; generation decisions, e.g. whether the (IF #F X) should return
 21 | ; unspecific and whether local variables should be turned into
 22 | ; symbols in the target package.
 23 | 
 24 | (define @translating-to-file? (make-fluid #f))
 25 | 
 26 | 
 27 | ; Program variable management:
 28 | 
 29 | (define (emit-program-variable-set! var CL-sym rhs-code)
 30 |   (cond ((mutable-program-variable? var)
 31 | 	 `(ps-lisp:setq ,CL-sym ,rhs-code))
 32 | 	(else
 33 | 	 `(ps:set!-aux
 34 | 	   (ps-lisp:quote ,(program-variable-name var))
 35 | 	   ,rhs-code
 36 | 	   (ps-lisp:quote ,CL-sym)))))
 37 | 
 38 | ; SUBSTITUTE-AND-PEEP
 39 | ; PS-LISP:SUBLIS would suffice here, but this additionally does some
 40 | ; peephole optimizations.  Careful -- this is semantically blind!
 41 | ; In particular, never put lambda-bindings in SUBST-type definitions.
 42 | 
 43 | (define (substitute-and-peep alist cl-form)
 44 |   (cond ((symbol? cl-form)
 45 | 	 (let ((probe (assq cl-form alist)))
 46 | 	   (if probe (cdr probe) cl-form)))
 47 | 	((pair? cl-form)
 48 | 	 (let ((yow (map (lambda (z) (substitute-and-peep alist z)) cl-form)))
 49 | 	   (case (car yow)
 50 | 	     ((ps-lisp:funcall) (funcallify (cadr yow) (cddr yow)))
 51 | 	     (else yow))))))
 52 | 
 53 | ; Dinky utilities
 54 | 
 55 | (define (insert-&rest l)
 56 |   (if (null? (cdr l))
 57 |       `(ps-lisp:&rest ,@l)
 58 |       (cons (car l) (insert-&rest (cdr l)))))
 59 | 
 60 | (define (cl-externalize-locals vars env)
 61 |   (map (lambda (var)
 62 | 	 (cl-externalize-local (local-variable-name var) env))
 63 |        vars))
 64 | 
 65 | (define (cl-externalize-local name env)
 66 |   (if (qualified-symbol? name)
 67 |       ;; Don't touch local variables that aren't named by ordinary
 68 |       ;; Scheme symbols.
 69 |       name
 70 |       (if (name-in-use? name env)
 71 | 	  (in-target-package (make-name-from-uid name (generate-uid)))
 72 | 	  (in-target-package (name->symbol name)))))
 73 | 
 74 | ; The lexical environment keeps track of which names are in use so that
 75 | ; we can know when it's safe not to rename.
 76 | 
 77 | (define (generation-env free-vars) ;Initial environment
 78 |   (map program-variable-name free-vars))
 79 | 
 80 | (define (bind-variables vars new-names env)
 81 |   (for-each (lambda (var new-name)
 82 | 	      (set-substitution! var new-name))
 83 | 	    vars
 84 | 	    new-names)
 85 |   (gbind vars env))
 86 | 
 87 | (define (bind-functions vars new-names env)
 88 |   (for-each (lambda (var new-name)
 89 | 	      (set-substitution! var `(fun ,new-name)))
 90 | 	    vars
 91 | 	    new-names)
 92 |   (gbind vars env))
 93 | 
 94 | (define (gbind vars env)
 95 |   (append (map local-variable-name vars) env))
 96 | 
 97 | (define name-in-use? memq)
 98 | 
 99 | ; Kludge -- use it heuristically only!
100 | 
101 | (define (mutable-program-variable? var)
102 |   (let ((name (program-variable-name var)))
103 |     (and (not (qualified-symbol? name))
104 | 	 (let* ((s (symbol->string name))
105 | 		(n (string-length s)))
106 | 	   (and (>= n 3)
107 | 		(char=? (string-ref s 0) #\*)
108 | 		(char=? (string-ref s (- n 1)) #\*))))))
109 | 
110 | 
111 | ; Package crud
112 | 
113 | (define (in-target-package sym)		;For pretty output
114 |   (if (fluid @translating-to-file?)
115 |       (change-package sym (fluid @target-package))
116 |       sym))
117 | 
118 | (define (change-package sym package)
119 |   (if (and package (not (qualified-symbol? sym)))
120 |       (intern-renaming-perhaps (symbol->string sym) package)
121 |       sym))
122 | 
123 | ; Code emission utilities; peephole optimizers
124 | 
125 | (define (prognify form-list)
126 |   (if (null? (cdr form-list))
127 |       (car form-list)
128 |       `(ps-lisp:progn ,@form-list)))
129 | 
130 | (define (deprognify cl-form)
131 |   (if (car-is? cl-form 'ps-lisp:progn)
132 |       (cdr cl-form)
133 |       (list cl-form)))
134 | 
135 | (define (deandify cl-form)
136 |   (if (car-is? cl-form 'ps-lisp:and)
137 |       (cdr cl-form)
138 |       (list cl-form)))
139 | 
140 | (define (deorify cl-form)
141 |   (if (car-is? cl-form 'ps-lisp:or)
142 |       (cdr cl-form)
143 |       (list cl-form)))
144 | 
145 | (define (funcallify fun args)
146 |   (cond ((car-is? fun 'ps-lisp:function)
147 | 	 ;; Peephole optimization
148 | 	 (let ((fun (cadr fun)))
149 | 	   (cond ((and (car-is? fun 'ps-lisp:lambda)
150 | 		       (not (memq 'ps-lisp:&rest (cadr fun)))
151 | 		       (= (length (cadr fun))
152 | 			  (length args)))
153 | 		  (letify (map list (cadr fun) args)
154 | 			  (prognify (cddr fun))))
155 | 		 (else
156 | 		  `(,fun ,@args)))))
157 | 	(else
158 | 	 `(ps-lisp:funcall ,fun ,@args))))
159 | 
160 | ;+++ To do: turn nested singleton LET's into LET*
161 | 
162 | (define (letify specs body)
163 |   (if (null? specs)
164 |       body
165 |       `(ps-lisp:let ,specs ,@(deprognify body))))
166 | 
167 | (define (sharp-quote-lambda? exp)
168 |   (and (car-is? exp 'ps-lisp:function)
169 |        (car-is? (cadr exp) 'ps-lisp:lambda)))
170 | 
171 | ; The following hack has the express purpose of suppressing obnoxious
172 | ; warnings from losing Common Lisp compilers.  The problem would be
173 | ; mitigated if Common Lisp had some way to proclaim a variable to be
174 | ; lexical (or "not misspelled", as Moon calls it), AND if compilers treated
175 | ; variables like they did functions, permitting forward references.
176 | 
177 | (define @CL-variable-references (make-fluid 'dont-accumulate))
178 | 
179 | (define (noting-variable-references thunk)
180 |   (let-fluid @CL-variable-references '() thunk))
181 | 
182 | (define (locally-specialize form-list)
183 |   (let ((vars (fluid @CL-variable-references)))
184 |     (if (or (null? vars)
185 | 	    (and (pair? form-list)
186 | 		 (pair? (car form-list))
187 | 		 (memq (caar form-list)
188 | 		       '(ps-lisp:defun ps-lisp:defstruct ps-lisp:deftype))))
189 | 	form-list
190 | 	`((ps-lisp:locally (ps-lisp:declare
191 | 			  (ps-lisp:special ,@(map program-variable-CL-symbol
192 | 					       vars)))
193 | 	    ,@form-list)))))
194 | 
195 | (define (emit-top-level code)		;form* -> form
196 |   (if (fluid @lambda-encountered?)
197 |       `(ps:at-top-level ,@code)
198 |       (prognify code)))
199 | 
200 | ; Continuation management
201 | 
202 | (define cont/value  '(cont/value))
203 | (define cont/return '(cont/return))
204 | (define cont/test   '(cont/test))
205 | (define cont/ignore '(cont/ignore))
206 | 
207 | (define continuation-type car)
208 | 
209 | (define (deliver-value-to-cont result-exp cont)
210 |   (case (continuation-type cont)
211 |     ((cont/value cont/ignore) result-exp)
212 |     ((cont/return) `(ps-lisp:return ,result-exp)) ;not return-from?
213 |     ((cont/test) (value-form->test-form result-exp))
214 |     (else (error "unrecognized continuation" cont))))
215 | 
216 | ; For deliver-test-to-cont, we know that the value is either T or NIL.
217 | (define (deliver-test-to-cont test-exp cont)
218 |   (case (continuation-type cont)
219 |     ((cont/test cont/ignore) test-exp)
220 |     ((cont/return) `(ps-lisp:return ,(test-form->value-form test-exp)))
221 |     ((cont/value) (test-form->value-form test-exp))
222 |     (else (error "unrecognized continuation" cont))))
223 | 
224 | (define (test-form->value-form cl-form)
225 |   `(ps:true? ,cl-form))
226 |       
227 | ; (truep (true? x)) is not equivalent to x in general, but as the result
228 | ; is being used as a test form, only its non-nilness matters.
229 | ; (truep (true? x))
230 | ;  == (not (eq (or x #f) #f))
231 | ;  == (not (eq (if x x #f) #f))
232 | ;  == (if x (not (eq x #f)) (not (eq #f #f)))
233 | ;  == (if x (not (eq x #f)) nil)
234 | ; so
235 | ; (if (truep (true? x)) y z)
236 | ;  == (if (if x (not (eq x #f)) x) y z)
237 | ;  == (if x (if (not (eq x #f)) y z) (if nil y z))
238 | ;  == (if x (if (eq x #f) z y) z)
239 | ;  == (if x y z)  whenever x is not #f.
240 | ; Now the result of calling test-form->value-form is never fed in as
241 | ; the argument to value-form->test-form, and the only other place a true?
242 | ; is introduced is by the primitives, and none of those can possibly pass
243 | ; #f as the argument to true?.  Therefore the transformation
244 | ; (truep (true? x)) => x  is safe for present purposes.
245 | 
246 | (define (value-form->test-form cl-form)
247 |   (cond ((car-is? cl-form 'ps:true?)
248 | 	 (cadr cl-form))
249 | 	(else
250 | 	 `(ps:truep ,cl-form))))
251 | 


--------------------------------------------------------------------------------
/src/fixup.sh:
--------------------------------------------------------------------------------
1 | 
2 | for f in *; do
3 |   if (test -r $f && grep -q Copyright $f); then
4 |     echo $f
5 |     sed -e "s+ + +" <$f >$f.tmp
6 |     mv -f $f.tmp $f
7 |   fi
8 | done
9 | 


--------------------------------------------------------------------------------
/src/form.scm:
--------------------------------------------------------------------------------
  1 | ;==============================================================================
  2 | ; Expressions
  3 | ;
  4 | ; Code for recognizing, destructuring, and checking the syntax of forms.
  5 | 
  6 | (define (literal? x)
  7 |   (or (number? x) (string? x) (boolean? x) (char? x)))
  8 | 
  9 | 
 10 | (define syntax-checkers
 11 |   (make-vector number-of-classes (lambda (form) form #t)))
 12 | 
 13 | (define (define-syntax-checker class proc)
 14 |   (vector-set! syntax-checkers class proc))
 15 | 
 16 | (define (check-special-form-syntax class form)
 17 |   ((vector-ref syntax-checkers class) form))
 18 | 
 19 | 
 20 | ; (let-syntax (<syntax-spec>*) <body>)
 21 | 
 22 | (define let-syntax-form-dspecs cadr)
 23 | (define let-syntax-form-body caddr)
 24 | 
 25 | (define-syntax-checker class/let-syntax
 26 |   (lambda (exp)
 27 |     (and (= (careful-length exp) 3)
 28 | 	 (careful-every check-syntax-spec (cadr exp)))))
 29 | 
 30 | ; (letrec-syntax (<syntax-spec>*) <body>)
 31 | 
 32 | (define letrec-syntax-form-dspecs let-syntax-form-dspecs)
 33 | (define letrec-syntax-form-body   let-syntax-form-body)
 34 | 
 35 | (define-syntax-checker class/letrec-syntax
 36 |   (lambda (exp)
 37 |     (and (= (careful-length exp) 3)
 38 | 	 (careful-every check-syntax-spec (cadr exp)))))
 39 | 
 40 | ; Syntax specs (<name> <form>)
 41 | 
 42 | (define syntax-spec-name car)
 43 | (define syntax-spec-form cadr)
 44 | (define syntax-spec-free-names caddr)
 45 | 
 46 | (define (check-syntax-spec syntax-spec)
 47 |   (let ((len (careful-length syntax-spec)))
 48 |     (and (or (= len 2)
 49 | 	     (and (= len 3)
 50 | 		  ;; Hack for scheme48 linker
 51 | 		  (list? (syntax-spec-free-names syntax-spec))))
 52 | 	 (name? (syntax-spec-name syntax-spec)))))
 53 | 
 54 | ; (define-syntax <name> <form>)
 55 | 
 56 | (define define-syntax-syntax-spec cdr)
 57 | 
 58 | (define-syntax-checker class/define-syntax
 59 |   (lambda (form)
 60 |     (check-syntax-spec (cdr form))))
 61 | 
 62 | ; (begin <statement>*)
 63 | 
 64 | (define begin-form-statements cdr)
 65 | 
 66 | (define-syntax-checker class/begin
 67 |   (lambda (form)
 68 |     (>= (careful-length form) 1)))	;must be a proper list
 69 | 
 70 | 
 71 | ; application
 72 | 
 73 | (define application-form-procedure car)
 74 | (define application-form-arguments cdr)
 75 | 
 76 | 
 77 | ; (lambda (<name>*) <body>)
 78 | 
 79 | (define lambda-form-formals cadr)
 80 | (define lambda-form-body cddr)
 81 | 
 82 | (define-syntax-checker class/lambda
 83 |   (lambda (exp)
 84 |     (and (>= (careful-length exp) 3)
 85 | 	 (check-formals (lambda-form-formals exp)))))
 86 | 
 87 | (define (check-formals formals)
 88 |   (or (null? formals)
 89 |       (name? formals)
 90 |       (and (name? (car formals)) (check-formals (cdr formals)))))
 91 | 
 92 | 
 93 | ; (letrec ((<name> <exp>)) <body>)
 94 | 
 95 | (define letrec-form-bspecs cadr)
 96 | (define letrec-form-body cddr)
 97 | 
 98 | (define-syntax-checker class/letrec
 99 |   (lambda (exp)
100 |     (and (>= (careful-length exp) 3)
101 | 	 (careful-every (lambda (syntax-spec)
102 | 			  (and (= (careful-length syntax-spec) 2)
103 | 			       (name? (syntax-spec-name syntax-spec))))
104 | 			(letrec-form-bspecs exp)))))
105 | 
106 | 
107 | ; (quote <text>)
108 | 
109 | (define quote-form-text cadr)
110 | 
111 | (define-syntax-checker class/quote
112 |   (lambda (exp)
113 |     (= (careful-length exp) 2)))
114 | 
115 | 
116 | ; (if <test> <con> <alt>)
117 | 
118 | (define if-form-test cadr)
119 | (define if-form-consequent caddr)
120 | (define (if-form-alternate? exp)
121 |   (not (null? (cdddr exp))))
122 | (define if-form-alternate cadddr)
123 | 
124 | (define-syntax-checker class/if
125 |   (lambda (exp)
126 |     (let ((len (careful-length exp)))
127 |       (or (= len 3) (= len 4)))))
128 | 
129 | 
130 | ; (set! <lhs> <rhs>)
131 | 
132 | (define set!-form-lhs cadr)
133 | (define set!-form-rhs caddr)
134 | 
135 | (define-syntax-checker class/set!
136 |   (lambda (exp)
137 |     (and (= (careful-length exp) 3)
138 | 	 (name? (cadr exp)))))
139 | 
140 | 
141 | ; (define name exp) or (define (name . args) . body)
142 | 
143 | (define-syntax-checker class/define
144 |   (lambda (form)
145 |     (and (pair? (cdr form))
146 | 	 (let ((pat (cadr form))
147 | 	       (len (careful-length form)))
148 | 	   (if (name? pat)
149 | 	       (or (= len 2) (= len 3))
150 | 	       (and (pair? pat)
151 | 		    (check-formals (cdr pat))
152 | 		    (>= len 3)))))))
153 | 
154 | (define (define-form-lhs form)
155 |   (let ((pat (cadr form)))
156 |     (if (pair? pat) (car pat) pat)))
157 | 
158 | (define (define-form-rhs form)
159 |   (let ((pat (cadr form)))
160 |     (cond ((pair? pat)
161 | 	   `(lambda ,(cdr pat) ,@(cddr form)))
162 | 	  ((null? (cddr form))
163 | 	   'ps:unspecific)		;(define foo)
164 | 	  (else
165 | 	   (caddr form)))))
166 | 
167 | 
168 | ; Versions of LENGTH and EVERY that do not assume that the lists they are
169 | ; handed are proper.
170 | 
171 | (define (careful-length l)
172 |   (if (null? l)
173 |       0
174 |       (if (pair? l)
175 | 	  (+ 1 (careful-length (cdr l)))
176 | 	  -1)))
177 | 
178 | (define (careful-every pred l)
179 |   (if (null? l)
180 |       #t
181 |       (and (pair? l)
182 | 	   (pred (car l))
183 | 	   (careful-every pred (cdr l)))))
184 | 


--------------------------------------------------------------------------------
/src/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 | 


--------------------------------------------------------------------------------
/src/kludge.lisp:
--------------------------------------------------------------------------------
 1 | 
 2 | ; Clobber some internal Lucid functions to make Pseudoscheme run
 3 | ; better.  This will probably break in some future Lucid release, but
 4 | ; it works in 4.1 on a Sparc.
 5 | 
 6 | ; As far as I can tell, (lcl::top-level-read) is the same as (read)
 7 | ; except that it also sets the variables -, +, ++, and +++.
 8 | 
 9 | (in-package "PS")
10 | 
11 | (defun kludge-top-level-read (original-top-level-read
12 | 			      preserve-whitespace-p
13 | 			      stream eof-error-p eof-value)
14 |   (if (eq *package* scheme-package)
15 |       (loop
16 |        (let ((c (peek-char t stream eof-error-p stream)))
17 | 	 (cond ((eq c stream) ;eof
18 | 		(return c))
19 | 	       ((eq c #\;)
20 | 		(read-line stream eof-error-p stream))   ;loop
21 | 	       ((eq c #\:)
22 | 		(return (funcall original-top-level-read
23 | 				 stream eof-error-p eof-value)))
24 | 	       (t
25 | 		(return
26 | 		 (let ((form (funcall *scheme-read* stream)))
27 | 		   (if (eq form eof-object)
28 | 		       (if eof-error-p
29 | 			   (error "End of file on stream ~S" stream)
30 | 			   eof-value)
31 | 		       (let ((result
32 | 			      (if (or (consp form)
33 | 				      (and (symbolp form)
34 | 					   (eq (symbol-package form)
35 | 					       scheme-package)))
36 | 				  `(scheme-form ,form)
37 | 				  form)))
38 | 			 (setq +++ ++ ++ + + - - result)
39 | 			 result))))))))
40 |       (funcall original-top-level-read stream eof-error-p eof-value)))
41 | 
42 | 
43 | ; Lucid can't be helped
44 | #|
45 |  (loop (if (listen stream)
46 | 	   (let ((c (peek-char nil stream eof-error-p)))
47 | 	     (if (eq c #\newline)
48 | 		 (return (read-char stream eof-error-p))))))
49 | 
50 |       (and (not (eq *readtable* scheme-readtable))
51 | 	   (not (eq *readtable* roadblock-readtable))
52 | 	   (not (eq *readtable* *non-scheme-readtable*)))
53 |       (progn (setq *readtable* roadblock-readtable)   ;Invoke Scheme reader
54 | 	     (let ((form (apply original-top-level-read args)))
55 | 	       (format *debug-io*
56 | 		       "~&(Fixing Lucid lossage: *readtable* restored to ~s~%"
57 | 		       'roadblock-readtable)
58 | 
59 |       ))
60 | |#
61 | 
62 | (defvar *original-top-level-read*
63 |   #'lucid::top-level-read)
64 | 
65 | (defun lucid::top-level-read (&optional (stream *standard-input*)
66 | 					(eof-error-p t)
67 | 					(eof-value stream))
68 |   ;; Should avoid preserving whitespace ?
69 |   (kludge-top-level-read *original-top-level-read*
70 | 			 nil
71 | 			 stream eof-error-p eof-value))
72 | 
73 | (defvar *original-debugger-top-level-read*
74 |   #'lucid::debugger-top-level-read)
75 | 
76 | (defun lucid::debugger-top-level-read (&optional (stream *debug-io*)
77 | 						 (eof-error-p t)
78 | 						 (eof-value stream))
79 |   ;; Should read-preserving-whitespace ?
80 |   (kludge-top-level-read *original-debugger-top-level-read*
81 | 			 t
82 | 			 stream eof-error-p eof-value))
83 | 


--------------------------------------------------------------------------------
/src/list.pso:
--------------------------------------------------------------------------------
 1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
 2 | 
 3 | ; This file was generated by Pseudoscheme 2.12
 4 | ;  running in CMU Common Lisp 16-Aug-1993
 5 | ;  from file /zu/jar/pseudo/list.scm
 6 | 
 7 | (ps:in-package "SCHEME-TRANSLATOR")
 8 | (BEGIN-TRANSLATED-FILE)
 9 | (DEFUN SOME (PRED L)
10 |   (IF (NOT (NULL L))
11 |       (LET ((TEMP (FUNCALL PRED (CAR L))))
12 |         (IF (TRUEP TEMP) TEMP (SOME PRED (CDR L))))
13 |       FALSE))
14 | (SET-VALUE-FROM-FUNCTION 'SOME 'SCHEME::SOME)
15 | (DEFUN EVERY (PRED L)
16 |   (OR (NULL L) (IF (TRUEP (FUNCALL PRED (CAR L))) (EVERY PRED (CDR L)) FALSE)))
17 | (SET-VALUE-FROM-FUNCTION 'EVERY 'SCHEME::EVERY)
18 | (DEFUN RASSQ (OBJ LST)
19 |   (IF (NULL LST)
20 |       FALSE
21 |       (IF (EQ OBJ (CDAR LST)) (CAR LST) (RASSQ OBJ (CDR LST)))))
22 | (SET-VALUE-FROM-FUNCTION 'RASSQ 'SCHEME::RASSQ)
23 | (DEFUN FILTER (PRED L)
24 |   (IF (NULL L)
25 |       'NIL
26 |       (IF (TRUEP (FUNCALL PRED (CAR L)))
27 |           (CONS (CAR L) (FILTER PRED (CDR L)))
28 |           (FILTER PRED (CDR L)))))
29 | (SET-VALUE-FROM-FUNCTION 'FILTER 'SCHEME::FILTER)
30 | (DEFUN RIGHT-REDUCE (PROC LST IDENTITY)
31 |   (IF (NULL LST)
32 |       IDENTITY
33 |       (RIGHT-REDUCE PROC (CDR LST) (FUNCALL PROC (CAR LST) IDENTITY))))
34 | (SET-VALUE-FROM-FUNCTION 'RIGHT-REDUCE 'SCHEME::RIGHT-REDUCE)
35 | (LOCALLY (DECLARE (SPECIAL REDUCE RIGHT-REDUCE)) (SETQ REDUCE RIGHT-REDUCE))
36 | (SET-FUNCTION-FROM-VALUE 'REDUCE 'SCHEME::REDUCE)
37 | (DEFUN SETDIFFQ (L1 L2)
38 |   (IF (NULL L2)
39 |       L1
40 |       (IF (NULL L1)
41 |           L1
42 |           (IF (MEMBER (CAR L1) L2 :TEST #'EQ)
43 |               (SETDIFFQ (CDR L1) L2)
44 |               (CONS (CAR L1) (SETDIFFQ (CDR L1) L2))))))
45 | (SET-VALUE-FROM-FUNCTION 'SETDIFFQ 'SCHEME::SETDIFFQ)
46 | (DEFUN UNIONQ (L1 L2)
47 |   (IF (NULL L1)
48 |       L2
49 |       (IF (NULL L2)
50 |           L1
51 |           (IF (MEMBER (CAR L1) L2 :TEST #'EQ)
52 |               (UNIONQ (CDR L1) L2)
53 |               (CONS (CAR L1) (UNIONQ (CDR L1) L2))))))
54 | (SET-VALUE-FROM-FUNCTION 'UNIONQ 'SCHEME::UNIONQ)
55 | (DEFUN INTERSECTQ (L1 L2)
56 |   (IF (NULL L1)
57 |       L1
58 |       (IF (NULL L2)
59 |           L2
60 |           (IF (MEMBER (CAR L1) L2 :TEST #'EQ)
61 |               (CONS (CAR L1) (INTERSECTQ (CDR L1) L2))
62 |               (INTERSECTQ (CDR L1) L2)))))
63 | (SET-VALUE-FROM-FUNCTION 'INTERSECTQ 'SCHEME::INTERSECTQ)
64 | (DEFUN INTERSECTQ? (L1 L2)
65 |   (IF (NOT (NULL L1))
66 |       (IF (NOT (NULL L2))
67 |           (OR (MEMBER (CAR L1) L2 :TEST #'EQ) (INTERSECTQ? (CDR L1) L2))
68 |           FALSE)
69 |       FALSE))
70 | (SET-VALUE-FROM-FUNCTION 'INTERSECTQ? 'SCHEME::INTERSECTQ?)
71 | 


--------------------------------------------------------------------------------
/src/list.scm:
--------------------------------------------------------------------------------
 1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
 2 | ; File list.scm / See file COPYING
 3 | 
 4 | ;;;; List utilities
 5 | 
 6 | (define (some pred l)
 7 |   (and (not (null? l))
 8 |        (or (pred (car l)) (some pred (cdr l)))))
 9 | 
10 | (define (every pred l)
11 |   (or (null? l)
12 |       (and (pred (car l)) (every pred (cdr l)))))
13 | 
14 | (define (rassq obj lst)
15 |   (cond ((null? lst) #f)
16 | 	((eq? obj (cdar lst)) (car lst))
17 | 	(else (rassq obj (cdr lst)))))
18 | 
19 | (define (filter pred l)
20 |   (cond ((null? l) '())
21 | 	((pred (car l)) (cons (car l) (filter pred (cdr l))))
22 | 	(else (filter pred (cdr l)))))
23 | 
24 | (define (right-reduce proc lst identity)
25 |   (cond ((null? lst) identity)
26 | 	(else (right-reduce proc (cdr lst) (proc (car lst) identity)))))
27 | 
28 | (define reduce right-reduce)
29 | 
30 | ; Set utilities
31 | 
32 | (define (setdiffq l1 l2)
33 |   (cond ((null? l2) l1)
34 | 	((null? l1) l1)
35 | 	((memq (car l1) l2)
36 | 	 (setdiffq (cdr l1) l2))
37 | 	(else (cons (car l1)
38 | 		    (setdiffq (cdr l1) l2)))))
39 | 
40 | (define (unionq l1 l2)
41 |   (cond ((null? l1) l2)
42 | 	((null? l2) l1)
43 | 	((memq (car l1) l2) (unionq (cdr l1) l2))
44 | 	(else (cons (car l1) (unionq (cdr l1) l2)))))
45 | 
46 | (define (intersectq l1 l2)
47 |   (cond ((null? l1) l1)
48 | 	((null? l2) l2)
49 | 	((memq (car l1) l2)
50 | 	 (cons (car l1) (intersectq (cdr l1) l2)))
51 | 	(else (intersectq (cdr l1) l2))))
52 | 
53 | (define (intersectq? l1 l2)
54 |   (and (not (null? l1))
55 |        (not (null? l2))
56 |        (or (memq (car l1) l2)
57 | 	   (intersectq? (cdr l1) l2))))
58 | 


--------------------------------------------------------------------------------
/src/loadit.lisp:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
  2 | ; Copyright (c) 1991-1994 Jonathan Rees / See file COPYING
  3 | (in-package :cl-user)
  4 | ;;;; Load script
  5 | 
  6 | ; Load this into any package that inherits the usual culprits (DEFUN, etc.).
  7 | 
  8 | ; Will not run in:
  9 | ;  Symbolics versions older than Rel 7.1
 10 | ;  VAX LISP versions older than V2.2
 11 | ;  Explorer versions older than 3.0
 12 | 
 13 | 
 14 | ; These are my personal favorite settings; you may want to change them.
 15 | 
 16 | ;(proclaim '(optimize (speed 3)
 17 | ;		     #-LispWorks (safety 2)
 18 | ;		     #+LispWorks (safety 3)  ;sux
 19 | ;		     (compilation-speed 0)))
 20 | 
 21 | 
 22 | (defvar *pseudoscheme-directory* 
 23 |   (make-pathname :name nil :type nil :version nil
 24 | 		 :defaults *load-truename*))
 25 | (defvar *use-scheme-read* t)
 26 | (defvar *use-scheme-write* t)
 27 | 
 28 | (defun load-pseudoscheme (&optional (dir *pseudoscheme-directory*))
 29 |   (designate-pseudoscheme-directory dir)
 30 |   (load (pseudo-pathname "pack")) ; Create packages
 31 |   (load-clever-loader)
 32 |   (load-pseudoscheme-run-time)
 33 |   ;; Note that if you're only going to run a program that's already been
 34 |   ;; compiled and/or fed through the translator, you can omit the following
 35 |   ;; two steps.
 36 |   (load-pseudoscheme-translator)
 37 |   (load-pseudoscheme-eval))
 38 | 
 39 | (defun designate-pseudoscheme-directory (dir)
 40 |   (setq *pseudoscheme-directory*
 41 | 	(let ((dir (pathname (or dir
 42 | 				 *default-pathname-defaults*))))
 43 | 	  (make-pathname :name nil
 44 | 			 :type nil
 45 | 			 :directory (pathname-directory dir)
 46 | 			 :device    (pathname-device dir)
 47 | 			 :host	    (pathname-host dir)))))
 48 | 
 49 | (defun pseudo-pathname (name)
 50 |   (make-pathname :name (filename-preferred-case name)
 51 | 		 :defaults *pseudoscheme-directory*))
 52 | 
 53 | ; These two definitions also occur in core.lisp:
 54 | (defun filename-preferred-case (name)
 55 |   #+unix (string-downcase name)
 56 |   #-unix (string-upcase name)
 57 |   )
 58 | ; PSO stands for Pseudo-Scheme Object file
 59 | (defvar *translated-file-type* (filename-preferred-case "pso"))
 60 | 
 61 | ; ----- Load silly file loader
 62 | 
 63 | (defvar clever-load)
 64 | (defun clever-load (&rest foo) (apply clever-load foo))
 65 | 
 66 | (defun load-clever-loader ()
 67 |   (load (pseudo-pathname "clever")) ;Get clever file loader
 68 |   (setq clever-load
 69 | 	(symbol-function (intern "CLEVER-LOAD"
 70 | 				 (find-package "CLEVER-LOAD")))))
 71 | 
 72 | ; ----- Load Scheme run-time system
 73 | 
 74 | (defvar revised^4-scheme-package)
 75 | 
 76 | (defun load-pseudoscheme-run-time ()
 77 | 
 78 |   (load-pseudoscheme-run-time-file "core")
 79 | 
 80 |   (load (pseudo-pathname "spack")) ; Create more packages
 81 | 
 82 |   (setq revised^4-scheme-package
 83 | 	(find-package "REVISED^4-SCHEME"))
 84 | 
 85 |   ;; This sets up the revised^4 scheme package, among other things
 86 |   (load-pseudoscheme-translated "closed" revised^4-scheme-package)
 87 | 
 88 |   ;; This loads into the revised^4 scheme package
 89 |   (load-pseudoscheme-run-time-file "rts")
 90 | 
 91 |   (load-pseudoscheme-run-time-file "readwrite")
 92 | 
 93 |   ;; read and write are optional.  Loading "read" gets you ... and
 94 |   ;; symbols with colons in their names.
 95 |   ;; Loading "write" gets you these plus (), #t, and #f.
 96 |   ;; The downside of using the Scheme reader is that it becomes nearly
 97 |   ;; impossible to use Common Lisp functions, variables, and symbols
 98 |   ;; from Scheme code.
 99 |   (if *use-scheme-read*
100 |       (load-pseudoscheme-translated "read" revised^4-scheme-package))
101 |   (if *use-scheme-write*
102 |       (load-pseudoscheme-translated "write" revised^4-scheme-package))
103 |   'done)
104 | 
105 | ; ----- Load translator
106 | 
107 | (defparameter scheme-translator-package nil)
108 | (defparameter translator-files nil)
109 | 
110 | (defun load-pseudoscheme-translator ()
111 |   (setq scheme-translator-package
112 | 	(find-package "SCHEME-TRANSLATOR"))
113 |   (setq translator-files
114 | 	(with-open-file (s (pseudo-pathname "translator.files"))
115 | 	  (read s)))
116 |   (mapc #'(lambda (file)
117 | 	    (load-pseudoscheme-translated file scheme-translator-package))
118 | 	translator-files)
119 |   'done)
120 | 
121 | (defun load-pseudoscheme-eval ()
122 |   (load-pseudoscheme-run-time-file "eval")
123 |   #+Lispm
124 |   (load-pseudoscheme-run-time-file "custom"))
125 | 
126 | 
127 | 
128 | (defun load-pseudoscheme-run-time-file (filespec)
129 |   (clever-load (pseudo-pathname (if (consp filespec)
130 | 				    (car filespec)
131 | 				    filespec))
132 | 	       :compile-if-necessary (not (consp filespec))))
133 | 
134 | (defun load-pseudoscheme-translated (file package)
135 |   (declare (ignore package))    ;no longer used
136 |   (clever-load (pseudo-pathname file)
137 | 	       :source-type *translated-file-type*
138 | 	       :compile-if-necessary t))
139 | 
140 | 
141 | ; Cope with vagaries of #+ in DEC's VAX LISP
142 | 
143 | (eval-when (eval load compile)
144 |   (when (find-if #'(lambda (feature)
145 | 		     (and (symbolp feature)
146 | 			  (string= (symbol-name feature) "DEC")))
147 | 		 *features*)
148 |     (pushnew ':DEC *features*)))
149 | 


--------------------------------------------------------------------------------
/src/module.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File module.scm / See file COPYING
  3 | 
  4 | ;;;; Interfaces, program environments, structures
  5 | 
  6 | ; Interfaces
  7 | 
  8 | (define interface-rtd
  9 |   (make-record-type 'interface '(id names aux-names)))
 10 | 
 11 | (define make-interface
 12 |   (record-constructor interface-rtd '(id names aux-names)))
 13 | 
 14 | (define interface-names (record-accessor interface-rtd 'names))
 15 | (define interface-aux-names (record-accessor interface-rtd 'aux-names))
 16 | 
 17 | ; INTERFACE-REF returns one of
 18 | ;   #F       if the name is not exported
 19 | ;   PUBLIC   if exported as a value
 20 | ;   PRIVATE  if exported as an auxiliary value
 21 | 
 22 | ;+++ This can be slow if SIG exports many variables (as does the r^4
 23 | ; interface).  If this becomes a problem, change it so that it does a
 24 | ; table lookup (after some threshold size?).
 25 | 
 26 | (define (interface-ref sig name)
 27 |   (cond ((memq name (interface-names sig)) 'public)
 28 | 	(else #f)))
 29 | 
 30 | (define (interface-ref-aux sig name)
 31 |   (cond ((memq name (interface-names sig)) 'public)
 32 | 	((memq name (interface-aux-names sig)) 'private)
 33 | 	(else #f)))
 34 | 
 35 | 
 36 | ; Program (i.e. top-level) environments contain macro definitions.
 37 | 
 38 | (define program-env-rtd
 39 |   (make-record-type 'program-env '(id use-list table package)))
 40 | (define program-env-id       (record-accessor program-env-rtd 'id))
 41 | (define program-env-use-list (record-accessor program-env-rtd 'use-list))
 42 | (define program-env-table    (record-accessor program-env-rtd 'table))
 43 | (define program-env-package  (record-accessor program-env-rtd 'package))
 44 | (define program-env? (record-predicate program-env-rtd))
 45 | 
 46 | (define make-program-env
 47 |   (let ((create (record-constructor program-env-rtd
 48 | 				    '(id use-list table package))))
 49 |     (lambda (id use-list)
 50 |       (let ((env
 51 | 	     (create id
 52 | 		     use-list
 53 | 		     (make-table)
 54 | 		     (make-package-using id (map structure-package use-list)))))
 55 | 	(init-environment-for-syntax! env)
 56 | 	env))))
 57 | 
 58 | (define-record-discloser program-env-rtd
 59 |   (lambda (r) (list "Program-env" (program-env-id r))))
 60 | 
 61 | ; Careful, name need not be a symbol
 62 | 
 63 | (define (program-env-lookup program-env name)
 64 |   (or (table-ref (program-env-table program-env) name)
 65 |       (program-env-new-variable program-env name)))
 66 | 
 67 | (define (program-env-define! program-env name binding)
 68 |   (table-set! (program-env-table program-env) name binding))
 69 | 
 70 | (define (program-env-ensure-defined program-env name)
 71 |   (let ((probe (table-ref (program-env-table program-env) name)))
 72 |     (if (and (node? probe)
 73 | 	     (program-variable? probe))
 74 | 	probe
 75 | 	(program-env-new-variable program-env name))))
 76 | 
 77 | (define (program-env-new-variable program-env name)
 78 |   (let ((q? (and (symbol? name)
 79 | 		 (qualified-symbol? name))))
 80 |     (or (and (not q?)
 81 | 	     (let loop ((mods (program-env-use-list program-env)))
 82 | 	       (and (not (null? mods))
 83 | 		    (or (structure-ref (car mods) name)
 84 | 			(loop (cdr mods))))))
 85 | 	;; SIDE EFFECT!  Not so good.
 86 | 	(let ((node (make-program-variable
 87 | 		     name
 88 | 		     (if q?
 89 | 			 name
 90 | 			 (intern-renaming-perhaps
 91 | 			  (name->string name)
 92 | 			  (program-env-package program-env))))))
 93 | 	  (table-set! (program-env-table program-env) name node)
 94 | 	  node))))
 95 | 
 96 | (define client-lookup program-env-lookup)   ;for classify
 97 | (define client-define! program-env-define!) ;for classify
 98 | (define client-ensure-defined program-env-ensure-defined)
 99 | 
100 | 
101 | ; Get the environment in which to evaluate transformer procedure expressions.
102 | 
103 | (define environment-for-syntax-key
104 |   (list 'environment-for-syntax-key))  ;any unique id
105 | 
106 | (define (get-environment-for-syntax env)
107 |   (force (lookup env environment-for-syntax-key)))
108 | 
109 | (define (define-transformer-env! env t-env-promise)
110 |   (define! env environment-for-syntax-key t-env-promise))
111 | 
112 | (define (init-environment-for-syntax! env)
113 |   (define-transformer-env! env
114 |     (delay (make-program-env
115 | 	    (string->symbol
116 | 	     (string-append (symbol->string (program-env-id env))
117 | 			    "[FOR-SYNTAX]"))
118 | 	    (list revised^4-scheme-structure)))))
119 | 
120 | 
121 | ; A structure is a pair <interface, program-environment>.
122 | ; Pavel Curtis would prefer to call these things "interfaces".
123 | 
124 | (define structure-rtd
125 |   (make-record-type 'structure '(id sig program-env package)))
126 | (define make-structure
127 |   (let ((create
128 | 	 (record-constructor structure-rtd '(id sig program-env package))))
129 |     (lambda (id sig env)
130 |       (create id sig env
131 | 	      (make-package-exporting
132 | 	           id
133 | 		   (let ((ppackage (program-env-package env)))
134 | 		     (map (lambda (name)
135 | 			    (intern-renaming-perhaps
136 | 		                 (symbol->string name)
137 | 				 ppackage))
138 | 			  (interface-names sig))))))))
139 | 
140 | 
141 | (define structure-id        (record-accessor structure-rtd 'id))
142 | (define structure-interface (record-accessor structure-rtd 'sig))
143 | (define structure-program-env (record-accessor structure-rtd 'program-env))
144 | (define structure-package   (record-accessor structure-rtd 'package))
145 | 
146 | (define-record-discloser structure-rtd
147 |   (lambda (r) (list "Structure" (structure-id r))))
148 | 
149 | (define (structure-ref mod name)
150 |   (if (eq? (interface-ref (structure-interface mod) name)
151 | 	   'public)
152 |       (program-env-lookup (structure-program-env mod) name)
153 |       #f))
154 | 


--------------------------------------------------------------------------------
/src/node.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File node.scm / See file COPYING
  3 | 
  4 | ;;;; Node abstraction
  5 | 
  6 | ;+++ Make it abstract at some point.
  7 | 
  8 | ; Standard type order (8):
  9 | ;  constant variable LAMBDA LETREC IF BEGIN SET! call
 10 | 
 11 | (define (node? obj)
 12 |   (and (vector? obj)
 13 |        (>= (vector-length obj) 1)
 14 |        (memq (vector-ref obj 0)
 15 | 	     '(constant local-variable program-variable
 16 | 			lambda letrec if begin set! call))))
 17 | 
 18 | (define (node-type node)
 19 |   (vector-ref node 0))
 20 | 
 21 | (define (node-predicate type)
 22 |   (lambda (node)
 23 |     (eq? (node-type node) type)))
 24 | 
 25 | (define (node-accessor type index)
 26 |   (lambda (node)
 27 |     (if (not (eq? (node-type node) type))
 28 | 	(error "wrong node type" node type))
 29 |     (vector-ref node index)))
 30 | 
 31 | (define (node-modifier type index)
 32 |   (lambda (node new-val)
 33 |     (if (not (eq? (node-type node) type))
 34 | 	(error "wrong node type" node type))
 35 |     (vector-set! node index new-val)))
 36 | 
 37 | ; Constant
 38 | 
 39 | (define (make-constant val quoted?)
 40 |   (vector 'constant val quoted?))
 41 | 
 42 | (define constant? (node-predicate 'constant))
 43 | 
 44 | (define constant-value (node-accessor 'constant 1))
 45 | (define constant-quoted? (node-accessor 'constant 2))
 46 | 
 47 | ; LAMBDA
 48 | 
 49 | (define (make-lambda vars body-node)
 50 |   (vector 'lambda vars body-node))
 51 | 
 52 | (define lambda? (node-predicate 'lambda))
 53 | 
 54 | (define lambda-vars (node-accessor 'lambda 1))
 55 | (define lambda-body (node-accessor 'lambda 2))
 56 | 
 57 | (define (n-ary? proc)
 58 |   (not (proper-list? (lambda-vars proc))))
 59 | 
 60 | (define (proper-list? thing)
 61 |   (or (null? thing)
 62 |       (and (pair? thing)
 63 | 	   (null? (cdr (last-pair thing))))))
 64 | 
 65 | (define (proper-listify thing)
 66 |   (cond ((null? thing) '())
 67 | 	((pair? thing) (cons (car thing) (proper-listify (cdr thing))))
 68 | 	(else (list thing))))
 69 | 
 70 | (define (map-bvl proc bvl)
 71 |   (cond ((null? bvl) '())
 72 | 	((pair? bvl)
 73 | 	 (cons (proc (car bvl)) (map-bvl proc (cdr bvl))))
 74 | 	(else (proc bvl))))
 75 | 
 76 | (define (for-each-bvl proc bvl)
 77 |   (cond ((null? bvl) #t)
 78 | 	((pair? bvl)
 79 | 	 (proc (car bvl))
 80 | 	 (for-each-bvl proc (cdr bvl)))
 81 | 	(else (proc bvl))))
 82 | 
 83 | ; LETREC
 84 | 
 85 | (define (make-letrec vars val-nodes body-node)
 86 |   (vector 'letrec vars val-nodes body-node #f))
 87 | 
 88 | (define letrec? (node-predicate 'letrec))
 89 | 
 90 | (define letrec-vars (node-accessor 'letrec 1))
 91 | (define letrec-vals (node-accessor 'letrec 2))
 92 | (define letrec-body (node-accessor 'letrec 3))
 93 | (define letrec-strategy (node-accessor 'letrec 4))
 94 | 
 95 | (define set-letrec-strategy! (node-modifier 'letrec 4))
 96 | 
 97 | ; IF
 98 | 
 99 | (define (make-if test con alt)
100 |   (vector 'if test con alt))
101 | 
102 | (define if? (node-predicate 'if))
103 | 
104 | (define if-test (node-accessor 'if 1))
105 | (define if-con  (node-accessor 'if 2))
106 | (define if-alt  (node-accessor 'if 3))
107 | 
108 | ; BEGIN
109 | 
110 | (define (make-begin first second)
111 |   (vector 'begin first second))
112 | (define begin? (node-predicate 'begin))
113 | (define begin-first  (node-accessor 'begin 1))
114 | (define begin-second (node-accessor 'begin 2))
115 | 
116 | ; SET!
117 | 
118 | (define (make-set! lhs rhs)
119 |   (vector 'set! lhs rhs))
120 | (define set!? (node-predicate 'set!))
121 | (define set!-lhs (node-accessor 'set! 1))
122 | (define set!-rhs (node-accessor 'set! 2))
123 | 
124 | ; Call
125 | 
126 | (define (make-call proc-node arg-nodes)
127 |   (vector 'call proc-node arg-nodes))
128 | 
129 | (define call? (node-predicate 'call))
130 | (define call-proc (node-accessor 'call 1))
131 | (define call-args (node-accessor 'call 2))
132 | 
133 | ; Definition
134 | 
135 | (define (make-define lhs rhs)
136 |   (vector 'define lhs rhs))
137 | (define define? (node-predicate 'define))
138 | (define define-lhs (node-accessor 'define 1))
139 | (define define-rhs (node-accessor 'define 2))
140 | 
141 | ; Variables
142 | 
143 | (define (make-local-variable uname)
144 |   (vector 'local-variable
145 | 	  uname				;1 user's name
146 | 	  #f     			;2 type (not used by pseudoscheme)
147 | 	  #f				;3 substitution
148 | 	  #f				;4 path - obsolete
149 | 	  #f				;5 value-refs?
150 | 	  #f				;6 proc-refs?
151 | 	  #f				;7 assigned?
152 | 	  #f				;8 closed-over?
153 | 	  ))
154 | 
155 | (define local-variable? (node-predicate 'local-variable))
156 | 
157 | (define local-variable-name   (node-accessor 'local-variable 1))
158 | (define local-variable-type   (node-accessor 'local-variable 2))
159 | (define variable-substitution (node-accessor 'local-variable 3))
160 | 
161 | (define set-local-variable-type! (node-modifier 'local-variable 2))
162 | (define set-substitution! (node-modifier 'local-variable 3))
163 | 
164 | (define variable-value-refs?  (node-accessor 'local-variable 5))
165 | (define variable-proc-refs?   (node-accessor 'local-variable 6))
166 | (define variable-assigned?    (node-accessor 'local-variable 7))
167 | (define variable-closed-over? (node-accessor 'local-variable 8))
168 | 
169 | (define (variable-incrementator n)
170 |   (let ((ref (node-accessor 'local-variable n))
171 | 	(mod (node-modifier 'local-variable n)))
172 |     (lambda (var)
173 |       (mod var (+ (or (ref var) 0) 1)))))
174 | 
175 | (define set-value-refs!  (variable-incrementator 5))
176 | (define set-proc-refs!   (variable-incrementator 6))
177 | (define set-assigned!    (variable-incrementator 7))
178 | (define set-closed-over! (variable-incrementator 8))
179 | 
180 | ; Program (or "global" or "top-level") variables
181 | 
182 | (define (make-program-variable name loc)
183 |   (vector 'program-variable name #f loc))
184 | 
185 | (define program-variable? (node-predicate 'program-variable))
186 | 
187 | (define program-variable-name     (node-accessor 'program-variable 1))
188 | (define program-variable-type     (node-accessor 'program-variable 2))
189 | (define program-variable-location (node-accessor 'program-variable 3))
190 | 
191 | (define set-program-variable-type! (node-modifier 'program-variable 2))
192 | 
193 | (define (variable? node)
194 |   (or (local-variable? node)
195 |       (program-variable? node)))
196 | 


--------------------------------------------------------------------------------
/src/p-record.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File record.scm / Copyright (c) 1989 Jonathan Rees / See file COPYING
  3 | 
  4 | ;;;; Record package for Pseudoscheme
  5 | 
  6 | (ps-lisp:defstruct (record-type-descriptor (:constructor make-rtd)
  7 | 					(:print-function print-rtd)
  8 | 					(:conc-name "RTD-"))
  9 |   identification
 10 |   unique-id
 11 |   field-names
 12 |   constructor-function
 13 |   predicate-function
 14 |   accessor-functions)
 15 | 
 16 | (define *record-type-unique-id* 0)
 17 | 
 18 | (define package-for-record-functions
 19 |   (ps-lisp:make-package
 20 |    (ps-lisp:if (ps-lisp:find-package ".RECORD")
 21 | 	    (let loop ((n 0))
 22 | 	      (let ((name (string-append ".RECORD-" (number->string n))))
 23 | 		(ps-lisp:if (ps-lisp:find-package name)
 24 | 			 (loop (+ n 1))
 25 | 			 name)))
 26 | 	    ".RECORD")
 27 |    :use '()))
 28 | 
 29 | (define (really-make-record-type type-id field-names)
 30 |   (let* ((conc
 31 | 	  (lambda things
 32 | 	    (ps-lisp:intern
 33 | 	     (apply string-append
 34 | 		    (map (lambda (thing)
 35 | 			   (cond ((string? thing) thing)
 36 | 				 ((number? thing)
 37 | 				  (number->string thing))
 38 | 				 ((symbol? thing)
 39 | 				  (ps-lisp:symbol-name thing))
 40 | 				 (else "?")))
 41 | 			 things))
 42 | 	     package-for-record-functions)))
 43 | 	 (id-symbol
 44 | 	  (conc type-id "#" *record-type-unique-id*))
 45 | 	 (constructor-function
 46 | 	  (conc 'make- id-symbol))
 47 | 	 (predicate-function
 48 | 	  (conc id-symbol '?))
 49 | 	 (accessor-functions
 50 | 	  (map (lambda (f)
 51 | 		    (conc id-symbol '- f))
 52 | 	       field-names))
 53 | 	 (rtd (make-rtd :identification type-id
 54 | 			:unique-id *record-type-unique-id*
 55 | 			:field-names field-names
 56 | 			:constructor-function constructor-function
 57 | 			:predicate-function predicate-function
 58 | 			:accessor-functions accessor-functions)))
 59 |     (ps-lisp:setf (ps-lisp:get id-symbol 'rtd) rtd)
 60 |     (let ((ps-lisp:*package* package-for-record-functions))
 61 |       ;; Careful -- :CONC-NAME NIL doesn't mean defstruct won't try to
 62 |       ;; intern new symbols in current package!
 63 |       (ps-lisp:eval `(ps-lisp:defstruct (,id-symbol
 64 | 				   (:constructor ,constructor-function ())
 65 | 				   (:print-function ,(ps-lisp:quote print-record))
 66 | 				   (:predicate ,predicate-function)
 67 | 				   (:copier ps-lisp:nil)
 68 | 				   (:conc-name ps-lisp:nil))
 69 | 		    ,@accessor-functions)))
 70 |     (set! *record-type-unique-id* (+ *record-type-unique-id* 1))
 71 |     rtd))
 72 | 
 73 | (define (record-constructor rtd . init-names-option)
 74 |   (let ((cfun (rtd-constructor-function rtd))
 75 | 	(funs (map (lambda (name)
 76 | 		     (rtd-accessor-function rtd name))
 77 | 		   (if (null? init-names-option)
 78 | 		       (rtd-field-names rtd)
 79 | 		       (car init-names-option)))))
 80 |     (ps-lisp:unless (ps-lisp:compiled-function-p (ps-lisp:symbol-function cfun))
 81 | 		 (ps-lisp:compile cfun))
 82 |     (ps-lisp:compile 'ps-lisp:nil
 83 | 		  `(ps-lisp:lambda ,funs
 84 | 		     (ps-lisp:let ((the-record (,cfun)))
 85 | 		       ,@(map (lambda (fun)
 86 | 				`(ps-lisp:setf (,fun the-record)
 87 | 					    ,fun))
 88 | 			      funs)
 89 | 		       the-record)))))
 90 | 
 91 | (define (record-predicate rtd)
 92 |   (let ((fun (rtd-predicate-function rtd)))
 93 | ;    (ps-lisp:unless (ps-lisp:compiled-function-p (ps-lisp:symbol-function fun))
 94 | ;                 (ps-lisp:compile fun))
 95 | ;    (ps-lisp:symbol-function fun)
 96 |     (ps-lisp:compile 'ps-lisp:nil
 97 | 		  `(ps-lisp:lambda (x)
 98 | 		     (ps-lisp:if (,fun x) ,#t ,#f))))) ;bootstrap subtlety
 99 | 
100 | (define (record-accessor rtd name)
101 |   (let ((fun (rtd-accessor-function rtd name)))
102 |     (ps-lisp:unless (ps-lisp:compiled-function-p (ps-lisp:symbol-function fun))
103 | 		 (ps-lisp:compile fun))
104 |     (ps-lisp:symbol-function fun)))
105 | 
106 | (define (record-modifier rtd name)
107 |   (let ((fun (rtd-accessor-function rtd name)))
108 |     (ps-lisp:compile 'ps-lisp:nil `(ps-lisp:lambda (x y)
109 | 			       (ps-lisp:setf (,fun x) y)))))
110 | 
111 | (define (rtd-accessor-function rtd name)
112 |   (let loop ((l (rtd-field-names rtd))
113 | 	     (a (rtd-accessor-functions rtd)))
114 |     (if (null? l)
115 | 	(ps-lisp:error "~S is not a field name for ~S records"
116 | 		    name
117 | 		    (rtd-identification rtd))
118 | 	(if (eq? name (car l))
119 | 	    (car a)
120 | 	    (loop (cdr l) (cdr a))))))
121 | 
122 | ; make-record-type:
123 | 
124 | (define record-type-table (ps-lisp:make-hash-table :test 'ps-lisp:equal))
125 | 
126 | (define (make-record-type type-id field-names)
127 |   (let* ((key (cons type-id field-names))
128 | 	 (existing (ps-lisp:gethash key record-type-table)))
129 |     (if (and (not (eq? existing 'ps-lisp:nil))
130 | 	     (begin ; Harlequin doesn't like ~&
131 | 		    (common-lisp:fresh-line ps-lisp:*query-io*)
132 | 		    (ps-lisp:format ps-lisp:*query-io*
133 | 				    "Existing ~S has fields ~S.~%"
134 | 				    existing
135 | 				    field-names)
136 | 		    (not (eq?
137 | 			  (ps-lisp:y-or-n-p
138 | 			   "Use that descriptor (instead of creating a new one)? ")
139 | 			  'ps-lisp:nil))))
140 | 	existing
141 | 	(let ((new (really-make-record-type type-id field-names)))
142 | 	  (ps-lisp:setf (ps-lisp:gethash key record-type-table) new)
143 | 	  new))))
144 | 
145 | (define (record-type record)
146 |   (ps-lisp:get (ps-lisp:type-of record) 'rtd))
147 | 
148 | ; Printing
149 | 
150 | (define (print-rtd rtd stream escape?)
151 |   escape? ;ignored
152 |   (ps-lisp:format stream
153 | 	       "#{Record-type-descriptor ~S.~S}"
154 | 	       (rtd-identification rtd)
155 | 	       (rtd-unique-id rtd)))
156 | 
157 | (define (print-record record stream escape?)
158 |   escape?				;ignored
159 |   (let ((d (disclose-record record)))
160 |     (display "#{" stream)
161 |     (display (if (symbol? (car d))
162 | 		     (ps-lisp:string-capitalize (symbol->string (car d)))
163 | 		     (car d))
164 | 	     stream)
165 |     (for-each (lambda (x)
166 | 		(write-char #\space stream)
167 | 		(write x stream))
168 | 	      (cdr d))
169 |     (display "}" stream)))
170 | 
171 | (define record-disclosers (ps-lisp:make-hash-table))
172 | 
173 | (define (disclose-record record)
174 |   ((ps-lisp:gethash (record-type record)
175 | 		    record-disclosers
176 | 		    default-record-discloser)
177 |    record))
178 | 
179 | (define (default-record-discloser record)
180 |   (list (rtd-identification (record-type record))))
181 | 
182 | (define (define-record-discloser rtd proc)
183 |   (ps-lisp:setf (ps-lisp:gethash rtd record-disclosers) proc))
184 | 


--------------------------------------------------------------------------------
/src/p-utils.pso:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2 | 
  3 | ; This file was generated by Pseudoscheme 2.12
  4 | ;  running in CMU Common Lisp 16-Aug-1993
  5 | ;  from file /zu/jar/pseudo/p-utils.scm
  6 | 
  7 | (ps:in-package "SCHEME-TRANSLATOR")
  8 | (BEGIN-TRANSLATED-FILE)
  9 | (DEFUN LAST-PAIR (X) (LAST X))
 10 | (SET-VALUE-FROM-FUNCTION 'LAST-PAIR 'SCHEME::LAST-PAIR)
 11 | (DEFUN VECTOR-POSQ (THING V) (OR (POSITION THING (THE SIMPLE-VECTOR V)) FALSE))
 12 | (SET-VALUE-FROM-FUNCTION 'VECTOR-POSQ 'SCHEME::VECTOR-POSQ)
 13 | (DEFUN STRING-POSQ (C S) (OR (POSITION C (THE SIMPLE-STRING S)) FALSE))
 14 | (SET-VALUE-FROM-FUNCTION 'STRING-POSQ 'SCHEME::STRING-POSQ)
 15 | (DEFUN MAKE-FLUID (TOP-LEVEL-VALUE)
 16 |   (LET ((F (GENSYM "FLUID")))
 17 |     (SET F TOP-LEVEL-VALUE)
 18 |     F))
 19 | (SET-VALUE-FROM-FUNCTION 'MAKE-FLUID 'SCHEME::MAKE-FLUID)
 20 | (DEFUN FLUID (F) (SYMBOL-VALUE F))
 21 | (SET-VALUE-FROM-FUNCTION 'FLUID 'SCHEME::FLUID)
 22 | (DEFUN SET-FLUID! (F VAL) (SET F VAL))
 23 | (SET-VALUE-FROM-FUNCTION 'SET-FLUID! 'SCHEME::SET-FLUID!)
 24 | (DEFUN LET-FLUID (F VAL THUNK) (PROGV (LIST F) (LIST VAL) (FUNCALL THUNK)))
 25 | (SET-VALUE-FROM-FUNCTION 'LET-FLUID 'SCHEME::LET-FLUID)
 26 | (DEFUN MAKE-TABLE () (VALUES (MAKE-HASH-TABLE :SIZE 20 :REHASH-SIZE 2.0)))
 27 | (SET-VALUE-FROM-FUNCTION 'MAKE-TABLE 'SCHEME::MAKE-TABLE)
 28 | (DEFUN TABLE-SET! (TABLE KEY VAL) (SETF (GETHASH KEY TABLE) VAL))
 29 | (SET-VALUE-FROM-FUNCTION 'TABLE-SET! 'SCHEME::TABLE-SET!)
 30 | (DEFUN TABLE-REF (TABLE KEY) (GETHASH KEY TABLE FALSE))
 31 | (SET-VALUE-FROM-FUNCTION 'TABLE-REF 'SCHEME::TABLE-REF)
 32 | (LOCALLY
 33 |  (DECLARE (SPECIAL CL-READTABLE))
 34 |  (SETQ CL-READTABLE (COPY-READTABLE 'NIL)))
 35 | (SET-FUNCTION-FROM-VALUE 'CL-READTABLE 'SCHEME::CL-READTABLE)
 36 | (DEFUN WRITE-PRETTY (FORM PORT PACKAGE)
 37 |   (LET (FUNCALL
 38 |         (*PACKAGE* PACKAGE)
 39 |         (*PRINT-CASE* :UPCASE)
 40 |         (*READTABLE* CL-READTABLE))
 41 |     (DECLARE (SPECIAL CL-READTABLE))
 42 |     (FORMAT PORT "~&")
 43 |     (WRITE FORM :STREAM PORT :PRETTY TRUE :LENGTH 'NIL :LEVEL 'NIL)
 44 |     (VALUES)))
 45 | (DEFUN INTERN-RENAMING-PERHAPS (.STRING PACKAGE)
 46 |   (DECLARE (SPECIAL .SCHEME-PACKAGE))
 47 |   (INTERN (IF (EQ PACKAGE .SCHEME-PACKAGE) .STRING (PERHAPS-RENAME .STRING))
 48 |           PACKAGE))
 49 | (SET-VALUE-FROM-FUNCTION 'INTERN-RENAMING-PERHAPS
 50 |                          'SCHEME::INTERN-RENAMING-PERHAPS)
 51 | (DEFUN PERHAPS-RENAME (.STRING)
 52 |   (DECLARE (SPECIAL SYM LISP-PACKAGE STATUS))
 53 |   (IF
 54 |    (OR
 55 |     (TRUEP
 56 |      (MULTIPLE-VALUE-BIND
 57 |          (SYM STATUS)
 58 |          (FIND-SYMBOL .STRING LISP-PACKAGE)
 59 |        SYM
 60 |        (TRUE? (EQ STATUS :EXTERNAL))))
 61 |     (AND (> (LENGTH (THE SIMPLE-STRING .STRING)) 0)
 62 |          (CHAR= (CHAR (THE SIMPLE-STRING .STRING) 0) #\&)))
 63 |    (STRING-APPEND "." .STRING)
 64 |    .STRING))
 65 | (SET-VALUE-FROM-FUNCTION 'PERHAPS-RENAME 'SCHEME::PERHAPS-RENAME)
 66 | (LOCALLY
 67 |  (DECLARE (SPECIAL LISP-PACKAGE))
 68 |  (SETQ LISP-PACKAGE (FIND-PACKAGE "PS-LISP")))
 69 | (SET-FUNCTION-FROM-VALUE 'LISP-PACKAGE 'SCHEME::LISP-PACKAGE)
 70 | (DEFUN QUALIFIED-SYMBOL? (SYM)
 71 |   (DECLARE (SPECIAL .SCHEME-PACKAGE))
 72 |   (IF (SYMBOLP SYM)
 73 |       (TRUE? (NOT (EQ (SYMBOL-PACKAGE SYM) .SCHEME-PACKAGE)))
 74 |       FALSE))
 75 | (SET-VALUE-FROM-FUNCTION 'QUALIFIED-SYMBOL? 'SCHEME::QUALIFIED-SYMBOL?)
 76 | (LOCALLY
 77 |  (DECLARE (SPECIAL .SCHEME-PACKAGE))
 78 |  (SETQ .SCHEME-PACKAGE (SYMBOL-PACKAGE 'SCHEME::ASKDJFH)))
 79 | (SET-FUNCTION-FROM-VALUE '.SCHEME-PACKAGE 'SCHEME::SCHEME-PACKAGE)
 80 | (DEFUN MAKE-PACKAGE-USING (ID USE-LIST)
 81 |   (DECLARE (SPECIAL LISP-PACKAGE))
 82 |   (LET ((NAME (SYMBOL->STRING ID)))
 83 |     (LET ((PROBE (FIND-PACKAGE NAME)))
 84 |       (LET ((PACKAGE
 85 |              (IF (NOT (EQ PROBE 'NIL))
 86 |                  (PROGN
 87 |                   (MAPC
 88 |                    #'(LAMBDA (USE)
 89 |                        (IF
 90 |                         (NOT
 91 |                          (OR (EQ USE LISP-PACKAGE)
 92 |                              (MEMBER USE USE-LIST :TEST #'EQ)))
 93 |                         (UNUSE-PACKAGE USE PROBE)))
 94 |                    (PACKAGE-USE-LIST PROBE))
 95 |                   PROBE)
 96 |                  (MAKE-PACKAGE NAME :USE USE-LIST))))
 97 |         (LET ()
 98 |           (USE-PACKAGE
 99 |            (IF (EQ ID 'SCHEME::SCHEME) USE-LIST (CONS LISP-PACKAGE USE-LIST))
100 |            PACKAGE)
101 |           PACKAGE)))))
102 | (SET-VALUE-FROM-FUNCTION 'MAKE-PACKAGE-USING 'SCHEME::MAKE-PACKAGE-USING)
103 | (DEFUN MAKE-PACKAGE-EXPORTING (ID SYMS)
104 |   (LET ((NAME (SYMBOL->STRING ID)))
105 |     (LET ((NEW (OR (FIND-PACKAGE NAME) (MAKE-PACKAGE NAME :USE 'NIL))))
106 |       (LET ()
107 |         (IMPORT SYMS NEW)
108 |         (EXPORT SYMS NEW)
109 |         NEW))))
110 | (SET-VALUE-FROM-FUNCTION 'MAKE-PACKAGE-EXPORTING
111 |                          'SCHEME::MAKE-PACKAGE-EXPORTING)
112 | (DEFUN SCHEME-IMPLEMENTATION-VERSION ()
113 |   (STRING-APPEND (LISP-IMPLEMENTATION-TYPE) " " (LISP-IMPLEMENTATION-VERSION)))
114 | (SET-VALUE-FROM-FUNCTION 'SCHEME-IMPLEMENTATION-VERSION
115 |                          'SCHEME::SCHEME-IMPLEMENTATION-VERSION)
116 | (DEFUN DEFINED-AS-CL-MACRO? (CL-SYM) (IF (MACRO-FUNCTION CL-SYM) TRUE FALSE))
117 | (SET-VALUE-FROM-FUNCTION 'DEFINED-AS-CL-MACRO? 'SCHEME::DEFINED-AS-CL-MACRO?)
118 | (DEFUN TRUE-NAME (SOURCE-FILE-NAME) (NAMESTRING (TRUENAME SOURCE-FILE-NAME)))
119 | (SET-VALUE-FROM-FUNCTION 'TRUE-NAME 'SCHEME::TRUE-NAME)
120 | (LOCALLY (DECLARE (SPECIAL .PACKAGE-NAME)) (SETQ .PACKAGE-NAME #'PACKAGE-NAME))
121 | (SET-FUNCTION-FROM-VALUE '.PACKAGE-NAME 'SCHEME::PACKAGE-NAME)
122 | (LOCALLY (DECLARE (SPECIAL .INTERN)) (SETQ .INTERN #'INTERN))
123 | (SET-FUNCTION-FROM-VALUE '.INTERN 'SCHEME::INTERN)
124 | 


--------------------------------------------------------------------------------
/src/p-utils.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File utils.scm / See file COPYING
  3 | 
  4 | ;;;; Miscellaneous general and not-so-general utilities
  5 | 
  6 | ; last-pair (was in r^3, flushed for r^4)
  7 | 
  8 | (define (last-pair x)
  9 |   (ps-lisp:last x))
 10 | 
 11 | ; posq
 12 | 
 13 | (define (vector-posq thing v)
 14 |   (ps-lisp:or (ps-lisp:position thing (ps-lisp:the ps-lisp:simple-vector v))
 15 | 	   #f))
 16 | 
 17 | (define (string-posq c s)
 18 |   (ps-lisp:or (ps-lisp:position c (ps-lisp:the ps-lisp:simple-string s))
 19 | 	   #f))
 20 | 
 21 | ; Fluids
 22 | 
 23 | (define (make-fluid top-level-value)
 24 |   (let ((f (ps-lisp:gensym "FLUID")))
 25 |     (ps-lisp:set f top-level-value)
 26 |     f))
 27 | 
 28 | (define (fluid f)
 29 |   (ps-lisp:symbol-value f))
 30 | 
 31 | (define (set-fluid! f val)
 32 |   (ps-lisp:set f val))
 33 | 
 34 | (define (let-fluid f val thunk)
 35 |   (ps-lisp:progv (list f) (list val) (thunk)))
 36 | 
 37 | ; Tables
 38 | 
 39 | (define (make-table)
 40 |   ;; Default size in VAX LISP is 71, which seems rather large.
 41 |   (ps-lisp:values (ps-lisp:make-hash-table :size 20 :rehash-size 2.0)))
 42 | 
 43 | (define (table-set! table key val)
 44 |   (ps-lisp:setf (ps-lisp:gethash key table) val))
 45 | 
 46 | (define (table-ref table key)
 47 |   (ps-lisp:gethash key table #f))
 48 | 
 49 | ; Pretty-printer used by translator
 50 | ; Two cases:
 51 | ;  - If package is scheme-package, then unqualified symbols must print
 52 | ;    without package prefixes, and qualified ones must print with.
 53 | ;  - Otherwise, the opposite, and the package prefix for unqualified
 54 | ;    symbols ought to be 
 55 | 
 56 | (define cl-readtable (ps-lisp:copy-readtable 'ps-lisp:nil))
 57 | 
 58 | (ps-lisp:defun write-pretty (form port package)
 59 |   (ps-lisp:let ((ps-lisp:*package* package)
 60 | 	     (ps-lisp:*print-case* :upcase)
 61 | 	     (ps-lisp:*readtable* cl-readtable))
 62 |     (ps-lisp:declare (ps-lisp:special cl-readtable))
 63 |     (ps-lisp:format port "~&")
 64 |     (ps-lisp:write form :stream port
 65 | 		     :pretty ps-lisp:t
 66 | 		     :length 'ps-lisp:nil
 67 | 		     :level 'ps-lisp:nil)
 68 |     (ps-lisp:values)))
 69 | 
 70 | ; Package stuff, etc.
 71 | 
 72 | (define (intern-renaming-perhaps string package)
 73 |   (ps-lisp:intern (if (eq? package scheme-package)
 74 | 		      string
 75 | 		      (perhaps-rename string))
 76 | 		  package))
 77 | 
 78 | (define (perhaps-rename string)  ;Cf. defune in rts.lisp
 79 |   (if (or (ps-lisp:multiple-value-bind (sym status) ;Good candidate for caching
 80 | 	      (ps-lisp:find-symbol string lisp-package)
 81 | 	      sym ;ignore
 82 | 	    (eq? status :external))
 83 | 	  (and (> (string-length string) 0)
 84 | 	       (char=? (string-ref string 0) #\&)))
 85 |       (string-append "." string)
 86 |       string))
 87 | 
 88 | (define lisp-package (ps-lisp:find-package "PS-LISP"))
 89 | 
 90 | (define (qualified-symbol? sym)
 91 |   (ps-lisp:if (ps-lisp:symbolp sym)
 92 | 	      (not (eq? (ps-lisp:symbol-package sym) scheme-package))
 93 | 	      #f))
 94 | 
 95 | (define scheme-package (ps-lisp:symbol-package 'askdjfh))
 96 | 
 97 | (define (make-package-using id use-list)
 98 |   (let* ((name (symbol->string id))
 99 | 	 (probe (ps-lisp:find-package name))
100 | 	 (package
101 | 	  (cond ((not (eq? probe 'ps-lisp:nil))
102 | 	         (for-each (lambda (use)
103 | 			     (if (not (or (eq? use lisp-package)
104 | 					  (memq use use-list)))
105 | 				 (ps-lisp:unuse-package use probe)))
106 | 			   (ps-lisp:package-use-list probe))
107 | 		 probe)
108 | 		(else (ps-lisp:make-package name :use use-list)))))
109 |     (ps-lisp:use-package (if (eq? id 'scheme)
110 | 			  use-list	;Kludge
111 | 			  (cons lisp-package use-list))
112 | 		      package)
113 |     package))
114 | 
115 | (define (make-package-exporting id syms)
116 |   (let* ((name (symbol->string id))
117 | 	 (new (ps-lisp:or (ps-lisp:find-package name)
118 | 		       (ps-lisp:make-package name :use '()))))
119 |     (ps-lisp:import syms new)
120 |     (ps-lisp:export syms new)
121 |     new))
122 | 
123 | 
124 | ; ps-lisp:namestring
125 | ; ps-lisp:truename
126 | ; ps-lisp:merge-pathnames
127 | ; ps-lisp:make-pathname
128 | ; ps-lisp:package-name
129 | 
130 | ; Etc.
131 | 
132 | (define (scheme-implementation-version)
133 |   (string-append (#'ps-lisp:lisp-implementation-type)
134 | 		 " "
135 | 		 (#'ps-lisp:lisp-implementation-version)))
136 | 
137 | (define (defined-as-CL-macro? CL-sym)
138 |   (ps-lisp:if (ps-lisp:macro-function CL-sym)
139 | 	      #t
140 | 	      #f))
141 | 
142 | (define (true-name source-file-name)
143 |   (ps-lisp:namestring (ps-lisp:truename source-file-name)))
144 | 
145 | (define package-name #'ps-lisp:package-name)
146 | 
147 | (define intern #'ps-lisp:intern)
148 | 


--------------------------------------------------------------------------------
/src/pack.lisp:
--------------------------------------------------------------------------------
  1 | ; Package definitions for Pseudoscheme.
  2 | 
  3 | ; If your Common Lisp doesn't have DEFPACKAGE, you'll have to translate
  4 | ; this file manually into appropriate IN-PACKAGE and EXPORT forms.
  5 | 
  6 | (in-package "CL-USER")  ;stifle warnings from compiler/loader
  7 | 
  8 | 
  9 | ; The SCHEME package is where Scheme symbols live.
 10 | 
 11 | (defpackage "SCHEME"
 12 |   (:use )
 13 |   (:export ))
 14 | 
 15 | ; Define the Pseudoscheme package.
 16 | 
 17 | (defpackage "PS"
 18 |   (:nicknames "PS-LISP" "PSEUDOSCHEME")
 19 |   (:use #.(if (find-package "COMMON-LISP") ;Avoid pollution.
 20 | 	      "COMMON-LISP"
 21 | 	      "LISP"))
 22 |   (:export "SET!-AUX"
 23 | 	   "SET-FUNCTION-FROM-VALUE"
 24 | 	   "SET-VALUE-FROM-FUNCTION"
 25 | 	   "SET-FORWARDING-FUNCTION"
 26 | 	   "UNSPECIFIC"
 27 | 	   "UNASSIGNED"
 28 | 	   "TRUE"			; #t
 29 | 	   "FALSE"			; #f
 30 | 	   "TRUE?"			; CL boolean -> Scheme boolean
 31 | 	   "TRUEP"			; Scheme boolean -> CL boolean
 32 | 	   "BEGIN-TRANSLATED-FILE"	;prelude
 33 | 	   "AT-TOP-LEVEL"  		;kludge for symbolics lossage
 34 | 	   "MAYBE-FIX-&REST-PARAMETER"	;ditto
 35 | 	   "%DEFINE-SYNTAX!"
 36 | 	   ;; Additional auxiliaries for Revised^4 builtins
 37 | 	   "SCHEME-PACKAGE"		;for STRING->SYMBOL
 38 | 	   "PROCEDUREP"			;for PROCEDURE?
 39 | 	   "SCHEME-SYMBOL-P"		;for SYMBOL?
 40 | 	   "SCHEME-EQUAL-P"		;for MEMBER, ASSOC, EQUAL?
 41 | 	   "BOOLEANP"
 42 | 	   "CHAR-WHITESPACE-P"
 43 | 	   "INPUT-PORT-P"
 44 | 	   "OUTPUT-PORT-P"
 45 | 	   "REALP"
 46 | 	   ;; Additional auxiliaries for Revised^4 non-builtins
 47 | 	   "SCHEME-LOAD"		;forward reference from RTS to EVAL
 48 | 	   "SCHEME-READTABLE"		;for READ
 49 | 	   "EOF-OBJECT"			;for READ, READ-CHAR
 50 | 	   ;; ... and for Revised^5
 51 | 	   "SCHEME-EVAL"
 52 | 	   "SCHEME-REPORT-ENVIRONMENT"
 53 | 	   "*CURRENT-REP-ENVIRONMENT*"
 54 | 	   ;; Random
 55 | 	   "SCHEME-ERROR"
 56 | 	   "SCHEME-WARN"
 57 | 	   "SCHEME-USER-ENVIRONMENT"
 58 | 	   "SCHEME-READ-USING-COMMONLISP-READER"
 59 | 	   "*DEFINE-SYNTAX!*"
 60 | 
 61 | 	   ;; Invoking the translator
 62 | 	   "SCHEME-COMPILE"
 63 | 	   "SCHEME-COMPILE-FILE"
 64 | 	   "TRANSLATE-FILE"
 65 | 
 66 | 	   ;; REP loop
 67 | 	   "SET-REP-ENVIRONMENT!"
 68 | 	   "SCHEME"
 69 | 	   "QUIT"
 70 | 
 71 | 	   ;; Handy
 72 | 	   "PP"
 73 | 	   "BENCHMARK-MODE"
 74 | 
 75 | 	   ;; Symbols in the LISP (or COMMON-LISP) package used by
 76 | 	   ;; translated programs and by the translator itself.
 77 | 	   "FRESH-LINE"      ;Added by JAR 10/8/1999
 78 | 	   "&BODY" ;rts.lisp
 79 | 	   "&OPTIONAL"
 80 | 	   "&REST"
 81 | 	   "*"
 82 | 	   "*DEFAULT-PATHNAME-DEFAULTS*"
 83 | 	   "*FEATURES*"
 84 | 	   "*PACKAGE*"
 85 | 	   "*PRINT-BASE*"
 86 | 	   "*PRINT-CASE*"
 87 | 	   "*QUERY-IO*"
 88 | 	   "*READTABLE*"
 89 | 	   "*READ-BASE*" ;rts.lisp
 90 | 	   "*SHARP-SHARP*" ;rts.lisp
 91 | 	   "*SCHEME-READ*"
 92 | 	   "*SCHEME-WRITE*"
 93 | 	   "*SCHEME-DISPLAY*"
 94 | 	   "*STANDARD-INPUT*"
 95 | 	   "*STANDARD-OUTPUT*"
 96 | 	   "+"
 97 | 	   "-"
 98 | 	   "/"
 99 | 	   "<"
100 | 	   "<="
101 | 	   "="
102 | 	   ">"
103 | 	   ">="
104 | 	   "ABS"
105 | 	   "ACOS"
106 | 	   "ALPHA-CHAR-P"
107 | 	   "AND"
108 | 	   "APPEND"
109 | 	   "APPLY"
110 | 	   "ASIN"
111 | 	   "ASSOC"
112 | 	   "ATAN"
113 | 	   "BLOCK"
114 | 	   "BOUNDP"
115 | 	   "CAAAAR"
116 | 	   "CAAADR"
117 | 	   "CAAAR"
118 | 	   "CAADAR"
119 | 	   "CAADDR"
120 | 	   "CAADR"
121 | 	   "CAAR"
122 | 	   "CADAAR"
123 | 	   "CADADR"
124 | 	   "CADAR"
125 | 	   "CADDAR"
126 | 	   "CADDDR"
127 | 	   "CADDR"
128 | 	   "CADR"
129 | 	   "CAR"
130 | 	   "CASE"
131 | 	   "CDAAAR"
132 | 	   "CDAADR"
133 | 	   "CDAAR"
134 | 	   "CDADAR"
135 | 	   "CDADDR"
136 | 	   "CDADR"
137 | 	   "CDAR"
138 | 	   "CDDAAR"
139 | 	   "CDDADR"
140 | 	   "CDDAR"
141 | 	   "CDDDAR"
142 | 	   "CDDDDR"
143 | 	   "CDDDR"
144 | 	   "CDDR"
145 | 	   "CDR"
146 | 	   "CEILING"
147 | 	   "CHAR"
148 | 	   "CHAR-CODE"
149 | 	   "CHAR-DOWNCASE"
150 | 	   "CHAR-EQUAL"
151 | 	   "CHAR-GREATERP"
152 | 	   "CHAR-LESSP"
153 | 	   "CHAR-NOT-GREATERP"
154 | 	   "CHAR-NOT-LESSP"
155 | 	   "CHAR-UPCASE"
156 | 	   "CHAR<"
157 | 	   "CHAR<="
158 | 	   "CHAR="
159 | 	   "CHAR>"
160 | 	   "CHAR>="
161 | 	   "CHARACTERP"
162 | 	   "CIS"
163 | 	   "CLOSE"
164 | 	   "CODE-CHAR"
165 | 	   "COERCE"
166 | 	   "COMPILE"
167 | 	   "COMPILE-FILE" ;helps with debugging
168 | 	   "COMPILED-FUNCTION-P"
169 | 	   "COMPLEX"
170 | 	   "COND"  ;?
171 | 	   "CONS"
172 | 	   "CONSP"
173 | 	   "COPY-LIST"
174 | 	   "COPY-READTABLE"
175 | 	   "COPY-SEQ"
176 | 	   "COS"
177 | 	   "DECLARE"
178 | 	   "DEFMACRO" ;for rts.lisp
179 | 	   "DEFPACKAGE"
180 | 	   "DEFSTRUCT"
181 | 	   "DEFTYPE"
182 | 	   "DEFUN"
183 | 	   "DEFVAR"  ;read, write
184 | 	   "DENOMINATOR"
185 | 	   "DIGIT-CHAR-P"
186 | 	   "DO"  ;?
187 | 	   "DRIBBLE"
188 | 	   "EQ"
189 | 	   "EQL"
190 | 	   "EQUAL"
191 | 	   "ERROR"
192 | 	   "EVAL"
193 | 	   "EVENP"
194 | 	   "EXP"
195 | 	   "EXPORT"
196 | 	   "EXPT"
197 | 	   "FBOUNDP"
198 | 	   "FILL"
199 | 	   "FIND-PACKAGE"
200 | 	   "FLET"
201 | 	   "FLOAT"
202 | 	   "FLOATP"
203 | 	   "FLOOR"
204 | 	   "FORMAT"
205 | 	   "FUNCALL"
206 | 	   "FUNCTION"
207 | 	   "GCD"
208 | 	   "GENSYM"
209 | 	   "GET"
210 | 	   "GETHASH"
211 | 	   "GO"
212 | 	   "IF"
213 | 	   "IGNORE" ;rts.lisp
214 | 	   "IMAGPART"
215 | 	   "IMPORT"
216 | 	   "IN-PACKAGE"
217 | 	   "INTEGERP"
218 | 	   "INTERN"
219 | 	   "LABELS"
220 | 	   "LAMBDA"
221 | 	   "LAST"
222 | 	   "LCM"
223 | 	   "LENGTH"
224 | 	   "LET"
225 | 	   "LET*"  ;?
226 | 	   "LISP-IMPLEMENTATION-TYPE"
227 | 	   "LISP-IMPLEMENTATION-VERSION"
228 | 	   "LIST"
229 | 	   "LISTEN"
230 | 	   "LOAD"
231 | 	   "LOCALLY"
232 | 	   "LOG"
233 | 	   "LOWER-CASE-P"
234 | 	   "MACRO-FUNCTION"
235 | 	   "MAKE-HASH-TABLE"
236 | 	   "MAKE-PACKAGE"
237 | 	   "MAKE-PATHNAME"
238 | 	   "MAKE-STRING" ;?
239 | 	   "MAP" ;?
240 | 	   "MAPC"
241 | 	   "MAPCAR"
242 | 	   "MAX"
243 | 	   "MEMBER"
244 | 	   "MERGE-PATHNAMES"
245 | 	   "MIN"
246 | 	   "MINUSP"
247 | 	   "MOD"
248 | 	   "MULTIPLE-VALUE-BIND"
249 | 	   "MULTIPLE-VALUE-CALL"
250 | 	   "NAMESTRING"
251 | 	   "NIL"
252 | 	   "NOT"
253 | 	   "NTH"
254 | 	   "NTHCDR"
255 | 	   "NULL"
256 | 	   "NUMBERP"
257 | 	   "NUMERATOR"
258 | 	   "ODDP"
259 | 	   "OPEN"
260 | 	   "OR"
261 | 	   "OTHERWISE"
262 | 	   "PACKAGE-NAME"
263 | 	   "PACKAGE-USE-LIST"
264 | 	   "PATHNAME"
265 | 	   "PEEK-CHAR"
266 | 	   "PHASE"
267 | 	   "PLUSP"
268 | 	   "POSITION"
269 | 	   "PRIN1"
270 | 	   "PRINC"
271 | 	   "PROG"
272 | 	   "PROGN"
273 | 	   "PROGV"
274 | 	   "PSETQ"
275 | 	   "QUOTE"
276 | 	   "RATIONALIZE"
277 | 	   "RATIONALP"
278 | 	   "READ"
279 | 	   "READ-CHAR"
280 | 	   "REALPART"
281 | 	   "REM"
282 | 	   "REMOVE"
283 | 	   "RENAME-PACKAGE"
284 | 	   "RETURN"
285 | 	   "RETURN-FROM"
286 | 	   "REVERSE"
287 | 	   "ROUND"
288 | 	   "SET"
289 | 	   "SET-MACRO-CHARACTER"
290 | 	   "SETF"
291 | 	   "SETQ"
292 | 	   "SIMPLE-STRING"
293 | 	   "SIMPLE-STRING-P"
294 | 	   "SIMPLE-VECTOR"
295 | 	   "SIN"
296 | 	   "SPECIAL"
297 | 	   "SQRT"
298 | 	   "STRING" ;?
299 | 	   "STRING-CAPITALIZE"
300 | 	   "STRING-DOWNCASE"
301 | 	   "STRING-EQUAL"
302 | 	   "STRING-GREATERP"
303 | 	   "STRING-LESSP"
304 | 	   "STRING-NOT-GREATERP"
305 | 	   "STRING-NOT-LESSP"
306 | 	   "STRING-UPCASE"
307 | 	   "STRING<"
308 | 	   "STRING<="
309 | 	   "STRING="
310 | 	   "STRING>"
311 | 	   "STRING>="
312 | 	   "SUBLIS"
313 | 	   "SUBSEQ"
314 | 	   "SVREF"
315 | 	   "SYMBOL-FUNCTION"
316 | 	   "SYMBOL-NAME"
317 | 	   "SYMBOL-PACKAGE"
318 | 	   "SYMBOL-VALUE"
319 | 	   "SYMBOLP" ;rts.lisp
320 | 	   "T"
321 | 	   "TAN"
322 | 	   "TERPRI"
323 | 	   "THE"
324 | 	   "TRUENAME"
325 | 	   "TRUNCATE"
326 | 	   "TYPE-OF"
327 | 	   "UNLESS"
328 | 	   "UNUSE-PACKAGE"
329 | 	   "UNWIND-PROTECT" ;rts.lisp
330 | 	   "UPPER-CASE-P"
331 | 	   "USE-PACKAGE"
332 | 	   "VALUES"
333 | 	   "VALUES-LIST"
334 | 	   "VECTOR"
335 | 	   "WARN"
336 | 	   "WHEN" ;rts.lisp
337 | 	   "WITH-OPEN-FILE"
338 | 	   "WRITE"
339 | 	   "WRITE-CHAR"
340 | 	   "WRITE-TO-STRING"
341 | 	   "Y-OR-N-P"
342 | 	   "ZEROP"
343 | 	   ;; rts.lisp:
344 | 	   "MAKE-SEQUENCE"
345 | 	   "READ-PRESERVING-WHITESPACE"
346 | 	   "FIND-IF"
347 | 	   "INLINE"
348 | 	   "WITH-INPUT-FROM-STRING"
349 | 	   "FIND-SYMBOL"
350 | 	   "CONCATENATE"
351 | 	   "KEYWORDP"
352 | 	   "PROCLAIM"
353 | 	   "SIMPLE-VECTOR-P"
354 | 	   ))
355 | 
356 | ; Lose
357 | 
358 | (defpackage "CLEVER-LOAD"
359 |   (:use #.(if (find-package "COMMON-LISP") ;Avoid pollution.
360 | 	      "COMMON-LISP"
361 | 	      "LISP"))
362 |   (:export "CLEVER-LOAD"
363 | 	   "*COMPILE-IF-NECESSARY-P*"))
364 | 


--------------------------------------------------------------------------------
/src/pseudo.lisp:
--------------------------------------------------------------------------------
 1 | 
 2 | (in-package "CL-USER")
 3 | 
 4 | (load "/zu/jar/pseudo/loadit.lisp")
 5 | 
 6 | (load-pseudoscheme "/zu/jar/pseudo/")
 7 | 
 8 | (format t
 9 | 	"~2&Do (ps:scheme) to enter Scheme, after which:~
10 | 	 ~%  (benchmark-mode) - have calls to primitives open-coded~
11 | 	 ~%  (compile-file \"foo.scm\") - compile a file of Scheme code~
12 | 	 ~%  (quit) - return to Common Lisp~
13 | 	 ~%  ## is last value displayed~
14 | 	 ~%  #'lisp:foo evaluates to Common Lisp function foo~
15 | 	 ~%All of Revised^4.5 Scheme is available, including define-syntax,~
16 | 	 ~%values, dynamic-wind, and eval, but not things that are too~
17 | 	 ~%difficult to do in Common Lisp, e.g. upward continuations and~
18 | 	 ~%proper tail-recursion in all possible circumstances.  See the~
19 | 	 ~%user guide for more information.~%")
20 | 


--------------------------------------------------------------------------------
/src/pseudoscheme-features.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 pseudoscheme-features.scm.
  7 | ; Synchronize any changes with all the other *-features.scm files.
  8 | 
  9 | (define *load-file-type* #f) ;For fun
 10 | 
 11 | 
 12 | ; SIGNALS
 13 | 
 14 | (define error #'ps:scheme-error)
 15 | 
 16 | (define warn #'ps:scheme-warn)
 17 | 
 18 | (define (signal type . stuff)
 19 |   (apply warn "condition signalled" type stuff))
 20 | 
 21 | (define (syntax-error . rest)		; Must return a valid expression.
 22 |   (apply warn rest)
 23 |   ''syntax-error)
 24 | 
 25 | (define (call-error message proc . args)
 26 |   (error message (cons proc args)))
 27 | 
 28 | 
 29 | ; FEATURES
 30 | 
 31 | (define force-output #'lisp:force-output)
 32 | 
 33 | (define (string-hash s)
 34 |   (let ((n (string-length s)))
 35 |     (do ((i 0 (+ i 1))
 36 |          (h 0 (+ h (lisp:char-code (string-ref s i)))))
 37 |         ((>= i n) h))))
 38 | 
 39 | (define (make-immutable! thing) thing)
 40 | (define (immutable? thing) thing #f)
 41 | (define (unspecific) (if #f #f))
 42 | 
 43 | 
 44 | ; BITWISE
 45 | 
 46 | (define arithmetic-shift #'lisp:ash)
 47 | (define bitwise-and #'lisp:logand)
 48 | (define bitwise-ior #'lisp:logior)
 49 | (define bitwise-not #'lisp:lognot)
 50 | 
 51 | 
 52 | ; ASCII
 53 | 
 54 | (define char->ascii #'lisp:char-code)
 55 | (define ascii->char #'lisp:code-char)
 56 | (define ascii-limit lisp:char-code-limit)
 57 | (define ascii-whitespaces '(32 10 9 12 13))
 58 | 
 59 | 
 60 | ; CODE-VECTORS
 61 | 
 62 | (define (make-code-vector len . fill-option)
 63 |   (lisp:make-array len :element-type '(lisp:unsigned-byte 8)
 64 | 		       :initial-element (if (null? fill-option)
 65 | 					    0
 66 | 					    (car fill-option))))
 67 | 
 68 | (define (code-vector? obj)
 69 |   (ps:true? (lisp:typep obj
 70 | 			(lisp:quote (lisp:simple-array (lisp:unsigned-byte 8)
 71 | 						       (lisp:*))))))
 72 | 
 73 | (define (code-vector-ref bv k)
 74 |   (lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
 75 | 		       bv)
 76 | 	     k))
 77 | 
 78 | (define (code-vector-set! bv k val)
 79 |   (lisp:setf (lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8)
 80 | 						     (lisp:*))
 81 | 				  bv)
 82 | 			k)
 83 | 	     val))
 84 | 
 85 | (define (code-vector-length bv)
 86 |   (lisp:length (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
 87 | 			 bv)))
 88 | 
 89 | 
 90 | ; The rest is unnecessary in Pseudoscheme versions 2.8d and after.
 91 | 
 92 | ;(define eval #'schi:scheme-eval)
 93 | ;(define (interaction-environment) schi:*current-rep-environment*)
 94 | ;(define scheme-report-environment
 95 | ;  (let ((env (scheme-translator:make-program-env
 96 | ;              'rscheme
 97 | ;              (list scheme-translator:revised^4-scheme-module))))
 98 | ;    (lambda (n)
 99 | ;      n ;ignore
100 | ;      env)))
101 | 
102 | ; Dynamic-wind.
103 | ;
104 | ;(define (dynamic-wind in body out)
105 | ;  (in)
106 | ;  (lisp:unwind-protect (body)
107 | ;    (out)))
108 | ;
109 | ;(define values #'lisp:values)
110 | ;
111 | ;(define (call-with-values thunk receiver)
112 | ;  (lisp:multiple-value-call receiver (thunk)))
113 | 


--------------------------------------------------------------------------------
/src/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 | 


--------------------------------------------------------------------------------
/src/purify.lisp:
--------------------------------------------------------------------------------
 1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-PURIFY; -*-
 2 | ; File hacks.lisp / See file COPYING
 3 | 
 4 | (in-package "SCHEME-PURIFY")
 5 | 
 6 | 
 7 | ; ----- Fix the SCHEME package, if necessary.  The home package of any
 8 | ; symbol in the SCHEME package must be SCHEME so that Scheme symbols
 9 | ; print as SCHEME::FOO when the Scheme package is not current.
10 | 
11 | (defun fix-scheme-package-if-necessary (package)
12 |   (if (not (equal (package-name package) "SCHEME"))
13 |       (rename-package package "SCHEME"))
14 |   (cond ((pollutedp package)
15 | 	 (purify-scheme-package package))))
16 | 
17 | (defun pollutedp (package)
18 |   (do-symbols (sym package)
19 |     (when (not (eq (symbol-package sym) package))
20 |       (return-from pollutedp t))))
21 | 
22 | ; Things about whose EQ-ness we care:
23 | 
24 | (defparameter losers
25 |   '("DEFINE"
26 |     "ELSE" "=>" "UNQUOTE" "UNQUOTE-SPLICING"
27 |     "HEUR" "B" "O" "D" "X"))
28 | 
29 | (defparameter ps-package (find-package "PS-LISP"))
30 | 
31 | (defun purify-scheme-package (package)
32 |   (format t "~&Purifying...")
33 |   ;; It shouldn't be necessary to bind *package* here, but it turns
34 |   ;; out to be the way to work around some obscure Symbolics bug.
35 |   (let ((*package* package))
36 |     (let ((winners (mapcar #'(lambda (name)
37 | 			       (intern name package))
38 | 			   losers)))
39 |       (unuse-package (package-use-list package) package)
40 |       (import winners package)
41 |       (do-symbols (sym package)
42 | 	(cond ((eq (symbol-package sym) package)
43 | 	       (unexport sym package)
44 | 	       ;; OK, do nothing.
45 | 	       )
46 | 	      ((eq sym (find-symbol (symbol-name sym) ps-package))
47 | 	       (let ((name (symbol-name sym)))
48 | 		 (if (member name losers :test #'string=)
49 | 		     (error "~S shouldn't be accessible in the LISP package, but it is."
50 | 			    sym))
51 | 		 (unintern sym package)
52 | 		 (let ((new-sym (intern name package)))
53 | 		   (assert (eq (symbol-package new-sym) package)
54 | 			   () "Lost on ~S" new-sym)
55 | 		   (symbol-forward sym new-sym))))
56 | 	      (t
57 | 	       (purify-symbol sym package)))))))
58 | 
59 | ; Clobber the symbol's home package so that it prints
60 | ; as SCHEME::FOO.
61 | (defun purify-symbol (sym package)
62 |   (unexport sym package)
63 |   (let ((name (symbol-name sym))
64 | 	(old-package (symbol-package sym)))
65 |     (format t " ~S" sym)
66 |     (unexport sym old-package)
67 |     (unintern sym old-package)			;?
68 |     (import sym package)
69 |     #+Lispm					;?
70 |     (setf (symbol-package sym) package)
71 |     (multiple-value-bind (hucairz status)
72 | 	(find-symbol name old-package)
73 |       (declare (ignore hucairz))
74 |       (unless status	;inherited
75 | 	(import sym old-package)))
76 |     (unless (and (eq sym (find-symbol name package))
77 | 		 (eq (symbol-package sym) package))
78 |       (format t "~& (Failed to move ~S to ~A package)~%"
79 | 	      sym
80 | 	      (package-name package)))))
81 | 
82 | (defun symbol-forward (from-sym to-sym)
83 |   (when (boundp from-sym)
84 |     (setf (symbol-value to-sym) (symbol-value from-sym))
85 |     (proclaim `(special ,to-sym)))
86 |   (cond ((or (special-form-p from-sym)
87 | 	     (macro-function from-sym))
88 | 	 (setf (macro-function to-sym)
89 | 	       #'(lambda (form env)
90 | 		   (declare (ignore env))
91 | 		   (cons from-sym (cdr form)))))
92 | 	((fboundp from-sym)
93 | 	 (setf (symbol-function to-sym)
94 | 	       (symbol-function from-sym)))))
95 | 
96 | 


--------------------------------------------------------------------------------
/src/readwrite.lisp:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: PS; -*-
  2 | ; File readtable.lisp / See file COPYING
  3 | 
  4 | ;;;; Scheme READ and WRITE
  5 | 
  6 | ; Fudged, using a Common Lisp readtable.
  7 | 
  8 | (in-package "PS")
  9 | 
 10 | (defparameter scheme-readtable (copy-readtable nil))
 11 | 
 12 | (defun scheme-read-using-commonlisp-reader (port)
 13 |   (let ((*package* scheme-package)
 14 | 	(*readtable* scheme-readtable))
 15 |     (read-preserving-whitespace port nil ps:eof-object)))
 16 | 
 17 | (setq ps:*scheme-read* #'scheme-read-using-commonlisp-reader)  ;Yow
 18 | 
 19 | (defun scheme-write-using-commonlisp-printer (obj port)
 20 |   (write-internal obj port t))
 21 | 
 22 | (defun scheme-display-using-commonlisp-printer (obj port)
 23 |   (write-internal obj port nil))
 24 | 
 25 | (setq ps:*scheme-write* #'scheme-write-using-commonlisp-printer)
 26 | (setq ps:*scheme-display* #'scheme-display-using-commonlisp-printer)
 27 | 
 28 | (defvar *non-scheme-readtable* (copy-readtable nil))
 29 | 
 30 | #+Symbolics
 31 | (pushnew scheme-readtable si:*valid-readtables*)
 32 | 
 33 | (defun quote-read-macro (stream c)
 34 |   (if (eq *package* scheme-package)
 35 |       (list (intern "QUOTE" scheme-package) (read stream t nil t))
 36 |       (funcall (get-macro-character #\' *non-scheme-readtable*) stream c)))
 37 | 
 38 | (defun quasiquote-read-macro (stream c)
 39 |   (if (eq *package* scheme-package)
 40 |       (list (intern "QUASIQUOTE" scheme-package) 
 41 | 	    (read stream t nil t))
 42 |       (funcall (get-macro-character #\` *non-scheme-readtable*) stream c)))
 43 | 
 44 | (defun unquote-read-macro (stream c)
 45 |   (if (eq *package* scheme-package)
 46 |       (let* ((following-char (peek-char nil stream t nil t))
 47 | 	     (marker (cond ((char= following-char #\@)
 48 | 			    (read-char stream)
 49 | 			    (intern "UNQUOTE-SPLICING" scheme-package))
 50 | 			   (t
 51 | 			    (intern "UNQUOTE" scheme-package)))))
 52 | 	(list marker (read stream t nil t)))
 53 |       (funcall (get-macro-character #\, *non-scheme-readtable*) stream c)))
 54 | 
 55 | (defun sharp-F-read-macro (stream subchar arg)
 56 |   (declare (ignore stream subchar arg))
 57 |   ps:false)
 58 | 
 59 | (defun sharp-T-read-macro (stream subchar arg)
 60 |   (declare (ignore stream subchar arg))
 61 |   ps:true)
 62 | 
 63 | (defun sharp-D-read-macro (stream subchar arg)
 64 |   (declare (ignore subchar arg))
 65 |   (let ((*read-base* 10.))
 66 |     (read stream t nil t)))
 67 | 
 68 | (defun sharp-E-read-macro (stream subchar arg)
 69 |   (declare (ignore subchar arg))
 70 |   (let ((n (read stream t nil t)))
 71 |     (if (rationalp n)
 72 | 	n
 73 | 	(rationalize n))))
 74 | 
 75 | (defun sharp-I-read-macro (stream subchar arg)
 76 |   (declare (ignore subchar arg))
 77 |   (let ((n (read stream t nil t)))
 78 |     (if (floatp n)
 79 | 	n
 80 | 	(float n))))
 81 | 
 82 | (defvar *sharp-sharp* '(values-list /))
 83 | 
 84 | (defun sharp-sharp-read-macro (stream subchar arg)
 85 |   (cond (arg (funcall (get-dispatch-macro-character #\# #\#
 86 | 						    *non-scheme-readtable*)
 87 | 		      stream subchar arg))
 88 | 	(t *sharp-sharp*)))
 89 | 
 90 | (defun illegal-read-macro (stream c)
 91 |   (unread-char c stream)		;won't work in general
 92 |   (when (eq *package* scheme-package)
 93 |     (cerror "Try to treat it as Common Lisp would."
 94 | 	    "The character `~A' was encountered."
 95 | 	    c))
 96 |   (let ((*readtable* *non-scheme-readtable*))
 97 |     (read stream nil 0 t)))
 98 | 
 99 | (let ((*readtable* scheme-readtable))
100 |   (set-macro-character #\' #'quote-read-macro)
101 |   (set-macro-character #\` #'quasiquote-read-macro)
102 |   (set-macro-character #\, #'unquote-read-macro)
103 |   (set-dispatch-macro-character #\# #\F #'sharp-F-read-macro)
104 |   (set-dispatch-macro-character #\# #\T #'sharp-T-read-macro)
105 |   (set-dispatch-macro-character #\# #\D #'sharp-D-read-macro)
106 |   (set-dispatch-macro-character #\# #\E #'sharp-E-read-macro)
107 |   (set-dispatch-macro-character #\# #\I #'sharp-I-read-macro)
108 |   (set-dispatch-macro-character #\# #\# #'sharp-sharp-read-macro)
109 |   ;; Don't mess with backslash, or strings will bite you.
110 |   (mapc #'(lambda (c)
111 | 	    (set-macro-character c #'illegal-read-macro t))
112 | 	'(#\[ #\] #\{ #\} #\|)))
113 | 
114 | 
115 | 
116 | (defun write-internal (obj port escapep)
117 |   (let ((*package* ps:scheme-package)
118 | 	(*readtable* ps:scheme-readtable))
119 |     (cond ((null obj)
120 | 	   (princ "()" port))
121 | 	  ((eq obj ps:false)
122 | 	   (write-char #\# port)
123 | 	   ;; Respect *print-case*
124 | 	   (let ((*package* (symbol-package 'f)))
125 | 	     (prin1 'f port)))
126 | 	  ((eq obj ps:true)
127 | 	   (write-char #\# port)
128 | 	   ;; Respect *print-case*
129 | 	   (let ((*package* (symbol-package 't)))
130 | 	     (prin1 't port)))
131 | 	  ((and (consp obj)
132 | 		(eq (car obj) 'scheme::quote)
133 | 		(consp (cdr obj))
134 | 		(null (cddr obj)))
135 | 	   (write-char #\' port)
136 | 	   (write (cadr obj) :stream port :escape escapep :array t))
137 | 	  (t
138 | 	   (write obj :stream port :escape escapep :array t)))
139 |     ps:unspecific))
140 | 


--------------------------------------------------------------------------------
/src/reify.pso:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2 | 
  3 | ; This file was generated by Pseudoscheme 2.12
  4 | ;  running in CMU Common Lisp 16-Aug-1993
  5 | ;  from file /zu/jar/pseudo/reify.scm
  6 | 
  7 | (ps:in-package "SCHEME-TRANSLATOR")
  8 | (BEGIN-TRANSLATED-FILE)
  9 | (LOCALLY
 10 |  (DECLARE (SPECIAL SCHEME-TRANSLATOR-ENV REVISED^4-SCHEME-STRUCTURE))
 11 |  (SETQ SCHEME-TRANSLATOR-ENV
 12 |        (MAKE-PROGRAM-ENV 'SCHEME::SCHEME-TRANSLATOR
 13 |                          (LIST REVISED^4-SCHEME-STRUCTURE))))
 14 | (SET-FUNCTION-FROM-VALUE 'SCHEME-TRANSLATOR-ENV 'SCHEME::SCHEME-TRANSLATOR-ENV)
 15 | (LOCALLY
 16 |  (DECLARE (SPECIAL SCHEME-TRANSLATOR-INTERFACE))
 17 |  (SETQ SCHEME-TRANSLATOR-INTERFACE
 18 |        (MAKE-INTERFACE 'SCHEME::SCHEME-TRANSLATOR
 19 |         '(SCHEME::MAKE-PROGRAM-ENV SCHEME::MAKE-INTERFACE
 20 |                                    SCHEME::MAKE-STRUCTURE
 21 |                                    SCHEME::PROGRAM-ENV-ID
 22 |                                    SCHEME::PROGRAM-ENV-PACKAGE
 23 |                                    SCHEME::PROGRAM-ENV-LOOKUP
 24 |                                    SCHEME::PROGRAM-ENV-DEFINE!
 25 |                                    SCHEME::TRANSLATE
 26 |                                    SCHEME::TRANSLATE-LAMBDA
 27 |                                    SCHEME::REALLY-TRANSLATE-FILE
 28 |                                    SCHEME::TRANSLATOR-VERSION
 29 |                                    SCHEME::PERFORM-USUAL-INTEGRATIONS!
 30 |                                    SCHEME::SCHEME-TRANSLATOR-ENV
 31 |                                    SCHEME::SCHEME-TRANSLATOR-STRUCTURE
 32 |                                    SCHEME::REVISED^4-SCHEME-STRUCTURE
 33 |                                    SCHEME::MAKE-SCHEME-USER-ENVIRONMENT
 34 |                                    SCHEME::INTERN-RENAMING-PERHAPS
 35 |                                    SCHEME::PROCESS-DEFINE-SYNTAX)
 36 |         'NIL)))
 37 | (SET-FUNCTION-FROM-VALUE 'SCHEME-TRANSLATOR-INTERFACE
 38 |                          'SCHEME::SCHEME-TRANSLATOR-INTERFACE)
 39 | (LOCALLY
 40 |  (DECLARE
 41 |   (SPECIAL SCHEME-TRANSLATOR-STRUCTURE
 42 |            SCHEME-TRANSLATOR-ENV
 43 |            SCHEME-TRANSLATOR-INTERFACE))
 44 |  (SETQ SCHEME-TRANSLATOR-STRUCTURE
 45 |        (MAKE-STRUCTURE 'SCHEME::SCHEME-TRANSLATOR
 46 |                        SCHEME-TRANSLATOR-INTERFACE
 47 |                        SCHEME-TRANSLATOR-ENV)))
 48 | (SET-FUNCTION-FROM-VALUE 'SCHEME-TRANSLATOR-STRUCTURE
 49 |                          'SCHEME::SCHEME-TRANSLATOR-STRUCTURE)
 50 | (DEFUN PERFORM-USUAL-INTEGRATIONS! (ENV)
 51 |   (DECLARE (SPECIAL REVISED^4-SCHEME-INTERFACE REVISED^4-SCHEME-ENV))
 52 |   (MAPC
 53 |    #'(LAMBDA (NAME)
 54 |        (LET ((PROBE
 55 |               (GET-INTEGRATION (PROGRAM-ENV-LOOKUP REVISED^4-SCHEME-ENV NAME))))
 56 |          (IF (TRUEP PROBE)
 57 |              (DEFINE-INTEGRATION! (PROGRAM-ENV-LOOKUP ENV NAME) PROBE))))
 58 |    (INTERFACE-NAMES REVISED^4-SCHEME-INTERFACE)))
 59 | (SET-VALUE-FROM-FUNCTION 'PERFORM-USUAL-INTEGRATIONS!
 60 |                          'SCHEME::PERFORM-USUAL-INTEGRATIONS!)
 61 | (DEFUN MAKE-SCHEME-USER-ENVIRONMENT (NAME)
 62 |   (DECLARE
 63 |    (SPECIAL SYNTAX-ERROR REVISED^4-SCHEME-INTERFACE REVISED^4-SCHEME-ENV))
 64 |   (LET ((ENV (MAKE-PROGRAM-ENV NAME 'NIL)))
 65 |     (MAPC
 66 |      #'(LAMBDA (.NAME.0)
 67 |          (MOVE-VALUE-OR-DENOTATION .NAME.0 REVISED^4-SCHEME-ENV ENV))
 68 |      (INTERFACE-NAMES REVISED^4-SCHEME-INTERFACE))
 69 |     (LET ((ENV-FOR-SYNTAX (GET-ENVIRONMENT-FOR-SYNTAX ENV)))
 70 |       (EVAL-FOR-SYNTAX
 71 |        (CONS 'SCHEME::DEFINE (CONS 'SCHEME::SYNTAX-ERROR (LIST FALSE)))
 72 |        ENV-FOR-SYNTAX)
 73 |       (FUNCALL
 74 |        (EVAL-FOR-SYNTAX
 75 |         '(SCHEME::LAMBDA (SCHEME::X)
 76 |                          (SCHEME::SET! SCHEME::SYNTAX-ERROR SCHEME::X))
 77 |         ENV-FOR-SYNTAX)
 78 |        SYNTAX-ERROR))
 79 |     ENV))
 80 | (SET-VALUE-FROM-FUNCTION 'MAKE-SCHEME-USER-ENVIRONMENT
 81 |                          'SCHEME::MAKE-SCHEME-USER-ENVIRONMENT)
 82 | (DEFUN MOVE-VALUE-OR-DENOTATION (NAME FROM TO)
 83 |   (LET ((DEN (PROGRAM-ENV-LOOKUP FROM NAME)))
 84 |     (IF (AND (TRUEP (NODE? DEN)) (TRUEP (PROGRAM-VARIABLE? DEN)))
 85 |         (LET ((FROM-SYM (PROGRAM-VARIABLE-LOCATION DEN)))
 86 |           (IF (BOUNDP FROM-SYM)
 87 |               (LET ((TO-SYM
 88 |                      (PROGRAM-VARIABLE-LOCATION (PROGRAM-ENV-LOOKUP TO NAME))))
 89 |                 (SETF (SYMBOL-VALUE TO-SYM) (SYMBOL-VALUE FROM-SYM))
 90 |                 (SET-FUNCTION-FROM-VALUE TO-SYM))
 91 |               (PROGRAM-ENV-DEFINE! TO NAME DEN)))
 92 |         (PROGRAM-ENV-DEFINE! TO NAME DEN))))
 93 | (SET-VALUE-FROM-FUNCTION 'MOVE-VALUE-OR-DENOTATION
 94 |                          'SCHEME::MOVE-VALUE-OR-DENOTATION)
 95 | (DEFUN EVAL-FOR-SYNTAX (FORM ENV) (EVAL (TRANSLATE FORM ENV)))
 96 | (SET-VALUE-FROM-FUNCTION 'EVAL-FOR-SYNTAX 'SCHEME::EVAL-FOR-SYNTAX)
 97 | (DEFUN .ERROR (&REST REST)
 98 |   (MAYBE-FIX-&REST-PARAMETER REST)
 99 |   (APPLY #'SCHEME-ERROR REST))
100 | (SET-VALUE-FROM-FUNCTION '.ERROR 'SCHEME::ERROR)
101 | (DEFUN GENERATE-STRUCTURE-DEFPACKAGE (STRUCT)
102 |   (LET ((ENV (STRUCTURE-PROGRAM-ENV STRUCT)))
103 |     (IF (EQ (STRUCTURE-ID STRUCT) (PROGRAM-ENV-ID ENV))
104 |         (GENERATE-PROGRAM-ENV-DEFPACKAGE ENV (LIST STRUCT))
105 |         (PROGN
106 |          (.WARN "multiple structures over a package NYI")
107 |          (CONS 'DEFPACKAGE
108 |                (CONS (SYMBOL->STRING (STRUCTURE-ID STRUCT))
109 |                      (CONS
110 |                       (CONS ':USE (LIST (SYMBOL->STRING (PROGRAM-ENV-ID ENV))))
111 |                       (LIST
112 |                        (CONS ':EXPORT
113 |                              (MAPCAR
114 |                               #'(LAMBDA (NAME)
115 |                                   (PERHAPS-RENAME (SYMBOL->STRING NAME)))
116 |                               (INTERFACE-NAMES
117 |                                (STRUCTURE-INTERFACE STRUCT))))))))))))
118 | (SET-VALUE-FROM-FUNCTION 'GENERATE-STRUCTURE-DEFPACKAGE
119 |                          'SCHEME::GENERATE-STRUCTURE-DEFPACKAGE)
120 | (DEFUN GENERATE-PROGRAM-ENV-DEFPACKAGE (ENV STRUCTS)
121 |   (DECLARE (SPECIAL LISP-PACKAGE))
122 |   (CONS 'DEFPACKAGE
123 |         (CONS (SYMBOL->STRING (PROGRAM-ENV-ID ENV))
124 |               (CONS
125 |                (CONS ':USE
126 |                      (CONS (.PACKAGE-NAME LISP-PACKAGE)
127 |                            (MAPCAR
128 |                             #'(LAMBDA (STRUCT)
129 |                                 (SYMBOL->STRING (STRUCTURE-ID STRUCT)))
130 |                             (PROGRAM-ENV-USE-LIST ENV))))
131 |                (LIST
132 |                 (CONS ':EXPORT
133 |                       (APPLY #'APPEND
134 |                              (MAPCAR
135 |                               #'(LAMBDA (STRUCT)
136 |                                   (MAPCAR
137 |                                    #'(LAMBDA (NAME)
138 |                                        (PERHAPS-RENAME (SYMBOL->STRING NAME)))
139 |                                    (INTERFACE-NAMES
140 |                                     (STRUCTURE-INTERFACE STRUCT))))
141 |                               STRUCTS))))))))
142 | (SET-VALUE-FROM-FUNCTION 'GENERATE-PROGRAM-ENV-DEFPACKAGE
143 |                          'SCHEME::GENERATE-PROGRAM-ENV-DEFPACKAGE)
144 | (DEFUN WRITE-DEFPACKAGES (STRUCT-LIST FILENAME)
145 |   (DECLARE (SPECIAL LISP-PACKAGE))
146 |   (LET ((SCHEME::STRING FILENAME)
147 |         (SCHEME::PROC
148 |          #'(LAMBDA (PORT)
149 |              (MAPC
150 |               #'(LAMBDA (STRUCT)
151 |                   (WITH-TARGET-PACKAGE LISP-PACKAGE
152 |                                        #'(LAMBDA ()
153 |                                            (WRITE-FORM
154 |                                             (GENERATE-STRUCTURE-DEFPACKAGE
155 |                                              STRUCT)
156 |                                             PORT)
157 |                                            (TERPRI PORT))))
158 |               STRUCT-LIST))))
159 |     (WITH-OPEN-FILE
160 |         (SCHEME::PORT (MERGE-PATHNAMES SCHEME::STRING) :DIRECTION :OUTPUT
161 |          :IF-EXISTS :NEW-VERSION)
162 |       (FUNCALL SCHEME::PROC SCHEME::PORT)))
163 |   (VALUES))
164 | (SET-VALUE-FROM-FUNCTION 'WRITE-DEFPACKAGES 'SCHEME::WRITE-DEFPACKAGES)
165 | 


--------------------------------------------------------------------------------
/src/reify.scm:
--------------------------------------------------------------------------------
  1 | 
  2 | ; Scheme translator environment and structure
  3 | 
  4 | (define scheme-translator-env
  5 |   (make-program-env
  6 |      'scheme-translator
  7 |      (list revised^4-scheme-structure)))
  8 | 
  9 | (define scheme-translator-interface
 10 |   (make-interface
 11 |     'scheme-translator
 12 |     '(make-program-env
 13 |       make-interface
 14 |       make-structure
 15 |       program-env-id
 16 |       program-env-package
 17 |       program-env-lookup
 18 |       program-env-define!
 19 |       translate
 20 |       translate-lambda
 21 |       really-translate-file
 22 |       translator-version
 23 |       perform-usual-integrations!
 24 |       scheme-translator-env
 25 |       scheme-translator-structure
 26 |       revised^4-scheme-structure
 27 |       make-scheme-user-environment
 28 |       intern-renaming-perhaps
 29 |       process-define-syntax
 30 |       )
 31 |     '()))
 32 | 
 33 | (define scheme-translator-structure
 34 |   (make-structure 'scheme-translator
 35 | 		  scheme-translator-interface
 36 | 		  scheme-translator-env))
 37 | 
 38 | 
 39 | ; Add integrations ("benchmark mode")
 40 | 
 41 | (define (perform-usual-integrations! env)
 42 |   (for-each (lambda (name)
 43 | 	      (let ((probe (get-integration
 44 | 			     (program-env-lookup revised^4-scheme-env name))))
 45 | 		(if probe
 46 | 		    (define-integration! (program-env-lookup env name)
 47 | 		      probe))))
 48 | 	    (interface-names revised^4-scheme-interface)))
 49 | 
 50 | 
 51 | ; A pristine user environment with no integrations.
 52 | 
 53 | (define (make-scheme-user-environment name)
 54 |   (let ((env (make-program-env name '())))
 55 |     (for-each (lambda (name)
 56 | 		(move-value-or-denotation name
 57 | 					  revised^4-scheme-env
 58 | 					  env))
 59 | 	      (interface-names revised^4-scheme-interface))
 60 | 
 61 |     (let ((env-for-syntax (get-environment-for-syntax env)))
 62 |       (eval-for-syntax `(define syntax-error ,#f) env-for-syntax)
 63 |       ((eval-for-syntax `(lambda (x) (set! syntax-error x)) env-for-syntax)
 64 |        syntax-error))
 65 | 
 66 |     env))
 67 | 
 68 | (define (move-value-or-denotation name from to)
 69 |   (let ((den (program-env-lookup from name)))
 70 |     (if (and (node? den)
 71 | 	     (program-variable? den))
 72 | 	(let ((from-sym (program-variable-location den)))
 73 | 	  (ps-lisp:if (ps-lisp:boundp from-sym)
 74 | 		   (let ((to-sym (program-variable-location
 75 | 				  (program-env-lookup to name))))
 76 | 		     (ps-lisp:setf (ps-lisp:symbol-value to-sym)
 77 | 				(ps-lisp:symbol-value from-sym))
 78 | 		     (ps:set-function-from-value to-sym))
 79 | 		   ;; This case handles ELSE and =>.
 80 | 		   (program-env-define! to name den)))
 81 | 	(program-env-define! to name den))))
 82 | 
 83 | 
 84 | ; These don't really belong anywhere
 85 | 
 86 | (define (eval-for-syntax form env)
 87 |   (ps-lisp:eval (translate form env)))
 88 | 
 89 | (define (error . rest)
 90 |   (apply #'ps:scheme-error rest))
 91 | 
 92 | 
 93 | (define (generate-structure-defpackage struct)
 94 |   (let ((env (structure-program-env struct)))
 95 |     (if (eq? (structure-id struct)
 96 | 	     (program-env-id env))
 97 | 	(generate-program-env-defpackage env (list struct))
 98 | 	(begin
 99 | 	  (warn "multiple structures over a package NYI")
100 | 	  `(ps-lisp:defpackage ,(symbol->string (structure-id struct))
101 | 	     (:use ,(symbol->string (program-env-id env)))
102 | 	     (:export ,@(map (lambda (name)
103 | 			       (perhaps-rename
104 | 				(symbol->string name)))
105 | 			     (interface-names
106 | 			      (structure-interface struct)))))))))
107 | 
108 | (define (generate-program-env-defpackage env structs)
109 |   `(ps-lisp:defpackage ,(symbol->string (program-env-id env))
110 |      (:use ,(package-name lisp-package)
111 | 	   ,@(map (lambda (struct)
112 | 		    (symbol->string (structure-id struct)))
113 | 		  (program-env-use-list env)))
114 |      (:export
115 |       ,@(apply append
116 | 	       (map (lambda (struct)
117 | 		      (map (lambda (name)
118 | 			     (perhaps-rename
119 | 			      (symbol->string name)))
120 | 			   (interface-names
121 | 			    (structure-interface struct))))
122 | 		    structs)))))
123 | 
124 | 			 
125 | (define (write-defpackages struct-list filename)
126 |   (call-with-output-file filename
127 |     (lambda (port)
128 |       (newline)
129 |       (display "Writing ")
130 |       (display (true-name port))
131 |       (for-each (lambda (struct)
132 | 		  (with-target-package lisp-package
133 | 		    (lambda ()
134 | 		      (write-form (generate-structure-defpackage struct) port)
135 | 		      (newline port))))
136 | 		struct-list)))
137 |   (values))
138 | 


--------------------------------------------------------------------------------
/src/rules.scm:
--------------------------------------------------------------------------------
  1 | ; Rewrite-rule compiler (a.k.a. "extend-syntax")
  2 | 
  3 | ; Example:
  4 | ;
  5 | ; (define-syntax or
  6 | ;   (syntax-rules ()
  7 | ;     ((or) #f)
  8 | ;     ((or e) e)
  9 | ;     ((or e1 e ...) (let ((temp e1))
 10 | ;		       (if temp temp (or e ...))))))
 11 | 
 12 | (define (rewrite-syntax-rules exp r c)
 13 |   (process-rules (cddr exp) (cadr exp) r c))
 14 | 
 15 | 
 16 | (define (process-rules rules subkeywords r c)
 17 | 
 18 |   (define %append (r 'append))
 19 |   (define %and (r 'and))
 20 |   (define %car (r 'car))
 21 |   (define %cdr (r 'cdr))
 22 |   (define %compare (r 'compare))
 23 |   (define %cond (r 'cond))
 24 |   (define %cons (r 'cons))
 25 |   (define %else (r 'else))
 26 |   (define %eq? (r 'eq?))
 27 |   (define %equal? (r 'equal?))
 28 |   (define %input (r 'input))
 29 |   (define %lambda (r 'lambda))
 30 |   (define %let (r 'let))
 31 |   (define %let* (r 'let*))
 32 |   (define %map (r 'map))
 33 |   (define %pair? (r 'pair?))
 34 |   (define %quote (r 'quote))
 35 |   (define %rename (r 'rename))
 36 |   (define %syntax-error (r 'syntax-error))
 37 |   (define %tail (r 'tail))
 38 |   (define %temp (r 'temp))
 39 | 
 40 |   (define (make-transformer rules)
 41 |     `(,%lambda (,%input ,%rename ,%compare)
 42 |        (,%let ((,%tail (,%cdr ,%input)))
 43 | 	 (,%cond ,@(map process-rule rules)
 44 | 		 (,%else
 45 | 		  (,%syntax-error
 46 | 		   "use of macro doesn't match definition"
 47 | 		   ,%input))))))
 48 | 
 49 |   (define (process-rule rule)
 50 |     (if (and (pair? rule)
 51 | 	     (pair? (cdr rule))
 52 | 	     (null? (cddr rule)))
 53 | 	(let ((pattern (cdar rule))
 54 | 	      (template (cadr rule)))
 55 | 	  `((,%and ,@(process-match %tail pattern))
 56 | 	    (,%let* ,(process-pattern pattern
 57 | 				      %tail
 58 | 				      (lambda (x) x))
 59 | 		    ,(process-template template
 60 | 				       0
 61 | 				       (meta-variables pattern 0 '())))))
 62 | 	(syntax-error "ill-formed syntax rule" rule)))
 63 | 
 64 |   ; Generate code to test whether input expression matches pattern
 65 | 
 66 |   (define (process-match input pattern)
 67 |     (cond ((name? pattern)
 68 | 	   (if (member pattern subkeywords)
 69 | 	       `((,%compare ,input (,%rename ',pattern)))
 70 | 	       `()))
 71 | 	  ((segment-pattern? pattern)
 72 | 	   (process-segment-match input (car pattern)))
 73 | 	  ((pair? pattern)
 74 | 	   `((,%let ((,%temp ,input))
 75 | 	       (,%and (,%pair? ,%temp)
 76 | 		    ,@(process-match `(,%car ,%temp) (car pattern))
 77 | 		    ,@(process-match `(,%cdr ,%temp) (cdr pattern))))))
 78 | 	  ((or (null? pattern) (boolean? pattern) (char? pattern))
 79 | 	   `((,%eq? ,input ',pattern)))
 80 | 	  (else
 81 | 	   `((,%equal? ,input ',pattern)))))
 82 | 
 83 |   (define (process-segment-match input pattern)
 84 |     (let ((conjuncts (process-match '(car l) pattern)))
 85 |       (if (null? conjuncts)
 86 | 	  `((list? ,input))			;+++
 87 | 	  `((let loop ((l ,input))
 88 | 	      (or (null? l)
 89 | 		  (and (pair? l)
 90 | 		       ,@conjuncts
 91 | 		       (loop (cdr l)))))))))
 92 | 
 93 |   ; Generate code to take apart the input expression
 94 |   ; This is pretty bad, but it seems to work (can't say why).
 95 | 
 96 |   (define (process-pattern pattern path mapit)
 97 |     (cond ((name? pattern)
 98 | 	   (if (memq pattern subkeywords)
 99 | 	       '()
100 | 	       (list (list pattern (mapit path)))))
101 | 	  ((segment-pattern? pattern)
102 | 	   (process-pattern (car pattern)
103 | 			    %temp
104 | 			    (lambda (x)	;temp is free in x
105 | 			      (mapit (if (eq? %temp x)
106 | 					 path ;+++
107 | 					 `(,%map (,%lambda (,%temp) ,x)
108 | 						 ,path))))))
109 | 	  ((pair? pattern)
110 | 	   (append (process-pattern (car pattern) `(,%car ,path) mapit)
111 | 		   (process-pattern (cdr pattern) `(,%cdr ,path) mapit)))
112 | 	  (else '())))
113 | 
114 |   ; Generate code to compose the output expression according to template
115 | 
116 |   (define (process-template template rank env)
117 |     (cond ((name? template)
118 | 	   (let ((probe (assq template env)))
119 | 	     (if probe
120 | 		 (if (<= (cdr probe) rank)
121 | 		     template
122 | 		     (syntax-error "template rank error (too few ...'s?)"
123 | 				   template))
124 | 		 `(,%rename ',template))))
125 | 	  ((segment-template? template)
126 | 	   (let ((vars
127 | 		  (free-meta-variables (car template) (+ rank 1) env '())))
128 | 	     (if (null? vars)
129 | 		 (syntax-error "too many ...'s" template)
130 | 		 (let* ((x (process-template (car template)
131 | 					     (+ rank 1)
132 | 					     env))
133 | 			(gen (if (equal? (list x) vars)
134 | 				 x	;+++
135 | 				 `(,%map (,%lambda ,vars ,x)
136 | 					 ,@vars))))
137 | 		   (if (null? (cddr template))
138 | 		       gen		;+++
139 | 		       `(,%append ,gen ,(process-template (cddr template)
140 | 							  rank env)))))))
141 | 	  ((pair? template)
142 | 	   `(,%cons ,(process-template (car template) rank env)
143 | 		    ,(process-template (cdr template) rank env)))
144 | 	  (else `(,%quote ,template))))
145 | 
146 |   ; Return an association list of (var . rank)
147 | 
148 |   (define (meta-variables pattern rank vars)
149 |     (cond ((name? pattern)
150 | 	   (if (memq pattern subkeywords)
151 | 	       vars
152 | 	       (cons (cons pattern rank) vars)))
153 | 	  ((segment-pattern? pattern)
154 | 	   (meta-variables (car pattern) (+ rank 1) vars))
155 | 	  ((pair? pattern)
156 | 	   (meta-variables (car pattern) rank
157 | 			   (meta-variables (cdr pattern) rank vars)))
158 | 	  (else vars)))
159 | 
160 |   ; Return a list of meta-variables of given higher rank
161 | 
162 |   (define (free-meta-variables template rank env free)
163 |     (cond ((name? template)
164 | 	   (if (and (not (memq template free))
165 | 		    (let ((probe (assq template env)))
166 | 		      (and probe (>= (cdr probe) rank))))
167 | 	       (cons template free)
168 | 	       free))
169 | 	  ((segment-template? template)
170 | 	   (free-meta-variables (car template)
171 | 				rank env
172 | 				(free-meta-variables (cddr template)
173 | 						     rank env free)))
174 | 	  ((pair? template)
175 | 	   (free-meta-variables (car template)
176 | 				rank env
177 | 				(free-meta-variables (cdr template)
178 | 						     rank env free)))
179 | 	  (else free)))
180 | 
181 |   c ;ignored
182 | 
183 |   ;; Kludge for Scheme48 linker.
184 |   ;; `(,%cons ,(make-transformer rules)
185 |   ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
186 | 
187 |   (make-transformer rules))
188 | 
189 | (define (segment-pattern? pattern)
190 |   (and (segment-template? pattern)
191 |        (or (null? (cddr pattern))
192 | 	   (syntax-error "segment matching not implemented" pattern))))
193 | 
194 | (define (segment-template? pattern)
195 |   (and (pair? pattern)
196 |        (pair? (cdr pattern))
197 |        (memq (cadr pattern) indicators-for-zero-or-more)))
198 | 
199 | (define indicators-for-zero-or-more (list (string->symbol "...") '---))
200 | 


--------------------------------------------------------------------------------
/src/s48-socket.scm:
--------------------------------------------------------------------------------
  1 | 
  2 | ; Emulate Scheme 48's sockets (and various other things) in Common Lisp.
  3 | 
  4 | #-LispWorks
  5 | (define (open-socket portno)
  6 |   ;; #+LispWorks (comm::create-tcp-socket-for-service portno)
  7 |   #+LispWorks 
  8 |   (begin
  9 |    (cl:format 'cl:t "~&Foreground TCP service not available in LispWorks.~
 10 |                      ~%Try ~S instead.~%" 
 11 | 	      `(spawn-server))     ;cf. flow/network.scm
 12 |    #f)
 13 |   #+Allegro
 14 |   (socket:make-socket :connect :passive :local-port portno)
 15 |   )
 16 | 
 17 | #-LispWorks
 18 | (define (close-socket sock)
 19 |   
 20 |   #+Allegro 'we-dont-need-no-close-here ;(lisp:close sock)
 21 |    )
 22 | 
 23 | #-LispWorks
 24 | (define (socket-listen sock)
 25 |   (let ((str ;#+LispWorks (comm::accept-connection-to-socket sock)
 26 | 	     #+Allegro   (socket:accept-connection sock)))
 27 |     (values str str)))
 28 | 
 29 | (define (socket-client host portno)
 30 |   (let ((str #+LispWorks (comm:open-tcp-stream host portno :direction :io)
 31 | 	     #+Allegro   (socket:make-socket :remote-host host :remote-port portno)))
 32 |     ;; It happens when we can't open a port that we get back NIL.
 33 |     ;; Trap that here for want of proceeding and reading from stream NIL.
 34 |     ;; Do something better later. -kmp 25-Apr-1999
 35 |     #+LispWorks (cl:check-type str (cl:not cl:null))
 36 |     (values str str)))
 37 | 
 38 | 
 39 | (define (start-up-server my-port proc)
 40 |   #+LispWorks
 41 |   (let ((the-server #f))
 42 |     (set! the-server
 43 | 	  (comm:start-up-server 
 44 | 	    :service my-port
 45 | 	    :function
 46 | 	           (lambda (handle)
 47 | 		     (let ((stream (cl:make-instance 'comm:socket-stream
 48 | 						     :socket handle
 49 | 						     :direction :io
 50 | 						     :element-type
 51 | 						     'cl:base-char)))
 52 | 		       (if (eq? (cl:unwind-protect (proc stream stream) (cl:close stream))  'shutdown)
 53 | 			   (mp:process-kill the-server))))))
 54 |     the-server)
 55 |   #-LispWorks
 56 |   ;; This obviously won't work.  Fix later.
 57 |   (spawn #'(lambda ()
 58 | 	     (call-with-socket my-port
 59 | 	       #'(lambda (sock)
 60 | 		   (format *debug-io* "~&Serving ERA connections on port ~s~%"
 61 | 			   my-port)
 62 | 		   (loop
 63 | 		    ;; foo -- cf. http-util.scm
 64 | 		    (let ((a (call-with-server-ports sock proc)))
 65 | 		      (when (eq a 'shutdown)
 66 | 			    (return 'done)))))))
 67 | 	 "Server"))
 68 | 
 69 | 
 70 | ;;; THESE DON'T BELONG HERE, but I don't want to create new files...
 71 | 
 72 | (define (force-output oport)
 73 |   (cl:finish-output oport))
 74 | 
 75 | (define (error? x) (ps:true? (cl:typep x 'cl:error)))
 76 | 
 77 | #+LispWorks
 78 | (map 'cl:eval '(
 79 | 
 80 | (cl:defun with-handler (handler thunk)
 81 |   (cl:handler-bind ((cl:condition #'(cl:lambda (condition)
 82 | 				      (cl:funcall handler 
 83 | 						  condition 
 84 | 						  (cl:lambda () 
 85 | 						    (cl:signal condition))))))
 86 |     (cl:funcall thunk)))
 87 | (ps:set-value-from-function 'with-handler)
 88 | 
 89 | ));pam
 90 | 
 91 | 
 92 | (define (display-condition x oport) 
 93 |   (lisp:format oport "~&~A~&" x))
 94 | 
 95 | (define (disclose-condition x) (cl:princ-to-string x))
 96 |   
 97 | 
 98 | ; CALL-WITH-STRING-OUTPUT-PORT
 99 | 
100 | (map 'cl:eval '(
101 | 
102 | (cl:defun call-with-string-output-port (proc)
103 |   (cl:with-output-to-string (str)
104 |     (cl:funcall proc str)))
105 | (ps:set-value-from-function 'call-with-string-output-port)
106 | 
107 | ));pam
108 | 
109 | ; Hmm.  What if machine-instance is already fully qualified?
110 | ; Should see if it contains a "." and omit suffix if so.
111 | 
112 | (define local-host-name #f)
113 | 
114 | (define local-host-name-is-localhost #f)
115 | 
116 | (define (initialize-local-host-name)
117 |   (set! local-host-name 
118 | 	(if local-host-name-is-localhost
119 | 	    "localhost"
120 | 	    (string-append (cl:string-downcase (cl:machine-instance))
121 | 			   ".crystaliz.com"))))
122 | 
123 | (initialize-local-host-name) ;might need to be redone if image dumped!!
124 | 
125 | 
126 | 


--------------------------------------------------------------------------------
/src/s48-table.scm:
--------------------------------------------------------------------------------
 1 | 
 2 | ; Scheme 48's table package, replicated for Pseudoscheme.
 3 | ; Somewhat redundant with p-utils.scm.
 4 | 
 5 | (define (make-table) (lisp:make-hash-table))
 6 | 
 7 | (define (table-ref table key)
 8 |   (let ((probe (lisp:gethash key table)))
 9 |     (lisp:if probe
10 | 	     probe
11 | 	     #f)))
12 | 
13 | (define (table-set! table key val)
14 |   (lisp:setf (lisp:gethash key table) val))
15 | 
16 | (define (table-walk proc table)
17 |   (lisp:maphash proc table))
18 | 


--------------------------------------------------------------------------------
/src/s48-threads.scm:
--------------------------------------------------------------------------------
  1 | 
  2 | ;; See interface at bottom of file.
  3 | 
  4 | (lisp:defpackage "S48-THREADS-SUPPORT"
  5 |   (:use "COMMON-LISP")
  6 |   (:export "MAKE-LOCK"
  7 |            "PROCESS-LOCK"
  8 | 	   "PROCESS-UNLOCK"
  9 | 	   "PROCESS-RUN-FUNCTION"
 10 | 	   "MAKE-PLACEHOLDER"
 11 | 	   "PLACEHOLDER-REF"
 12 | 	   "PLACEHOLDER-SET"))
 13 | (lisp:in-package "S48-THREADS-SUPPORT")
 14 | 
 15 | ; KMP's code
 16 | 
 17 | (defun *nyi (x) (error "Not yet implemented: ~S" x))
 18 | (defmacro nyi (x) (warn "Not yet implemented: ~S" x) `(*nyi ',x))
 19 | 
 20 | (defun make-lock ()
 21 |   #+LispWorks (mp:make-lock)
 22 |   #+Allegro   (mp::make-process-lock)
 23 |   #-(or LispWorks Allegro) (nyi make-lock))
 24 | 
 25 | (defun process-lock (lock &optional whostate timeout)
 26 |   (check-type whostate (or null (real 0.1 20)) ;imposed by Franz - ugh
 27 | 	      "a timeout between 0.1 and 20 seconds")
 28 |   #+LispWorks (mp:process-lock lock whostate timeout)
 29 |   #+Allegro   (mp::process-lock lock sys:*current-process* whostate timeout)
 30 |   #-(or LispWorks Allegro) (nyi process-lock))
 31 | 
 32 | (defun process-unlock (lock &optional errorp)
 33 |   #+LispWorks (mp:process-unlock lock errorp)
 34 |   #+Allegro   (if errorp 
 35 | 	          (mp::process-unlock lock)
 36 | 	          (ignore-errors (mp::process-unlock lock)))
 37 |   #-(or LispWorks Allegro) (nyi process-unlock))
 38 | 
 39 | (defmacro with-process-lock ((lock &rest keys &key whostate timeout)
 40 | 			     &body forms)
 41 |   (declare (ignore whostate timeout)) ;they're used in keys
 42 |   #+LispWorks `(mp:with-lock (,lock ,@keys) ,@forms)
 43 |   #+Allegro   `(mp:with-process-lock (,lock ,@keys) ,@forms)
 44 |   #-(or LispWorks Allegro) 
 45 |       `(call-with-process-lock #'(lambda () ,@forms) ,@keys))
 46 | 
 47 | #-(or LispWorks Allegro)
 48 | (defun call-with-process-lock (fn &key whostate timeout)
 49 |   (nyi call-with-process-lock))
 50 | 
 51 | ; 12 Multiprocessing
 52 | ;
 53 | ; 12.3 Locks
 54 | ; Locks can be used to control access to shared data by several processes.
 55 | ;
 56 | ; A lock has the following components: name (a string), lock (t or nil,
 57 | ; that is, whether the lock is set or not), owner (a process, or nil)
 58 | ; and count (an integer showing the number of times the lock has been
 59 | ; set).
 60 | ;
 61 | ; The two main symbols used in locking are the function make-lock, to
 62 | ; create a lock, and the macro with-lock, to execute a body of code
 63 | ; while holding the specified lock.
 64 | ;
 65 | ; mp:make-lock 
 66 | ; Function
 67 | ;
 68 | ; mp:make-lock &key important-p &allow-other-keys
 69 | ;
 70 | ; Creates a lock object. If important-p is t the lock is added to the
 71 | ; list held in the global variable mp:*important-locks*. The function
 72 | ; mp:free-important-locks frees all important locks associated with a
 73 | ; given process (or all the important locks if called on nil). Other
 74 | ; keywords should be names of the lock components.
 75 | ;
 76 | ; mp:process-lock 
 77 | ; Function
 78 | ;
 79 | ; mp:process-lock lock &optional whostate timeout
 80 | ;
 81 | ; Blocks the current process until the lock is claimed or timeout
 82 | ; elapses if it has been specified. Returns t if lock was claimed, nil
 83 | ; otherwise.
 84 | ;
 85 | ; mp:process-unlock 
 86 | ; Function
 87 | ;
 88 | ; mp:process-unlock lock &optional errorp
 89 | ;
 90 | ; Releases the lock. If errorp is non-nil it signals an error if the
 91 | ; current process does not own the lock. The default value of errorp is
 92 | ; t.
 93 | ;
 94 | ; mp:with-lock 
 95 | ; Macro
 96 | ;
 97 | ; mp:with-lock ((lock &rest lock-args) &body body
 98 | ;
 99 | ; Executes the body with lock held. Arguments to pass on to
100 | ; mp:process-lock are specified using lock-args.  The following
101 | ; accessors are available for locks: lock-owner, lock-count, lock-name
102 | ; and lock-lock.
103 | 
104 | 
105 | 
106 | ;;; more kmp code
107 | 
108 | (defun process-run-function (name function &rest args)
109 |   #+Genera
110 |   (apply #'process:process-run-function name function args)
111 |   #+LispWorks
112 |   (apply #'mp:process-run-function name '() function args)
113 |   #+Allegro
114 |   (apply #'mp:process-run-function name function args))
115 | 
116 | (defun process-wait (whostate wait-function &rest args)
117 |   #+Genera
118 |   (apply #'process:process-wait whostate wait-function args)
119 |   #+(or LispWorks Allegro)
120 |   (apply #'mp:process-wait whostate wait-function args))
121 |   
122 | (defun process-kill (process)
123 |   #+(or LispWorks Allegro) (mp:process-kill process)
124 |   #-(or LispWorks Allegro) (nyi process-kill))
125 | 
126 | 
127 | 
128 | 
129 | ; some JAR code
130 | 
131 | (defun make-placeholder (id)
132 |   (mp:make-mailbox :lock-name id))
133 | 
134 | (defun placeholder-ref (ph) (mp:mailbox-read ph "placeholder-ref"))
135 | (defun placeholder-set (ph x) (mp:mailbox-send ph x))
136 | 
137 | ;Scheme 48
138 | ;    make-placeholder [id]
139 | ;    placeholder-value p       -- should be called placeholder-ref
140 | ;    placeholder-set! p xx
141 | ;Lispworks - mailbox
142 | ;    mp:make-mailbox :size nn :lock-name xx
143 | ;      "The reader process is set to the current process."
144 | ;      Size argument appears to be meaningless.
145 | ;    mp:mailbox-read mm [wait-reason]
146 | ;    mp:mailbox-send mm xx
147 | 
148 | 
149 | 
150 | ;;;; Interface
151 | 
152 | (lisp:in-package "SCHEME")
153 | 
154 | ; Temp kludge
155 | 
156 | (define (make-lock)               (s48-threads-support:make-lock))
157 | (define (obtain-lock lock)        (s48-threads-support:process-lock lock))
158 | (define (release-lock lock)       (s48-threads-support:process-unlock lock))
159 | (define (spawn thunk description)
160 |   (s48-threads-support:process-run-function description thunk))
161 | 
162 | (define make-placeholder #'s48-threads-support:make-placeholder)
163 | (define placeholder-ref #'s48-threads-support:placeholder-ref)
164 | (define placeholder-set! #'s48-threads-support:placeholder-set)
165 | 


--------------------------------------------------------------------------------
/src/schemify.pso:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2 | 
  3 | ; This file was generated by Pseudoscheme 2.12
  4 | ;  running in CMU Common Lisp 16-Aug-1993
  5 | ;  from file /zu/jar/pseudo/schemify.scm
  6 | 
  7 | (ps:in-package "SCHEME-TRANSLATOR")
  8 | (BEGIN-TRANSLATED-FILE)
  9 | (DEFUN SCHEMIFY-TOP (NODE) (SCHEMIFY NODE 'NIL))
 10 | (SET-VALUE-FROM-FUNCTION 'SCHEMIFY-TOP 'SCHEME::SCHEMIFY-TOP)
 11 | (DEFUN SCHEMIFY (NODE ENV)
 12 |   (IF (TRUEP (NODE? NODE))
 13 |       (CASE (NODE-TYPE NODE)
 14 |         ((SCHEME::PROGRAM-VARIABLE) (PROGRAM-VARIABLE-NAME NODE))
 15 |         ((SCHEME::LOCAL-VARIABLE)
 16 |          (LET ((PROBE (TRUE? (ASSOC NODE ENV :TEST #'EQ))))
 17 |            (IF (TRUEP PROBE) (CDR PROBE) (LOCAL-VARIABLE-NAME NODE))))
 18 |         ((SCHEME::CALL) (SCHEMIFY-CALL NODE ENV))
 19 |         ((SCHEME::CONSTANT)
 20 |          (LET ((VAL (CONSTANT-VALUE NODE)))
 21 |            (IF
 22 |             (OR (NUMBERP VAL)
 23 |                 (CHARACTERP VAL)
 24 |                 (SIMPLE-STRING-P VAL)
 25 |                 (BOOLEANP VAL))
 26 |             VAL
 27 |             (CONS 'SCHEME::QUOTE (LIST VAL)))))
 28 |         ((SCHEME::LAMBDA)
 29 |          (LET ((VARS (LAMBDA-VARS NODE)))
 30 |            (LET ((NEW-VARS
 31 |                   (MAPCAR #'(LAMBDA (VAR) (EXTERNALIZE-VARIABLE VAR ENV))
 32 |                           VARS)))
 33 |              (LET ()
 34 |                (CONS 'SCHEME::LAMBDA
 35 |                      (CONS NEW-VARS
 36 |                            (SCHEMIFY-BODY (LAMBDA-BODY NODE)
 37 |                                           (SCHEMIFY-BIND VARS
 38 |                                                          NEW-VARS
 39 |                                                          ENV))))))))
 40 |         ((SCHEME::LETREC)
 41 |          (LET ((VARS (LETREC-VARS NODE)))
 42 |            (LET ((VALS (LETREC-VALS NODE)))
 43 |              (LET ((NEW-VARS
 44 |                     (MAPCAR #'(LAMBDA (VAR) (EXTERNALIZE-VARIABLE VAR ENV))
 45 |                             VARS)))
 46 |                (LET ((.ENV.0 (SCHEMIFY-BIND VARS NEW-VARS ENV)))
 47 |                  (LET ()
 48 |                    (CONS 'SCHEME::LETREC
 49 |                          (CONS
 50 |                           (MAPCAR
 51 |                            #'(LAMBDA (VAR VAL)
 52 |                                (CONS VAR (LIST (SCHEMIFY VAL .ENV.0))))
 53 |                            NEW-VARS
 54 |                            VALS)
 55 |                           (SCHEMIFY-BODY (LETREC-BODY NODE) .ENV.0)))))))))
 56 |         ((SCHEME::IF)
 57 |          (LET ((TEST (SCHEMIFY (IF-TEST NODE) ENV))
 58 |                (CON (SCHEMIFY (IF-CON NODE) ENV))
 59 |                (ALT (SCHEMIFY (IF-ALT NODE) ENV)))
 60 |            (CONS 'SCHEME::IF (CONS TEST (CONS CON (LIST ALT))))))
 61 |         ((SCHEME::SET!)
 62 |          (CONS 'SCHEME::SET!
 63 |                (CONS (SCHEMIFY (SET!-LHS NODE) ENV)
 64 |                      (LIST (SCHEMIFY (SET!-RHS NODE) ENV)))))
 65 |         ((SCHEME::BEGIN)
 66 |          (CONS 'SCHEME::BEGIN
 67 |                (CONS (SCHEMIFY (BEGIN-FIRST NODE) ENV)
 68 |                      (UNBEGINIFY (SCHEMIFY (BEGIN-SECOND NODE) ENV)))))
 69 |         ((SCHEME::DEFINE)
 70 |          (LET ((VAR (SCHEMIFY (DEFINE-LHS NODE) ENV)))
 71 |            (IF (NOT (SCHEME-SYMBOL-P VAR))
 72 |                (.ERROR "defining a non-variable -- shouldn't happen" VAR))
 73 |            (CONS 'SCHEME::DEFINE
 74 |                  (CONS VAR (LIST (SCHEMIFY (DEFINE-RHS NODE) ENV))))))
 75 |         (OTHERWISE (CONS 'SCHEME::UNKNOWN-NODE-TYPE (LIST NODE))))
 76 |       NODE))
 77 | (SET-VALUE-FROM-FUNCTION 'SCHEMIFY 'SCHEME::SCHEMIFY)
 78 | (DEFUN SCHEMIFY-CALL (NODE ENV)
 79 |   (DECLARE (SPECIAL REVISED^4-SCHEME-ENV))
 80 |   (LET ((PROC (CALL-PROC NODE)))
 81 |     (LET ((ARGS (CALL-ARGS NODE)))
 82 |       (FLET ((PUNT ()
 83 |                (CONS (SCHEMIFY PROC ENV)
 84 |                      (MAPCAR #'(LAMBDA (SUBNODE) (SCHEMIFY SUBNODE ENV))
 85 |                              ARGS))))
 86 |         (LET ()
 87 |           (CASE (NODE-TYPE PROC)
 88 |             ((SCHEME::LAMBDA)
 89 |              (LET ((PROC-EXP (SCHEMIFY PROC ENV)))
 90 |                (CONS 'SCHEME::LET
 91 |                      (CONS
 92 |                       (MAPCAR
 93 |                        #'(LAMBDA (VAR ARG)
 94 |                            (CONS VAR (LIST (SCHEMIFY ARG ENV))))
 95 |                        (CADR PROC-EXP)
 96 |                        ARGS)
 97 |                       (CDDR PROC-EXP)))))
 98 |             ((SCHEME::PROGRAM-VARIABLE)
 99 |              (IF
100 |               (EQ (PROGRAM-VARIABLE-LOCATION PROC)
101 |                   (PROGRAM-ENV-LOOKUP REVISED^4-SCHEME-ENV 'SCHEME::AND-AUX))
102 |               (CONS 'SCHEME::AND
103 |                     (CONS (SCHEMIFY (CAR ARGS) ENV)
104 |                           (LIST (DETHUNKIFY (CADR ARGS) ENV))))
105 |               (IF
106 |                (EQ (PROGRAM-VARIABLE-LOCATION PROC)
107 |                    (PROGRAM-ENV-LOOKUP REVISED^4-SCHEME-ENV 'SCHEME::OR-AUX))
108 |                (CONS 'SCHEME::OR
109 |                      (CONS (SCHEMIFY (CAR ARGS) ENV)
110 |                            (LIST (DETHUNKIFY (CADR ARGS) ENV))))
111 |                (IF
112 |                 (EQ (PROGRAM-VARIABLE-LOCATION PROC)
113 |                     (PROGRAM-ENV-LOOKUP REVISED^4-SCHEME-ENV
114 |                                         'SCHEME::CASE-AUX))
115 |                 (CONS 'SCHEME::CASE
116 |                       (CONS (SCHEMIFY (CAR ARGS) ENV)
117 |                             (APPEND
118 |                              (MAPCAR
119 |                               #'(LAMBDA (KEYS ARG)
120 |                                   (CONS KEYS
121 |                                         (UNBEGINIFY (DETHUNKIFY ARG ENV))))
122 |                               (CONSTANT-VALUE (CADR ARGS))
123 |                               (CDDDR ARGS))
124 |                              (LIST
125 |                               (CONS 'SCHEME::ELSE
126 |                                     (LIST (DETHUNKIFY (CADDR ARGS) ENV)))))))
127 |                 (PUNT)))))
128 |             (OTHERWISE (PUNT))))))))
129 | (SET-VALUE-FROM-FUNCTION 'SCHEMIFY-CALL 'SCHEME::SCHEMIFY-CALL)
130 | (DEFUN DETHUNKIFY (NODE ENV)
131 |   (IF (AND (TRUEP (LAMBDA? NODE)) (NULL (LAMBDA-VARS NODE)))
132 |       (SCHEMIFY (LAMBDA-BODY NODE) ENV)
133 |       (LIST (SCHEMIFY NODE ENV))))
134 | (SET-VALUE-FROM-FUNCTION 'DETHUNKIFY 'SCHEME::DETHUNKIFY)
135 | (DEFUN SCHEMIFY-BODY (NODE ENV) (UNBEGINIFY (SCHEMIFY NODE ENV)))
136 | (SET-VALUE-FROM-FUNCTION 'SCHEMIFY-BODY 'SCHEME::SCHEMIFY-BODY)
137 | (DEFUN UNBEGINIFY (.EXP)
138 |   (IF (TRUEP (CAR-IS? .EXP 'SCHEME::BEGIN)) (CDR .EXP) (LIST .EXP)))
139 | (SET-VALUE-FROM-FUNCTION 'UNBEGINIFY 'SCHEME::UNBEGINIFY)
140 | (DEFUN EXTERNALIZE-VARIABLE (VAR ENV)
141 |   (LET ((NAME (LOCAL-VARIABLE-NAME VAR)))
142 |     (IF (TRUEP (RASSQ NAME ENV))
143 |         (MAKE-NAME-FROM-UID NAME (GENERATE-UID))
144 |         NAME)))
145 | (SET-VALUE-FROM-FUNCTION 'EXTERNALIZE-VARIABLE 'SCHEME::EXTERNALIZE-VARIABLE)
146 | (DEFUN SCHEMIFY-BIND (VARS NAMES ENV) (APPEND (MAPCAR #'CONS VARS NAMES) ENV))
147 | (SET-VALUE-FROM-FUNCTION 'SCHEMIFY-BIND 'SCHEME::SCHEMIFY-BIND)
148 | 


--------------------------------------------------------------------------------
/src/schemify.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File schemify.scm / See file COPYING
  3 | 
  4 | ;;;; SCHEMIFY
  5 | 
  6 | ; SCHEMIFY is an inverse to alpha-conversion.
  7 | ;  This generally keeps the user's original variable names whenever
  8 | ;  there is no conflict.  That's the only thing the env argument is
  9 | ;  used for.
 10 | 
 11 | (define (schemify-top node)
 12 |   (schemify node '()))
 13 | 
 14 | (define (schemify node env)
 15 |   (if (node? node)
 16 |       (case (node-type node)
 17 | 	((program-variable)
 18 | 	 (program-variable-name node))
 19 | 	((local-variable)
 20 | 	 (let ((probe (assq node env)))
 21 | 	   (if probe
 22 | 	       (cdr probe)
 23 | 	       (local-variable-name node))))
 24 | 	((call)
 25 | 	 (schemify-call node env))
 26 | 	((constant)
 27 | 	 (let ((val (constant-value node)))
 28 | 	   (if (or (number? val) (char? val) (string? val) (boolean? val))
 29 | 	       val
 30 | 	       `',val)))
 31 | 	((lambda)
 32 | 	 (let* ((vars (lambda-vars node))
 33 | 		(new-vars (map (lambda (var) (externalize-variable var env))
 34 | 			       vars)))
 35 | 	   `(lambda ,new-vars
 36 | 	      ,@(schemify-body (lambda-body node)
 37 | 			       (schemify-bind vars new-vars env)))))
 38 | 	((letrec)
 39 | 	 (let* ((vars (letrec-vars node))
 40 | 		(vals (letrec-vals node))
 41 | 		(new-vars (map (lambda (var) (externalize-variable var env))
 42 | 			       vars))
 43 | 		(env (schemify-bind vars new-vars env)))
 44 | 	   `(letrec ,(map (lambda (var val)
 45 | 			    `(,var ,(schemify val env)))
 46 | 			  new-vars
 47 | 			  vals)
 48 | 		    ,@(schemify-body (letrec-body node) env))))
 49 | 	((if)
 50 | 	 (let ((test (schemify (if-test node) env))
 51 | 	       (con  (schemify (if-con node) env))
 52 | 	       (alt  (schemify (if-alt node) env)))
 53 | 	   ;;+++ Deal with an UNSPECIFIC alt
 54 | 	   `(if ,test ,con ,alt)))
 55 | 	((set!)
 56 | 	 `(set! ,(schemify (set!-lhs node) env)
 57 | 		,(schemify (set!-rhs node) env)))
 58 | 	((begin)
 59 | 	 `(begin ,(schemify (begin-first node) env)
 60 | 		 ,@(unbeginify (schemify (begin-second node) env))))
 61 | 	((define)
 62 | 	 (let ((var (schemify (define-lhs node) env)))
 63 | 	   (if (not (symbol? var))
 64 | 	       (error "defining a non-variable -- shouldn't happen" var))
 65 | 	   `(define ,var
 66 | 	      ,(schemify (define-rhs node) env))))
 67 | 	(else
 68 | 	 `(unknown-node-type ,node)))
 69 |       node))
 70 | 
 71 | (define (schemify-call node env)
 72 |   (let* ((proc (call-proc node))
 73 | 	 (args (call-args node))
 74 | 	 (punt (lambda ()
 75 | 		 `(,(schemify proc env)
 76 | 		   ,@(map (lambda (subnode) (schemify subnode env))
 77 | 			  args)))))
 78 |     (case (node-type proc)
 79 |       ((lambda)
 80 |        ;; +++ Check for mismatching # of args
 81 |        (let ((proc-exp (schemify proc env)))
 82 | 	 `(let ,(map (lambda (var arg) `(,var ,(schemify arg env)))
 83 | 		     (cadr proc-exp)
 84 | 		     args)
 85 | 	    ,@(cddr proc-exp))))
 86 |       ((program-variable)
 87 |        ;; Rather kludgey.
 88 |        (cond ((eq? (program-variable-location proc)
 89 | 		   (program-env-lookup revised^4-scheme-env 'and-aux))
 90 | 	      `(and ,(schemify (car args) env)
 91 | 		    ,(dethunkify (cadr args) env)))
 92 | 	     ((eq? (program-variable-location proc)
 93 | 		   (program-env-lookup revised^4-scheme-env 'or-aux))
 94 | 	      `(or ,(schemify (car args) env)
 95 | 		   ,(dethunkify (cadr args) env)))
 96 | 	     ((eq? (program-variable-location proc)
 97 | 		   (program-env-lookup revised^4-scheme-env 'case-aux))
 98 | 	      `(case ,(schemify (car args) env)
 99 | 		 ,@(map (lambda (keys arg)
100 | 			  `(,keys ,@(unbeginify (dethunkify arg env))))
101 | 			(constant-value (cadr args))
102 | 			(cdddr args))
103 | 		 (else ,(dethunkify (caddr args) env))))
104 | 	     ;; make-promise
105 | 	     (else (punt))))
106 |       (else (punt)))))
107 | 
108 | (define (dethunkify node env)
109 |   (if (and (lambda? node)
110 | 	   (null? (lambda-vars node)))
111 |       (schemify (lambda-body node) env)
112 |       `(,(schemify node env))))
113 | 
114 | (define (schemify-body node env)
115 |   (unbeginify (schemify node env)))
116 | 
117 | (define (unbeginify exp)
118 |   (if (car-is? exp 'begin) (cdr exp) (list exp)))
119 | 
120 | ; Generate a non-conflicting name
121 | 
122 | (define (externalize-variable var env)
123 |   (let ((name (local-variable-name var)))
124 |     (if (rassq name env)
125 | 	(make-name-from-uid name (generate-uid))
126 | 	name)))
127 | 
128 | (define (schemify-bind vars names env)
129 |   (append (map cons vars names) env))
130 | 


--------------------------------------------------------------------------------
/src/sicp.scm:
--------------------------------------------------------------------------------
 1 | ; Compatibility mode for use with Abelson & Sussman's book,
 2 | ; Structure & Interpretation of Computer Programs.
 3 | ; This is intended to be loaded into Pseudoscheme.
 4 | 
 5 | (define-syntax cons-stream
 6 |   (lambda (e r c) `(,(r 'cons) ,(cadr e) (,(r 'delay) ,(caddr e)))))
 7 | 
 8 | (define head car)
 9 | (define (tail s) (force (cdr s)))
10 | (define the-empty-stream '<the-empty-stream>)
11 | (define (empty-stream? s) (eq? s the-empty-stream))
12 | 
13 | (define-syntax sequence
14 |   (lambda (e r c) `(,(r 'begin) ,@(cdr e))))
15 | 
16 | (define t #t)
17 | (define nil #f)
18 | (define (atom? x) (not (pair? x)))
19 | 
20 | (define (print x)
21 |   (write x)
22 |   (newline))
23 | (define princ display)
24 | (define prin1 write)
25 | 
26 | (define (explode thing)
27 |   (map (lambda (c) (string->symbol (string c)))
28 |        (string->list (cond ((symbol? thing)
29 | 			    (symbol->string thing))
30 | 			   ((number? thing)
31 | 			    (number->string thing))
32 | 			   (else
33 | 			    (error "invalid argument to explode" thing))))))
34 | 
35 | (define (implode l)
36 |   (string->symbol (list->string (map (lambda (s)
37 | 				       (string-ref (symbol->string s) 0))
38 | 				     l))))
39 | 
40 | (define mapcar map)
41 | (define mapc for-each)
42 | 
43 | (define (1+ x) (+ x 1))
44 | (define (-1+ x) (- x 1))
45 | 
46 | (define (get sym ind)
47 |   (ps-lisp:or (ps-lisp:get sym ind) #f))
48 | 
49 | (define (put sym ind val)
50 |   (ps-lisp:setf (ps-lisp:get sym ind) val))
51 | 
52 | 
53 | ; AND and OR are procedures according to SICP.  Replace references
54 | ; as needed with *AND and *OR.
55 | 
56 | (define (*and . rest)
57 |   (let loop ((rest rest))
58 |     (if (null? rest)
59 | 	#t
60 | 	(and (car rest) (loop (cdr rest))))))
61 | 
62 | (define (*or . rest)
63 |   (let loop ((rest rest))
64 |     (if (null? rest)
65 | 	#f
66 | 	(or (car rest) (loop (cdr rest))))))
67 | 


--------------------------------------------------------------------------------
/src/spack.lisp:
--------------------------------------------------------------------------------
 1 | (DEFPACKAGE "REVISED^4-SCHEME"
 2 |             (:USE "PS")
 3 |             (:EXPORT ".AND" "BEGIN" ".CASE" ".COND" "DEFINE" "DELAY" ".DO"
 4 |              ".IF" ".LAMBDA" "LETREC" ".LET" ".LET*" ".OR" "QUASIQUOTE"
 5 |              ".QUOTE" "SET!" "UNQUOTE" "UNQUOTE-SPLICING" "DEFINE-SYNTAX"
 6 |              "LET-SYNTAX" "LETREC-SYNTAX" "SYNTAX-RULES" "=>" "ELSE" ".*" ".+"
 7 |              ".-" "./" ".<" ".<=" ".=" ".>" ".>=" ".APPLY" "BOOLEAN?"
 8 |              "CALL-WITH-CURRENT-CONTINUATION" ".CAR" ".CDR" "CHAR->INTEGER"
 9 |              "CHAR-READY?" "CLOSE-INPUT-PORT" "CLOSE-OUTPUT-PORT" "COMPLEX?"
10 |              ".CONS" "CURRENT-INPUT-PORT" "CURRENT-OUTPUT-PORT" ".DENOMINATOR"
11 |              "EOF-OBJECT?" "EQ?" "EQV?" "EXACT->INEXACT" "EXACT?" "IMAG-PART"
12 |              "INEXACT->EXACT" "INEXACT?" "INPUT-PORT?" "INTEGER->CHAR"
13 |              "INTEGER?" ".LOAD" "MAGNITUDE" "MAKE-POLAR" "MAKE-RECTANGULAR"
14 |              ".MAKE-STRING" "MAKE-VECTOR" "MODULO" "NEWLINE" ".NOT" "NULL?"
15 |              "NUMBER?" ".NUMERATOR" "OPEN-INPUT-FILE" "OPEN-OUTPUT-FILE"
16 |              "OUTPUT-PORT?" "PAIR?" ".PEEK-CHAR" "PROCEDURE?" "QUOTIENT"
17 |              "RATIONAL?" ".READ-CHAR" "REAL-PART" "REAL?" "REMAINDER"
18 |              "SET-CAR!" "SET-CDR!" ".STRING" "STRING->SYMBOL" "STRING-LENGTH"
19 |              "STRING-REF" "STRING-SET!" "STRING?" "SYMBOL->STRING" "SYMBOL?"
20 |              "TRANSCRIPT-ON" "TRANSCRIPT-OFF" "VECTOR-LENGTH" "VECTOR-REF"
21 |              "VECTOR-SET!" "VECTOR?" ".WRITE-CHAR" ".APPEND" ".ASSOC" "ASSQ"
22 |              "ASSV" ".ABS" ".ACOS" "ANGLE" ".ASIN" ".ATAN" ".CAAAAR" ".CAAADR"
23 |              ".CAADAR" ".CAADDR" ".CAAAR" ".CAADR" ".CAAR" ".CADAAR" ".CADADR"
24 |              ".CADDAR" ".CADDDR" ".CADAR" ".CADDR" ".CADR"
25 |              "CALL-WITH-INPUT-FILE" "CALL-WITH-OUTPUT-FILE" ".CDAAAR" ".CDAADR"
26 |              ".CDADAR" ".CDADDR" ".CDAAR" ".CDADR" ".CDAR" ".CDDAAR" ".CDDADR"
27 |              ".CDDDAR" ".CDDDDR" ".CDDAR" ".CDDDR" ".CDDR" ".CEILING"
28 |              "CHAR-ALPHABETIC?" "CHAR-CI<=?" "CHAR-CI<?" "CHAR-CI=?"
29 |              "CHAR-CI>=?" "CHAR-CI>?" ".CHAR-DOWNCASE" "CHAR-LOWER-CASE?"
30 |              "CHAR-NUMERIC?" ".CHAR-UPCASE" "CHAR-UPPER-CASE?"
31 |              "CHAR-WHITESPACE?" "CHAR<=?" "CHAR<?" "CHAR=?" "CHAR>=?" "CHAR>?"
32 |              "CHAR?" ".COS" "DISPLAY" "EQUAL?" "EVEN?" ".EXP" ".EXPT" ".FLOOR"
33 |              "FOR-EACH" "FORCE" ".GCD" ".LCM" ".LIST" ".LOG" ".LENGTH"
34 |              "LIST->STRING" "LIST->VECTOR" "LIST-REF" "LIST-TAIL" "LIST?"
35 |              ".MAP" ".MAX" ".MEMBER" "MEMQ" "MEMV" ".MIN" "NEGATIVE?"
36 |              "NUMBER->STRING" "ODD?" ".RATIONALIZE" "POSITIVE?" ".READ"
37 |              ".REVERSE" ".ROUND" ".SIN" ".SQRT" "STRING->LIST" "STRING->NUMBER"
38 |              "STRING-APPEND" "STRING-CI<=?" "STRING-CI<?" "STRING-CI=?"
39 |              "STRING-CI>=?" "STRING-CI>?" "STRING-COPY" "STRING-FILL!"
40 |              "STRING<=?" "STRING<?" "STRING=?" "STRING>=?" "STRING>?"
41 |              "SUBSTRING" ".TAN" ".TRUNCATE" ".VECTOR" "VECTOR->LIST"
42 |              "VECTOR-FILL!" "WITH-INPUT-FROM-FILE" "WITH-OUTPUT-TO-FILE"
43 |              ".WRITE" "ZERO?" ".VALUES" "CALL-WITH-VALUES" "DYNAMIC-WIND"
44 |              ".EVAL" "INTERACTION-ENVIRONMENT" ".SCHEME-REPORT-ENVIRONMENT"))
45 | (DEFPACKAGE "SCHEME-TRANSLATOR"
46 |             (:USE "PS" "REVISED^4-SCHEME")
47 |             (:EXPORT "MAKE-PROGRAM-ENV" "MAKE-INTERFACE" "MAKE-STRUCTURE"
48 |              "PROGRAM-ENV-ID" "PROGRAM-ENV-PACKAGE" "PROGRAM-ENV-LOOKUP"
49 |              "PROGRAM-ENV-DEFINE!" "TRANSLATE" "TRANSLATE-LAMBDA"
50 |              "REALLY-TRANSLATE-FILE" "TRANSLATOR-VERSION"
51 |              "PERFORM-USUAL-INTEGRATIONS!" "SCHEME-TRANSLATOR-ENV"
52 |              "SCHEME-TRANSLATOR-STRUCTURE" "REVISED^4-SCHEME-STRUCTURE"
53 |              "MAKE-SCHEME-USER-ENVIRONMENT" "INTERN-RENAMING-PERHAPS"
54 |              "PROCESS-DEFINE-SYNTAX"))
55 | 


--------------------------------------------------------------------------------
/src/ssig.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File ssig.scm / See file COPYING
  3 | 
  4 | ;;;; Scheme interfaces
  5 | 
  6 | ; The separation into core and non-core is very tentative for now.
  7 | ; Could be split into two different interfaces at some point.
  8 | 
  9 | (define revised^4-scheme-interface
 10 |   (make-interface
 11 |    'revised^4-scheme
 12 |    '(
 13 |      ;; Syntax
 14 |      and begin case cond define
 15 |      delay do if lambda letrec let let* or
 16 |      quasiquote quote set! unquote unquote-splicing 
 17 |      define-syntax let-syntax letrec-syntax   ;New stuff
 18 |      syntax-rules			;Pattern-based macro definer
 19 |      ;; for-syntax ?
 20 |      => else
 21 | 
 22 |      ;; Core procedures
 23 |      * + - / < <= = > >=
 24 |      apply
 25 |      boolean?
 26 |      call-with-current-continuation
 27 |      car cdr
 28 |      char->integer
 29 |      char-ready?
 30 |      close-input-port close-output-port
 31 |      complex? cons current-input-port current-output-port
 32 |      denominator
 33 |      eof-object? eq? eqv? exact->inexact exact?
 34 |      imag-part inexact->exact inexact? input-port?
 35 |      integer->char integer?
 36 |      load
 37 |      magnitude make-polar make-rectangular make-string
 38 |      make-vector modulo
 39 |      newline not null? number? 
 40 |      numerator
 41 |      open-input-file open-output-file output-port?
 42 |      pair? peek-char procedure?
 43 |      quotient
 44 |      rational? read-char real-part real?
 45 |      remainder
 46 |      set-car! set-cdr!
 47 |      string
 48 |      string->symbol 
 49 |      string-length string-ref string-set!
 50 |      string? symbol->string symbol?
 51 |      transcript-on transcript-off
 52 |      vector-length vector-ref vector-set! vector?
 53 |      write-char
 54 | 
 55 |      ;; Non-core procedures (definable in terms of core)
 56 |      append assoc assq assv
 57 |      abs acos angle
 58 |      asin atan
 59 |      caaaar caaadr caadar caaddr caaar caadr caar
 60 |      cadaar cadadr caddar cadddr cadar caddr cadr
 61 |      call-with-input-file
 62 |      call-with-output-file
 63 |      cdaaar cdaadr cdadar cdaddr cdaar cdadr cdar
 64 |      cddaar cddadr cdddar cddddr cddar cdddr cddr
 65 |      ceiling
 66 |      char-alphabetic?
 67 |      char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>?
 68 |      char-downcase char-lower-case? char-numeric?
 69 |      char-upcase
 70 |      char-upper-case? char-whitespace? char<=? char<? char=?
 71 |      char>=? char>? char?
 72 |      cos
 73 |      display
 74 |      equal? even? exp expt
 75 |      floor for-each force
 76 |      gcd
 77 |      lcm list log
 78 |      length list->string list->vector list-ref list-tail
 79 |      list?
 80 |      map max member memq memv min
 81 |      negative? number->string
 82 |      odd?
 83 |      rationalize
 84 |      positive? read reverse round sin sqrt 
 85 |      string->list string->number string-append
 86 |      string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>?
 87 |      string-copy string-fill!
 88 |      string<=? string<? string=? string>=? string>? substring
 89 |      tan truncate
 90 |      vector vector->list vector-fill! with-input-from-file
 91 |      with-output-to-file write zero? 
 92 | 
 93 |      ;; Revised^5 stuff
 94 |      values call-with-values dynamic-wind
 95 |      eval interaction-environment scheme-report-environment
 96 |      )
 97 |    ;; Private variables
 98 |    '(and-aux case-aux make-promise or-aux
 99 |      unspecific =>-aux
100 |      )))
101 | 


--------------------------------------------------------------------------------
/src/strategy.pso:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2 | 
  3 | ; This file was generated by Pseudoscheme 2.12
  4 | ;  running in CMU Common Lisp 16-Aug-1993
  5 | ;  from file /zu/jar/pseudo/strategy.scm
  6 | 
  7 | (ps:in-package "SCHEME-TRANSLATOR")
  8 | (BEGIN-TRANSLATED-FILE)
  9 | (DEFUN GET-LETREC-STRATEGY (NODE)
 10 |   (DECLARE (SPECIAL N-ARY? VARIABLE-VALUE-REFS?))
 11 |   (LET ((TEMP (LETREC-STRATEGY NODE)))
 12 |     (IF (TRUEP TEMP)
 13 |         TEMP
 14 |         (LET ((STRATEGY
 15 |                (LET ((VARS (LETREC-VARS NODE)) (VALS (LETREC-VALS NODE)))
 16 |                  (IF
 17 |                   (OR (NULL VARS) (NOT (TRUEP (FUNCTION-BINDABLE? VARS VALS))))
 18 |                   'SCHEME::GENERAL
 19 |                   (IF
 20 |                    (OR (TRUEP (SOME VARIABLE-VALUE-REFS? VARS))
 21 |                        (TRUEP (SOME N-ARY? VALS))
 22 |                        (TRUEP (EXISTS-LOSING-CALL? NODE)))
 23 |                    'SCHEME::LABELS
 24 |                    'SCHEME::PROG)))))
 25 |           (SET-LETREC-STRATEGY! NODE STRATEGY)
 26 |           STRATEGY))))
 27 | (SET-VALUE-FROM-FUNCTION 'GET-LETREC-STRATEGY 'SCHEME::GET-LETREC-STRATEGY)
 28 | (DEFUN EXISTS-LOSING-CALL? (NODE)
 29 |   (LET ((VARS (LETREC-VARS NODE)))
 30 |     (LET ((TEMP (CONTAINS-LOSER? (LETREC-BODY NODE) VARS 'SCHEME::WIN)))
 31 |       (IF (TRUEP TEMP)
 32 |           TEMP
 33 |           (SOME #'(LAMBDA (PROC) (CALL-WILL-LOSE? PROC VARS 'SCHEME::WIN))
 34 |                 (LETREC-VALS NODE))))))
 35 | (SET-VALUE-FROM-FUNCTION 'EXISTS-LOSING-CALL? 'SCHEME::EXISTS-LOSING-CALL?)
 36 | (DEFUN CONTAINS-LOSER? (NODE VARS K)
 37 |   (CASE (NODE-TYPE NODE)
 38 |     ((SCHEME::LOCAL-VARIABLE SCHEME::PROGRAM-VARIABLE SCHEME::CONSTANT) FALSE)
 39 |     ((SCHEME::LETREC)
 40 |      (LET ((TEMP (CONTAINS-LOSER? (LETREC-BODY NODE) VARS K)))
 41 |        (IF (TRUEP TEMP)
 42 |            TEMP
 43 |            (IF (EQ (GET-LETREC-STRATEGY NODE) 'SCHEME::PROG)
 44 |                (SOME #'(LAMBDA (PROC) (CALL-WILL-LOSE? PROC VARS K))
 45 |                      (LETREC-VALS NODE))
 46 |                (LIST-CONTAINS-LOSER? (LETREC-VALS NODE) VARS 'SCHEME::LOSE)))))
 47 |     ((SCHEME::IF)
 48 |      (LET ((TEMP (CONTAINS-LOSER? (IF-TEST NODE) VARS 'SCHEME::LOSE)))
 49 |        (IF (TRUEP TEMP)
 50 |            TEMP
 51 |            (LET ((.TEMP.0 (CONTAINS-LOSER? (IF-CON NODE) VARS K)))
 52 |              (IF (TRUEP .TEMP.0)
 53 |                  .TEMP.0
 54 |                  (CONTAINS-LOSER? (IF-ALT NODE) VARS K))))))
 55 |     ((SCHEME::BEGIN)
 56 |      (LET ((TEMP (CONTAINS-LOSER? (BEGIN-FIRST NODE) VARS 'SCHEME::LOSE)))
 57 |        (IF (TRUEP TEMP) TEMP (CONTAINS-LOSER? (BEGIN-SECOND NODE) VARS K))))
 58 |     ((SCHEME::SET!) (CONTAINS-LOSER? (SET!-RHS NODE) VARS 'SCHEME::LOSE))
 59 |     ((SCHEME::LAMBDA) (CONTAINS-LOSER? (LAMBDA-BODY NODE) VARS 'SCHEME::LOSE))
 60 |     ((SCHEME::CALL)
 61 |      (LET ((PROC (CALL-PROC NODE)))
 62 |        (IF (TRUEP (LAMBDA? PROC))
 63 |            (LET ((TEMP (CALL-WILL-LOSE? PROC VARS K)))
 64 |              (IF (TRUEP TEMP)
 65 |                  TEMP
 66 |                  (LIST-CONTAINS-LOSER? (CALL-ARGS NODE) VARS 'SCHEME::LOSE)))
 67 |            (IF (TRUEP (PROGRAM-VARIABLE? PROC))
 68 |                (LET ((N (NUMBER-OF-NON-CONTINUATION-ARGS PROC)))
 69 |                  (IF (TRUEP N)
 70 |                      (PROG (|.A.1| |.I.2|)
 71 |                        (PSETQ |.A.1| (CALL-ARGS NODE) |.I.2| 0)
 72 |                        (GO LOOP)
 73 |                       LOOP
 74 |                        (LET ((A |.A.1|) (I |.I.2|))
 75 |                          (IF (= I N)
 76 |                              (RETURN
 77 |                               (SOME
 78 |                                #'(LAMBDA (ARG) (CALL-WILL-LOSE? ARG VARS K))
 79 |                                A))
 80 |                              (LET ((TEMP
 81 |                                     (CONTAINS-LOSER? (CAR A)
 82 |                                                      VARS
 83 |                                                      'SCHEME::LOSE)))
 84 |                                (IF (TRUEP TEMP)
 85 |                                    (RETURN TEMP)
 86 |                                    (PROGN
 87 |                                     (PSETQ |.A.1| (CDR A) |.I.2| (+ I 1))
 88 |                                     (GO LOOP)))))))
 89 |                      (LIST-CONTAINS-LOSER? (CALL-ARGS NODE)
 90 |                                            VARS
 91 |                                            'SCHEME::LOSE)))
 92 |                (LET ((TEMP
 93 |                       (IF (MEMBER PROC VARS :TEST #'EQ)
 94 |                           (TRUE? (EQ K 'SCHEME::LOSE))
 95 |                           (CONTAINS-LOSER? PROC VARS 'SCHEME::LOSE))))
 96 |                  (IF (TRUEP TEMP)
 97 |                      TEMP
 98 |                      (LIST-CONTAINS-LOSER? (CALL-ARGS NODE)
 99 |                                            VARS
100 |                                            'SCHEME::LOSE)))))))
101 |     (OTHERWISE (.ERROR "unknown node type" NODE))))
102 | (SET-VALUE-FROM-FUNCTION 'CONTAINS-LOSER? 'SCHEME::CONTAINS-LOSER?)
103 | (DEFUN LIST-CONTAINS-LOSER? (NODE-LIST VARS K)
104 |   (SOME #'(LAMBDA (NODE) (CONTAINS-LOSER? NODE VARS K)) NODE-LIST))
105 | (SET-VALUE-FROM-FUNCTION 'LIST-CONTAINS-LOSER? 'SCHEME::LIST-CONTAINS-LOSER?)
106 | (DEFUN CALL-WILL-LOSE? (PROC-NODE VARS K)
107 |   (IF (TRUEP (LAMBDA? PROC-NODE))
108 |       (CONTAINS-LOSER? (LAMBDA-BODY PROC-NODE) VARS K)
109 |       (CONTAINS-LOSER? PROC-NODE VARS 'SCHEME::LOSE)))
110 | (SET-VALUE-FROM-FUNCTION 'CALL-WILL-LOSE? 'SCHEME::CALL-WILL-LOSE?)
111 | (DEFUN NUMBER-OF-NON-CONTINUATION-ARGS (VAR)
112 |   (IF
113 |    (OR (EQ VAR (BUILT-IN 'SCHEME::AND-AUX))
114 |        (EQ VAR (BUILT-IN 'SCHEME::OR-AUX)))
115 |    1
116 |    (IF (EQ VAR (BUILT-IN 'SCHEME::=>-AUX))
117 |        2
118 |        (IF (EQ VAR (BUILT-IN 'SCHEME::CASE-AUX)) 1 FALSE))))
119 | (SET-VALUE-FROM-FUNCTION 'NUMBER-OF-NON-CONTINUATION-ARGS
120 |                          'SCHEME::NUMBER-OF-NON-CONTINUATION-ARGS)
121 | (DEFUN FUNCTION-BINDABLE? (VARS VALS)
122 |   (DECLARE (SPECIAL LAMBDA?))
123 |   (IF (NOT (NULL VARS))
124 |       (IF
125 |        (TRUEP
126 |         (EVERY #'(LAMBDA (VAR) (TRUE? (NOT (TRUEP (VARIABLE-ASSIGNED? VAR)))))
127 |                VARS))
128 |        (EVERY LAMBDA? VALS)
129 |        FALSE)
130 |       FALSE))
131 | (SET-VALUE-FROM-FUNCTION 'FUNCTION-BINDABLE? 'SCHEME::FUNCTION-BINDABLE?)
132 | 


--------------------------------------------------------------------------------
/src/strategy.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File strategy.scm / See file COPYING
  3 | 
  4 | ;;;; Compute strategy for compiling a LETREC
  5 | 
  6 | (define (get-letrec-strategy node)
  7 |   (or (letrec-strategy node)
  8 |       (let ((strategy
  9 | 	     (let ((vars (letrec-vars node))
 10 | 		   (vals (letrec-vals node)))
 11 | 	       (cond ((or (null? vars)
 12 | 			  (not (function-bindable? vars vals)))
 13 | 		      'general)
 14 | 		     ((or (some variable-value-refs? vars)
 15 | 			  (some n-ary? vals)
 16 | 			  (exists-losing-call? node))
 17 | 		      'labels)
 18 | 		     (else 'prog)))))
 19 | 	(set-letrec-strategy! node strategy)
 20 | 	strategy)))
 21 | 
 22 | ; The following procedure does a tail recursion analysis to find calls
 23 | ; to the labels functions that are in non-tail-recursive positions.
 24 | 
 25 | (define (exists-losing-call? node)
 26 |   (let ((vars (letrec-vars node)))
 27 |     (or (contains-loser? (letrec-body node) vars 'win)
 28 | 	(some (lambda (proc)
 29 | 		(call-will-lose? proc vars 'win))
 30 | 	      (letrec-vals node)))))
 31 | 
 32 | (define (contains-loser? node vars k)
 33 |   (case (node-type node)
 34 |     ((local-variable program-variable constant) #f)
 35 |     ((letrec)
 36 |      (or (contains-loser? (letrec-body node) vars k)
 37 | 	 (if (eq? (get-letrec-strategy node) 'prog)
 38 | 	     (some (lambda (proc)
 39 | 		     (call-will-lose? proc vars k))
 40 | 		   (letrec-vals node))
 41 | 	     (list-contains-loser? (letrec-vals node) vars 'lose))))
 42 |     ((if)
 43 |      (or (contains-loser? (if-test node) vars 'lose)
 44 | 	 (contains-loser? (if-con node) vars k)
 45 | 	 (contains-loser? (if-alt node) vars k)))
 46 |     ((begin)
 47 |      (or (contains-loser? (begin-first node) vars 'lose)
 48 | 	 (contains-loser? (begin-second node) vars k)))
 49 |     ((set!)
 50 |      (contains-loser? (set!-rhs node) vars 'lose))
 51 |     ((lambda)
 52 |      (contains-loser? (lambda-body node) vars 'lose))
 53 |     ((call)
 54 |      (let ((proc (call-proc node)))
 55 |        (cond ((lambda? proc)
 56 | 	      ;;+++ Could deal with (let ((p (lambda ...))) ... (p ...))
 57 | 	      ;; here, but punt for now.
 58 | 	      (or (call-will-lose? proc vars k)
 59 | 		  (list-contains-loser? (call-args node) vars 'lose)))
 60 | 	     ((program-variable? proc)
 61 | 	      (let ((n (number-of-non-continuation-args proc)))
 62 | 		(if n
 63 | 		    (let loop ((a (call-args node)) (i 0))
 64 | 		      (if (= i n)
 65 | 			  (some (lambda (arg)
 66 | 				  (call-will-lose? arg vars k))
 67 | 				a)
 68 | 			  (or (contains-loser? (car a) vars 'lose)
 69 | 			      (loop (cdr a) (+ i 1)))))
 70 | 		    (list-contains-loser? (call-args node) vars 'lose))))
 71 | 	     (else
 72 | 	      (or (if (memq proc vars)
 73 | 		      (eq? k 'lose)
 74 | 		      (contains-loser? proc vars 'lose))
 75 | 		  (list-contains-loser? (call-args node) vars 'lose))))))
 76 |     (else (error "unknown node type" node))))
 77 | 
 78 | (define (list-contains-loser? node-list vars k)
 79 |   (some (lambda (node)
 80 | 	  (contains-loser? node vars k))
 81 | 	node-list))
 82 | 
 83 | ; PROC-NODE will be evaluated and then immediately invoked.
 84 | 
 85 | (define (call-will-lose? proc-node vars k)
 86 |   (if (lambda? proc-node)
 87 |       (contains-loser? (lambda-body proc-node) vars k)
 88 |       (contains-loser? proc-node vars 'lose)))
 89 | 
 90 | (define (number-of-non-continuation-args var)
 91 |   ;; Kind of slow -- should speed this up somehow?  This information
 92 |   ;; ought to be in the integrations-table, at least.
 93 |   (cond ((or (eq? var (built-in 'and-aux))
 94 | 	     (eq? var (built-in 'or-aux)))
 95 | 	 1)
 96 | 	((eq? var (built-in '=>-aux)) 2)
 97 | 	((eq? var (built-in 'case-aux)) 1)
 98 | 	(else #f)))
 99 | 
100 | ; True if it will be possible to bind the variables using FLET or LABELS.
101 | 
102 | (define (function-bindable? vars vals)
103 |   (and (not (null? vars))
104 |        (every (lambda (var)
105 | 		;; Maybe require that there be no non-function refs?
106 | 		(not (variable-assigned? var)))
107 | 	      vars)
108 |        (every lambda? vals)))
109 | 


--------------------------------------------------------------------------------
/src/translate.scm:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2 | ; File translate.scm / See file COPYING
  3 | 
  4 | ;;;; Translation from Scheme to Common Lisp
  5 | 
  6 | ; TRANSLATE translates a single Scheme expression into Common Lisp.
  7 | 
  8 | (define (translate form env)
  9 |   (with-target-package (program-env-package env)
 10 |     (lambda ()
 11 |       (translate-to-common-lisp (list form) env))))
 12 | 
 13 | ; Used by translate and translate-file
 14 | 
 15 | (define (translate-to-common-lisp forms env)
 16 |   (prognify
 17 |    (let recur ((forms forms))
 18 |      (if (null? forms)
 19 | 	 '()
 20 | 	 (cons (with-uid-reset
 21 | 		(lambda ()
 22 | 		  (let-fluid @free-variables '()
 23 | 		    (lambda ()
 24 | 		      (let ((node (alpha-top (car forms) env)))
 25 | 			(generate-top
 26 | 			 node
 27 | 			 (generation-env (fluid @free-variables))
 28 | 			 (not (null? (cdr forms)))))))))
 29 | 	       (recur (cdr forms)))))))
 30 | 
 31 | ; Used by SCHEME-COMPILE.
 32 | 
 33 | (define (translate-lambda form env)
 34 |   (with-uid-reset
 35 |    (lambda ()
 36 |      (let-fluid @free-variables '()
 37 |        (lambda ()
 38 | 	 (let ((node (alpha-top form env)))
 39 | 	   (if (lambda? node)
 40 | 	       (generate-lambda-top
 41 | 		  node
 42 | 		  (generation-env (fluid @free-variables)))
 43 | 	       (error "not a lambda expression" form))))))))
 44 | 
 45 | ; File transduction
 46 | 
 47 | (define (really-translate-file source-file-name
 48 | 			       translated-file-name
 49 | 			       program-env)
 50 |   (let ((source-code (read-file source-file-name)))
 51 |     (compiling-to-file
 52 |       translated-file-name
 53 |       (program-env-package program-env)
 54 |       (lambda (port)
 55 | 	(display ";  from file " port)
 56 | 	(display (true-name source-file-name) port)
 57 | 	(newline port))
 58 |       (lambda (port)
 59 | 	(for-each (lambda (form)
 60 | 		    (write-flattened form port))
 61 | 		  (translate-to-common-lisp source-code program-env))))))
 62 | 
 63 | ; The following generates a file CLOSED.PSO from the information we
 64 | ; have on how to open-code the built-in procedures.
 65 | 
 66 | (define (write-closed-definitions structure outfile)
 67 |   (compiling-to-file outfile
 68 | 		     (structure-package structure)
 69 | 		     (lambda (port) port)
 70 | 		     (lambda (port)
 71 | 		       (write-closed-definitions-1 structure port))))
 72 | 
 73 | (define (write-closed-definitions-1 structure port)
 74 |   (let ((sig (structure-interface structure))
 75 | 	(env (structure-program-env structure)))
 76 |     (let ((funs '())
 77 | 	  (defs '()))
 78 |       (let ((do-it
 79 | 	     (lambda (name)
 80 | 	       (let* ((den (program-env-lookup env name))
 81 | 		      (info (get-integration den)))
 82 | 		 (if info
 83 | 		     (let ((sym (program-variable-location den)))
 84 | 		       (case (car info)
 85 | 			 ((val)
 86 | 			  (write-form `(ps-lisp:locally
 87 | 					   (ps-lisp:declare (ps-lisp:special ,sym))
 88 | 					 (ps-lisp:setq ,sym ,(cadr info)))
 89 | 				      port)
 90 | 			  (write-form `(ps:set-function-from-value
 91 | 					    (ps-lisp:quote ,sym))
 92 | 				      port))
 93 | 			 ((fun)
 94 | 			  (if (not (memq name '(car cdr))) ;kludge
 95 | 			      (set! funs (cons (list sym (cadr info))
 96 | 					       funs))))
 97 | 			 ((pred)
 98 | 			  (write-form
 99 | 			   (case (if (null? (cddr info))
100 | 				    'n
101 | 				    (caddr info))
102 | 			     ((1)
103 | 			      `(ps-lisp:defun ,sym (x)
104 | 				 (ps:true? (,(cadr info) x))))
105 | 			     ((2)
106 | 			      `(ps-lisp:defun ,sym (x y)
107 | 				 (ps:true? (,(cadr info) x y))))
108 | 			     (else
109 | 			      `(ps-lisp:defun ,sym (ps-lisp:&rest x)
110 | 				 (ps:true? (ps-lisp:apply #',(cadr info)
111 | 							 x)))))
112 | 			   port)
113 | 			  (set! defs (cons sym defs)))
114 | 			 ((subst lambda)
115 | 			  (write-form `(ps-lisp:defun ,sym ,@(cdr info)) port)
116 | 			  (set! defs (cons sym defs)))
117 | 			 ((special) 0) ;don't generate any definition
118 | 			 (else
119 | 			  (error "peculiar built-in" info)))))))))
120 | 	(for-each do-it (interface-names sig))
121 | 	(for-each do-it (interface-aux-names sig)))
122 |       (write-form
123 |         `(ps-lisp:mapc (ps-lisp:function ps:set-value-from-function)
124 | 		    (ps-lisp:quote ,(reverse defs)))
125 | 	port)
126 |       (write-form
127 |         `(ps-lisp:mapc #'(ps-lisp:lambda (z)
128 | 			(ps-lisp:let ((our-sym (ps-lisp:car z))
129 | 				   (cl-sym (ps-lisp:cadr z)))
130 | 			  (ps-lisp:setf (ps-lisp:symbol-function our-sym) 
131 | 				     (ps-lisp:symbol-function cl-sym))
132 | 			  (ps:set-value-from-function our-sym)))
133 | 		    (ps-lisp:quote ,(reverse funs)))
134 | 	port))))
135 | 
136 | ; Utilities
137 | 
138 | (define (with-target-package package thunk)
139 |   (let-fluid @target-package package
140 |     thunk))
141 | 
142 | (define (compiling-to-file outfile package write-message proc)
143 |   (let-fluid @translating-to-file? #t
144 |     (lambda ()
145 |       (with-target-package package
146 | 	(lambda ()
147 | 	  (call-with-output-file outfile
148 | 	    (lambda (port)
149 | 	      (write-file-identification port)
150 | 	      (write-message port)
151 | 	      (newline port)
152 | 	      (display "(ps:in-package " port)
153 | 	      (write (package-name package) port)
154 | 	      (display ")" port)
155 | 	      (newline port)
156 | 	      (write-form '(ps:begin-translated-file) port)
157 | 	      (newline port)
158 | 	      ;; Now do the real work.
159 | 	      (proc port)
160 | 	      (newline port)
161 | 	      outfile)))))))
162 | 
163 | (define (write-file-identification port)
164 |   (newline)
165 |   (display "Writing ")
166 |   (display (true-name port))
167 |   (display "; -*- Mode: Lisp; Syntax: Common-Lisp; Package: " port)
168 |   (display (package-name (fluid @target-package)) port) ;Heuristic
169 |   (display "; -*-" port)
170 |   (newline port)
171 |   (newline port)
172 |   (display "; This file was generated by " port)
173 |   (display (translator-version) port)
174 |   (newline port)
175 |   (display ";  running in " port)
176 |   (display (scheme-implementation-version) port)
177 |   (newline port))
178 | 
179 | (define (write-flattened form port)
180 |   (cond ((not (pair? form))
181 | 	 (if (not (or (symbol? form)
182 | 		      (number? form)
183 | 		      (boolean? form)
184 | 		      (string? form)
185 | 		      (char? form)))
186 | 	     ;; Who knows, it might be important.
187 | 	     (write-form form port)))
188 |         ((eq? (car form) 'ps-lisp:quote)
189 | 	 )				;do nothing
190 | 	((eq? (car form) 'ps-lisp:progn)
191 | 	 (for-each (lambda (form)
192 | 		     (write-flattened form port))
193 | 		   (cdr form)))
194 | 	(else
195 | 	 (write-form form port))))
196 | 
197 | (define (write-form form port)
198 |   (write-pretty form port (fluid @target-package)))
199 | 


--------------------------------------------------------------------------------
/src/translator.files:
--------------------------------------------------------------------------------
 1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
 2 | 
 3 | ("p-record"   ; record package
 4 |  "p-utils"    ; tables and fluids
 5 |  "list"       ; list utilities
 6 |  "classes"    ; expression classes
 7 |  "form"       ; expression stuff used by classifier
 8 |  "classify"   ; expression classifier
 9 |  "node"       ; budding node abstraction
10 |  "module"     ; signatures and structures
11 |  "ssig"       ; Scheme signature
12 |  "alpha"      ; front end
13 |  "rules"      ; the (syntax-rules ...) macro
14 |  "derive"     ; derived expression types
15 |  "strategy"   ; LETREC strategy anaylzer
16 |  "version"
17 |  "schemify"   ; degenerate back end
18 | 
19 |  ;; Common Lisp back end
20 |  "emit"       ; code emission utilities
21 |  "generate"   ; CL code generator
22 |  "builtin"    ; CL info about scheme built-ins
23 |  "translate"  ; phase coordination and file transducer
24 |  "reify"      ; miscellaneous
25 |  )
26 | 


--------------------------------------------------------------------------------
/src/version.pso:
--------------------------------------------------------------------------------
 1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
 2 | 
 3 | ; This file was generated by Pseudoscheme 2.12
 4 | ;  running in CMU Common Lisp 16-Aug-1993
 5 | ;  from file /zu/jar/pseudo/version.scm
 6 | 
 7 | (ps:in-package "SCHEME-TRANSLATOR")
 8 | (BEGIN-TRANSLATED-FILE)
 9 | (DEFUN TRANSLATOR-VERSION () "Pseudoscheme 2.12")
10 | (SET-VALUE-FROM-FUNCTION 'TRANSLATOR-VERSION 'SCHEME::TRANSLATOR-VERSION)
11 | 


--------------------------------------------------------------------------------
/src/version.scm:
--------------------------------------------------------------------------------
1 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
2 | ; File version.scm
3 | 
4 | (define (translator-version) "Pseudoscheme 2.12")
5 | 


--------------------------------------------------------------------------------
/src/write.pso:
--------------------------------------------------------------------------------
  1 | ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: REVISED^4-SCHEME; -*-
  2 | 
  3 | ; This file was generated by Pseudoscheme 2.12
  4 | ;  running in CMU Common Lisp 16-Aug-1993
  5 | ;  from file /zu/jar/pseudo/write.scm
  6 | 
  7 | (ps:in-package "REVISED^4-SCHEME")
  8 | (BEGIN-TRANSLATED-FILE)
  9 | (DEFUN OUTPUT-PORT-OPTION (PORT-OPTION)
 10 |   (IF (NULL PORT-OPTION)
 11 |       *STANDARD-OUTPUT*
 12 |       (IF (NULL (CDR PORT-OPTION))
 13 |           (CAR PORT-OPTION)
 14 |           (SCHEME-ERROR "write-mumble: too many arguments" PORT-OPTION))))
 15 | (SET-VALUE-FROM-FUNCTION 'OUTPUT-PORT-OPTION 'SCHEME::OUTPUT-PORT-OPTION)
 16 | (DEFUN DISCLOSE (OBJ) OBJ FALSE)
 17 | (SET-VALUE-FROM-FUNCTION 'DISCLOSE 'SCHEME::DISCLOSE)
 18 | (DEFUN WRITE-STRING (.STRING PORT) (PRINC .STRING PORT))
 19 | (SET-VALUE-FROM-FUNCTION 'WRITE-STRING 'SCHEME::WRITE-STRING)
 20 | (DEFUN SCHEME-WRITE (OBJ &REST PORT-OPTION)
 21 |   (MAYBE-FIX-&REST-PARAMETER PORT-OPTION)
 22 |   (LET ((PORT (OUTPUT-PORT-OPTION PORT-OPTION)))
 23 |     (LABELS ((RECUR (.OBJ.0)
 24 |                (RECURRING-WRITE .OBJ.0 PORT #'RECUR)))
 25 |       (RECUR OBJ))))
 26 | (SET-VALUE-FROM-FUNCTION 'SCHEME-WRITE 'SCHEME::SCHEME-WRITE)
 27 | (DEFUN RECURRING-WRITE (OBJ PORT RECUR)
 28 |   (IF (NULL OBJ)
 29 |       (WRITE-STRING "()" PORT)
 30 |       (IF (CONSP OBJ)
 31 |           (WRITE-LIST OBJ PORT RECUR)
 32 |           (IF (EQ OBJ TRUE)
 33 |               (WRITE-BOOLEAN 'SCHEME::T PORT)
 34 |               (IF (EQ OBJ FALSE)
 35 |                   (WRITE-BOOLEAN 'SCHEME::F PORT)
 36 |                   (IF (SCHEME-SYMBOL-P OBJ)
 37 |                       (WRITE-SYMBOL OBJ PORT)
 38 |                       (IF (NUMBERP OBJ)
 39 |                           (WRITE-NUMBER OBJ PORT)
 40 |                           (IF (SIMPLE-STRING-P OBJ)
 41 |                               (WRITE-STRING-LITERAL OBJ PORT)
 42 |                               (IF (CHARACTERP OBJ)
 43 |                                   (WRITE-CHAR-LITERAL OBJ PORT)
 44 |                                   (WRITE-OTHER OBJ PORT RECUR))))))))))
 45 | (SET-VALUE-FROM-FUNCTION 'RECURRING-WRITE 'SCHEME::RECURRING-WRITE)
 46 | (DEFUN WRITE-SYMBOL (OBJ PORT) (WRITE-STRING (SYMBOL->STRING OBJ) PORT))
 47 | (SET-VALUE-FROM-FUNCTION 'WRITE-SYMBOL 'SCHEME::WRITE-SYMBOL)
 48 | (DEFUN WRITE-BOOLEAN (MUMBLE PORT)
 49 |   (WRITE-CHAR #\# PORT)
 50 |   (WRITE-SYMBOL MUMBLE PORT))
 51 | (SET-VALUE-FROM-FUNCTION 'WRITE-BOOLEAN 'SCHEME::WRITE-BOOLEAN)
 52 | (DEFUN WRITE-NUMBER (N PORT) (WRITE-STRING (NUMBER->STRING N 10) PORT))
 53 | (SET-VALUE-FROM-FUNCTION 'WRITE-NUMBER 'SCHEME::WRITE-NUMBER)
 54 | (DEFUN WRITE-CHAR-LITERAL (OBJ PORT)
 55 |   (LET ((PROBE (CHARACTER-NAME OBJ)))
 56 |     (WRITE-STRING "#\\" PORT)
 57 |     (IF (TRUEP PROBE) (WRITE-SYMBOL PROBE PORT) (WRITE-CHAR OBJ PORT))))
 58 | (SET-VALUE-FROM-FUNCTION 'WRITE-CHAR-LITERAL 'SCHEME::WRITE-CHAR-LITERAL)
 59 | (DEFUN CHARACTER-NAME (.CHAR)
 60 |   (IF (CHAR= .CHAR #\SPACE)
 61 |       'SCHEME::SPACE
 62 |       (IF (CHAR= .CHAR #\NEWLINE) 'SCHEME::NEWLINE FALSE)))
 63 | (SET-VALUE-FROM-FUNCTION 'CHARACTER-NAME 'SCHEME::CHARACTER-NAME)
 64 | (DEFUN WRITE-STRING-LITERAL (OBJ PORT)
 65 |   (WRITE-CHAR #\" PORT)
 66 |   (LET ((LEN (LENGTH (THE SIMPLE-STRING OBJ))))
 67 |     (PROG (|.I.0|)
 68 |       (SETQ |.I.0| 0)
 69 |       (GO .LOOP.104)
 70 |      .LOOP.104
 71 |       (LET ((I |.I.0|))
 72 |         (IF (= I LEN)
 73 |             (RETURN (WRITE-CHAR #\" PORT))
 74 |             (PROGN
 75 |              (LET ((C (CHAR (THE SIMPLE-STRING OBJ) I)))
 76 |                (IF (OR (CHAR= C #\\) (CHAR= C #\")) (WRITE-CHAR #\\ PORT))
 77 |                (WRITE-CHAR C PORT))
 78 |              (SETQ |.I.0| (+ I 1))
 79 |              (GO .LOOP.104)))))))
 80 | (SET-VALUE-FROM-FUNCTION 'WRITE-STRING-LITERAL 'SCHEME::WRITE-STRING-LITERAL)
 81 | (DEFUN WRITE-LIST (OBJ PORT RECUR)
 82 |   (IF (TRUEP (QUOTATION? OBJ))
 83 |       (PROGN (WRITE-CHAR #\' PORT) (FUNCALL RECUR (CADR OBJ)))
 84 |       (PROGN
 85 |        (WRITE-CHAR #\( PORT)
 86 |        (FUNCALL RECUR (CAR OBJ))
 87 |        (PROG (L N)
 88 |          (PSETQ L (CDR OBJ) N 1)
 89 |          (GO LOOP)
 90 |         LOOP
 91 |          (IF (NOT (CONSP L))
 92 |              (IF (NOT (NULL L))
 93 |                  (PROGN (WRITE-STRING " . " PORT) (RETURN (FUNCALL RECUR L)))
 94 |                  (RETURN UNSPECIFIC))
 95 |              (PROGN
 96 |               (WRITE-CHAR #\SPACE PORT)
 97 |               (FUNCALL RECUR (CAR L))
 98 |               (PSETQ L (CDR L) N (+ N 1))
 99 |               (GO LOOP))))
100 |        (WRITE-CHAR #\) PORT))))
101 | (SET-VALUE-FROM-FUNCTION 'WRITE-LIST 'SCHEME::WRITE-LIST)
102 | (DEFUN QUOTATION? (OBJ)
103 |   (IF (CONSP OBJ)
104 |       (IF (EQ (CAR OBJ) 'SCHEME::QUOTE)
105 |           (IF (CONSP (CDR OBJ)) (TRUE? (NULL (CDDR OBJ))) FALSE)
106 |           FALSE)
107 |       FALSE))
108 | (SET-VALUE-FROM-FUNCTION 'QUOTATION? 'SCHEME::QUOTATION?)
109 | (DEFUN WRITE-VECTOR (OBJ PORT RECUR)
110 |   (WRITE-STRING "#(" PORT)
111 |   (LET ((Z (LENGTH (THE SIMPLE-VECTOR OBJ))))
112 |     (IF (> Z 0)
113 |         (PROGN
114 |          (FUNCALL RECUR (SVREF OBJ 0))
115 |          (PROG (|.I.0|)
116 |            (SETQ |.I.0| 1)
117 |            (GO LOOP)
118 |           LOOP
119 |            (LET ((I |.I.0|))
120 |              (OR (>= I Z)
121 |                  (PROGN
122 |                   (WRITE-CHAR #\SPACE PORT)
123 |                   (FUNCALL RECUR (SVREF OBJ I))
124 |                   (SETQ |.I.0| (+ I 1))
125 |                   (GO LOOP))))))))
126 |   (WRITE-CHAR #\) PORT))
127 | (SET-VALUE-FROM-FUNCTION 'WRITE-VECTOR 'SCHEME::WRITE-VECTOR)
128 | (DEFUN WRITE-OTHER (OBJ PORT RECUR)
129 |   (LET ((L (DISCLOSE OBJ)))
130 |     (IF (TRUEP L)
131 |         (PROGN
132 |          (WRITE-STRING "#{" PORT)
133 |          (DISPLAY-TYPE-NAME (CAR L) PORT)
134 |          (MAPC #'(LAMBDA (X) (WRITE-CHAR #\SPACE PORT) (FUNCALL RECUR X))
135 |                (CDR L))
136 |          (WRITE-STRING "}" PORT))
137 |         (IF (PROCEDUREP OBJ)
138 |             (WRITE-STRING "#{Procedure}" PORT)
139 |             (IF (INPUT-PORT-P OBJ)
140 |                 (WRITE-STRING "#{Input-port}" PORT)
141 |                 (IF (OUTPUT-PORT-P OBJ)
142 |                     (WRITE-STRING "#{Output-port}" PORT)
143 |                     (IF (EQ OBJ EOF-OBJECT)
144 |                         (WRITE-STRING "#{End-of-file}" PORT)
145 |                         (IF (TRUEP (VECTOR? OBJ))
146 |                             (WRITE-VECTOR OBJ PORT RECUR)
147 |                             (IF (EQ OBJ (IF NIL FALSE))
148 |                                 (WRITE-STRING "#{Unspecific}" PORT)
149 |                                 (PRIN1 OBJ PORT))))))))))
150 | (SET-VALUE-FROM-FUNCTION 'WRITE-OTHER 'SCHEME::WRITE-OTHER)
151 | (DEFUN DISPLAY-TYPE-NAME (NAME PORT)
152 |   (IF (SCHEME-SYMBOL-P NAME)
153 |       (LET ((S (SYMBOL->STRING NAME)))
154 |         (LET ((LEN (LENGTH (THE SIMPLE-STRING S))))
155 |           (LET ()
156 |             (IF (AND (> LEN 0) (ALPHA-CHAR-P (CHAR (THE SIMPLE-STRING S) 0)))
157 |                 (PROGN
158 |                  (WRITE-CHAR (CHAR-UPCASE (CHAR (THE SIMPLE-STRING S) 0)) PORT)
159 |                  (PROG (|.I.0|)
160 |                    (SETQ |.I.0| 1)
161 |                    (GO .LOOP.130)
162 |                   .LOOP.130
163 |                    (LET ((I |.I.0|))
164 |                      (OR (>= I LEN)
165 |                          (PROGN
166 |                           (WRITE-CHAR
167 |                            (CHAR-DOWNCASE (CHAR (THE SIMPLE-STRING S) I))
168 |                            PORT)
169 |                           (SETQ |.I.0| (+ I 1))
170 |                           (GO .LOOP.130))))))
171 |                 (DISPLAY NAME PORT)))))
172 |       (DISPLAY NAME PORT)))
173 | (SET-VALUE-FROM-FUNCTION 'DISPLAY-TYPE-NAME 'SCHEME::DISPLAY-TYPE-NAME)
174 | (DEFUN SCHEME-DISPLAY (OBJ &REST PORT-OPTION)
175 |   (MAYBE-FIX-&REST-PARAMETER PORT-OPTION)
176 |   (LET ((PORT (OUTPUT-PORT-OPTION PORT-OPTION)))
177 |     (LABELS ((RECUR (.OBJ.0)
178 |                (IF (SIMPLE-STRING-P .OBJ.0)
179 |                    (WRITE-STRING .OBJ.0 PORT)
180 |                    (IF (CHARACTERP .OBJ.0)
181 |                        (WRITE-CHAR .OBJ.0 PORT)
182 |                        (RECURRING-WRITE .OBJ.0 PORT #'RECUR)))))
183 |       (RECUR OBJ))))
184 | (SET-VALUE-FROM-FUNCTION 'SCHEME-DISPLAY 'SCHEME::SCHEME-DISPLAY)
185 | (LOCALLY (DECLARE (SPECIAL SCHEME-WRITE)) (SETQ *SCHEME-WRITE* SCHEME-WRITE))
186 | (LOCALLY
187 |  (DECLARE (SPECIAL SCHEME-DISPLAY))
188 |  (SETQ *SCHEME-DISPLAY* SCHEME-DISPLAY))
189 | 


--------------------------------------------------------------------------------
/src/write.scm:
--------------------------------------------------------------------------------
  1 | 
  2 | ; Scheme48's WRITE module, adapted for use in Pseudoscheme.
  3 | ; (compile-file "~/pseudo/write" scheme-translator::revised^4-scheme-env)
  4 | ; (load "~/pseudo/write" scheme-translator::revised^4-scheme-env)
  5 | ; (define write revised^4-scheme:.write)
  6 | ; (define display revised^4-scheme:display)
  7 | 
  8 | ; Problem: symbols come out in upper case.
  9 | 
 10 | 
 11 | (define (output-port-option port-option)
 12 |   (cond ((null? port-option) (current-output-port))
 13 | 	((null? (cdr port-option)) (car port-option))
 14 | 	(else (ps:scheme-error "write-mumble: too many arguments"
 15 | 				 port-option))))
 16 | 
 17 | (define (disclose obj)
 18 |   obj ;ignored
 19 |   #f)
 20 | 
 21 | (define (write-string string port)
 22 |   (ps-lisp:princ string port))
 23 | 
 24 | 
 25 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
 26 | ; Copyright (c) 1993 by Richard Kelsey and Jonathan Rees.  See file COPYING.
 27 | 
 28 | 
 29 | ; This is file write.scm.
 30 | 
 31 | ;;;; WRITE
 32 | 
 33 | ; To use this with some Scheme other than Scheme48, do the following:
 34 | ;  1. Copy the definition of output-port-option from port.scm
 35 | ;  2. Define write-string as appropriate (as a write-char loop)
 36 | ;  3. (define (disclose x) #f)
 37 | 
 38 | (define (scheme-write obj . port-option)
 39 |   (let ((port (output-port-option port-option)))
 40 |     (let recur ((obj obj))
 41 |       (recurring-write obj port recur))))
 42 | 
 43 | (define (recurring-write obj port recur)
 44 |   (cond ((null? obj) (write-string "()" port))
 45 |         ((pair? obj) (write-list obj port recur))
 46 |         ((eq? obj #t) (write-boolean 't port))
 47 |         ((eq? obj #f) (write-boolean 'f port))
 48 |         ((symbol? obj) (write-symbol obj port))
 49 |         ((number? obj) (write-number obj port))
 50 |         ((string? obj) (write-string-literal obj port))
 51 |         ((char? obj) (write-char-literal obj port))
 52 | 	(else (write-other obj port recur))))
 53 | 
 54 | (define (write-symbol obj port)
 55 |   (write-string (symbol->string obj) port)) ;downcase or upcase if desired
 56 | 
 57 | (define (write-boolean mumble port)
 58 |   (write-char #\# port)
 59 |   (write-symbol mumble port))
 60 | 
 61 | (define (write-number n port)
 62 |   (write-string (number->string n 10) port))
 63 | 
 64 | (define (write-char-literal obj port)
 65 |   (let ((probe (character-name obj)))
 66 |     (write-string "#\\" port)
 67 |     (if probe
 68 | 	(write-symbol probe port)
 69 | 	(write-char obj port))))
 70 | 
 71 | (define (character-name char)
 72 |   (cond ((char=? char #\space) 'space)
 73 |         ((char=? char #\newline) 'newline)
 74 | 	(else #f)))
 75 | 
 76 | (define (write-string-literal obj port)
 77 |   (write-char #\" port)
 78 |   (let ((len (string-length obj)))
 79 |     (do ((i 0 (+ i 1)))
 80 | 	((= i len) (write-char #\" port))
 81 |       (let ((c (string-ref obj i)))
 82 | 	(if (or (char=? c #\\) (char=? c #\"))
 83 | 	    (write-char #\\ port))
 84 | 	(write-char c port)))))
 85 | 
 86 | (define (write-list obj port recur)
 87 |   (cond ((quotation? obj)
 88 |          (write-char #\' port)
 89 |          (recur (cadr obj)))
 90 |         (else
 91 |          (write-char #\( port)
 92 |          (recur (car obj))
 93 |          (let loop ((l (cdr obj))
 94 |                     (n 1))
 95 |               (cond ((not (pair? l))
 96 |                      (cond ((not (null? l))
 97 |                             (write-string " . " port)
 98 |                             (recur l))))
 99 |                     (else
100 |                       (write-char #\space port)
101 |                       (recur (car l))
102 |                       (loop (cdr l) (+ n 1)))))
103 |          (write-char #\) port))))
104 | 
105 | (define (quotation? obj)
106 |   (and (pair? obj)
107 |        (eq? (car obj) 'quote)
108 |        (pair? (cdr obj))
109 |        (null? (cddr obj))))
110 | 
111 | (define (write-vector obj port recur)
112 |    (write-string "#(" port)
113 |    (let ((z (vector-length obj)))
114 |      (cond ((> z 0)
115 |             (recur (vector-ref obj 0))
116 |             (let loop ((i 1))
117 |               (cond ((>= i z))
118 |                     (else
119 |                      (write-char #\space port)
120 |                      (recur (vector-ref obj i))
121 |                      (loop (+ i 1))))))))
122 |    (write-char #\) port))
123 | 
124 | ; The vector case goes last just so that this version of WRITE can be
125 | ; used in Scheme implementations in which records, ports, or
126 | ; procedures are represented as vectors.  (Scheme48 doesn't have this
127 | ; property.)
128 | 
129 | (define (write-other obj port recur)
130 |   (cond ((disclose obj)
131 | 	 => (lambda (l)
132 | 	      (write-string "#{" port)
133 | 	      (display-type-name (car l) port)
134 | 	      (for-each (lambda (x)
135 | 			  (write-char #\space port)
136 | 			  (recur x))
137 | 			(cdr l))
138 | 	      (write-string "}" port)))
139 | 	((procedure? obj) (write-string "#{Procedure}" port))
140 | 	((input-port? obj)  (write-string "#{Input-port}" port))
141 | 	((output-port? obj) (write-string "#{Output-port}" port))
142 | 	((eof-object? obj) (write-string "#{End-of-file}" port))
143 | 	((vector? obj) (write-vector obj port recur))
144 | 	((eq? obj (if #f #f)) (write-string "#{Unspecific}" port))
145 | 	(else
146 | 	 ;; (write-string "#{Random object}" port)
147 | 	 (ps-lisp:prin1 obj port)
148 | 	 )))
149 | 
150 | ; Display the symbol WHO-CARES as Who-cares.
151 | 
152 | (define (display-type-name name port)
153 |   (if (symbol? name)
154 |       (let* ((s (symbol->string name))
155 | 	     (len (string-length s)))
156 | 	(if (and (> len 0)
157 | 		 (char-alphabetic? (string-ref s 0)))
158 | 	    (begin (write-char (char-upcase (string-ref s 0)) port)
159 | 		   (do ((i 1 (+ i 1)))
160 | 		       ((>= i len))
161 | 		     (write-char (char-downcase (string-ref s i)) port)))
162 | 	    (display name port)))
163 |       (display name port)))
164 | 
165 | ;(define (write-string s port)
166 | ;  (do ((i 0 (+ i 1)))
167 | ;      ((= i (string-length s)))
168 | ;    (write-char (string-ref s i) port)))
169 | 
170 | 
171 | 
172 | ; DISPLAY
173 | 
174 | (define (scheme-display obj . port-option)
175 |   (let ((port (output-port-option port-option)))
176 |     (let recur ((obj obj))
177 |       (cond ((string? obj) (write-string obj port))
178 | 	    ((char? obj) (write-char obj port))
179 | 	    (else
180 | 	     (recurring-write obj port recur))))))
181 | 
182 | (ps-lisp:setq ps:*scheme-write* scheme-write)
183 | (ps-lisp:setq ps:*scheme-display* scheme-display)
184 | 


--------------------------------------------------------------------------------