;;; -*- Mode: Lisp; Syntax: Common-lisp; Package: (PSEUDOSCHEME :USE (LISP) :SHADOW (+ - * / ASSOC CASE ERROR EVAL LAMBDA LET LET* LOOP MAKE-STRING MAP MEMBER NIL PEEK-CHAR PRINT READ READ-CHAR T WRITE)) -*-
;;; Written by Jonathan Rees, summer & fall 1986
;;; with help from Eric Benson, Kent Pitman, and John Ramsdell.
;;; There is a separate docuemntation file, please read it.
(in-package 'pseudoscheme :use '(lisp))
(shadow '(
+ - * /
assoc
case
error
eval
lambda
let
let*
loop ;Symbolics Rel 7 loses
make-string
map
member
nil
peek-char
print
read
read-char
t
write
))
(export '(
declare-pseudoscheme-package
in-package
use-package
export
import
provide
require
shadow
trace untrace
compile-file
convert-arglist
describe
ed
scheme
))
(eval-when (lisp:eval load compile)
(defconstant nil lisp:nil)
(defconstant t lisp:t)
(defconstant else lisp:t)
(defparameter *preprocess?* nil) ;set to t after bootstrap is complete
)
(eval-when (lisp:eval load compile)
(defun sharp-T-read-macro (stream subchar arg)
#-Symbolics (declare (ignore stream subchar arg))
#+Symbolics (progn stream subchar arg)
t)
(defun sharp-F-read-macro (stream subchar arg)
#-Symbolics (declare (ignore stream subchar arg))
#+Symbolics (progn stream subchar arg)
nil)
(defvar cl-sharp-sharp
#+Symbolics #'(lisp:lambda (&rest ignore) (error "Symbolics loses"))
#-Symbolics (get-dispatch-macro-character #\# #\#))
(defun sharp-sharp-read-macro (stream subchar arg)
(cond (arg (funcall cl-sharp-sharp stream subchar arg))
(t 'lisp:*)))
(set-dispatch-macro-character #\# #\# #'sharp-sharp-read-macro)
(set-dispatch-macro-character #\# #\T #'sharp-T-read-macro)
(set-dispatch-macro-character #\# #\F #'sharp-F-read-macro)
;;; Generally useful utility:
(defun concatenate-symbol (&rest things)
(values (intern (apply #'concatenate 'string
(mapcar #'(lisp:lambda (thing)
(if (numberp thing)
(with-output-to-string (s) (princ thing s))
(string thing)))
things)))))
(defparameter concatenate-symbol #'concatenate-symbol)
;;; Implementing Scheme global variables well is not at all easy.
#|
For each global variable, we keep track of a "reference history"
and its current "definition method".
The reference history is some subset of the following keywords:
:variable x
:setq (setq x ...)
:set!-globally (set!-globally x ...)
:function (x ...) at a point when definition status
was :function
:macro (x ...) at a point when definition status
was :macro
The definition method is one of:
:variable (setq x ...) / (defun x (&rest args) (apply x args))
:constant (defconstant x ...)
:function (defun x ...) / (setq x #'x)
:macro (defmacro x ...) / (setq x #'x[closed])
Here's how we use this information:
1. When we see a reference to variable x, we may generate either
x or #'x.
Correctness considerations:
-- x is always correct.
-- #'x is correct iff definition status isn't :macro.
Efficiency considerations:
-- x is always preferable to #'x.
2. When we see a call (x ...), we may generate either
(x ...) or (funcall x ...).
Correctness considerations:
-- (funcall x ...) is always correct.
-- (x ...) is correct iff method isn't :constant.
Efficiency considerations:
-- (funcall x ...) is preferable if status is :variable.
-- (x ...) is preferable otherwise.
3. When we see an assignment (set! x ...), we may generate either
(setq x ...) or (set!-globally x ...).
Correctness considerations:
-- We are quite screwed if status is :macro.
-- setq is correct only if status is (and/or will be) :variable.
-- set!-globally is always correct.
Efficiency considerations:
-- Want (setq x ...) if at all possible.
4. When we see (define x ...), we can generate any of the variants
enumerated above.
Correctness considerations:
-- :variable is always correct,
-- :function is correct iff [rhs is lambda and] :setq isn't in
history,
-- :macro is correct iff [rhs is lambda and] :function and :setq
aren't in history.
Efficiency considerations:
-- :variable is never preferable (unless :setq is in history,
in which case it's forced).
-- :macro is always preferable when it's correct and the function
body is small.
It is possible to get screwed by this mechanism, if you compile a file
under one set of assumptions and then load it where an incompatible set
is in effect.
|#
(defun use-method (var method)
(cond
((and (eq method :function)
(lisp:member :setq (get var 'history)))
(cerror "proceed as if everything was all right"
"(DEFINE ~S ...) is being implemented as (DEFUN ~S ...), but~
~%some previously generated code assumed that it was OK to~
~%implement (SET! ~S ...) as (SETQ ~S ...)."
var var var var))
((and (eq method :macro)
(lisp:member :function (get var 'history)))
(cerror "proceed as if everything was all right"
"(DEFINE ~S ...) is being implemented as (DEFMACRO ~S ...), but~
~%some code containing a call (~S ...) was compiled before this
~%definition was seen."
var var var)))
(setf (get var 'method) method))
(defun record-variable-usage (var usage)
(lisp:let ((h (get var 'history)))
(if (not (lisp:member usage h))
(setf (get var 'history)
(cons usage h)))))
(use-method 't :variable)
(use-method 'nil :variable)
(defun lexical-name (var)
(or (get var 'lexical-name) ;Speed hacque
(lisp:let ((*package* (symbol-package var)))
(lisp:let ((lex (concatenate-symbol "." var)))
(setf (get var 'lexical-name) lex)
lex))))
);nehw-lave
;;; Scheme names database
(eval-when (lisp:eval load compile)
(defmacro entry-type (entry) `(car ,entry))
(defmacro entry-name (entry) `(cadr ,entry))
(defmacro entry-dests (entry) `(caddr ,entry))
(defmacro entry-provision (entry) `(cadddr ,entry))
(defun inherit? (entry)
(and (eq (entry-type entry) 'proc)
(lisp:member (entry-provision entry) '(cl ~cl))))
(defun renaming? (entry)
(lisp:let ((prov (entry-provision entry)))
(and (eq (entry-type entry) 'proc)
(consp prov)
(lisp:member (car prov) '(=cl ~cl)))))
);nehw-lave
(defun set-up-database-entry (entry)
(lisp:let ((name (entry-name entry)))
(setf (get name 'scheme-info) entry)
(cond ((inherit? entry)
;; Inheriting from CL -- just set the value cell.
(if (and (boundp name)
(not (eq (symbol-value name)
(symbol-function name))))
(cerror "clobber the value that's already there"
"package pollution! -- ~s is bound"
name))
(use-method name :function))
((renaming? entry)
(lisp:let ((src (cadr (entry-provision entry))))
(if (and (boundp name)
(not (eq (symbol-value name)
(symbol-function src))))
(cerror "clobber value that's already there"
"package pollution! -- ~s is bound"
name))
(if (and (fboundp name)
(not (macro-function name)))
(cerror "clobber function that's already there"
"package pollution! -- ~s is defined"
name))
(use-method name :macro))))
(entry-name entry)))
;;; DEFMACRO is the most reliable way to get efficient compilation.
;;; PROCLAIM INLINE may lose.
(defmacro define-scheme-database (&body db)
`(progn 'compile
(defparameter scheme-names
(mapcar #'set-up-database-entry ',db))
;; Work around @#%$$% 3600 bug.
,@(lisp:let ((names (mapcar #'(lisp:lambda (entry)
(entry-name entry))
db)))
(if (< (length names) #+Symbolics 200 #-Symbolics 1000000)
`((export ',names))
`((export ',(subseq names 0 200))
(export ',(subseq names 200)))))
,@(mapcan #'(lisp:lambda (entry)
(lisp:let ((name (entry-name entry)))
(cond ((inherit? entry)
`((defparameter ,name #',name)))
((renaming? entry)
(lisp:let ((src
(cadr (entry-provision entry))))
`((defmacro ,name (&rest x) `(,',src ,@x))
(defparameter ,name #',src))))
(t '()))))
db)))
;;; Entries within each major category are in alphabetical order.
;;; "ps" stands for "pseudoscheme".
;;; "DESTS" is a list of the dialects to which this feature belongs:
;;; E = essential subset of Revised↑3 Scheme
;;; R = non-essential Revised↑3 Scheme
;;; T = Yale Scheme
;;; M = MIT Scheme
;;; S = used in Abelson & Sussman
(define-scheme-database
;;(TYPE NAME (DESTS) PROVIDED-BY)
(random else (E T S) ps)
(binding nil (R T S) ps)
(binding t (R T S) ps)
(binding the-empty-stream ( S) ps)
(binding user-initial-environment ( S) ps)
(syntax and (R T ) CL)
(syntax begin (E ) ps)
(syntax case (R T ) ps)
(syntax cond (E T S) CL)
(syntax cons-stream ( S) ps)
(syntax define (E T S) ps)
(syntax define-macro ( T ) ps)
(syntax delay (R T S) ps)
(syntax do (R T ) CL)
(syntax if (E T S) CL)
(syntax lambda (E T S) ps)
(syntax let (E ) ps)
(syntax let* (R T ) ps)
(syntax letrec (E ) ps)
(syntax or (R T ) CL)
(syntax quasiquote (R ) ps)
(syntax quote (E T S) CL)
(syntax sequence ( S) (= begin))
(syntax set! (E ) ps)
(syntax unquote ( ) ps)
(syntax unquote-splicing ( ) ps)
(proc * (R T ) (=CL lisp:*))
(proc + (R T ) (=CL lisp:+))
(proc -1+ ( T S) (=CL 1-))
(proc - (R T ) (=CL lisp:-))
(proc / (E T S) (=CL lisp:/))
(proc 1+ ( T S) CL)
(proc <= (E T S) CL)
(proc < (E T S) CL)
(proc = (E T S) CL)
(proc >= (E T S) CL)
(proc > (E T S) CL)
(proc abs (E T S) CL)
(proc acos (R T ) CL)
(proc angle (R ) (=CL phase))
(proc append (E T ) CL)
(proc apply (E T ) ~CL)
(proc asin (R T ) CL)
(proc assoc (E S) ps)
(proc assq (E T S) ps)
(proc assv (E ) (=CL lisp:assoc))
(proc atan (R ) CL)
(proc atom? ( T S) (=CL atom)) ;Yuck
(proc boolean? (E T ) ps)
(proc caaaar (E T S) CL)
(proc caaadr (E T S) CL)
(proc caaar (E T S) CL)
(proc caadar (E T S) CL)
(proc caaddr (E T S) CL)
(proc caadr (E T S) CL)
(proc caar (E T S) CL)
(proc cadaar (E T S) CL)
(proc cadadr (E T S) CL)
(proc cadar (E T S) CL)
(proc caddar (E T S) CL)
(proc cadddr (E T S) CL)
(proc caddr (E T S) CL)
(proc cadr (E T S) CL)
(proc call-with-current-continuation (E ) ps)
(proc call-with-input-file (E ) ps)
(proc call-with-output-file (E ) ps)
(proc car (E T S) CL)
(proc cdaaar (E T S) CL)
(proc cdaadr (E T S) CL)
(proc cdaar (E T S) CL)
(proc cdadar (E T S) CL)
(proc cdaddr (E T S) CL)
(proc cdadr (E T S) CL)
(proc cdar (E T S) CL)
(proc cddaar (E T S) CL)
(proc cddadr (E T S) CL)
(proc cddar (E T S) CL)
(proc cdddar (E T S) CL)
(proc cddddr (E T S) CL)
(proc cdddr (E T S) CL)
(proc cddr (E T S) CL)
(proc cdr (E T S) CL)
(proc ceiling (R ) ~CL)
(proc char->integer (E ) (=CL char-code))
(proc char-alphabetic? (R ) (=CL alpha-char-p))
(proc char-ci<=? (R ) (=CL char-not-greaterp))
(proc char-ci<? (R ) (=CL char-lessp))
(proc char-ci=? (R ) (=CL char-equal))
(proc char-ci>=? (R ) (=CL char-not-lessp))
(proc char-ci>? (R ) (=CL char-greaterp))
(proc char-downcase (R ) CL)
(proc char-lower-case? (R ) (=CL lower-case-p))
(proc char-numeric? (R ) (=CL digit-char-p))
(proc char-ready? (R ) ?)
(proc char-upcase (R ) CL)
(proc char-upper-case? (R ) (=CL upper-case-p))
(proc char-whitespace? (R ) ps)
(proc char<=? (E ) (=CL char<=))
(proc char<? (E ) (=CL char<))
(proc char=? (E ) (=CL char=))
(proc char>=? (E ) (=CL char>=))
(proc char>? (E ) (=CL char>))
(proc char? (E T ) (=CL characterp))
(proc close-input-port (R ) (=CL close))
(proc close-output-port (R ) (=CL close))
(proc complex? (E ) (=CL numberp))
(proc cons (E T S) CL)
(proc cons* ( T ) (=CL list*)) ;For quasiquote
(proc cos (R T S) CL)
(proc current-input-port (E ) ps)
(proc current-output-port (E ) ps)
(proc denominator (R ) CL)
(proc display (R T ) (~CL princ))
(proc empty-stream? ( S) (=CL null))
(proc eof-object? (E ) ps)
(proc eq? (E T S) (=CL eq))
(proc equal? (E ) (=CL equal))
(proc eqv? (E ) (=CL eql))
(proc error ( T S) ps)
(proc eval ( T S) ps)
(proc even? (E T ) (=CL evenp))
(proc exact? (E ) ps)
(proc exact->inexact (R ) -)
(proc expt (R T S) CL)
(proc exp (R T S) CL)
(proc floor (R ) ~CL)
(proc for-each (R ) (~CL mapc))
(proc force (R S) ps)
(proc gcd (R S) CL)
(proc head ( S) (=CL car))
(proc imag-part (R ) (=CL imagpart))
(proc inexact? (E ) ps)
(proc inexact->exact (R ) -)
(proc input-port? (E ) ps)
(proc integer->char (E ) (=CL code-char))
(proc integer? (E T ) (=CL integerp))
(proc last-pair (R ) (=CL last))
(proc lcm (R ) CL)
(proc length (E T S) CL)
(proc list (E T S) CL)
(proc list->string (E T ) ps)
(proc list->vector (E T ) ps)
(proc list-ref (R ) ps)
(proc list-tail (R ) ps)
(proc load (E T ) ~CL)
(proc log (R T ) CL)
(proc magnitude (R ) (=CL abs))
(proc make-polar (R ) ps)
(proc make-rectangular (R ) (=CL complex))
(proc make-string (E T S) ps)
(proc make-vector (E T S) ps)
(proc map (R T ) (~CL mapcar))
(proc max (E T S) CL)
(proc member (E T S) ps)
(proc memq (E T S) ps)
(proc memv (E ) (=CL lisp:member))
(proc min (E T S) CL)
(proc modulo (R ) (=CL mod))
(proc negative? (E ) (=CL minusp))
(proc newline (E T ) (=CL terpri))
(proc not (E T S) CL)
(proc null? (E T S) (=CL null))
(proc number->string (R ) ps)
(proc number? (E T S) (=CL numberp))
(proc numerator (R ) CL)
(proc odd? (E T ) (=CL oddp))
(proc open-input-file (R ) ps)
(proc open-output-file (R ) ps)
(proc output-port? (E ) ps)
(proc pair? (E T ) (=CL consp))
(proc positive? (E T ) (=CL plusp))
(proc pp ( T M) ps)
(proc princ ( S) ~CL)
;; PRINT is incompatible between T and S&ICP.
(proc prin1 ( S) CL)
(proc procedure? (E ) ps)
(proc quotient (E T S) ps)
(proc random ( M) CL)
(proc rational? (E T ) (=CL rationalp))
(proc rationalize (R ) CL)
(proc read-char (E T ) ps)
(proc read (E T ) ps)
(proc real? (E T ) ps)
(proc real-part (R ) (=CL realpart))
(proc remainder (E T S) (=CL rem))
(proc reverse (R T ) CL)
(proc round (R ) ~CL)
(proc set-car! (E ) ps)
(proc set-cdr! (E ) ps)
(proc sin (R S) CL)
(proc sqrt (R T S) CL)
(proc string->list (E T ) ps)
(proc string->number (R T ) ps)
(proc string->symbol (R T ) ps)
(proc string-append (E T ) ps)
(proc string-ci<=? (R ) (=CL string-not-greaterp))
(proc string-ci<? (R ) (=CL string-lessp))
(proc string-ci=? (R ) (=CL string-equal))
(proc string-ci>=? (R ) (=CL string-not-lessp))
(proc string-ci>? (R ) (=CL string-greaterp))
(proc string-copy (R ) (=CL copy-seq))
(proc string-fill! (R ) (=CL fill))
(proc string-length (E T ) (=CL length))
(proc string-ref (E ) (=CL char))
(proc string-set! (R ) ps)
(proc string<=? (E ) (=CL string<=))
(proc string<? (E ) (=CL string<))
(proc string=? (E ) (=CL string=))
(proc string>=? (E ) (=CL string>=))
(proc string>? (E ) (=CL string>))
(proc string? (E T ) (=CL stringp))
(proc substring (E ) (=CL subseq))
(proc symbol->string (E T ) (=CL symbol-name))
(proc symbol? (E T ) ps)
(proc tail ( S) ps)
(proc tan (R T ) CL)
(proc transcript-on (R T ) (=CL dribble))
(proc transcript-off (R T ) (=CL dribble))
(proc truncate (R ) ~CL)
(proc vector->list (E T ) ps)
(proc vector-fill! (R ) (=CL fill))
(proc vector-length (E T ) (=CL length))
(proc vector-ref (E S) (=CL svref))
(proc vector-set! (E S) ps)
(proc vector? (E T ) ps)
(proc vector (E T ) CL)
(proc with-input-from-file (R ) ps)
(proc with-output-to-file (R ) ps)
(proc write-char (E ) CL)
(proc write (R ) (~CL prin1))
(proc zero? (E T ) (=CL zerop))
)
;;; Code manipulation utilities.
(eval-when (lisp:eval load compile)
;;; Set up for the type syntax extension
(defun rest? (params)
(and (not (null params))
(or (not (consp params))
(eq (car params) '&rest)
(eq (car params) '&body))))
(defun end? (params) (null params))
(defun parameter-name (param) (if (consp param) (car param) param))
(defun rest-parameter (params)
(if (consp params) (cadr params) params))
(defun named? (param) param)
(defun convert-arglist (params mode &optional (optional-or-key nil))
(cond ((rest? params)
(lisp:let* ((p (rest-parameter params))
(name (if (named? p)
(parameter-name p)
'ignore)))
(ecase mode
((apply)
(list (if (named? p) name ''())))
((no-rest)
'())
((scheme-lambda)
name)
((defmacro) ;wonderful hack
`(,(if (string= (symbol-name name) "BODY") '&body '&rest) ,name))
((cl-lambda)
`(&rest ,name))
((the-args)
(if (named? p) (list name) '())))))
((end? params)
(ecase mode
((apply) '('()))
((no-rest scheme-lambda defmacro cl-lambda the-args) '())))
(t
(lisp:let ((param (car params)))
(cond ((lisp:member param '(&optional &key))
(ecase mode
((defmacro cl-lambda) params)
((apply no-rest scheme-lambda the-args)
;; Gross approximation!!!
(convert-arglist (cdr params) mode param))))
(t
(cons (parameter-name param)
(convert-arglist (cdr params) mode optional-or-key))))))))
(defun lambda-expression? (exp)
(and (consp exp) (eq (car exp) 'lambda)))
(defun definition? (exp)
(and (consp exp) (eq (car exp) 'define)))
(defun undefinify (body)
(do ((e body (cdr e))
(d '()
(lisp:let ((pat (cadr (car e)))
(bod (cddr (car e))))
(cons (if (consp pat)
`(,(car pat) (lambda ,(cdr pat) ,@bod))
(cdr (car e)))
d))))
((or (null (cdr e))
(not (definition? (car e))))
(if (null d)
body
`((letrec ,(reverse d) ,@e))))))
(defun beginify (forms)
(if (null (cdr forms)) (car forms) `(begin ,@forms)))
(defun maybe-preprocess (exp)
(if *preprocess?* (preprocess-top exp) exp))
;;; Prevents repeated preprocessing.
(defun prevent-preprocessing (forms)
`(macrolet ((scheme-expression (&rest form) form))
,@forms))
(defvar *allow-possibly-incorrect-speed-hacks?* nil)
(defun *---*? (var)
(lisp:let ((s (symbol-name var)))
(and (>= (length s) 3)
(char= (aref s 0) #\*)
(char= (aref s (- (length s) 1)) #\*))))
);nehw-lave
;;; It would take a while to explain how this hack works. Trust me.
(defmacro scheme-expression (-ignore- &rest form)
#+Symbolics -ignore-
#-Symbolics (declare (ignore -ignore-))
(prevent-preprocessing (list (maybe-preprocess form))))
;;; Definition forms: DEFINE, DEFINE-MACRO
;;; These can only occur at top level (what about inside a BEGIN?).
;;; Must use DEFVAR to inhibit "not declared special" warnings.
(defmacro define (pat &body body)
(if (consp pat)
`(define ,(car pat) (lambda ,(cdr pat) ,@body))
(lisp:let* ((var pat)
(val (maybe-preprocess (car body)))
(h (get var 'history)))
(cond ((or (lisp:member :setq h)
(*---*? var))
`(define[variable] ,var ,val))
((and *allow-possibly-incorrect-speed-hacks?*
(not (lisp:member :function h))
(not (lisp:member :set!-globally h))
(or (and (lambda-expression? val)
(not (complicated? val)))
(and (symbolp val)
(lisp:member (get val 'method)
'(:macro :function)))))
`(define[subst] ,var ,val))
((lambda-expression? val)
`(define[function] ,var ,val))
((and *allow-possibly-incorrect-speed-hacks?*
(number? val))
`(define[constant] ,var ,val))
(t
`(define[variable] ,var ,val))))))
(defmacro define[function] (var (-ignore- vars . body))
#-Symbolics (declare (ignore -ignore-)) #+Symbolics -ignore-
(use-method var :function)
`(progn 'compile
(use-method ',var :function)
(defvar ,var)
(defun ,var ,(convert-arglist vars 'cl-lambda)
(definition-body ,vars ,@body))
(setq ,var #',var)
',var))
(defmacro define[variable] (var val)
(use-method var :variable)
`(progn 'compile
(use-method ',var :variable)
(defvar ,var)
(setq ,var ,(prevent-preprocessing (list val)))
(defun ,var (&rest args)
(apply ,var args))))
(defmacro define[constant] (var val)
(use-method var :constant)
`(progn 'compile
(use-method ',var :constant)
(defconstant ,var ,(prevent-preprocessing (list val)))))
(defmacro define[subst] (pat &body body)
(if (consp pat)
`(define[subst] ,(car pat) (lambda ,(cdr pat) ,@body))
(lisp:let ((var pat)
(val (car body)))
(use-method var :macro)
(if (lambda-expression? (car body))
(lisp:let* ((vars (cadr val))
(body-exp (if (null (cdddr val))
(caddr val)
`(progn ,@(cddr val))))
(aux-var (concatenate-symbol var '[closed]))
(the-vars (convert-arglist vars 'the-args)))
`(progn 'compile
(use-method ',var :macro)
(defmacro ,var ,(convert-arglist vars 'defmacro)
,(if (null the-vars)
`',body-exp
`(sublis (mapcar #'cons
',the-vars
(list ,@the-vars))
',body-exp)))
(defvar ,var)
(defun ,aux-var ,(convert-arglist vars 'cl-lambda)
(definition-body ,vars ,@(cddr val)))
(setq ,var #',aux-var)
',var))
`(progn 'compile
(use-method ',var :macro)
(defmacro ,var (&rest args)
`(,',val ,@args))
(defparameter ,var
,(prevent-preprocessing (list val))))))))
(defmacro define-macro (pat &body body)
(lisp:let* ((name (car pat))
(kludge (maybe-preprocess `(lambda ,(cdr pat) ,@body)))
(bvl (cadr kludge))
(body (cddr kludge)))
`(progn 'compile
(defmacro ,name ,(convert-arglist bvl 'defmacro)
,@body)
(eval-when (lisp:eval load compile)
(setf (get ',name 'scheme-macro) t))
',name)))
(defmacro definition-body (vars &body body)
(prevent-preprocessing `((lambda-body ,vars ,@body))))
;;; Pass 2 of Scheme->CL translation is accomplished by a bunch of CL
;;; macros.
;;; Special forms are in alphabetical order
(defmacro define-pseudo-macro (pat &body body)
(lisp:let* ((name (car pat))
(aux-name (lisp:let ((*package* (find-package 'pseudoscheme)))
(concatenate-symbol name '-aux))))
`(progn 'compile
(setf (get ',name 'aux-name) ',aux-name)
(defmacro ,name ,(convert-arglist (cdr pat) 'defmacro)
`(scheme-expression ,',aux-name ,',name
,@(list* ,@(convert-arglist (cdr pat) 'apply))))
(defmacro ,aux-name (-ignore- ,@(convert-arglist (cdr pat) 'defmacro))
#+Symbolics -ignore-
#-Symbolics (declare (ignore -ignore-))
,@body))))
(defmacro begin (&rest forms) ;Allow for (begin (define ...) ...)
`(progn 'compile ,@forms))
(defmacro call (&rest args)
`(funcall ,@args))
(defmacro jcall (&rest args)
`(funcall ,@args))
(define-pseudo-macro (case test-object . body)
`(lisp:case ,test-object
,@(mapcar #'(lisp:lambda (clause)
(if (eq (car clause) 'else)
`(otherwise ,@(cdr clause))
clause))
body)))
(define-pseudo-macro (cons-stream hd tl)
`(cons ,hd (delay ,tl)))
(define-pseudo-macro (delay exp)
`(make-delay :thunk-or-value #'(lisp:lambda () ,exp)))
;;; We can't just define a LISP:LAMBDA macro, since the host Common Lisp
;;; might define one of its own that shouldn't be clobberred. (This is
;;; the case on the 3600.)
(define-pseudo-macro (lambda vars . body)
`#'(lisp:lambda ,(convert-arglist vars 'cl-lambda)
(lambda-body ,vars ,@body)))
;;; Used by pass-1 output
(define-pseudo-macro (allow-function-references vars . body)
(if (null vars)
(beginify body)
`(macrolet ,(mapcar #'(lisp:lambda (var)
`(,var (&rest args)
`(call ,',var ,@args)))
vars)
,@body)))
;;; Needed by top-level DEFINE; makes bodies of lambda-expressions
;;; prettier for GRINDEF etc.
(defmacro lambda-body (vars &body body)
#-Symbolics
(declare (ignore vars))
(lisp:let* ((body (undefinify body))
#+Symbolics
(rest-var (if (atom vars) vars (cdr (last vars)))))
#-Symbolics
(beginify body)
#+Symbolics
(if rest-var
`(lisp:let ((,rest-var (copy-list ,rest-var)))
,@body)
(beginify body))))
(define-pseudo-macro (let specs . body)
(cond ((or (null specs) (consp specs))
;; Normal case
`(lisp:let ,specs ,@(undefinify body)))
(t
;; Named LET
(lisp:let ((tag specs)
(specs (car body))
(body (cdr body)))
`(,(if *preprocess?* 'letrec 'letrec[tagbody])
;; If preprocessor is turned off, be optimistic.
((,tag (lambda ,(mapcar #'car specs)
,@body)))
(,tag ,@(mapcar #'cadr specs)))))))
(define-pseudo-macro (let* specs . body)
(cond ((null specs) (beginify body))
(t `(let (,(car specs))
(let* ,(cdr specs) ,@body)))))
;;; There are three kinds of LETREC. In the absence of further
;;; information we assume the worst.
;;; 1. Most general case
(define-pseudo-macro (letrec specs . body)
`(let ,(mapcar #'(lisp:lambda (spec) `(,(car spec) ':undefined))
specs)
(allow-function-references ,(mapcar #'car specs)
,@(mapcar #'(lisp:lambda (spec) `(setq ,@spec)) specs)
,@(undefinify body))))
;;; 2. Somewhat less general; SET! and non-functional references not
;;; allowed.
(defmacro letrec[labels] (specs &body body)
`(lisp:labels ,(mapcar #'(lisp:lambda (spec)
(lisp:let ((var (car spec))
(val (cadr spec)))
(cond ((lambda-expression? val)
`(,var ,(convert-arglist (cadr val) 'cl-lambda)
(lambda-body ,@(cdr val))))
(t
(cerror "ignore it"
"losing LETREC spec - ~s"
spec)
`(,var (&rest foo) foo)))))
specs)
,@body))
;;; 3. This is the interesting case: the LETREC is really a loop. This
;;; only works if all calls to all the procedures are at the same
;;; tail-recursion level.
(defmacro letrec[tagbody] (specs &body body)
#-TAIL-RECURSION-WINS
(lisp:let* ((number-of-registers
(apply #'max (mapcar #'(lisp:lambda (spec)
(length (cadr (cadr spec))))
specs)))
(registers
(do ((i 0 (lisp:+ i 1))
(regs '() (cons (gensym "REG-") regs)))
((= i number-of-registers) (reverse regs))))
(block-name (gensym "LETREC-")))
`(lisp:block ,block-name
(lisp:let ,registers
(macrolet ,(mapcar #'(lisp:lambda (spec)
(lisp:let ((tag (car spec))
(vars (cadr (cadr spec))))
`(,tag ,vars
`(progn (setq ,@(list ,@(mapcan #'(lisp:lambda (reg var)
`(',reg ,var))
registers
vars)))
(go ,',tag)))))
specs)
(tagbody
(return-from ,block-name ,(beginify (undefinify body)))
,@(mapcan #'(lisp:lambda (spec)
(list (car spec)
`(return-from ,block-name
(let ,(mapcar #'list (cadr (cadr spec)) registers)
,@(undefinify (cddr (cadr spec)))))))
specs))))))
#+TAIL-RECURSION-WINS
`(letrec[labels] ,specs ,@body))
(define-pseudo-macro (sequence . forms)
`(begin ,@forms))
;;; Note that SET! on lambda-bound variables won't work in
;;; unpreprocessed programs.
(define-pseudo-macro (set! var val)
(lisp:let ((method (get var 'method)))
(cond ((or (null method) (eq method :variable))
;; Be optimistic.
(record-variable-usage var :setq)
`(setq ,var ,val))
(t
(when (eq method :macro)
(cerror "proceed as if everything was OK"
"(DEFINE ~S ...) was implemented as (DEFMACRO ~S ...),~
~%but (SET! ~S ...) was encountered"
var var var))
(record-variable-usage var :set!-globally)
`(set!-globally ',var ,val)))))
(defun set!-globally (var val)
(record-variable-usage var :set!-globally)
(setf (symbol-value var) val)
(if (procedure? val)
(setf (symbol-function var) val)
(setf (symbol-function var)
#'(lisp:lambda (&rest args)
(apply var args))))
t)
;;; quasiquote
(define-pseudo-macro (quasiquote x)
(expand-quasiquote x 0))
(define-pseudo-macro (unquote x)
(cerror "act as if the comma wasn't there at all"
"comma not inside backquote form - ,~S" x)
x)
(define-pseudo-macro (unquote-splicing x)
(cerror "act as if the ,@ wasn't there at all"
"\",@\" not inside backquote form - ,@~S" x)
x)
(define (expand-quasiquote x level)
(multiple-value-bind (mode arg)
(descend-quasiquote x level)
(finalize-quasiquote mode arg)))
(define (finalize-quasiquote mode arg)
(cond ((eq mode 'quote) `',arg)
((eq mode 'unquote) arg)
((eq mode 'unquote-splicing)
(cerror "act as if () had been seen instead of ,@<form>"
",@ in illegal context - ,@~s"
arg))
(else (cons mode arg))))
;;; The two return values, mode and arg, are interpreted as follows:
;;; mode arg meaning
;;; QUOTE x 'x
;;; UNQUOTE x x
;;; LIST (x1 x2 ...) (LIST x1 x2 ...)
;;; CONS* (x1 x2 ...) (CONS* x1 x2 ...)
;;; APPEND (x1 x2 ...) (APPEND x1 x2 ...)
(define (descend-quasiquote x level)
(cond ((vector? x)
(descend-quasiquote-vector x level))
((atom x)
(values 'quote x))
((interesting-to-quasiquote? x 'quasiquote)
(descend-quasiquote-pair x (1+ level)))
((interesting-to-quasiquote? x 'unquote)
(cond ((= level 0)
(values 'unquote (cadr x)))
(else
;; BUG: ,,@ doesn't work. I think this is the spot
;; where it would have to be hacked in.
(descend-quasiquote-pair x (- level 1)))))
((interesting-to-quasiquote? x 'unquote-splicing)
(cond ((= level 0)
(values 'unquote-splicing (cadr x)))
(else
(descend-quasiquote-pair x (- level 1)))))
(else
(descend-quasiquote-pair x level))))
(define (descend-quasiquote-pair x level)
(multiple-value-bind (car-mode car-arg)
(descend-quasiquote (car x) level)
(multiple-value-bind (cdr-mode cdr-arg)
(descend-quasiquote (cdr x) level)
(cond ((and (eq car-mode 'quote) (eq cdr-mode 'quote))
(values 'quote x))
((eq car-mode 'unquote-splicing)
;; (,@mumble ...)
(cond ((and (eq cdr-mode 'quote) (null cdr-arg))
(values 'unquote
car-arg))
((eq cdr-mode 'append)
(values 'append
(cons car-arg cdr-arg)))
(else
(values 'append
(list car-arg (finalize-quasiquote cdr-mode cdr-arg))))))
((and (eq cdr-mode 'quote) (null cdr-arg))
(values 'list
(list (finalize-quasiquote car-mode car-arg))))
((or (eq cdr-mode 'list) (eq cdr-mode 'cons*))
(values cdr-mode
(cons (finalize-quasiquote car-mode car-arg)
cdr-arg)))
(else
(values 'cons*
(list (finalize-quasiquote car-mode car-arg)
(finalize-quasiquote cdr-mode cdr-arg))))))))
;;; #(a b c) ==> '#(a b c)
;;; #(a ,b c) ==> (vector 'a b 'c)
;;; #(a ,@b ,c) ==> (list->vector (append '(a) b (list c)))
;;; Isn't there some elegant way to do this?
;;; YES. Parameterize descend-quasiquote-pair.
(define (descend-quasiquote-vector x level)
(let loop ((i (- (vector-length x) 1))
(modes '())
(args '())
(flag nil))
(cond ((>= i 0)
(multiple-value-bind (mode arg)
(descend-quasiquote (vector-ref x i) level)
;; mode = quote, unquote, unquote-splicing, list, cons*
(loop (- i 1)
(cons mode modes)
(cons arg args)
(or flag (not (eq mode 'quote))))))
((not flag)
(values x 'quote))
((lisp:member 'unquote-splicing modes)
(values 'list->vector
(list (cons 'append
(mapcar (lambda (mode arg)
(cond ((eq mode 'unquote-splicing) arg)
;; Not good.
((eq mode 'quote)
(list 'quote (list arg)))
(else
(list 'list
(finalize-quasiquote mode arg)))))
modes
args)))))
(else
(values 'vector
(mapcar #'finalize-quasiquote modes args))))))
(define (interesting-to-quasiquote? x marker)
(and (consp x)
(eq (car x) marker)
(consp (cdr x))
(null (cddr x))))
;;;; Procedures
(defmacro define-pseudo (pat &body body)
`(define ,pat ,@body))
(defmacro define-pseudo[subst] (pat &body body)
`(define[subst] ,pat ,@body))
(define-pseudo[subst] (assq obj list)
(lisp:assoc obj list :test #'eq))
(define-pseudo[subst] (assoc obj list)
(lisp:assoc obj list :test #'equal))
(define-pseudo[subst] (boolean? obj)
(or (eq obj t) (eq obj nil)))
(define-pseudo[subst] (call-with-current-continuation proc)
(block current-continuation
(call proc #'(lisp:lambda (val)
(return-from current-continuation val)))))
(define-pseudo[subst] (call-with-input-file string proc)
(with-open-file (port string :direction :input)
(call proc port)))
(define-pseudo[subst] (call-with-output-file string proc)
(with-open-file (port string :direction :output)
(call proc port)))
(define-pseudo (char-whitespace? char)
(or (char= char #\space)
(not (graphic-char-p char))))
(define-pseudo[subst] (current-input-port)
*standard-input*)
(define-pseudo[subst] (current-output-port)
*standard-output*)
(define-pseudo[subst] (eof-object? obj)
(eq obj 'eof-object))
(define-pseudo (error . items)
(apply #'cerror
"Return from the call to the ERROR procedure"
(apply #'concatenate
'string
"~a"
(mapcar #'(lisp:lambda (item)
#-Symbolics (declare (ignore item))
#+Symbolics item
"~%~s")
(cdr items)))
items))
#+LispM
(setf (get 'error :error-reporter) t) ;Thanks to KMP
(define-pseudo (eval obj env)
env
(lisp:eval (prevent-preprocessing (list (preprocess-top obj)))))
(define-pseudo (exact? num)
num
nil)
(defstruct (delay (:print-function print-delay) (:predicate delay?))
(forced-yet? nil)
thunk-or-value)
(defun print-delay (obj stream escape?)
#-Symbolics (declare (ignore escape?))
#+Symbolics escape?
(if (delay-forced-yet? obj)
(format stream "#{Forced ~S}" (delay-thunk-or-value obj))
(format stream "#{Delayed}")))
(define-pseudo (force obj)
(cond ((delay? obj)
(lisp:let ((tv (delay-thunk-or-value obj)))
(cond ((delay-forced-yet? obj) tv)
(t (lisp:let ((val (funcall tv)))
(setf (delay-thunk-or-value obj) val)
(setf (delay-forced-yet? obj) t)
val)))))
(t obj)))
(define-pseudo (inexact? num)
num
t)
(define-pseudo (input-port? obj)
(and (streamp obj) (input-stream-p obj)))
(define-pseudo[subst] (list->string list)
(coerce list 'string))
(defvar the-empty-vector '#())
(define-pseudo (list->vector l)
(if (null l)
the-empty-vector
(coerce l 'vector)))
(define-pseudo[subst] (list-ref list n)
(nth n list))
(define-pseudo[subst] (list-tail list n)
(nthcdr n list))
(defvar the-empty-string "")
(define-pseudo[subst] (make-polar r th)
(* r (cis th)))
(define-pseudo (make-string size
&optional fill)
(cond ((= size 0) the-empty-string)
(fill (lisp:make-string size :initial-element fill))
(t (lisp:make-string size))))
(define-pseudo (make-vector size
&optional
(fill '*uninitialized-vector-element*))
(if (= size 0)
the-empty-vector
(make-sequence 'vector size :initial-element fill)))
(define-pseudo[subst] (memq obj list)
(lisp:member obj list :test #'eq))
(define-pseudo[subst] (member obj list)
(lisp:member obj list :test #'equal))
(define-pseudo (number->string num format)
(if (not (and (consp format) (string= (symbol-name (car format)) "HEUR")))
(cerror "act as if the format was (HEUR)"
"unimplemented format: (NUMBER->STRING '~s '~s)"
num format))
(write-to-string num))
(define-pseudo[subst] (open-input-file string)
(open string :direction :in))
(define-pseudo[subst] (open-output-file string)
(open string :direction :out))
(define-pseudo (output-port? obj)
(and (streamp obj) (output-stream-p obj)))
(define-pseudo (pp obj &optional (port *standard-input*))
(lisp:let ((*print-pretty* t))
(format port "~&")
(lisp:print obj port)
(values)))
(defconstant closures-might-be-conses?
(consp (lisp:eval '#'(lisp:lambda (x) x))))
(define-pseudo (procedure? obj)
(and (functionp obj)
(not (symbolp obj))
(and (not closures-might-be-conses?)
(not (consp obj)))))
(define-pseudo[subst] (quotient n1 n2)
(values (truncate n1 n2)))
(define-pseudo (read &optional (port *standard-input*))
(lisp:read port nil 'eof-object))
(define-pseudo (read-char &optional (port *standard-input*))
(lisp:read-char port nil 'eof-object))
(define-pseudo (real? obj)
(and (numberp obj) (not (complexp obj))))
(define-pseudo[subst] (set-car! pair obj)
(setf (car pair) obj))
(define-pseudo[subst] (set-cdr! pair obj)
(setf (cdr pair) obj))
(define-pseudo[subst] (string->list string)
(coerce string 'list))
(define-pseudo (string->number string exactness radix)
exactness
(let ((*read-base* (case radix
((b) 2)
((o) 8)
((d) 10)
((x) 16)
(else (error "bad radix arg to STRING->NUMBER"
radix)))))
(with-input-from-string (s string)
(read s)))) ;very crude approximation
(define-pseudo[subst] (string->symbol string)
(values (intern string)))
(define-pseudo (string-append . strings)
(apply #'concatenate 'string strings))
(define-pseudo[subst] (string-set! s k obj)
(setf (aref (the simple-string s) k) obj))
(define-pseudo (symbol? x)
(and x (symbolp x) (not (eq x t))))
(define-pseudo[subst] (tail stream)
(force (cdr stream)))
(define-pseudo the-empty-stream '())
(define-pseudo user-initial-environment nil)
(define-pseudo (vector? obj)
(and (simple-vector-p obj)
;; Strings are simple vectors in CLISP (this is a bug)
#+tops-20
(not (stringp obj))
;; Structures are vectors in CLISP, bolixlisp, etc.
#+(or tops-20 symbolics vax)
(not (typep obj 'structure))))
(define-pseudo[subst] (vector->list vec)
(coerce vec 'list))
(define-pseudo[subst] (vector-set! vec k obj)
(setf (svref vec k) obj))
(define-pseudo[subst] (with-input-from-file string thunk)
(with-open-file (*standard-input* string :direction :input)
(call thunk)))
(define-pseudo[subst] (with-output-to-file string thunk)
(with-open-file (*standard-output* string :direction :output)
(call thunk)))
;;; Pass 1: Scheme -> readable-CL [preprocessor]
;;; Pass 2: readable-CL -> executable-CL [macros]
;;; Preprocessor to allow for combinations whose cars aren't symbols.
;;; There's the potential for doing a lot of translations and
;;; optimizations in a Scheme->CL preprocessor, but the idea is that we
;;; want to as little translation as possible in order that
;;; pretty-printing and debugging can work as smoothly as possible. Too
;;; much translation was the downfall of the previous Scheme-in-CL
;;; implementation: programs were impossible to debug.
;;; Be careful -- the output of the preprocessor is Common Lisp, not
;;; Scheme. Don't call the preprocessor twice on a given piece of
;;; code.
;;; - Global SET!'s must clobber the function cell, but local ones don't.
;;; - Annotate binding constructs to say when MACROLET's are needed for
;;; variables occurring in function position.
;;; - Detect absence of SET! and do some rudimentary tail recursion
;;; analysis for optimization of LETREC.
;;; The rudiments of global tail recursion processing are here (CALL vs.
;;; JCALL) but don't imagine that tail recursion can be easily added.
;;; Two reasons:
;;; (1) JCALL isn't inserted in all the places it needs to be, and
;;; (2) it might be inserted in some places where it shouldn't be (I'm
;;; not sure).
;;; Bindings
;;; For each variable, we want to know:
;;; Does it occur in value position?
;;; Does it occur in function position?
;;; If so, does it appear with a consistent continuation?
;;; Does it occur in a SET! ?
;;; ENV is a list of (name val? fun? set?).
(defstruct (binding
(:conc-name lisp:nil)
(:predicate lisp:nil)
(:copier lisp:nil)
(:constructor make-binding (old-name new-name)))
old-name
new-name
(value-references? nil)
(function-references? nil)
(assigned? nil)
(continuation-when-called nil))
(define[subst] (bind-var var new-var env)
(cons (make-binding var new-var) env))
(define (lookup name env)
(locally (declare (optimize (speed 3) (safety 0)))
(find name env :key #'old-name)))
(define[subst] (set-value-references?! binding)
(setf (value-references? binding) t))
(define[subst] (set-function-references?! binding)
(setf (function-references? binding) t))
(define[subst] (set-assigned?! binding)
(setf (assigned? binding) t))
(define (set-continuation-when-called! binding want-k)
(let ((have-k (continuation-when-called binding)))
(cond ((null? have-k)
(setf (continuation-when-called binding) want-k))
((not (eq? have-k want-k))
(setf (continuation-when-called binding) 'inconsistent)))))
;;; Preprocessor starts here.
(define (preprocess-top exp)
(preprocess exp '() '(value)))
(define (preprocess exp env k)
(cond ((symbol? exp)
(let ((probe (lookup exp env)))
(cond ((not probe)
(record-variable-usage exp :variable)
exp) ;Free (i.e. global) variable
(t
(set-value-references?! probe)
(new-name probe)))))
((not (pair? exp)) exp)
((not (symbol? (car exp)))
`(,(if (eq? (car k) 'return) 'jcall 'call)
,@(preprocess-list exp env)))
((get (car exp) 'scheme-macro)
(preprocess (macroexpand-1 exp) env k))
(else
(case (car exp)
((begin sequence)
`(,(car exp) ,@(preprocess-sequence (cdr exp) env k)))
((case)
`(case ,(preprocess (cadr exp) env '(value))
,@(map (lambda (clause)
`(,(car clause) ,@(preprocess-sequence (cdr clause) env k)))
(cddr exp))))
((cond)
`(cond ,@(map (lambda (clause)
(cons (preprocess (car clause) env '(value))
(if (null? (cdr clause))
'()
(preprocess-sequence (cdr clause) env k))))
(cdr exp))))
((do)
(preprocess-do exp env k))
((lambda)
(let* ((vars (convert-arglist (cadr exp) 'the-args))
(new-vars (lexical-names vars))
(env (bind-vars vars new-vars env))
(body (preprocess-body (cddr exp) vars env
(if (eq? (car k) 'letrec)
(cadr k)
'(return)))))
`(lambda ,(lexical-names (cadr exp))
,@body)))
((let)
(preprocess-let exp env k))
((let*)
(preprocess-let* exp env k))
((letrec)
(preprocess-letrec exp env k))
((quasiquote)
(preprocess (expand-quasiquote (cadr exp) 0) env k))
((quote) exp)
((set!)
(let* ((var (cadr exp))
(val (preprocess (caddr exp) env exp))
(probe (lookup var env)))
(cond (probe
(set-assigned?! probe) ;assigned
`(setq ,(new-name probe) ,val))
(else
`(set! ,var ,val)))))
((if)
`(if ,(preprocess (cadr exp) env '(value))
,@(map (lambda (exp) (preprocess exp env k))
(cddr exp))))
((and or)
`(,(car exp)
,@(if (null? (cdr exp))
'()
(preprocess-sequence (cdr exp) env k))))
((cons-stream delay)
`(,(car exp) ,@(preprocess-list exp env)))
((macrolet progn function lisp:let lisp:let* define setq call jcall)
(cerror "use the expression without preprocessing it"
"bogus input for Scheme->CL preprocessor -- ~s"
exp)
exp)
(else
(let* ((var (car exp))
(probe (lookup var env))
(args (preprocess-list (cdr exp) env)))
(cond (probe
(set-function-references?! probe)
(set-continuation-when-called! probe k)
`(,(new-name probe) ,@args))
((or (memq (get var 'method) '(:variable :constant))
(memq :setq (get var 'history)))
(record-variable-usage var :variable)
`(,(if (eq? (car k) 'return) 'jcall 'call)
,var ,@args))
(t
(if (eq? (get var 'method) :macro)
(record-variable-usage var :macro)
(record-variable-usage var :function))
`(,var ,@args)))))))))
(define (preprocess-let exp env k)
(if (symbol? (cadr exp))
(let ((tag (cadr exp))
(bindings (caddr exp)))
(preprocess `(letrec ((,tag (lambda ,(map car bindings)
,@(cdddr exp))))
(,tag ,@(map cadr bindings)))
env k))
(let* ((vars (map car (cadr exp)))
(new-vars (lexical-names vars))
(bindings (preprocess-bindings (cadr exp) new-vars env))
(env (bind-vars vars new-vars env))
(body (preprocess-body (cddr exp) vars env k)))
`(let ,bindings ,@body))))
(define (preprocess-bindings bindings new-vars env)
(map (lambda (spec new-var)
`(,new-var ,(preprocess (cadr spec) env '(value))))
bindings
new-vars))
(define (preprocess-let* exp env k)
(let loop ((old (cadr exp))
(new '())
(vars '())
(env env))
(if (null? old)
`(let* ,(reverse new)
,@(preprocess-body (cddr exp) vars env k))
(let* ((var (caar old))
(new-var (lexical-name var)))
(loop (cdr old)
(cons (cons new-var
(preprocess-region (cdar old) vars env '(value)))
new)
(cons var vars)
(bind-var var new-var env))))))
;;; For an input expression (letrec ((f (arg) f-body)) body) we can generate
;;; any of three possible outputs. In order of decreasing generality:
;;;
;;; Pass-1 (preproc.) Pass-2 output (macroexpansion)
;;; output
;;;
;;; 1. (letrec ...) (let ((f :undefined))
;;; (allow-function-references (f)
;;; (setq f #'(lambda ...))
;;; ...))
;;;
;;; 2. (letrec[labels] ...) (labels ((f ...)) ...)
;;;
;;; 3. (letrec[tagbody] ...) (let ((reg))
;;; (tagbody ... f ... (setq reg ...) (go f) ...))
(define (preprocess-letrec exp env k)
(let* ((vars (map car (cadr exp)))
(new-vars (lexical-names vars))
(env (bind-vars vars new-vars env))
(unique (list 'letrec-return))
(binding-cont (list 'letrec unique))
(bindings (map (lambda (spec new-var)
`(,new-var ,(preprocess (cadr spec) env binding-cont)))
(cadr exp)
new-vars))
(body (preprocess-sequence (undefinify (cddr exp)) env unique))
(type
(cond ((null? bindings) 'let)
((not (and (every (lambda (var)
(let ((z (lookup var env)))
;; All refs are function refs.
(and (not (value-references? z))
(not (assigned? z)))))
vars)
(every (lambda (binding) (lambda-expression? (cadr binding)))
bindings)))
'letrec)
((every (lambda (var)
(let ((z (lookup var env)))
(eq? (continuation-when-called z) unique)))
vars)
(for-each (lambda (var)
(let ((z (lookup var env)))
;; Permit nested lops
(set-continuation-when-called! z k)))
vars)
'letrec[tagbody])
(else
`letrec[labels]))))
`(,type ,bindings ,@body)))
(define (preprocess-do exp env k)
(let* ((specs (cadr exp))
(vars (map car specs))
(new-vars (lexical-names vars))
(new-env (bind-vars vars new-vars env))
(end (caddr exp)))
`(do ,(map (lambda (spec new-var)
`(,new-var
,(preprocess (cadr spec) env '(value))
,@(if (null? (cddr spec))
'()
(preprocess-region (cddr spec)
vars
new-env
'(value)))))
specs
new-vars)
(,@(preprocess-region (list (car end)) vars new-env '(value))
,@(preprocess-region (cdr end) vars new-env k))
,@(if (null? (cdddr exp))
'()
(preprocess-region (cdddr exp) vars new-env '(ignore))))))
(define (preprocess-sequence exp-list env k)
(cond ((null? (cdr exp-list))
(list (preprocess (car exp-list) env k)))
(else
;; Continuation can't be IGNORE -- this routine is also used
;; by AND, OR, and DO
(cons (preprocess (car exp-list) env '(value))
(preprocess-sequence (cdr exp-list) env k)))))
(define (preprocess-list exp-list env)
(map (lambda (exp) (preprocess exp env '(value)))
exp-list))
(define (preprocess-body body vars env k)
(preprocess-region (undefinify body) vars env k))
;;; Allow function references to VARS within the sequence BODY.
;;; The output is never a longer list than the input.
(define (preprocess-region body vars env k)
(let* ((body (preprocess-sequence body env k)) ;side-affects env
(vars (function-vars vars env)))
(if vars
`((allow-function-references ,(convert-arglist vars 'no-rest)
,@body))
body)))
(define (function-vars vars env)
(do ((v vars (cdr v))
(f '() ;; A VAX LISP bug prevents the use of LET here.
(lisp:let ((z (lookup (car v) env)))
(if (function-references? z)
(cons (new-name z) f)
f))))
((null? v) f)))
(define (lexical-names vars) ;deal with dotted
(cond ((pair? vars)
(cons (lexical-name (car vars))
(lexical-names (cdr vars))))
((symbol? vars) (lexical-name vars))
(else vars)))
(define (bind-vars vars new-vars env)
(do ((vars vars (cdr vars))
(new-vars new-vars (cdr new-vars))
(env env (bind-var (car vars) (car new-vars) env)))
((null? vars) env)))
;;; Gross kludge for guessing when it's OK to substitute.
(define (proper-list? thing)
(or (null? thing)
(and (pair? thing)
(null? (cdr (last-pair thing))))))
(define (complicated? lambda-exp)
(let ((vars (cadr lambda-exp))
(body (cddr lambda-exp))
(var-count 0))
(or (not (proper-list? vars))
(letrec ((count
(lambda (exp)
(cond ((pair? exp)
(do ((n 0 (+ n (count (car l))))
(l exp (cdr l)))
((null? l) n)))
((memq exp vars)
(set! var-count (+ var-count 1)))
(t 1)))))
(or (> (count body) 10)
(> var-count (length vars)))))))
;;; Adapted from OZ:<DAM.PROVER>METAP.LISP.2. Thanks to DAM for
;;; figuring this out.
#+Symbolics
(progn 'compile
(setf (get 'define 'zwei:definition-function-spec-type) 'defun)
(setf (get 'define-macro 'zwei:definition-function-spec-type) 'defun)
(setf (get 'define-pseudo 'zwei:definition-function-spec-type) 'defun)
(setf (get 'define-pseudo-macro 'zwei:definition-function-spec-type) 'defun)
;The value of the property ZWEI:DEFINITION-FUNCTION-SPEC-FINDER
;should be a function which takes the ZWEI point after the definition
;symbol (e.g. DEFINE) and returns the point at the begining of the fspec.
;See the function ZWEI:GET-DEFINITION-FUNCTION-SPEC
;DEFINE-FSPEC-FINDER goes forward to the begining of the next atom.
;This means skipping white space and left parenthesis.
(defun define-fspec-finder (bp)
(zwei:forward-over (cons (if (numberp (car zwei:*whitespace-chars*))
40.
#\()
zwei:*whitespace-chars*)
bp))
(setf (get 'define 'zwei:definition-function-spec-finder) #'define-fspec-finder)
(setf (get 'define-macro 'zwei:definition-function-spec-finder) #'define-fspec-finder)
(setf (get 'define-pseudo 'zwei:definition-function-spec-finder) #'define-fspec-finder)
(setf (get 'define-pseudo-macro 'zwei:definition-function-spec-finder) #'define-fspec-finder)
)
#+Symbolics (zl:setq-standard-value si:*prinarray* t)
#-Symbolics (setq *print-array* t)
(defun quasiquote-read-macro (stream c)
#+Symbolics c #-Symbolics (declare (ignore c))
(list 'quasiquote (lisp:read stream t nil t)))
(defun unquote-read-macro (stream c)
#+Symbolics c #-Symbolics (declare (ignore c))
(list (lisp:let ((following-char
(lisp:peek-char nil stream nil stream t)))
(cond ((char= following-char #\@)
(read-char stream)
'unquote-splicing)
(t 'unquote)))
(lisp:read stream t nil t)))
(set-macro-character #\` #'quasiquote-read-macro)
(set-macro-character #\, #'unquote-read-macro)
#+Symbolics ;This stuff still doesn't make PP work.
(progn 'compile
(zl:defprop quasiquote grind-quasiquote si:grind-macro)
(defun grind-quasiquote (exp loc) loc
(si:gtyo #.(zl:character (char-code #\`)))
(si:grind-form (cadr exp) (zl:locf (cadr exp))))
(zl:defprop unquote grind-unquote si:grind-macro)
(defun grind-unquote (exp loc) loc
(si:gtyo #.(zl:character (char-code #\,)))
(si:grind-form (cadr exp) (zl:locf (cadr exp))))
(zl:defprop unquote-splicing grind-unquote-splicing si:grind-macro)
(defun grind-unquote-splicing (exp loc) loc
(si:gtyo #.(zl:character (char-code #\,)))
(si:gtyo #.(zl:character (char-code #\@)))
(si:grind-form (cadr exp) (zl:locf (cadr exp))))
)
#+(and VAX VMS)
(progn 'compile
(system::define-list-print-function quasiquote (list stream)
(declare (list list))
(if (= (length list) 2)
(format stream "`~W" (second list))
(format stream "~1!~@{~W~↑ ~:←~}~." list)))
(system::define-list-print-function unquote (list stream)
(declare (list list))
(if (= (length list) 2)
(format stream ",~W" (second list))
(format stream "~1!~@{~W~↑ ~:←~}~." list)))
(system::define-list-print-function unquote-splicing (list stream)
(declare (list list))
(if (= (length list) 2)
(format stream ",@~W" (second list))
(format stream "~1!~@{~W~↑ ~:←~}~." list)))
);ngorp
(defvar *scheme-source-file-type* "SCM")
#+Symbolics
(lisp:let ((type (zl:string *scheme-source-file-type*)))
(cond ((not (lisp:member type fs:*its-uninteresting-types* :test #'equal))
(push type fs:*its-uninteresting-types*))))
#+Symbolics
(fs:define-canonical-type :scheme *scheme-source-file-type*) ;Scheme source
;;; Default mode for scheme source is lisp.
#+Symbolics
(unless (assoc :scheme fs:*file-type-mode-alist*)
(push (cons :scheme :lisp) fs:*file-type-mode-alist*))
;;;
(defun declare-pseudoscheme-package (pkg)
#-Symbolics (declare (ignore pkg))
#+Symbolics (pushnew (if (packagep pkg) pkg (find-package pkg))
si:*reasonable-packages*)
t)
(defun scheme ()
#+Symbolics
(zl:setq-standard-value zl:package (find-package 'scheme))
#-Symbolics
(set! *package* (find-package 'scheme))
'scheme)
(setq *preprocess?* t)
(provide "pseudoscheme")
(in-package 'scheme :use '(pseudoscheme))
(declare-pseudoscheme-package 'scheme)