#| -*-Scheme-*-
-$Id: arith.scm,v 1.8 2001/12/23 17:20:57 cph Exp $
+$Id: arith.scm,v 1.9 2002/02/03 03:38:53 cph Exp $
-Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1989-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(let-syntax
((define-standard-unary
- (non-hygienic-macro-transformer
- (lambda (name flo:op int:op)
- `(DEFINE (,name X)
- (IF (FLONUM? X)
- (,flo:op X)
- (,int:op X)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) X)
+ (IF (FLONUM? X)
+ (,(close-syntax (list-ref form 2) environment) X)
+ (,(close-syntax (list-ref form 3) environment) X)))))))
(define-standard-unary rational? (lambda (x) x true) int:integer?)
(define-standard-unary integer? flo:integer? int:integer?)
(define-standard-unary exact? (lambda (x) x false)
\f
(let-syntax
((define-standard-binary
- (non-hygienic-macro-transformer
- (lambda (name flo:op int:op)
- `(DEFINE (,name X Y)
- (IF (FLONUM? X)
- (IF (FLONUM? Y)
- (,flo:op X Y)
- (,flo:op X (INT:->FLONUM Y)))
- (IF (FLONUM? Y)
- (,flo:op (INT:->FLONUM X) Y)
- (,int:op X Y))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((flo:op (close-syntax (list-ref form 2) environment))
+ (int:op (close-syntax (list-ref form 3) environment)))
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) X Y)
+ (IF (FLONUM? X)
+ (IF (FLONUM? Y)
+ (,flo:op X Y)
+ (,flo:op X (INT:->FLONUM Y)))
+ (IF (FLONUM? Y)
+ (,flo:op (INT:->FLONUM X) Y)
+ (,int:op X Y)))))))))
(define-standard-binary real:+ flo:+ int:+)
(define-standard-binary real:- flo:- int:-)
(define-standard-binary rationalize
(let-syntax
((define-integer-binary
- (non-hygienic-macro-transformer
- (lambda (name operator)
- `(DEFINE (,name N M)
- (IF (FLONUM? N)
- (INT:->FLONUM
- (,operator (FLO:->INTEGER N)
- (IF (FLONUM? M) (FLO:->INTEGER M) M)))
- (IF (FLONUM? M)
- (INT:->FLONUM (,operator N (FLO:->INTEGER M)))
- (,operator N M))))))))
- (define-integer-binary quotient int:quotient)
- (define-integer-binary remainder int:remainder)
- (define-integer-binary modulo int:modulo)
- (define-integer-binary real:gcd int:gcd)
- (define-integer-binary real:lcm int:lcm))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((operator (close-syntax (list-ref form 3) environment))
+ (flo->int
+ (lambda (n)
+ `(IF (FLO:INTEGER? ,n)
+ (FLO:->INTEGER ,n)
+ (ERROR:WRONG-TYPE-ARGUMENT ,n "integer"
+ ',(list-ref form 2))))))
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) N M)
+ (IF (FLONUM? N)
+ (INT:->FLONUM
+ (,operator ,(flo->int 'N)
+ (IF (FLONUM? M) (FLO:->INTEGER M) M)))
+ (IF (FLONUM? M)
+ (INT:->FLONUM (,operator N ,(flo->int 'M)))
+ (,operator N M)))))))))
+ (define-integer-binary quotient quotient int:quotient)
+ (define-integer-binary remainder remainder int:remainder)
+ (define-integer-binary modulo modulo int:modulo)
+ (define-integer-binary real:gcd gcd int:gcd)
+ (define-integer-binary real:lcm lcm int:lcm))
(define (numerator q)
(if (flonum? q)
(let-syntax
((define-transcendental-unary
- (non-hygienic-macro-transformer
- (lambda (name hole? hole-value function)
- `(DEFINE (,name X)
- (IF (,hole? X)
- ,hole-value
- (,function (REAL:->FLONUM X))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) X)
+ (IF (,(close-syntax (list-ref form 2) environment) X)
+ ,(close-syntax (list-ref form 3) environment)
+ (,(close-syntax (list-ref form 4) environment)
+ (REAL:->FLONUM X))))))))
(define-transcendental-unary exp real:exact0= 1 flo:exp)
(define-transcendental-unary log real:exact1= 0 flo:log)
(define-transcendental-unary sin real:exact0= 0 flo:sin)
#| -*-Scheme-*-
-$Id: constr.scm,v 1.3 1999/01/02 06:06:43 cph Exp $
+$Id: constr.scm,v 1.4 2002/02/03 03:38:53 cph Exp $
-Copyright (c) 1989-1999 Massachusetts Institute of Technology
+Copyright (c) 1989-1999, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
+
+(declare (usual-integrations))
\f
;;; Procedures for managing a set of ordering constraints
#| -*-Scheme-*-
-$Id: macros.scm,v 4.22 2001/12/23 17:20:57 cph Exp $
+$Id: macros.scm,v 4.23 2002/02/03 03:38:53 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
,x))))))
(define-syntax package
- (non-hygienic-macro-transformer
- (lambda (names . body)
- (make-syntax-closure
- (scode/make-sequence
- `(,@(map (lambda (name)
- (scode/make-definition name
- (make-unassigned-reference-trap)))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (not (syntax-match? '((* IDENTIFIER) * EXPRESSION) (cdr form)))
+ (error "Ill-formed special form:" form))
+ (let ((names (cadr form))
+ (body (cddr form)))
+ `(,(make-syntactic-closure environment '() 'BEGIN)
+ ,@(map (let ((r-define
+ (make-syntactic-closure environment '() 'DEFINE)))
+ (lambda (name)
+ `(,r-define ,name)))
names)
- ,(scode/make-combination
- (let ((block (syntax* (append body (list unspecific)))))
- (if (scode/open-block? block)
- (scode/open-block-components block
- (lambda (names* declarations body)
- (scode/make-lambda lambda-tag:let '() '() #f
- (list-transform-negative names*
- (lambda (name)
- (memq name names)))
- declarations
- body)))
- (scode/make-lambda lambda-tag:let '() '() #f '() '() block)))
- '())))))))
+ (,(make-syntactic-closure environment '() 'LET) () ,@body))))))
(define-syntax define-export
- (non-hygienic-macro-transformer
- (lambda (pattern . body)
- (parse-define-syntax pattern body
- (lambda (name body)
- name
- `(SET! ,pattern ,@body))
- (lambda (pattern body)
- `(SET! ,(car pattern)
- (NAMED-LAMBDA ,pattern ,@body)))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
+ `(,(make-syntactic-closure environment '() 'SET!)
+ ,@(cdr form)))
+ ((syntax-match? '((IDENTIFIER . MIT-BVL) + EXPRESSION) (cdr form))
+ `(,(make-syntactic-closure environment '() 'SET!)
+ ,(caadr form)
+ (,(make-syntactic-closure environment '() 'NAMED-LAMBDA)
+ ,@(cdr form))))
+ (else
+ (error "Ill-formed special form:" form))))))
\f
(define-syntax define-vector-slots
(non-hygienic-macro-transformer
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.27 2001/12/22 03:21:44 cph Exp $
+$Id: compiler.pkg,v 1.28 2002/02/03 03:38:53 cph Exp $
-Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
make-rvalue
make-snode
package)
- (import (runtime macros)
- parse-define-syntax))
+ (import (runtime syntactic-closures)
+ syntax-match?))
(define-package (compiler declarations)
(files "machines/i386/decls")
;;; -*-Scheme-*-
;;;
-;;; $Id: buffer.scm,v 1.184 2001/12/23 17:20:58 cph Exp $
+;;; $Id: buffer.scm,v 1.185 2002/02/03 03:38:53 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(let-syntax
((rename
- (non-hygienic-macro-transformer
- (lambda (slot-name)
- `(DEFINE-INTEGRABLE ,(symbol-append 'BUFFER- slot-name)
- ,(symbol-append 'BUFFER-% slot-name))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((slot-name (cadr form)))
+ `(DEFINE-INTEGRABLE
+ ,(close-syntax (symbol-append 'BUFFER- slot-name) environment)
+ ,(close-syntax (symbol-append 'BUFFER-% slot-name)
+ environment)))))))
(rename name)
(rename default-directory)
(rename pathname)
;;; -*-Scheme-*-
;;;
-;;; $Id: buffrm.scm,v 1.58 2000/10/26 04:18:59 cph Exp $
+;;; $Id: buffrm.scm,v 1.59 2002/02/03 03:38:53 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2000, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
;;;; Buffer Frames
))
(define-method buffer-frame (:make-leaf frame)
- (let ((frame* (=> superior :make-inferior buffer-frame)))
+ (let ((frame* (==> superior :make-inferior buffer-frame)))
(set-buffer-frame-size! frame* (window-x-size frame) (window-y-size frame))
(set-window-buffer! frame* (window-buffer frame))
(initial-modeline! frame* modeline-inferior)
frame*))
(define-method buffer-frame (:initialize! frame window*)
- (usual=> frame :initialize! window*)
+ (usual==> frame :initialize! window*)
(set! text-inferior (make-inferior frame buffer-window))
(set! border-inferior (make-inferior frame vertical-border-window))
(set! last-select-time 0))
(define-method buffer-frame (:kill! window)
(remove-buffer-window! (window-buffer window) window)
- (usual=> window :kill!))
+ (usual==> window :kill!))
(define-method buffer-frame (:update-display! window screen x-start y-start
xl xu yl yu display-style)
(define (set-buffer-frame-size! window x y)
(with-instance-variables buffer-frame window (x y)
- (usual=> window :set-size! x y)
+ (usual==> window :set-size! x y)
(if modeline-inferior
(begin
(set! y (- y (inferior-y-size modeline-inferior)))
(object-of-class? buffer-frame object))
(define (make-buffer-frame superior new-buffer modeline?)
- (let ((frame (=> superior :make-inferior buffer-frame)))
+ (let ((frame (==> superior :make-inferior buffer-frame)))
(set-window-buffer! frame new-buffer)
(initial-modeline! frame modeline?)
frame))
;;; -*-Scheme-*-
;;;
-;;; $Id: bufwin.scm,v 1.309 2000/04/10 02:30:36 cph Exp $
+;;; $Id: bufwin.scm,v 1.310 2002/02/03 03:38:53 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2000, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
;;;; Buffer Windows: Base
;;;; Standard Methods
(define-method buffer-window (:initialize! window window*)
- (usual=> window :initialize! window*)
+ (usual==> window :initialize! window*)
(%reset-window-structures! window)
(%clear-window-buffer-state! window))
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(%unset-window-buffer! window)
(set-interrupt-enables! mask))
- (usual=> window :kill!))
+ (usual==> window :kill!))
(define-method buffer-window (:salvage! window)
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(define (buffer-window/cursor-enable! window)
(if (%window-debug-trace window)
((%window-debug-trace window) 'window window 'cursor-enable!))
- (=> (inferior-window (%window-cursor-inferior window)) :enable!))
+ (==> (inferior-window (%window-cursor-inferior window)) :enable!))
(define (buffer-window/cursor-disable! window)
(if (%window-debug-trace window)
((%window-debug-trace window) 'window window 'cursor-disable!))
- (=> (inferior-window (%window-cursor-inferior window)) :disable!))
+ (==> (inferior-window (%window-cursor-inferior window)) :disable!))
\f
;;;; Update
(let ((group (%window-group window)))
(add-group-clip-daemon! group (%window-clip-daemon window))
(%set-window-point-index! window (mark-index (group-point group))))
- (if (buffer-display-start new-buffer)
+ (if (and (buffer-display-start new-buffer)
+ (window-x-size window))
(set-new-coordinates! window
(mark-index (buffer-display-start new-buffer))
0
;;; -*-Scheme-*-
;;;
-;;; $Id: calias.scm,v 1.23 2001/12/23 17:20:58 cph Exp $
+;;; $Id: calias.scm,v 1.24 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;; Predefined special keys
(let-syntax ((make-key
- (non-hygienic-macro-transformer
- (lambda (name)
- `(DEFINE ,name (INTERN-SPECIAL-KEY ',name 0))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (close-syntax (cadr form) environment)))
+ `(DEFINE ,name
+ (INTERN-SPECIAL-KEY ',name 0)))))))
(make-key backspace)
(make-key stop)
(make-key f1)
;;; -*-Scheme-*-
;;;
-;;; $Id: clscon.scm,v 1.7 1999/01/02 06:11:34 cph Exp $
+;;; $Id: clscon.scm,v 1.8 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1986-1999, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
;;;; Class/Object System: Class Constructor
class)))))))
(define (make-instance-transforms superclass variables)
- (define (generate variables n tail)
- (if (null? variables)
- tail
+ (define (generate variables n)
+ (if (pair? variables)
(cons (cons (car variables) n)
- (generate (cdr variables) (1+ n) tail))))
+ (generate (cdr variables) (+ n 1)))
+ '()))
(if superclass
- (generate variables
- (class-object-size superclass)
- (class-instance-transforms superclass))
- (generate variables 1 '())))
+ (append (class-instance-transforms superclass)
+ (generate variables (class-object-size superclass)))
+ (generate variables 1)))
(define (name->class name)
(let ((entry (assq name class-descriptors)))
;;; -*-Scheme-*-
;;;
-;;;$Id: clsmac.scm,v 1.7 2001/12/23 17:20:58 cph Exp $
+;;; $Id: clsmac.scm,v 1.8 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989, 1999, 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1999, 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; ******************************************************************
\f
(define-syntax define-class
- (non-hygienic-macro-transformer
- (lambda (name superclass variables)
- (guarantee-symbol "Class name" name)
- (if (not (null? superclass))
- (guarantee-symbol "Class name" superclass))
- ;; Compile-time definition.
- (make-class name
- (if (null? superclass) false (name->class superclass))
- variables)
- ;; Load-time definition.
- `(DEFINE ,name
- (MAKE-CLASS ',name
- ,(if (null? superclass) false superclass)
- ',variables)))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (and (syntax-match? '(IDENTIFIER DATUM (* SYMBOL)) (cdr form))
+ (or (identifier? (caddr form))
+ (null? (caddr form))))
+ (let ((name (cadr form))
+ (superclass (if (null? (caddr form)) #f (caddr form)))
+ (variables (cadddr form)))
+ ;; Compile-time definition.
+ (make-class (identifier->symbol name)
+ (and superclass
+ (name->class (identifier->symbol superclass)))
+ variables)
+ ;; Load-time definition.
+ `(,(make-syntactic-closure environment '() 'DEFINE)
+ ,name
+ (,(make-syntactic-closure environment '() 'MAKE-CLASS)
+ ',(identifier->symbol name)
+ ,superclass
+ ',variables)))
+ (ill-formed-syntax form)))))
(define-syntax define-method
- (non-hygienic-macro-transformer
- (lambda (class bvl . body)
- (syntax-class-definition class bvl body
- (lambda (name expression)
- (make-syntax-closure
- (make-method-definition class name expression)))))))
-
-(define-syntax with-instance-variables
- (non-hygienic-macro-transformer
- (lambda (class self free-names . body)
- (guarantee-symbol "Self name" self)
- (make-syntax-closure
- (syntax-class-expression class self free-names body)))))
-
-(define-syntax =>
- (non-hygienic-macro-transformer
- (lambda (object operation . arguments)
- (guarantee-symbol "Operation name" operation)
- (let ((obname (string->uninterned-symbol "object")))
- `(LET ((,obname ,object))
- ((CLASS-METHODS/REF (OBJECT-METHODS ,obname) ',operation)
- ,obname
- ,@arguments))))))
-
-(define-syntax usual=>
- (non-hygienic-macro-transformer
- (lambda (object operation . arguments)
- (guarantee-symbol "Operation name" operation)
- (if (not *class-name*)
- (error "Not inside class expression: USUAL=>" operation))
- `((CLASS-METHODS/REF (CLASS-METHODS (CLASS-SUPERCLASS ,*class-name*))
- ',operation)
- ,object
- ,@arguments))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (let ((finish
+ (lambda (name operation expression)
+ `(,(make-syntactic-closure environment '() 'CLASS-METHOD-DEFINE)
+ ,name
+ ',operation
+ ,expression))))
+ (cond ((syntax-match? '(IDENTIFIER SYMBOL EXPRESSION) (cdr form))
+ (finish (cadr form) (caddr form) (cadddr form)))
+ ((and (syntax-match? '(IDENTIFIER (SYMBOL . MIT-BVL) + EXPRESSION)
+ (cdr form))
+ (pair? (cdr (caddr form)))
+ (identifier? (cadr (caddr form))))
+ (finish (cadr form)
+ (car (caddr form))
+ `(,(make-syntactic-closure environment '() 'NAMED-LAMBDA)
+ ,(caddr form)
+ (,(make-syntactic-closure environment '()
+ 'WITH-INSTANCE-VARIABLES)
+ ,(cadr form)
+ ,(cadr (caddr form))
+ ()
+ ,@(cdddr form)))))
+ (else
+ (ill-formed-syntax form)))))))
\f
-(define (syntax-class-definition class bvl body receiver)
- (parse-definition bvl body
- (lambda (name expression)
- (receiver name (syntax expression)))
- (lambda (bvl body)
- (let ((operation (car bvl))
- (self (cadr bvl)))
- (guarantee-symbol "Operation name" operation)
- (guarantee-symbol "Self name" self)
- (receiver operation
- (syntax-class-expression class
- self
- '()
- `((NAMED-LAMBDA ,bvl ,@body))))))))
-
-(define (parse-definition bvl body simple compound)
- (define (loop bvl body)
- (if (pair? (car bvl))
- (loop (car bvl)
- `((LAMBDA ,(cdr bvl) ,@body)))
- (compound bvl body)))
- (if (symbol? bvl)
- (begin (if (not (null? (cdr body)))
- (error "Multiple forms in definition body" body))
- (simple bvl (car body)))
- (loop bvl body)))
-
-(define *class-name* false)
-
-(define (syntax-class-expression class-name self free-names expression)
- (guarantee-symbol "Class name" class-name)
- (fluid-let ((*class-name* class-name))
- (transform-instance-variables
- (class-instance-transforms (name->class class-name))
- self
- free-names
- (syntax* expression))))
-
-(define (make-method-definition class operation expression)
- (make-comb (make-scode-variable 'CLASS-METHOD-DEFINE)
- (make-scode-variable class)
- operation
- expression))
+(define with-instance-variables
+ (make-macro-reference-trap
+ (make-compiler-item
+ (lambda (form environment history)
+ (if (syntax-match? '(IDENTIFIER EXPRESSION (* IDENTIFIER) + EXPRESSION)
+ (cdr form))
+ (let ((class-name (cadr form))
+ (self (caddr form))
+ (free-names (cadddr form))
+ (body (cddddr form)))
+ (transform-instance-variables
+ (class-instance-transforms
+ (name->class (identifier->symbol class-name)))
+ (compile/subexpression self environment history select-caddr)
+ free-names
+ (compile/subexpression
+ `(,(make-syntactic-closure system-global-environment '() 'BEGIN)
+ ,@body)
+ environment
+ history
+ select-cddddr)))
+ (ill-formed-syntax form))))))
-(define (make-comb operator . operands)
- (make-combination operator operands))
+(define-syntax ==>
+ (syntax-rules ()
+ ((==> object operation argument ...)
+ (let ((temp object))
+ ((object-method temp 'operation) temp argument ...)))))
-(define (guarantee-symbol s x)
- (if (not (symbol? x))
- (error (string-append s " must be a symbol") x)))
\ No newline at end of file
+(define-syntax usual==>
+ (syntax-rules ()
+ ((usual==> object operation argument ...)
+ (let ((temp object))
+ ((usual-method (object-class temp) 'operation) temp argument ...)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: comman.scm,v 1.85 2001/03/21 19:25:16 cph Exp $
+$Id: comman.scm,v 1.86 2002/02/03 03:38:54 cph Exp $
-Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
+Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(make-string-table 500))
(define (name->command name #!optional if-undefined)
- (let ((name (canonicalize-name name)))
- (or (string-table-get editor-commands (symbol-name name))
- (case (if (default-object? if-undefined) 'INTERN if-undefined)
- ((#F) #f)
- ((ERROR) (error "Undefined command:" name))
- ((INTERN)
- (letrec ((command
- (make-command
- name
- "undefined command"
- '()
- (lambda () (editor-error "Undefined command:" name)))))
- command))
- (else
- (error:bad-range-argument if-undefined 'NAME->COMMAND))))))
+ (or (string-table-get editor-commands (symbol-name name))
+ (case (if (default-object? if-undefined) 'INTERN if-undefined)
+ ((#F) #f)
+ ((ERROR) (error "Undefined command:" name))
+ ((INTERN)
+ (letrec ((command
+ (make-command
+ name
+ "undefined command"
+ '()
+ (lambda () (editor-error "Undefined command:" name)))))
+ command))
+ (else
+ (error:bad-range-argument if-undefined 'NAME->COMMAND)))))
(define (->command object)
(if (command? object)
(define-integrable variable-value variable-%value)
(define-integrable variable-default-value variable-%default-value)
-(define-integrable define-variable-value-validity-test
- set-variable-value-validity-test!)
(define (variable-name-string variable)
(editor-name/internal->external (symbol-name (variable-name variable))))
-(define (make-variable name description value buffer-local?)
+(define (make-variable name description value buffer-local?
+ #!optional test normalization)
(let* ((sname (symbol-name name))
(variable
(or (string-table-get editor-variables sname)
(set-variable-initial-value! variable value)
(set-variable-%default-value! variable value)
(set-variable-assignment-daemons! variable '())
- (set-variable-value-validity-test! variable #f)
- (set-variable-value-normalization! variable #f)
+ ;; Next two are written strangely because DEFAULT-OBJECT?
+ ;; expansion contains (THE-ENVIRONMENT), which can't be inlined.
+ (if (default-object? test)
+ (set-variable-value-validity-test! variable #f)
+ (set-variable-value-validity-test! variable test))
+ (if (default-object? normalization)
+ (set-variable-value-normalization! variable #f)
+ (set-variable-value-normalization! variable normalization))
variable))
-(define-integrable (make-variable-buffer-local! variable)
+(define (make-variable-buffer-local! variable)
(set-variable-buffer-local?! variable #t))
\f
(define (normalize-variable-value variable value)
(make-string-table 50))
(define (name->variable name #!optional if-undefined)
- (let ((name (canonicalize-name name)))
- (or (string-table-get editor-variables (symbol-name name))
- (case (if (default-object? if-undefined) 'INTERN if-undefined)
- ((#F) #f)
- ((ERROR) (error "Undefined variable:" name))
- ((INTERN) (make-variable name "" #f #f))
- (else (error:bad-range-argument if-undefined 'NAME->VARIABLE))))))
+ (or (string-table-get editor-variables (symbol-name name))
+ (case (if (default-object? if-undefined) 'INTERN if-undefined)
+ ((#F) #f)
+ ((ERROR) (error "Undefined variable:" name))
+ ((INTERN) (make-variable name "" #f #f))
+ (else (error:bad-range-argument if-undefined 'NAME->VARIABLE)))))
(define (->variable object)
(if (variable? object)
;;; -*-Scheme-*-
;;;
-;;; $Id: comwin.scm,v 1.146 2000/10/30 19:18:54 cph Exp $
+;;; $Id: comwin.scm,v 1.147 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-1999, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
;;;; Combination Windows
;;; support the :NEW-ROOT-WINDOW! operation, but is otherwise not
;;; constrained.
-;;; (=> WINDOW :NEW-ROOT-WINDOW! WINDOW*)
+;;; (==> WINDOW :NEW-ROOT-WINDOW! WINDOW*)
;;; This is called whenever the root is changed. It need not do
;;; anything at all, but it is useful to keep track of the root.
;;; The leaf windows must be subclasses of COMBINATION-LEAF-WINDOW,
;;; and they must support these operations:
-;;; (=> WINDOW :MAKE-LEAF)
+;;; (==> WINDOW :MAKE-LEAF)
;;; Make a new leaf which can be placed next to WINDOW. For example,
;;; if WINDOW is a buffer window, the new window should also be a
;;; buffer window, visiting the same buffer, and sharing the same
;;; superior.
-;;; (=> WINDOW :MINIMUM-X-SIZE)
-;;; (=> WINDOW :MINIMUM-Y-SIZE)
+;;; (==> WINDOW :MINIMUM-X-SIZE)
+;;; (==> WINDOW :MINIMUM-Y-SIZE)
;;; These define how small the window is allowed to be. Since the
;;; combination window operations change the sizes of leaf windows,
(set-inferior-start! (window-inferior combination new)
(+ x n)
y))))
- (if (or (< n (=> leaf :minimum-x-size))
- (< n* (=> new :minimum-x-size)))
+ (if (or (< n (==> leaf :minimum-x-size))
+ (< n* (==> new :minimum-x-size)))
(begin
(deallocate-leaf! new)
false)
(begin
- (=> leaf :set-x-size! n)
- (=> new :set-size! n* y)
+ (==> leaf :set-x-size! n)
+ (==> new :set-size! n* y)
new)))))))
(define (window-split-vertically! leaf #!optional n)
(set-inferior-start! (window-inferior combination new)
x
(+ y n)))))
- (if (or (< n (=> leaf :minimum-y-size))
- (< n* (=> new :minimum-y-size)))
+ (if (or (< n (==> leaf :minimum-y-size))
+ (< n* (==> new :minimum-y-size)))
(begin
(deallocate-leaf! new)
false)
(begin
- (=> leaf :set-y-size! n)
- (=> new :set-size! x n*)
+ (==> leaf :set-y-size! n)
+ (==> new :set-size! x n*)
new)))))))
\f
(define (allocate-leaf! leaf v)
(let ((superior (window-superior leaf)))
(if (or (not (combination? superior))
(not (eq? v (combination-vertical? superior))))
- (let ((combination (=> superior :make-inferior combination-window)))
- (=> superior :set-inferior-position! combination
- (=> superior :inferior-position leaf))
+ (let ((combination (==> superior :make-inferior combination-window)))
+ (==> superior :set-inferior-position! combination
+ (==> superior :inferior-position leaf))
(set-combination-vertical! combination v)
(window-replace! leaf combination)
(set-combination-child! combination leaf)
(set-window-next! leaf false)
- (=> superior :delete-inferior! leaf)
+ (==> superior :delete-inferior! leaf)
(add-inferior! combination leaf)
(set-inferior-start! (window-inferior combination leaf) 0 0)
(set-window-size! combination
(window-x-size leaf)
(window-y-size leaf)))))
- (let ((new (=> leaf :make-leaf)))
+ (let ((new (==> leaf :make-leaf)))
(set-window-next! new (window-next leaf))
(if (window-next leaf) (set-window-previous! (window-next leaf) new))
(link-windows! leaf new)
window))))
(unlink-leaf! leaf)
(if (combination-vertical? superior)
- (=> window :set-y-size!
- (+ (window-y-size window) y-size))
- (=> window :set-x-size!
- (+ (window-x-size window) x-size))))))
+ (==> window :set-y-size!
+ (+ (window-y-size window) y-size))
+ (==> window :set-x-size!
+ (+ (window-x-size window) x-size))))))
(let ((do-next
(lambda ()
(adjust-size! next)
(let ((combination (window-superior leaf))
(next (window-next leaf))
(previous (window-previous leaf)))
- (=> leaf :kill!)
+ (==> leaf :kill!)
(delete-inferior! combination leaf)
(if previous
(set-window-next! previous next)
(if (not (window-next child))
(begin
(delete-inferior! combination child)
- (=> (window-superior combination) :replace-inferior!
- combination
- child)
+ (==> (window-superior combination) :replace-inferior!
+ combination
+ child)
(window-replace! combination child)))))
(define (window-replace! old new)
(with-instance-variables combination-leaf-window old (new)
(cond ((not (combination? superior))
- (=> superior :new-root-window! new))
+ (==> superior :new-root-window! new))
((and (combination? new)
(eq? (combination-vertical? superior)
(combination-vertical? new)))
(- new-room new-s)))))))))))))
\f
(define (window-min-x-size window)
- (=> window :minimum-x-size))
+ (==> window :minimum-x-size))
(define (send-window-x-size! window x)
- (=> window :set-x-size! x))
+ (==> window :set-x-size! x))
(define (window-min-y-size window)
- (=> window :minimum-y-size))
+ (==> window :minimum-y-size))
(define (send-window-y-size! window y)
- (=> window :set-y-size! y))
+ (==> window :set-y-size! y))
(define scale-combination-inferiors-x!
(scale-combination-inferiors! false window-x-size window-min-x-size
scale-combination-inferiors-y!))
(define-method combination-window (:minimum-x-size combination)
- (=> (window-leftmost-leaf combination) :minimum-x-size))
+ (==> (window-leftmost-leaf combination) :minimum-x-size))
(define-method combination-window (:minimum-y-size combination)
- (=> (window-leftmost-leaf combination) :minimum-y-size))
+ (==> (window-leftmost-leaf combination) :minimum-y-size))
(define (set-combination-x-size! combination x)
(scale-combination-inferiors-x! combination x false)
;;; -*-Scheme-*-
;;;
-;;; $Id: dosproc.scm,v 1.7 2001/12/23 17:20:58 cph Exp $
+;;; $Id: dosproc.scm,v 1.8 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1992-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1992-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;; package: (edwin process)
(declare (usual-integrations))
-\f
-(define subprocesses-available? false)
+
+(define subprocesses-available?
+ #f)
(define (process-list)
'())
(define (get-buffer-process buffer)
buffer
- false)
+ #f)
(define (buffer-processes buffer)
buffer
'())
-(define-integrable (process-operation name)
+(define (process-operation name)
(lambda (process)
(editor-error "Processes not implemented" name process)))
(let-syntax ((define-process-operation
- (non-hygienic-macro-transformer
- (lambda (name)
- `(define ,name (process-operation ',name))))))
-
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (close-syntax (cadr form) environment)))
+ `(DEFINE ,name (PROCESS-OPERATION ',name)))))))
(define-process-operation delete-process))
(define (process-status-changes?)
- false)
+ #f)
(define (process-output-available?)
- false)
\ No newline at end of file
+ #f)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: edtfrm.scm,v 1.90 1999/01/02 06:11:34 cph Exp $
+;;; $Id: edtfrm.scm,v 1.91 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-1999, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
;;;; Editor Frame
(define (set-editor-frame-size! window x y)
(with-instance-variables editor-frame window (x y)
- (usual=> window :set-size! x y)
+ (usual==> window :set-size! x y)
(set-inferior-start! root-inferior 0 0)
(let ((y* (- y typein-y-size)))
(set-inferior-start! typein-inferior 0 y*)
#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.279 2001/12/21 18:41:18 cph Exp $
+$Id: edwin.pkg,v 1.280 2002/02/03 03:38:54 cph Exp $
-Copyright (c) 1989-2001 Massachusetts Institute of Technology
+Copyright (c) 1989-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(files "clsmac")
(parent (edwin))
(export (edwin window)
- =>
+ ==>
define-class
define-method
- usual=>
+ usual==>
with-instance-variables)
- (import ()
- (make-scode-variable make-variable)
- (scode-variable-name variable-name)))
+ (import (runtime syntactic-closures)
+ compile/subexpression
+ make-compiler-item
+ select-caddr
+ select-cddddr))
(define-package (edwin class-macros transform-instance-variables)
(files "xform")
(parent (edwin class-macros))
(export (edwin class-macros)
- transform-instance-variables))
+ transform-instance-variables)
+ (import ()
+ (make-scode-variable make-variable)
+ (scode-variable-name variable-name)))
(define-package (edwin class-constructor)
(files "clscon")
(files "macros")
(parent (edwin))
(export (edwin)
- canonicalize-name
command-defined?
command-name->scheme-name
define-command
;;; -*-Scheme-*-
;;;
-;;; $Id: macros.scm,v 1.70 2001/12/23 17:20:58 cph Exp $
+;;; $Id: macros.scm,v 1.71 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-1999, 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-1999, 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;; Editor Macros
(declare (usual-integrations))
-\f
-(define edwin-syntax-table (->environment '(EDWIN))) ;upwards compatibility
+;; Upwards compatibility:
+(define edwin-syntax-table (->environment '(EDWIN)))
+\f
(define-syntax define-command
- (non-hygienic-macro-transformer
- (lambda (name description interactive procedure)
- (let ((name (canonicalize-name name)))
- (let ((scheme-name (command-name->scheme-name name)))
- `(DEFINE ,scheme-name
- (MAKE-COMMAND ',name
- ,description
- ,(if (null? interactive)
- `'()
- interactive)
- ,(if (and (pair? procedure)
- (eq? 'LAMBDA (car procedure))
- (pair? (cdr procedure)))
- `(NAMED-LAMBDA (,scheme-name
- ,@(cadr procedure))
- ,@(cddr procedure))
- procedure))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (capture-syntactic-environment
+ (lambda (closing-environment)
+ (if (syntax-match? '(SYMBOL EXPRESSION EXPRESSION EXPRESSION)
+ (cdr form))
+ (let ((name (list-ref form 1))
+ (description (close-syntax (list-ref form 2) environment))
+ (interactive (list-ref form 3))
+ (procedure (list-ref form 4)))
+ (let ((scheme-name
+ (close-syntax (command-name->scheme-name name)
+ environment)))
+ `(DEFINE ,scheme-name
+ (MAKE-COMMAND ',name
+ ,description
+ ,(if (null? interactive)
+ `'()
+ (close-syntax interactive environment))
+ ,(close-syntax
+ (if (and (pair? procedure)
+ (identifier=? environment
+ (car procedure)
+ closing-environment
+ 'LAMBDA)
+ (pair? (cdr procedure)))
+ `(,(close-syntax 'NAMED-LAMBDA
+ closing-environment)
+ (,scheme-name ,@(cadr procedure))
+ ,@(cddr procedure))
+ procedure)
+ environment)))))
+ (ill-formed-syntax form)))))))
(define-syntax ref-command-object
- (non-hygienic-macro-transformer
- (lambda (name)
- (command-name->scheme-name (canonicalize-name name)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(SYMBOL) (cdr form))
+ (close-syntax (command-name->scheme-name (cadr form)) environment)
+ (ill-formed-syntax form)))))
+
+(define (command-name->scheme-name name)
+ (symbol-append 'EDWIN-COMMAND$ name))
(define-syntax ref-command
- (non-hygienic-macro-transformer
- (lambda (name)
- `(COMMAND-PROCEDURE
- ,(command-name->scheme-name (canonicalize-name name))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (if (syntax-match? '(SYMBOL) (cdr form))
+ `(COMMAND-PROCEDURE (REF-COMMAND-OBJECT ,(cadr form)))
+ (ill-formed-syntax form)))))
(define-syntax command-defined?
- (non-hygienic-macro-transformer
- (lambda (name)
- (let ((variable-name
- (command-name->scheme-name (canonicalize-name name))))
- `(LET ((_ENV (->ENVIRONMENT '(EDWIN))))
- (AND (ENVIRONMENT-BOUND? _ENV ',variable-name)
- (ENVIRONMENT-ASSIGNED? _ENV ',variable-name)))))))
-
-(define (command-name->scheme-name name)
- (symbol-append 'EDWIN-COMMAND$ name))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (if (syntax-match? '(SYMBOL) (cdr form))
+ (let ((variable-name (command-name->scheme-name (cadr form))))
+ `(LET ((_ENV (->ENVIRONMENT '(EDWIN))))
+ (AND (ENVIRONMENT-BOUND? _ENV ',variable-name)
+ (ENVIRONMENT-ASSIGNED? _ENV ',variable-name))))
+ (ill-formed-syntax form)))))
\f
(define-syntax define-variable
- (non-hygienic-macro-transformer
- (lambda args
- (apply (variable-definition #f) args))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (expand-variable-definition form environment `#F))))
(define-syntax define-variable-per-buffer
- (non-hygienic-macro-transformer
- (lambda args
- (apply (variable-definition #t) args))))
-
-(define (variable-definition buffer-local?)
- (lambda (name description #!optional value test normalization)
- (let ((name (canonicalize-name name)))
- (let ((scheme-name (variable-name->scheme-name name)))
- `(BEGIN
- (DEFINE ,scheme-name
- (MAKE-VARIABLE ',name
- ,description
- ,(if (default-object? value) '#F value)
- ',buffer-local?))
- ,@(if (default-object? test)
- '()
- `((SET-VARIABLE-VALUE-VALIDITY-TEST! ,scheme-name
- ,test)))
- ,@(if (default-object? normalization)
- '()
- `((SET-VARIABLE-VALUE-NORMALIZATION!
- ,scheme-name
- ,normalization))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (expand-variable-definition form environment `#T))))
+
+(define (expand-variable-definition form environment buffer-local?)
+ (if (and (syntax-match? '(SYMBOL + EXPRESSION) (cdr form))
+ (<= (length form) 6))
+ `(DEFINE ,(close-syntax (variable-name->scheme-name (list-ref form 1))
+ environment)
+ (MAKE-VARIABLE ',(list-ref form 1)
+ ,(close-syntax (list-ref form 2) environment)
+ ,(if (> (length form) 3)
+ (close-syntax (list-ref form 3) environment)
+ '#F)
+ ,buffer-local?
+ ,(if (> (length form) 4)
+ (close-syntax (list-ref form 4) environment)
+ '#F)
+ ,(if (> (length form) 5)
+ (close-syntax (list-ref form 5) environment)
+ '#F)))
+ (ill-formed-syntax form)))
(define-syntax ref-variable-object
- (non-hygienic-macro-transformer
- (lambda (name)
- (variable-name->scheme-name (canonicalize-name name)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(SYMBOL) (cdr form))
+ (close-syntax (variable-name->scheme-name (cadr form)) environment)
+ (ill-formed-syntax form)))))
+
+(define (variable-name->scheme-name name)
+ (symbol-append 'EDWIN-VARIABLE$ name))
(define-syntax ref-variable
- (non-hygienic-macro-transformer
- (lambda (name #!optional buffer)
- (let ((name (variable-name->scheme-name (canonicalize-name name))))
- (if (default-object? buffer)
- `(VARIABLE-VALUE ,name)
- `(VARIABLE-LOCAL-VALUE ,buffer ,name))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(SYMBOL ? EXPRESSION) (cdr form))
+ (let ((name `(REF-VARIABLE-OBJECT ,(cadr form))))
+ (if (pair? (cddr form))
+ `(VARIABLE-LOCAL-VALUE ,(close-syntax (caddr form) environment)
+ ,name)
+ `(VARIABLE-VALUE ,name)))
+ (ill-formed-syntax form)))))
(define-syntax set-variable!
- (non-hygienic-macro-transformer
- (lambda (name #!optional value buffer)
- (let ((name (variable-name->scheme-name (canonicalize-name name)))
- (value (if (default-object? value) '#F value)))
- (if (default-object? buffer)
- `(SET-VARIABLE-VALUE! ,name ,value)
- `(SET-VARIABLE-LOCAL-VALUE! ,buffer ,name ,value))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (expand-variable-assignment form environment
+ (lambda (name value buffer)
+ (if buffer
+ `(SET-VARIABLE-LOCAL-VALUE! ,buffer ,name ,value)
+ `(SET-VARIABLE-VALUE! ,name ,value)))))))
(define-syntax local-set-variable!
- (non-hygienic-macro-transformer
- (lambda (name #!optional value buffer)
- `(DEFINE-VARIABLE-LOCAL-VALUE!
- ,(if (default-object? buffer) '(CURRENT-BUFFER) buffer)
- ,(variable-name->scheme-name (canonicalize-name name))
- ,(if (default-object? value) '#F value)))))
-
-(define (variable-name->scheme-name name)
- (symbol-append 'EDWIN-VARIABLE$ name))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (expand-variable-assignment form environment
+ (lambda (name value buffer)
+ `(DEFINE-VARIABLE-LOCAL-VALUE! ,(or buffer `(CURRENT-BUFFER)) ,name
+ ,value))))))
+
+(define (expand-variable-assignment form environment generator)
+ (if (and (syntax-match? '(SYMBOL * EXPRESSION) (cdr form))
+ (<= (length form) 4))
+ (generator `(REF-VARIABLE-OBJECT ,(list-ref form 1))
+ (if (> (length form) 2)
+ (close-syntax (list-ref form 2) environment)
+ `#F)
+ (if (> (length form) 3)
+ (close-syntax (list-ref form 3) environment)
+ #f))
+ (ill-formed-syntax form)))
\f
(define-syntax define-major-mode
- (non-hygienic-macro-transformer
- (lambda (name super-mode-name display-name description
- #!optional initialization)
- (let ((name (canonicalize-name name))
- (super-mode-name
- (and super-mode-name (canonicalize-name super-mode-name))))
- `(DEFINE ,(mode-name->scheme-name name)
- (MAKE-MODE ',name
- #T
- ',(or display-name (symbol->string name))
- ,(if super-mode-name
- `(->MODE ',super-mode-name)
- `#F)
- ,description
- ,(let ((super-initialization
- (and super-mode-name
- `(MODE-INITIALIZATION
- ,(mode-name->scheme-name
- super-mode-name))))
- (initialization
- (and (not (default-object? initialization))
- initialization)))
- (cond (super-initialization
- `(LAMBDA (BUFFER)
- (,super-initialization BUFFER)
- ,@(if initialization
- `((,initialization BUFFER))
- `())))
- (initialization)
- (else
- `(LAMBDA (BUFFER) BUFFER UNSPECIFIC))))))))))
+ (sc-macro-transformer
+ (let ((pattern
+ `(SYMBOL ,(lambda (x) (or (not x) (symbol? x)))
+ ,(lambda (x) (or (not x) (string? x)))
+ EXPRESSION
+ ? EXPRESSION)))
+ (lambda (form environment)
+ (if (syntax-match? pattern (cdr form))
+ (let ((name (list-ref form 1))
+ (super-mode-name (list-ref form 2)))
+ (let ((scheme-name
+ (close-syntax (mode-name->scheme-name name) environment)))
+ `(DEFINE ,scheme-name
+ (MAKE-MODE ',name
+ #T
+ ',(or (list-ref form 3)
+ (symbol->string name))
+ ,(if super-mode-name
+ `(->MODE ',super-mode-name)
+ `#F)
+ ,(close-syntax (list-ref form 4) environment)
+ ,(let ((initialization
+ (if (and (> (length form) 5)
+ (list-ref form 5))
+ (close-syntax (list-ref form 5)
+ environment)
+ #f)))
+ (if super-mode-name
+ `(LAMBDA (BUFFER)
+ ((MODE-INITIALIZATION
+ (MODE-SUPER-MODE ,scheme-name))
+ BUFFER)
+ ,@(if initialization
+ `((,initialization BUFFER))
+ `()))
+ (or initialization
+ `(LAMBDA (BUFFER)
+ BUFFER
+ UNSPECIFIC))))))))
+ (ill-formed-syntax form))))))
(define-syntax define-minor-mode
- (non-hygienic-macro-transformer
- (lambda (name display-name description #!optional initialization)
- (let ((name (canonicalize-name name)))
- `(DEFINE ,(mode-name->scheme-name name)
- (MAKE-MODE ',name
- #F
- ',(or display-name (symbol->string name))
- #F
- ,description
- ,(if (and (not (default-object? initialization))
- initialization)
- initialization
- `(LAMBDA (BUFFER) BUFFER UNSPECIFIC))))))))
+ (sc-macro-transformer
+ (let ((pattern
+ `(SYMBOL ,(lambda (x) (or (not x) (string? x)))
+ EXPRESSION
+ ? EXPRESSION)))
+ (lambda (form environment)
+ (if (syntax-match? pattern (cdr form))
+ (let ((name (list-ref form 1)))
+ `(DEFINE ,(close-syntax (mode-name->scheme-name name) environment)
+ (MAKE-MODE ',name
+ #F
+ ',(or (list-ref form 2)
+ (symbol->string name))
+ #F
+ ,(close-syntax (list-ref form 3) environment)
+ ,(if (and (> (length form) 4)
+ (list-ref form 4))
+ (close-syntax (list-ref form 4) environment)
+ `(LAMBDA (BUFFER) BUFFER UNSPECIFIC)))))
+ (ill-formed-syntax form))))))
(define-syntax ref-mode-object
- (non-hygienic-macro-transformer
- (lambda (name)
- (mode-name->scheme-name (canonicalize-name name)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(SYMBOL) (cdr form))
+ (close-syntax (mode-name->scheme-name (cadr form)) environment)
+ (ill-formed-syntax form)))))
(define (mode-name->scheme-name name)
- (symbol-append 'EDWIN-MODE$ name))
-
-(define (canonicalize-name name)
- (cond ((symbol? name) name)
- ((string? name) (intern (string-replace name #\Space #\-)))
- (else (error "illegal name" name))))
\ No newline at end of file
+ (symbol-append 'EDWIN-MODE$ name))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: modes.scm,v 1.34 2001/03/21 19:25:25 cph Exp $
+;;; $Id: modes.scm,v 1.35 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(define editor-modes
(make-string-table))
-(define (name->mode object #!optional if-undefined)
- (let ((name (canonicalize-name object)))
- (let ((sname (symbol-name name)))
- (or (string-table-get editor-modes sname)
- (case (if (default-object? if-undefined) 'INTERN if-undefined)
- ((#F) #f)
- ((ERROR) (error "Undefined mode:" name))
- ((INTERN)
- (make-mode name #t sname #f ""
- (lambda () (error "Undefined mode:" name))))
-
- (else
- (error:bad-range-argument if-undefined 'NAME->MODE)))))))
+(define (name->mode name #!optional if-undefined)
+ (let ((sname (symbol-name name)))
+ (or (string-table-get editor-modes sname)
+ (case (if (default-object? if-undefined) 'INTERN if-undefined)
+ ((#F) #f)
+ ((ERROR) (error "Undefined mode:" name))
+ ((INTERN)
+ (make-mode name #t sname #f ""
+ (lambda () (error "Undefined mode:" name))))
+
+ (else
+ (error:bad-range-argument if-undefined 'NAME->MODE))))))
(define (->mode object)
(if (mode? object)
;;; -*-Scheme-*-
;;;
-;;;$Id: modwin.scm,v 1.41 1999/03/18 02:29:30 cph Exp $
+;;;$Id: modwin.scm,v 1.42 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-1999, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
;;;; Modeline Window
(set! shows-buffer-modified? value)))
(define-method modeline-window (:initialize! window window*)
- (usual=> window :initialize! window*)
+ (usual==> window :initialize! window*)
(set! y-size 1)
(set! shows-buffer-modified? #f))
;;; -*-Scheme-*-
;;;
-;;; $Id: regexp.scm,v 1.77 2001/12/23 17:20:58 cph Exp $
+;;; $Id: regexp.scm,v 1.78 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(make-mark group start)))
\f
(define-syntax default-end-mark
- (non-hygienic-macro-transformer
- (lambda (start end)
- `(IF (DEFAULT-OBJECT? ,end)
- (GROUP-END ,start)
- (BEGIN
- (IF (NOT (MARK<= ,start ,end))
- (ERROR "Marks incorrectly related:" ,start ,end))
- ,end)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((start (close-syntax (cadr form) environment))
+ (end (close-syntax (caddr form) environment)))
+ `(IF (DEFAULT-OBJECT? ,end)
+ (GROUP-END ,start)
+ (BEGIN
+ (IF (NOT (MARK<= ,start ,end))
+ (ERROR "Marks incorrectly related:" ,start ,end))
+ ,end))))))
(define-syntax default-start-mark
- (non-hygienic-macro-transformer
- (lambda (start end)
- `(IF (DEFAULT-OBJECT? ,start)
- (GROUP-START ,end)
- (BEGIN
- (IF (NOT (MARK<= ,start ,end))
- (ERROR "Marks incorrectly related:" ,start ,end))
- ,start)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((start (close-syntax (cadr form) environment))
+ (end (close-syntax (caddr form) environment)))
+ `(IF (DEFAULT-OBJECT? ,start)
+ (GROUP-START ,end)
+ (BEGIN
+ (IF (NOT (MARK<= ,start ,end))
+ (ERROR "Marks incorrectly related:" ,start ,end))
+ ,start))))))
(define-syntax default-case-fold-search
- (non-hygienic-macro-transformer
- (lambda (case-fold-search mark)
- `(IF (DEFAULT-OBJECT? ,case-fold-search)
- (GROUP-CASE-FOLD-SEARCH (MARK-GROUP ,mark))
- ,case-fold-search))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((case-fold-search (close-syntax (cadr form) environment))
+ (mark (close-syntax (caddr form) environment)))
+ `(IF (DEFAULT-OBJECT? ,case-fold-search)
+ (GROUP-CASE-FOLD-SEARCH (MARK-GROUP ,mark))
+ ,case-fold-search)))))
(define (search-forward string start #!optional end case-fold-search)
(%re-search string start (default-end-mark start end)
(mark-index end))))
(and index
(make-mark group index)))))
-
+\f
(define (re-match-forward regexp start #!optional end case-fold-search)
(let ((end (default-end-mark start end))
(case-fold-search (default-case-fold-search case-fold-search start))
(mark-index end))))
(and index
(make-mark group index)))))
-\f
+
(define (re-search-buffer-forward regexp syntax-table group start end)
(let ((index
((ucode-primitive re-search-buffer-forward)
;;; -*-Scheme-*-
;;;
-;;; $Id: schmod.scm,v 1.58 2001/12/20 21:28:00 cph Exp $
+;;; $Id: schmod.scm,v 1.59 2002/02/03 03:38:54 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
;;;
(symbol->string symbol)
method))
-(for-each (lambda (entry) (scheme-indent-method (car entry) (cdr entry)))
- `((BEGIN . 0)
- (CASE . 1)
- (DELAY . 0)
- (DO . 2)
- (LAMBDA . 1)
- (LET . ,scheme-mode:indent-let-method)
- (LET* . 1)
- (LETREC . 1)
+(for-each (lambda (entry)
+ (for-each (lambda (name) (scheme-indent-method name (car entry)))
+ (cdr entry)))
+ `(;; R4RS keywords:
+ (0 BEGIN DELAY)
+ (1 CASE LAMBDA LET* LETREC LET-SYNTAX LETREC-SYNTAX SYNTAX-RULES)
+ (2 DO)
+ (,scheme-mode:indent-let-method LET)
- (CALL-WITH-INPUT-FILE . 1)
- (WITH-INPUT-FROM-FILE . 1)
- (CALL-WITH-OUTPUT-FILE . 1)
- (WITH-OUTPUT-TO-FILE . 1)
+ ;; R4RS procedures:
+ (1 CALL-WITH-INPUT-FILE WITH-INPUT-FROM-FILE
+ CALL-WITH-OUTPUT-FILE WITH-OUTPUT-TO-FILE)
- ;; Remainder are MIT Scheme specific.
+ ;; MIT Scheme keywords:
+ (1 DEFINE-STRUCTURE FLUID-LET LET*-SYNTAX LOCAL-DECLARE
+ NAMED-LAMBDA)
- (DEFINE-STRUCTURE . 1)
- (FLUID-LET . 1)
- (LET-SYNTAX . 1)
- (LOCAL-DECLARE . 1)
- (NAMED-LAMBDA . 1)
-
- (CALL-WITH-APPEND-FILE . 1)
- (CALL-WITH-BINARY-APPEND-FILE . 1)
- (CALL-WITH-BINARY-INPUT-FILE . 1)
- (CALL-WITH-BINARY-OUTPUT-FILE . 1)
- (WITH-INPUT-FROM-PORT . 1)
- (WITH-INPUT-FROM-STRING . 1)
- (WITH-OUTPUT-TO-PORT . 1)
- (WITH-OUTPUT-TO-STRING . 0)
- (CALL-WITH-VALUES . 1)
- (WITH-VALUES . 1)
- (WITHIN-CONTINUATION . 1)
-
- (MAKE-CONDITION-TYPE . 3)
- (WITH-RESTART . 4)
- (WITH-SIMPLE-RESTART . 2)
- (BIND-CONDITION-HANDLER . 2)
- (KEEP-MATCHING-ITEMS . 1)
- (KEEP-MATCHING-ITEMS! . 1)
- (DELETE-MATCHING-ITEMS . 1)
- (DELETE-MATCHING-ITEMS! . 1)
- (FIND-MATCHING-ITEM . 1)
- (LIST-TRANSFORM-POSITIVE . 1)
- (LIST-TRANSFORM-NEGATIVE . 1)
- (LIST-SEARCH-POSITIVE . 1)
- (LIST-SEARCH-NEGATIVE . 1)
- (FOR-ALL? . 1)
- (THERE-EXISTS? . 1)))
+ ;; MIT Scheme procedures:
+ (0 WITH-OUTPUT-TO-STRING)
+ (1 CALL-WITH-APPEND-FILE CALL-WITH-BINARY-APPEND-FILE
+ CALL-WITH-BINARY-INPUT-FILE CALL-WITH-BINARY-OUTPUT-FILE
+ WITH-INPUT-FROM-PORT WITH-INPUT-FROM-STRING WITH-OUTPUT-TO-PORT
+ CALL-WITH-VALUES WITH-VALUES WITHIN-CONTINUATION
+ KEEP-MATCHING-ITEMS KEEP-MATCHING-ITEMS! DELETE-MATCHING-ITEMS
+ DELETE-MATCHING-ITEMS! FIND-MATCHING-ITEM
+ LIST-TRANSFORM-POSITIVE LIST-TRANSFORM-NEGATIVE
+ LIST-SEARCH-POSITIVE LIST-SEARCH-NEGATIVE
+ FOR-ALL? THERE-EXISTS?)
+ (2 WITH-SIMPLE-RESTART BIND-CONDITION-HANDLER)
+ (3 MAKE-CONDITION-TYPE)
+ (4 WITH-RESTART)))
(define scheme-mode:indent-regexps
`(SCHEME-MODE:INDENT-REGEXPS
;;; -*-Scheme-*-
;;;
-;;;$Id: search.scm,v 1.153 2001/12/23 17:20:58 cph Exp $
+;;;$Id: search.scm,v 1.154 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-1999, 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-1999, 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(declare (usual-integrations))
\f
(let-syntax
- ((define-forward-search
- (non-hygienic-macro-transformer
- (lambda (name find-next)
- `(DEFINE (,name GROUP START END CHAR)
- ;; Assume (FIX:<= START END)
- (AND (NOT (FIX:= START END))
- (COND ((FIX:<= END (GROUP-GAP-START GROUP))
- (,find-next (GROUP-TEXT GROUP) START END CHAR))
- ((FIX:<= (GROUP-GAP-START GROUP) START)
- (LET ((POSITION
- (,find-next
- (GROUP-TEXT GROUP)
- (FIX:+ START (GROUP-GAP-LENGTH GROUP))
- (FIX:+ END (GROUP-GAP-LENGTH GROUP))
- CHAR)))
- (AND POSITION
- (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
- ((,find-next (GROUP-TEXT GROUP)
- START
- (GROUP-GAP-START GROUP)
- CHAR))
- (ELSE
- (LET ((POSITION
- (,find-next (GROUP-TEXT GROUP)
- (GROUP-GAP-END GROUP)
- (FIX:+ END (GROUP-GAP-LENGTH GROUP))
- CHAR)))
- (AND POSITION
- (FIX:- POSITION
- (GROUP-GAP-LENGTH GROUP))))))))))))
-(define-forward-search group-find-next-char substring-find-next-char)
-(define-forward-search group-find-next-char-ci substring-find-next-char-ci)
-(define-forward-search group-find-next-char-in-set
- substring-find-next-char-in-set))
+ ((define-search
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (close-syntax (cadr form) environment))
+ (find-next (close-syntax (caddr form) environment)))
+ `(DEFINE (,name GROUP START END CHAR)
+ ;; Assume (FIX:<= START END)
+ (AND (NOT (FIX:= START END))
+ (COND ((FIX:<= END (GROUP-GAP-START GROUP))
+ (,find-next (GROUP-TEXT GROUP) START END CHAR))
+ ((FIX:<= (GROUP-GAP-START GROUP) START)
+ (LET ((POSITION
+ (,find-next
+ (GROUP-TEXT GROUP)
+ (FIX:+ START (GROUP-GAP-LENGTH GROUP))
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)))
+ (AND POSITION
+ (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
+ ((,find-next (GROUP-TEXT GROUP)
+ START
+ (GROUP-GAP-START GROUP)
+ CHAR))
+ (ELSE
+ (LET ((POSITION
+ (,find-next (GROUP-TEXT GROUP)
+ (GROUP-GAP-END GROUP)
+ (FIX:+ END
+ (GROUP-GAP-LENGTH GROUP))
+ CHAR)))
+ (AND POSITION
+ (FIX:- POSITION
+ (GROUP-GAP-LENGTH GROUP)))))))))))))
+ (define-search group-find-next-char substring-find-next-char)
+ (define-search group-find-next-char-ci substring-find-next-char-ci)
+ (define-search group-find-next-char-in-set substring-find-next-char-in-set))
(let-syntax
- ((define-backward-search
- (non-hygienic-macro-transformer
- (lambda (name find-previous)
- `(DEFINE (,name GROUP START END CHAR)
- ;; Assume (FIX:<= START END)
- (AND (NOT (FIX:= START END))
- (COND ((FIX:<= END (GROUP-GAP-START GROUP))
- (,find-previous (GROUP-TEXT GROUP) START END CHAR))
- ((FIX:<= (GROUP-GAP-START GROUP) START)
- (LET ((POSITION
- (,find-previous
- (GROUP-TEXT GROUP)
- (FIX:+ START (GROUP-GAP-LENGTH GROUP))
- (FIX:+ END (GROUP-GAP-LENGTH GROUP))
- CHAR)))
- (AND POSITION
- (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
- ((,find-previous (GROUP-TEXT GROUP)
- (GROUP-GAP-END GROUP)
- (FIX:+ END (GROUP-GAP-LENGTH GROUP))
- CHAR)
- => (LAMBDA (POSITION)
- (FIX:- POSITION (GROUP-GAP-LENGTH GROUP))))
- (else
- (,find-previous (GROUP-TEXT GROUP)
- START
- (GROUP-GAP-START GROUP)
- CHAR)))))))))
-(define-backward-search group-find-previous-char substring-find-previous-char)
-(define-backward-search group-find-previous-char-ci
- substring-find-previous-char-ci)
-(define-backward-search group-find-previous-char-in-set
- substring-find-previous-char-in-set))
-
+ ((define-search
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (close-syntax (cadr form) environment))
+ (find-previous (close-syntax (caddr form) environment)))
+ `(DEFINE (,name GROUP START END CHAR)
+ ;; Assume (FIX:<= START END)
+ (AND (NOT (FIX:= START END))
+ (COND ((FIX:<= END (GROUP-GAP-START GROUP))
+ (,find-previous (GROUP-TEXT GROUP) START END CHAR))
+ ((FIX:<= (GROUP-GAP-START GROUP) START)
+ (LET ((POSITION
+ (,find-previous
+ (GROUP-TEXT GROUP)
+ (FIX:+ START (GROUP-GAP-LENGTH GROUP))
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)))
+ (AND POSITION
+ (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
+ ((,find-previous (GROUP-TEXT GROUP)
+ (GROUP-GAP-END GROUP)
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)
+ => (LAMBDA (POSITION)
+ (FIX:- POSITION (GROUP-GAP-LENGTH GROUP))))
+ (else
+ (,find-previous (GROUP-TEXT GROUP)
+ START
+ (GROUP-GAP-START GROUP)
+ CHAR))))))))))
+ (define-search group-find-previous-char substring-find-previous-char)
+ (define-search group-find-previous-char-ci substring-find-previous-char-ci)
+ (define-search group-find-previous-char-in-set
+ substring-find-previous-char-in-set))
+\f
(define-integrable (%find-next-newline group start end)
(group-find-next-char group start end #\newline))
(let ((index (group-find-previous-char group end start #\newline)))
(and index
(fix:+ index 1))))
-\f
+
(define (group-match-substring-forward group start end
string string-start string-end)
(let ((text (group-text group))
(make-mark group index)))))
(define-syntax default-end-mark
- (non-hygienic-macro-transformer
- (lambda (start end)
- `(IF (DEFAULT-OBJECT? ,end)
- (GROUP-END ,start)
- (BEGIN
- (IF (NOT (MARK<= ,start ,end))
- (ERROR "Marks incorrectly related:" ,start ,end))
- ,end)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((start (close-syntax (cadr form) environment))
+ (end (close-syntax (caddr form) environment)))
+ `(IF (DEFAULT-OBJECT? ,end)
+ (GROUP-END ,start)
+ (BEGIN
+ (IF (NOT (MARK<= ,start ,end))
+ (ERROR "Marks incorrectly related:" ,start ,end))
+ ,end))))))
(define-syntax default-start-mark
- (non-hygienic-macro-transformer
- (lambda (start end)
- `(IF (DEFAULT-OBJECT? ,start)
- (GROUP-START ,end)
- (BEGIN
- (IF (NOT (MARK<= ,start ,end))
- (ERROR "Marks incorrectly related:" ,start ,end))
- ,start)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((start (close-syntax (cadr form) environment))
+ (end (close-syntax (caddr form) environment)))
+ `(IF (DEFAULT-OBJECT? ,start)
+ (GROUP-START ,end)
+ (BEGIN
+ (IF (NOT (MARK<= ,start ,end))
+ (ERROR "Marks incorrectly related:" ,start ,end))
+ ,start))))))
(define (char-match-forward char start #!optional end case-fold-search)
(and (mark< start (default-end-mark start end))
;;; -*-Scheme-*-
;;;
-;;; $Id: syntax.scm,v 1.88 2001/12/23 17:20:58 cph Exp $
+;;; $Id: syntax.scm,v 1.89 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;; Lisp Parsing
(define-syntax default-end/forward
- (non-hygienic-macro-transformer
- (lambda (start end)
- `(COND ((DEFAULT-OBJECT? ,end)
- (GROUP-END ,start))
- ((MARK<= ,start ,end)
- ,end)
- (ELSE
- (ERROR "Marks incorrectly related:" ,start ,end))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((start (close-syntax (cadr form) environment))
+ (end (close-syntax (caddr form) environment)))
+ `(IF (DEFAULT-OBJECT? ,end)
+ (GROUP-END ,start)
+ (BEGIN
+ (IF (NOT (MARK<= ,start ,end))
+ (ERROR "Marks incorrectly related:" ,start ,end))
+ ,end))))))
(define-syntax default-end/backward
- (non-hygienic-macro-transformer
- (lambda (start end)
- `(COND ((DEFAULT-OBJECT? ,end)
- (GROUP-START ,start))
- ((MARK>= ,start ,end)
- ,end)
- (ELSE
- (ERROR "Marks incorrectly related:" ,start ,end))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((start (close-syntax (cadr form) environment))
+ (end (close-syntax (caddr form) environment)))
+ `(IF (DEFAULT-OBJECT? ,end)
+ (GROUP-START ,start)
+ (BEGIN
+ (IF (NOT (MARK>= ,start ,end))
+ (ERROR "Marks incorrectly related:" ,start ,end))
+ ,end))))))
(define (forward-prefix-chars start #!optional end)
(let ((group (mark-group start))
#| -*-Scheme-*-
-$Id: tterm.scm,v 1.32 2001/12/23 17:20:58 cph Exp $
+$Id: tterm.scm,v 1.33 2002/02/03 03:38:54 cph Exp $
-Copyright (c) 1990-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1990-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(key-table false))
(let-syntax ((define-accessor
- (non-hygienic-macro-transformer
- (lambda (name)
- `(DEFINE-INTEGRABLE (,(symbol-append 'SCREEN- name) SCREEN)
- (,(symbol-append 'TERMINAL-STATE/ name)
- (SCREEN-STATE SCREEN))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE-INTEGRABLE
+ (,(close-syntax (symbol-append 'SCREEN- name)
+ environment)
+ SCREEN)
+ (,(close-syntax (symbol-append 'TERMINAL-STATE/ name)
+ environment)
+ (SCREEN-STATE SCREEN)))))))
(define-updater
- (non-hygienic-macro-transformer
- (lambda (name)
- `(DEFINE-INTEGRABLE
- (,(symbol-append 'SET-SCREEN- name '!) SCREEN ,name)
- (,(symbol-append 'SET-TERMINAL-STATE/ name '!)
- (SCREEN-STATE SCREEN)
- ,name))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ (let ((param (make-synthetic-identifier name)))
+ `(DEFINE-INTEGRABLE
+ (,(close-syntax (symbol-append 'SET-SCREEN- name '!)
+ environment)
+ SCREEN
+ ,param)
+ (,(close-syntax
+ (symbol-append 'SET-TERMINAL-STATE/ name '!)
+ environment)
+ (SCREEN-STATE SCREEN)
+ ,param))))))))
(define-accessor description)
(define-accessor baud-rate-index)
(define-accessor baud-rate)
;;; -*-Scheme-*-
;;;
-;;; $Id: utils.scm,v 1.50 2001/12/23 17:20:58 cph Exp $
+;;; $Id: utils.scm,v 1.51 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
standard-error-handler))
\f
(define-syntax chars-to-words-shift
- (non-hygienic-macro-transformer
- (lambda ()
+ (sc-macro-transformer
+ (lambda (form environment)
+ form environment
;; This is written as a macro so that the shift will be a constant
;; in the compiled code.
;; It does not work when cross-compiled!
;;; -*-Scheme-*-
;;;
-;;; $Id: utlwin.scm,v 1.59 1999/01/02 06:11:34 cph Exp $
+;;; $Id: utlwin.scm,v 1.60 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-1999, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
;;;; Utility Windows
())
(define-method vertical-border-window (:initialize! window window*)
- (usual=> window :initialize! window*)
+ (usual==> window :initialize! window*)
(set! x-size 1))
(define-method vertical-border-window (:set-x-size! window x)
(enabled?))
(define-method cursor-window (:initialize! window window*)
- (usual=> window :initialize! window*)
+ (usual==> window :initialize! window*)
(set! x-size 1)
(set! y-size 1)
(set! enabled? false))
;;; -*-Scheme-*-
;;;
-;;; $Id: window.scm,v 1.159 1999/01/02 06:11:34 cph Exp $
+;;; $Id: window.scm,v 1.160 2002/02/03 03:38:54 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-1999, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
;;;; Window System
(define (window-initialize! window window*)
(%set-window-superior! window window*)
(set-window-inferiors! window '())
- (%set-window-redisplay-flags! window
- (=> window* :inferior-redisplay-flags window)))
+ (%set-window-redisplay-flags!
+ window
+ (==> window* :inferior-redisplay-flags window)))
(define (window-kill! window)
- (for-each-inferior-window window (lambda (window) (=> window :kill!))))
+ (for-each-inferior-window window (lambda (window) (==> window :kill!))))
(define-integrable (window-superior window)
(with-instance-variables vanilla-window window () superior))
(define (set-window-superior! window window*)
(%set-window-superior! window window*)
- (let ((flags (=> window* :inferior-redisplay-flags window)))
+ (let ((flags (==> window* :inferior-redisplay-flags window)))
(%set-window-redisplay-flags! window flags)
(setup-redisplay-flags! flags)
(for-each-inferior window
(lambda (inferior)
(set-inferior-redisplay-flags! inferior (cons false flags))
- (=> (inferior-window inferior) :set-superior! window)))))
+ (==> (inferior-window inferior) :set-superior! window)))))
\f
(define (window-size window receiver)
(receiver (window-x-size window) (window-y-size window)))
false
(cons false (window-redisplay-flags window)))))
(set-window-inferiors! window (cons inferior (window-inferiors window)))
- (=> window* :initialize! window)
+ (==> window* :initialize! window)
inferior)))
(define (add-inferior! window window*)
false
(cons false (window-redisplay-flags window)))))
(set-window-inferiors! window (cons inferior (window-inferiors window)))
- (=> window* :set-superior! window)
+ (==> window* :set-superior! window)
inferior))
(define (delete-inferior! window window*)
(define (replace-inferior! window old new)
(set-inferior-window! (find-inferior (window-inferiors window) old) new)
- (=> new :set-superior! window))
+ (==> new :set-superior! window))
\f
;;; Returns #T if the redisplay finished, #F if aborted.
;;; Notice that the :UPDATE-DISPLAY! operation is assumed to return
(lambda (window screen x-start y-start xl xu yl yu display-style)
(and (or (display-style/ignore-input? display-style)
(not ((editor-halt-update? current-editor))))
- (=> window :update-display! screen x-start y-start xl xu yl yu
- display-style)))))
+ (==> window :update-display! screen x-start y-start xl xu yl yu
+ display-style)))))
(define (update-inferiors! inferiors screen x-start y-start xl xu yl yu
display-style updater)
(if (fix:< 0 bs) (receiver 0 bs) true))))
(define (salvage-inferiors! window)
- (for-each-inferior-window window (lambda (window) (=> window :salvage!))))
+ (for-each-inferior-window window (lambda (window) (==> window :salvage!))))
(define (display-style/discard-screen-contents? display-style)
(if (pair? display-style)
(%set-window-x-size! (inferior-window inferior) x))
(define-integrable (set-inferior-x-size! inferior x)
- (=> (inferior-window inferior) :set-x-size! x))
+ (==> (inferior-window inferior) :set-x-size! x))
(define-integrable (inferior-y-size inferior)
(window-y-size (inferior-window inferior)))
(%set-window-y-size! (inferior-window inferior) y))
(define-integrable (set-inferior-y-size! inferior y)
- (=> (inferior-window inferior) :set-y-size! y))
+ (==> (inferior-window inferior) :set-y-size! y))
(define-integrable (inferior-size inferior receiver)
(window-size (inferior-window inferior) receiver))
(define-integrable (set-inferior-size! inferior x y)
- (=> (inferior-window inferior) :set-size! x y))
+ (==> (inferior-window inferior) :set-size! x y))
(define (find-inferior? inferiors window)
(let loop ((inferiors inferiors))
;;; -*-Scheme-*-
;;;
-;;; $Id: xcom.scm,v 1.19 2001/12/23 17:20:58 cph Exp $
+;;; $Id: xcom.scm,v 1.20 2002/02/03 03:38:55 cph Exp $
;;;
-;;; Copyright (c) 1989-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1989-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(let-syntax
((copy
- (non-hygienic-macro-transformer
- (lambda (name)
- `(DEFINE ,(symbol-append 'EDWIN-COMMAND$X- name)
- ,(symbol-append 'EDWIN-COMMAND$ name))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE
+ ,(close-syntax (symbol-append 'EDWIN-COMMAND$X- name)
+ environment)
+ ,(close-syntax (symbol-append 'EDWIN-COMMAND$ name)
+ environment)))))))
(copy set-foreground-color)
(copy set-background-color)
(copy set-border-color)
(let-syntax
((copy
- (non-hygienic-macro-transformer
- (lambda (name)
- `(DEFINE ,(symbol-append 'EDWIN-VARIABLE$X-SCREEN- name)
- ,(symbol-append 'EDWIN-VARIABLE$FRAME- name))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE
+ ,(close-syntax (symbol-append 'EDWIN-VARIABLE$X-SCREEN- name)
+ environment)
+ ,(close-syntax (symbol-append 'EDWIN-VARIABLE$FRAME- name)
+ environment)))))))
(copy icon-name-format)
(copy icon-name-length))
;;; -*-Scheme-*-
;;;
-;;;$Id: xform.scm,v 1.11 2001/12/19 01:44:43 cph Exp $
+;;;$Id: xform.scm,v 1.12 2002/02/03 03:38:55 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989, 1990, 1999, 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(let ((entry (assq (scode-variable-name variable) transforms)))
(if (not entry)
variable
- (make-combination vector-ref
- (list (make-scode-variable name-of-self)
- (cdr entry))))))
+ (make-combination vector-ref (list name-of-self (cdr entry))))))
(define (transform-assignment transforms assignment)
(assignment-components assignment
(if (not entry)
(make-assignment name value)
(make-combination vector-set!
- (list (make-scode-variable name-of-self)
+ (list name-of-self
(cdr entry)
value)))))))
/* -*-C-*-
-$Id: i386.h,v 1.34 2001/12/19 19:53:46 cph Exp $
+$Id: i386.h,v 1.35 2002/02/03 03:38:55 cph Exp $
-Copyright (c) 1992-2001 Massachusetts Institute of Technology
+Copyright (c) 1992-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
{
extern int EXFUN (ASM_ENTRY_POINT(i386_interface_initialize), (void));
extern void EXFUN (declare_builtin, (unsigned long, char *));
- extern int ia32_cpuid_needed;
int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT)));
unsigned char * esi_value = ((unsigned char *) (&Registers[0]));
int fp_support_present = (i386_interface_initialize ());
#| -*-Scheme-*-
-$Id: os2pm.scm,v 1.10 2001/12/23 17:20:59 cph Exp $
+$Id: os2pm.scm,v 1.11 2002/02/03 03:38:55 cph Exp $
-Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1995-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
;;;; Syntax
(define-syntax define-pm-procedure
- (non-hygienic-macro-transformer
- (lambda (name . clauses)
- (let ((external-name (if (pair? name) (car name) name))
- (internal-name (if (pair? name) (cadr name) name)))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((external-name
+ (if (pair? (cadr form)) (car (cadr form)) (cadr form)))
+ (internal-name
+ (if (pair? (cadr form)) (cadr (cadr form)) (cadr form)))
+ (clauses (cddr form)))
`(BEGIN
(HASH-TABLE/PUT! PM-PROCEDURES ',external-name
(MAKE-PMP (TRANSLATE-NAME ',external-name)
;;; -*-Scheme-*-
;;;
-;;; $Id: utabmd.scm,v 9.82 2001/12/23 17:20:59 cph Exp $
+;;; $Id: utabmd.scm,v 9.83 2002/02/03 03:38:55 cph Exp $
;;;
-;;; Copyright (c) 1987-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1987-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; [] System-call names
(define-syntax ucode-primitive
- (non-hygienic-macro-transformer
- (lambda args
- (apply make-primitive-procedure args))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply make-primitive-procedure (cdr form)))))
(vector-set! (get-fixed-objects-vector)
#x09 ;(fixed-objects-vector-slot 'SYSTEM-CALL-NAMES)
;;; This identification string is saved by the system.
-"$Id: utabmd.scm,v 9.82 2001/12/23 17:20:59 cph Exp $"
+"$Id: utabmd.scm,v 9.83 2002/02/03 03:38:55 cph Exp $"
#| -*-Scheme-*-
-$Id: apply.scm,v 1.4 2001/12/23 17:20:59 cph Exp $
+$Id: apply.scm,v 1.5 2002/02/03 03:38:55 cph Exp $
-Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1992, 1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
;;; at boot time, and this code replaces it.
(define (apply-2 f a0)
- (define (fail)
- (error "apply: Improper argument list" a0))
-
- (let-syntax ((apply-dispatch&bind
- (non-hygienic-macro-transformer
- (lambda (var clause . clauses)
- (if (null? clauses)
- (cadr clause)
- (let walk ((lv var)
- (clause clause)
- (clauses clauses))
- `(if (not (pair? ,lv))
- (if (null? ,lv)
- ,(cadr clause)
- (fail))
- ,(if (null? (cdr clauses))
- (cadr (car clauses))
- (let ((lv* (generate-uninterned-symbol))
- (av* (car clause)))
- `(let ((,lv* (cdr ,lv))
- (,av* (car ,lv)))
- ,(walk lv* (car clauses)
- (cdr clauses))))))))))))
- (apply-dispatch&bind a0
- (v0 (f))
- (v1 (f v0))
- (v2 (f v0 v1))
- (v3 (f v0 v1 v2))
- (v4 (f v0 v1 v2 v3))
- (v5 (f v0 v1 v2 v3 v4))
- #|
+ (let ((fail (lambda () (error "apply: Improper argument list" a0))))
+ (let-syntax
+ ((apply-dispatch&bind
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((var (close-syntax (cadr form) environment))
+ (clause (caddr form))
+ (clauses (cdddr form)))
+ (if (pair? clauses)
+ (let walk
+ ((lv var)
+ (clause clause)
+ (clauses clauses)
+ (free '()))
+ `(COND ((PAIR? ,lv)
+ ,(if (pair? (cdr clauses))
+ (let ((av (car clause))
+ (lv* (make-synthetic-identifier 'L)))
+ `(LET ((,av (CAR ,lv))
+ (,lv* (CDR ,lv)))
+ ,(walk lv*
+ (car clauses)
+ (cdr clauses)
+ (cons av free))))
+ (make-syntactic-closure environment free
+ (cadr (car clauses)))))
+ ((NULL? ,lv)
+ ,(make-syntactic-closure environment free
+ (cadr clause)))
+ (ELSE (FAIL))))
+ (make-syntactic-closure environment '() (cadr clause))))))))
+ (apply-dispatch&bind a0
+ (v0 (f))
+ (v1 (f v0))
+ (v2 (f v0 v1))
+ (v3 (f v0 v1 v2))
+ (v4 (f v0 v1 v2 v3))
+ (v5 (f v0 v1 v2 v3 v4))
+ #|
(v6 (f v0 v1 v2 v3 v4 v5))
(v7 (f v0 v1 v2 v3 v4 v5 v6))
|#
- (else ((ucode-primitive apply) f a0)))))
+ (else ((ucode-primitive apply) f a0))))))
(define (apply-entity-procedure self f . args)
- ;; This is safe because args is a newly-consed list
- ;; shared with no other code (modulo debugging).
-
- (define (splice! last next)
- (if (null? (cdr next))
- (set-cdr! last (car next))
- (splice! next (cdr next))))
-
self ; ignored
(apply-2 f
- (cond ((null? args) '())
- ((null? (cdr args))
- (car args))
- (else
- (splice! args (cdr args))
- args))))
+ (if (pair? args)
+ (if (pair? (cdr args))
+ (begin
+ ;; This is safe because args is a newly-consed list
+ ;; shared with no other code (modulo debugging).
+ (let loop ((last args) (next (cdr args)))
+ (if (pair? (cdr next))
+ (loop next (cdr next))
+ (set-cdr! last (car next))))
+ args)
+ (car args))
+ '())))
(define (initialize-package!)
(set! apply
apply-entity-procedure
(vector (fixed-objects-item 'ARITY-DISPATCHER-TAG)
(lambda ()
- (error "apply needs at least one argument"))
- (lambda (f)
- (f))
+ (error:wrong-number-of-arguments apply '(1 . #F) '()))
+ (lambda (f) (f))
apply-2)))
unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: arith.scm,v 1.48 2001/12/23 17:20:59 cph Exp $
+$Id: arith.scm,v 1.49 2002/02/03 03:38:55 cph Exp $
-Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1989-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
;;;; Utilities
(define-syntax copy
- (non-hygienic-macro-transformer
- (lambda (x)
- `(LOCAL-DECLARE ((INTEGRATE ,x)) ,x))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(IDENTIFIER) (cdr form))
+ (let ((identifier (close-syntax (cadr form) environment)))
+ `(LOCAL-DECLARE ((INTEGRATE ,identifier)) ,identifier))
+ (ill-formed-syntax form)))))
;;;; Primitives
(let-syntax
((commutative
- (non-hygienic-macro-transformer
- (lambda (name generic-binary identity primitive-binary)
- `(SET! ,name
- (MAKE-ENTITY
- (NAMED-LAMBDA (,name SELF . ZS)
- SELF ; ignored
- (REDUCE ,generic-binary ,identity ZS))
- (VECTOR
- (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
- (NAMED-LAMBDA (,(symbol-append 'NULLARY- name))
- ,identity)
- (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z)
- (IF (NOT (COMPLEX:COMPLEX? Z))
- (ERROR:WRONG-TYPE-ARGUMENT Z FALSE ',name))
- Z)
- (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2)
- ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2)))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1))
+ (identity (close-syntax (list-ref form 3) environment)))
+ `(SET! ,name
+ (MAKE-ENTITY
+ (NAMED-LAMBDA (,name SELF . ZS)
+ SELF ; ignored
+ (REDUCE ,(close-syntax (list-ref form 2) environment)
+ ,identity
+ ZS))
+ (VECTOR
+ (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
+ (NAMED-LAMBDA (,(symbol-append 'NULLARY- name))
+ ,identity)
+ (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z)
+ (IF (NOT (COMPLEX:COMPLEX? Z))
+ (ERROR:WRONG-TYPE-ARGUMENT Z "number" ',name))
+ Z)
+ (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2)
+ ((UCODE-PRIMITIVE ,(list-ref form 4)) Z1 Z2))))))))))
(commutative + complex:+ 0 &+)
(commutative * complex:* 1 &*))
(let-syntax
((non-commutative
- (non-hygienic-macro-transformer
- (lambda (name generic-unary generic-binary
- generic-inverse inverse-identity primitive-binary)
- `(SET! ,name
- (MAKE-ENTITY
- (NAMED-LAMBDA (,name SELF Z1 . ZS)
- SELF ; ignored
- (,generic-binary
- Z1
- (REDUCE ,generic-inverse ,inverse-identity ZS)))
- (VECTOR
- (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
- #F
- ,generic-unary
- (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2)
- ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2)))))))))
- (non-commutative - complex:negate complex:- complex:+ 0 &-)
- (non-commutative / complex:invert complex:/ complex:* 1 &/))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1)))
+ `(SET! ,name
+ (MAKE-ENTITY
+ (NAMED-LAMBDA (,name SELF Z1 . ZS)
+ SELF ; ignored
+ (,(close-syntax (list-ref form 3) environment)
+ Z1
+ (REDUCE ,(close-syntax (list-ref form 4) environment)
+ ,(close-syntax (list-ref form 5) environment)
+ ZS)))
+ (VECTOR
+ (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
+ #F
+ ,(close-syntax (list-ref form 2) environment)
+ (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2)
+ ((UCODE-PRIMITIVE ,(list-ref form 6)) Z1 Z2))))))))))
+ (non-commutative - complex:negate complex:- complex:+ 0 &-)
+ (non-commutative / complex:invert complex:/ complex:* 1 &/))
\f
(let-syntax
((relational
- (non-hygienic-macro-transformer
- (lambda (name generic-binary primitive-binary correct-type? negated?)
- `(SET! ,name
- (MAKE-ENTITY
- (NAMED-LAMBDA (,name SELF . ZS)
- SELF ; ignored
- (REDUCE-COMPARATOR ,generic-binary ZS ',name))
- (VECTOR
- (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
- (NAMED-LAMBDA (,(symbol-append 'NULLARY- name)) #T)
- (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z)
- (IF (NOT (,correct-type? Z))
- (ERROR:WRONG-TYPE-ARGUMENT Z FALSE ',name))
- #T)
- ,(if negated?
- `(NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2)
- (NOT ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2)))
- `(NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2)
- ((UCODE-PRIMITIVE ,primitive-binary)
- Z1 Z2))))))))))
- (relational = complex:= &= complex:complex? #F)
- (relational < complex:< &< complex:real? #F)
- (relational > complex:> &> complex:real? #F)
- (relational <= (lambda (x y) (not (complex:< y x))) &> complex:real? #T)
- (relational >= (lambda (x y) (not (complex:< x y))) &< complex:real? #T))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1))
+ (type (list-ref form 4)))
+ `(SET! ,name
+ (MAKE-ENTITY
+ (NAMED-LAMBDA (,name SELF . ZS)
+ SELF ; ignored
+ (REDUCE-COMPARATOR
+ ,(close-syntax (list-ref form 2) environment)
+ ZS ',name))
+ (VECTOR
+ (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
+ (NAMED-LAMBDA (,(symbol-append 'NULLARY- name)) #T)
+ (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z)
+ (IF (NOT (,(intern (string-append "complex:" type "?"))
+ Z))
+ (ERROR:WRONG-TYPE-ARGUMENT
+ Z ,(string-append type " number") ',name))
+ #T)
+ (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2)
+ ,(let ((p
+ `((UCODE-PRIMITIVE ,(list-ref form 3)) Z1 Z2)))
+ (if (list-ref form 5)
+ `(NOT ,p)
+ p)))))))))))
+ (relational = complex:= &= "complex" #F)
+ (relational < complex:< &< "real" #F)
+ (relational > complex:> &> "real" #F)
+ (relational <= (lambda (x y) (not (complex:< y x))) &> "real" #T)
+ (relational >= (lambda (x y) (not (complex:< x y))) &< "real" #T))
(let-syntax
((max/min
- (non-hygienic-macro-transformer
- (lambda (name generic-binary)
- `(SET! ,name
- (MAKE-ENTITY
- (NAMED-LAMBDA (,name SELF X . XS)
- SELF ; ignored
- (REDUCE-MAX/MIN ,generic-binary X XS ',name))
- (VECTOR
- (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
- #F
- (NAMED-LAMBDA (,(symbol-append 'UNARY- name) X)
- (IF (NOT (COMPLEX:REAL? X))
- (ERROR:WRONG-TYPE-ARGUMENT X FALSE ',name))
- X)
- ,generic-binary)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1))
+ (generic-binary (close-syntax (list-ref form 2) environment)))
+ `(SET! ,name
+ (MAKE-ENTITY
+ (NAMED-LAMBDA (,name SELF X . XS)
+ SELF ; ignored
+ (REDUCE-MAX/MIN ,generic-binary X XS ',name))
+ (VECTOR
+ (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
+ #F
+ (NAMED-LAMBDA (,(symbol-append 'UNARY- name) X)
+ (IF (NOT (COMPLEX:REAL? X))
+ (ERROR:WRONG-TYPE-ARGUMENT X "real number" ',name))
+ X)
+ ,generic-binary))))))))
(max/min max complex:max)
(max/min min complex:min))
(let-syntax
((define-addition-operator
- (non-hygienic-macro-transformer
- (lambda (name int:op)
- `(define (,name u/u* v/v*)
- (rat:binary-operator u/u* v/v*
- ,int:op
- (lambda (u v v*)
- (make-rational (,int:op (int:* u v*) v) v*))
- (lambda (u u* v)
- (make-rational (,int:op u (int:* v u*)) u*))
- (lambda (u u* v v*)
- (let ((d1 (int:gcd u* v*)))
- (if (int:= d1 1)
- (make-rational (,int:op (int:* u v*) (int:* v u*))
- (int:* u* v*))
- (let* ((u*/d1 (int:quotient u* d1))
- (t
- (,int:op (int:* u (int:quotient v* d1))
- (int:* v u*/d1))))
- (if (int:zero? t)
- 0 ;(make-rational 0 1)
- (let ((d2 (int:gcd t d1)))
- (make-rational
- (int:quotient t d2)
- (int:* u*/d1 (int:quotient v* d2)))))))))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (close-syntax (list-ref form 1) environment))
+ (int:op (close-syntax (list-ref form 2) environment)))
+ `(DEFINE (,name U/U* V/V*)
+ (RAT:BINARY-OPERATOR U/U* V/V*
+ ,int:op
+ (LAMBDA (U V V*)
+ (MAKE-RATIONAL (,int:op (INT:* U V*) V) V*))
+ (LAMBDA (U U* V)
+ (MAKE-RATIONAL (,int:op U (INT:* V U*)) U*))
+ (LAMBDA (U U* V V*)
+ (LET ((D1 (INT:GCD U* V*)))
+ (IF (INT:= D1 1)
+ (MAKE-RATIONAL (,int:op (INT:* U V*) (INT:* V U*))
+ (INT:* U* V*))
+ (LET* ((U*/D1 (INT:QUOTIENT U* D1))
+ (T
+ (,int:op (INT:* U (INT:QUOTIENT V* D1))
+ (INT:* V U*/D1))))
+ (IF (INT:ZERO? T)
+ 0 ;(MAKE-RATIONAL 0 1)
+ (LET ((D2 (INT:GCD T D1)))
+ (MAKE-RATIONAL
+ (INT:QUOTIENT T D2)
+ (INT:* U*/D1
+ (INT:QUOTIENT V* D2))))))))))))))))
(define-addition-operator rat:+ int:+)
(define-addition-operator rat:- int:-))
(let-syntax
((define-integer-coercion
- (non-hygienic-macro-transformer
- (lambda (name operation-name coercion)
- `(DEFINE (,name Q)
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) Q)
(COND ((RATNUM? Q)
- (,coercion (RATNUM-NUMERATOR Q) (RATNUM-DENOMINATOR Q)))
+ (,(close-syntax (list-ref form 3) environment)
+ (RATNUM-NUMERATOR Q)
+ (RATNUM-DENOMINATOR Q)))
((INT:INTEGER? Q) Q)
(ELSE
- (ERROR:WRONG-TYPE-ARGUMENT Q FALSE ',operation-name))))))))
+ (ERROR:WRONG-TYPE-ARGUMENT Q
+ "real number"
+ ',(list-ref form 2)))))))))
(define-integer-coercion rat:floor floor int:floor)
(define-integer-coercion rat:ceiling ceiling int:ceiling)
(define-integer-coercion rat:truncate truncate int:quotient)
(let-syntax
((define-standard-unary
- (non-hygienic-macro-transformer
- (lambda (name flo:op rat:op)
- `(DEFINE (,name X)
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) X)
(IF (FLONUM? X)
- (,flo:op X)
- (,rat:op X)))))))
+ (,(close-syntax (list-ref form 2) environment) X)
+ (,(close-syntax (list-ref form 3) environment) X)))))))
(define-standard-unary real:1+ (lambda (x) (flo:+ x flo:1)) (copy rat:1+))
(define-standard-unary real:-1+ (lambda (x) (flo:- x flo:1)) (copy rat:-1+))
(define-standard-unary real:negate flo:negate (copy rat:negate))
\f
(let-syntax
((define-standard-binary
- (non-hygienic-macro-transformer
- (lambda (name flo:op rat:op)
- `(DEFINE (,name X Y)
- (IF (FLONUM? X)
- (IF (FLONUM? Y)
- (,flo:op X Y)
- (,flo:op X (RAT:->INEXACT Y)))
- (IF (FLONUM? Y)
- (,flo:op (RAT:->INEXACT X) Y)
- (,rat:op X Y))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((flo:op (close-syntax (list-ref form 2) environment))
+ (rat:op (close-syntax (list-ref form 3) environment)))
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) X Y)
+ (IF (FLONUM? X)
+ (IF (FLONUM? Y)
+ (,flo:op X Y)
+ (,flo:op X (RAT:->INEXACT Y)))
+ (IF (FLONUM? Y)
+ (,flo:op (RAT:->INEXACT X) Y)
+ (,rat:op X Y)))))))))
(define-standard-binary real:+ flo:+ (copy rat:+))
(define-standard-binary real:- flo:- (copy rat:-))
(define-standard-binary real:rationalize
(let-syntax
((define-integer-binary
- (non-hygienic-macro-transformer
- (lambda (name operator-name operator)
- (let ((flo->int
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((operator (close-syntax (list-ref form 3) environment))
+ (flo->int
(lambda (n)
`(IF (FLO:INTEGER? ,n)
(FLO:->INTEGER ,n)
- (ERROR:WRONG-TYPE-ARGUMENT ,n FALSE ',operator-name)))))
- `(DEFINE (,name N M)
+ (ERROR:WRONG-TYPE-ARGUMENT ,n "integer"
+ ',(list-ref form 2))))))
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) N M)
(IF (FLONUM? N)
(INT:->INEXACT
(,operator ,(flo->int 'N)
(let-syntax
((define-rational-unary
- (non-hygienic-macro-transformer
- (lambda (name operator)
- `(DEFINE (,name Q)
- (IF (FLONUM? Q)
- (RAT:->INEXACT (,operator (FLO:->RATIONAL Q)))
- (,operator Q)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((operator (close-syntax (list-ref form 2) environment)))
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) Q)
+ (IF (FLONUM? Q)
+ (RAT:->INEXACT (,operator (FLO:->RATIONAL Q)))
+ (,operator Q))))))))
(define-rational-unary real:numerator rat:numerator)
(define-rational-unary real:denominator rat:denominator))
\f
(let-syntax
((define-transcendental-unary
- (non-hygienic-macro-transformer
- (lambda (name hole? hole-value function)
- `(DEFINE (,name X)
- (IF (,hole? X)
- ,hole-value
- (,function (REAL:->INEXACT X))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(DEFINE (,(close-syntax (list-ref form 1) environment) X)
+ (IF (,(close-syntax (list-ref form 2) environment) X)
+ ,(close-syntax (list-ref form 3) environment)
+ (,(close-syntax (list-ref form 4) environment)
+ (REAL:->INEXACT X))))))))
(define-transcendental-unary real:exp real:exact0= 1 flo:exp)
(define-transcendental-unary real:log real:exact1= 0 flo:log)
(define-transcendental-unary real:sin real:exact0= 0 flo:sin)
#| -*-Scheme-*-
-$Id: debug.scm,v 14.42 2001/12/23 17:20:59 cph Exp $
+$Id: debug.scm,v 14.43 2002/02/03 03:38:55 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(define command-set)
(define-syntax define-command
- (non-hygienic-macro-transformer
- (lambda (bvl . body)
- (let ((dstate (cadr bvl))
- (port (caddr bvl)))
- `(DEFINE (,(car bvl) #!OPTIONAL ,dstate ,port)
- (LET ((,dstate (IF (DEFAULT-OBJECT? ,dstate) *DSTATE* ,dstate))
- (,port (IF (DEFAULT-OBJECT? ,port) *PORT* ,port)))
- ,@body))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '((IDENTIFIER IDENTIFIER IDENTIFIER) + EXPRESSION)
+ (cdr form))
+ (let ((dstate (cadr (cadr form)))
+ (port (caddr (cadr form))))
+ `(DEFINE (,(car (cadr form)) #!OPTIONAL ,dstate ,port)
+ (LET ((,dstate (IF (DEFAULT-OBJECT? ,dstate) *DSTATE* ,dstate))
+ (,port (IF (DEFAULT-OBJECT? ,port) *PORT* ,port)))
+ ,@(map (let ((free (list dstate port)))
+ (lambda (expression)
+ (make-syntactic-closure environment free
+ expression)))
+ (cddr form)))))
+ (ill-formed-syntax form)))))
\f
;;;; Display commands
#| -*-Scheme-*-
-$Id: defstr.scm,v 14.37 2002/01/12 02:56:14 cph Exp $
+$Id: defstr.scm,v 14.38 2002/02/03 03:38:55 cph Exp $
Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
|#
\f
-(define-syntax define-structure
- (non-hygienic-macro-transformer
- (lambda (name-and-options . slot-descriptions)
- (let ((structure
- (with-values
- (lambda ()
- (if (pair? name-and-options)
- (values (car name-and-options) (cdr name-and-options))
- (values name-and-options '())))
- (lambda (name options)
- (parse/options name
- options
- (map parse/slot-description
- slot-descriptions))))))
- (do ((slots (structure/slots structure) (cdr slots))
- (index (if (structure/named? structure)
- (+ (structure/offset structure) 1)
- (structure/offset structure))
- (+ index 1)))
- ((null? slots))
- (set-slot/index! (car slots) index))
- `(BEGIN ,@(type-definitions structure)
- ,@(constructor-definitions structure)
- ,@(accessor-definitions structure)
- ,@(modifier-definitions structure)
- ,@(predicate-definitions structure)
- ,@(copier-definitions structure))))))
+(define-expander 'DEFINE-STRUCTURE system-global-environment
+ (lambda (form environment closing-environment)
+ (if (not (and (pair? (cdr form)) (list? (cddr form))))
+ (error "Ill-formed special form:" form))
+ (make-syntactic-closure closing-environment '()
+ (let ((name-and-options (cadr form))
+ (slot-descriptions (cddr form)))
+ (let ((structure
+ (call-with-values
+ (lambda ()
+ (if (pair? name-and-options)
+ (values (car name-and-options) (cdr name-and-options))
+ (values name-and-options '())))
+ (lambda (name options)
+ (if (not (symbol? name))
+ (error "Structure name must be a symbol:" name))
+ (if (not (list? options))
+ (error "Structure options must be a list:" options))
+ (let ((context
+ (make-parser-context name
+ environment
+ closing-environment)))
+ (parse/options options
+ (parse/slot-descriptions slot-descriptions)
+ context))))))
+ `(BEGIN ,@(type-definitions structure)
+ ,@(constructor-definitions structure)
+ ,@(accessor-definitions structure)
+ ,@(modifier-definitions structure)
+ ,@(predicate-definitions structure)
+ ,@(copier-definitions structure)))))))
\f
-;;;; Parse Options
-
-;; These two names are separated to cross-syntaxing from #F=='() to
-;; #F != '()
+;;;; Parse options
+
+(define (parse/options options slots context)
+ (let ((options (apply-option-transformers options context)))
+ (let ((conc-name-option (find-option 'CONC-NAME options))
+ (constructor-options (find-options 'CONSTRUCTOR options))
+ (keyword-constructor-options
+ (find-options 'KEYWORD-CONSTRUCTOR options))
+ (copier-option (find-option 'COPIER options))
+ (predicate-option (find-option 'PREDICATE options))
+ (print-procedure-option (find-option 'PRINT-PROCEDURE options))
+ (type-option (find-option 'TYPE options))
+ (type-descriptor-option (find-option 'TYPE-DESCRIPTOR options))
+ (named-option (find-option 'NAMED options))
+ (safe-accessors-option (find-option 'SAFE-ACCESSORS options))
+ (initial-offset-option (find-option 'INITIAL-OFFSET options)))
+ (check-for-duplicate-constructors constructor-options
+ keyword-constructor-options)
+ (if (and type-descriptor-option named-option)
+ (error "Conflicting structure options:"
+ (option/original type-descriptor-option)
+ (option/original named-option)))
+ (let ((tagged?
+ (or (not type-option)
+ type-descriptor-option
+ named-option))
+ (offset
+ (if initial-offset-option
+ (option/argument initial-offset-option)
+ 0)))
+ (if (not type-option)
+ (check-for-illegal-untyped named-option initial-offset-option))
+ (if (not tagged?)
+ (check-for-illegal-untagged predicate-option
+ print-procedure-option))
+ (do ((slots slots (cdr slots))
+ (index (if tagged? (+ offset 1) offset) (+ index 1)))
+ ((not (pair? slots)))
+ (set-slot/index! (car slots) index))
+ (call-with-values
+ (lambda ()
+ (compute-tagging-info type-descriptor-option
+ named-option
+ context))
+ (lambda (type-name tag-expression)
+ (make-structure context
+ (if conc-name-option
+ (option/argument conc-name-option)
+ (default-conc-name context))
+ (compute-constructors constructor-options
+ keyword-constructor-options
+ context)
+ (map option/arguments keyword-constructor-options)
+ (and copier-option (option/argument copier-option))
+ (if predicate-option
+ (option/argument predicate-option)
+ (and tagged? (default-predicate-name context)))
+ (if print-procedure-option
+ (option/argument print-procedure-option)
+ (and type-option
+ (default-unparser-text context)))
+ (if type-option
+ (option/argument type-option)
+ 'RECORD)
+ tagged?
+ (and tagged? type-name)
+ (and tagged? tag-expression)
+ (and safe-accessors-option
+ (option/argument safe-accessors-option))
+ offset
+ slots)))))))
+\f
+(define (find-option keyword options)
+ (find-matching-item options
+ (lambda (option)
+ (eq? (option/keyword option) keyword))))
+
+(define (find-options keyword options)
+ (keep-matching-items options
+ (lambda (option)
+ (eq? (option/keyword option) keyword))))
+
+(define (check-for-duplicate-constructors constructor-options
+ keyword-constructor-options)
+ (let loop
+ ((options (append constructor-options keyword-constructor-options)))
+ (if (pair? options)
+ (let ((option (car options))
+ (options (cdr options)))
+ (let ((conflict
+ (let ((name (car (option/arguments option))))
+ (and name
+ (find-matching-item options
+ (lambda (option*)
+ (eq? (car (option/arguments option*))
+ name)))))))
+ (if conflict
+ (error "Conflicting constructor definitions:"
+ (option/original option)
+ (option/original conflict))))
+ (loop options)))))
+
+(define (check-for-illegal-untyped named-option initial-offset-option)
+ (let ((lose
+ (lambda (option)
+ (error "Structure option illegal without TYPE option:"
+ (option/original option)))))
+ (if (and named-option
+ (let ((arguments (option/arguments named-option)))
+ (and (pair? arguments)
+ (not (car arguments)))))
+ (lose named-option))
+ (if initial-offset-option
+ (lose initial-offset-option))))
+
+(define (check-for-illegal-untagged predicate-option print-procedure-option)
+ (let ((test
+ (lambda (option)
+ (if (and option
+ (let ((arguments (option/arguments option)))
+ (and (pair? arguments)
+ (car arguments))))
+ (error "Structure option illegal for unnamed structure:"
+ (option/original option))))))
+ (test predicate-option)
+ (test print-procedure-option)))
+
+(define (compute-constructors constructor-options
+ keyword-constructor-options
+ context)
+ (let* ((constructors (map option/arguments constructor-options))
+ (constructors* (delete '(#F) constructors)))
+ (cond ((or (pair? keyword-constructor-options)
+ (pair? constructors*))
+ constructors*)
+ ((member '(#F) constructors) '())
+ (else (list (list (default-constructor-name context)))))))
+
+(define (compute-tagging-info type-descriptor-option named-option context)
+ (let ((single (lambda (name) (values name name))))
+ (cond (type-descriptor-option
+ (single (option/argument type-descriptor-option)))
+ (named-option
+ (let ((arguments (option/arguments named-option)))
+ (if (pair? arguments)
+ (values #f (car arguments))
+ (single (default-type-name context)))))
+ (else
+ (single (default-type-name context))))))
+\f
+(define (false-expression? object context)
+ (or (let loop ((object object))
+ (or (not object)
+ (and (syntactic-closure? object)
+ (loop (syntactic-closure/form object)))))
+ (and (identifier? object)
+ (there-exists? false-expression-names
+ (lambda (name)
+ (identifier=? (parser-context/environment context)
+ object
+ (parser-context/closing-environment context)
+ name))))))
+
+(define (false-marker? object)
+ (or (not object)
+ (memq object false-expression-names)))
+
+(define false-expression-names
+ '(FALSE NIL))
+
+(define (true-marker? object)
+ (or (eq? #t object)
+ (memq object true-expression-names)))
+
+(define true-expression-names
+ '(TRUE T))
+
+(define (option/argument option)
+ (car (option/arguments option)))
+
+(define (default-conc-name context)
+ (symbol-append (parser-context/name context) '-))
+
+(define (default-constructor-name context)
+ (close (symbol-append 'MAKE- (parser-context/name context)) context))
+
+(define (default-copier-name context)
+ (close (symbol-append 'COPY- (parser-context/name context)) context))
+
+(define (default-predicate-name context)
+ (close (symbol-append (parser-context/name context) '?) context))
+
+(define (default-unparser-text context)
+ `(,(absolute 'STANDARD-UNPARSER-METHOD context)
+ ',(parser-context/name context)
+ #F))
-(define names-meaning-false
- '(#F FALSE NIL))
+(define (default-type-name context)
+ (close (parser-context/name context) context))
-(define (make-default-defstruct-unparser-text name)
- `(,(absolute 'STANDARD-UNPARSER-METHOD)
- ',name
- #F))
+(define (close name context)
+ (make-syntactic-closure (parser-context/environment context) '() name))
+\f
+(define (apply-option-transformers options context)
+ (let loop ((options options))
+ (if (pair? options)
+ (let ((option (car options))
+ (options (cdr options)))
+ (let ((lose
+ (lambda () (error "Ill-formed structure option:" option))))
+ (let ((entry
+ (assq (cond ((and (pair? option)
+ (symbol? (car option))
+ (list? (cdr option)))
+ (car option))
+ ((symbol? option)
+ option)
+ (else
+ (lose)))
+ known-options)))
+ (if (not entry)
+ (lose))
+ (let ((normal-option (if (pair? option) option (list option)))
+ (can-be-duplicated? (cadr entry))
+ (transformer (cddr entry)))
+ (let ((option*
+ (and (not can-be-duplicated?)
+ (find-matching-item options
+ (let ((keyword (car normal-option)))
+ (lambda (option*)
+ (eq? (if (pair? option*)
+ (car option*)
+ option*)
+ keyword)))))))
+ (if option*
+ (error "Duplicate structure option:" option option*)))
+ (cons (let ((option* (transformer normal-option context)))
+ (if (not option*)
+ (lose))
+ (make-option (car option*)
+ (cdr option*)
+ option))
+ (loop options))))))
+ '())))
-(define (parse/options name options slots)
- (if (not (symbol? name))
- (error "Structure name must be a symbol:" name))
- (if (not (list? options))
- (error "Structure options must be a list:" options))
- (let ((conc-name (symbol-append name '-))
- (default-constructor-disabled? false)
- (boa-constructors '())
- (keyword-constructors '())
- (copier-name false)
- (predicate-name (symbol-append name '?))
- (print-procedure default)
- (type 'RECORD)
- (type-name name)
- (tag-expression name)
- (safe-accessors? #f)
- (offset 0)
- (options-seen '()))
- (for-each
- (lambda (option)
- (if (not (or (symbol? option)
- (and (pair? option)
- (symbol? (car option))
- (list? (cdr option)))))
- (error "Ill-formed structure option:" option))
- (with-values
- (lambda ()
- (if (pair? option)
- (values (car option) (cdr option))
- (values option '())))
- (lambda (keyword arguments)
- (set! options-seen (cons (cons keyword option) options-seen))
- (let ((n-arguments (length arguments))
- (check-duplicate
- (lambda ()
- (let ((previous (assq keyword (cdr options-seen))))
- (if previous
- (error "Duplicate structure option:"
- previous option)))))
- (symbol-option
- (lambda (argument)
- (cond ((memq argument names-meaning-false) false)
- ((symbol? argument) argument)
- (else (error "Illegal structure option:" option))))))
- (let ((check-argument
- (lambda ()
- (if (not (= n-arguments 1))
- (error
- (if (= n-arguments 0)
- "Structure option requires an argument:"
- "Structure option accepts at most 1 argument:")
- option))))
- (check-arguments
- (lambda (max)
- (if (> n-arguments max)
- (error (string-append
- "Structure option accepts at most "
- (number->string max)
- " arguments:")
- option)))))
- (case keyword
- ((CONC-NAME)
- (check-duplicate)
- (check-argument)
- (set! conc-name (symbol-option (car arguments))))
- ((CONSTRUCTOR)
- (check-arguments 2)
- (if (null? arguments)
- (set! boa-constructors
- (cons (list option (symbol-append 'MAKE- name))
- boa-constructors))
- (let ((name (car arguments)))
- (if (memq name names-meaning-false)
- (set! default-constructor-disabled? true)
- (set! boa-constructors
- (cons (cons option arguments)
- boa-constructors))))))
- ((KEYWORD-CONSTRUCTOR)
- (check-arguments 1)
- (set! keyword-constructors
- (cons (list option
- (if (null? arguments)
- (symbol-append 'MAKE- name)
- (car arguments)))
- keyword-constructors)))
- ((COPIER)
- (check-duplicate)
- (check-arguments 1)
- (set! copier-name
- (if (null? arguments)
- (symbol-append 'COPY- name)
- (symbol-option (car arguments)))))
- ((PREDICATE)
- (check-duplicate)
- (check-arguments 1)
- (set! predicate-name
- (if (null? arguments)
- (symbol-append name '?)
- (symbol-option (car arguments)))))
- ((PRINT-PROCEDURE)
- (check-duplicate)
- (check-argument)
- (set! print-procedure
- (and (not (memq (car arguments) names-meaning-false))
- (car arguments))))
- ((TYPE)
- (check-duplicate)
- (check-argument)
- (if (not (memq (car arguments) '(VECTOR LIST)))
- (error "Illegal structure option:" option))
- (set! type (car arguments)))
- ((TYPE-DESCRIPTOR)
- (check-duplicate)
- (check-argument)
- (set! type-name (car arguments))
- (set! tag-expression type-name))
- ((NAMED)
- (check-duplicate)
- (check-arguments 1)
- (if (null? arguments)
- (begin
- (set! type-name name)
- (set! tag-expression type-name))
- (begin
- (set! type-name false)
- (set! tag-expression (car arguments)))))
- ((SAFE-ACCESSORS)
- (check-duplicate)
- (check-arguments 1)
- (set! safe-accessors?
- (if (null? arguments) #t (car arguments))))
- ((INITIAL-OFFSET)
- (check-duplicate)
- (check-argument)
- (if (not (exact-nonnegative-integer? (car arguments)))
- (error "Illegal structure option:" option))
- (set! offset (car arguments)))
- (else
- (error "Unknown structure option:" option))))))))
- options)
- (let loop ((constructors (append boa-constructors keyword-constructors)))
- (if (not (null? constructors))
- (begin
- (let ((name (cadar constructors)))
- (for-each (lambda (constructor)
- (if (eq? name (cadr constructor))
- (error "Conflicting constructor definitions:"
- (caar constructors)
- (car constructor))))
- (cdr constructors)))
- (loop (cdr constructors)))))
- (let ((type-seen? (assq 'TYPE options-seen))
- (type-descriptor-seen? (assq 'TYPE-DESCRIPTOR options-seen))
- (named-seen? (assq 'NAMED options-seen)))
- (if (and type-descriptor-seen? named-seen?)
- (error "Conflicting options:" type-descriptor-seen? named-seen?))
- (let ((named? (or (not type-seen?) type-descriptor-seen? named-seen?)))
- (if (not type-seen?)
- (let ((check-option
- (lambda (seen?)
- (if seen?
- (error "Structure option illegal without TYPE option:"
- (cdr seen?))))))
- (check-option (and (not type-name) named-seen?))
- (check-option (assq 'INITIAL-OFFSET options-seen))))
- (if (not named?)
- (let ((check
- (lambda (option-seen)
- (if option-seen
- (error
- "Structure option illegal for unnamed structure:"
- (cdr option-seen))))))
- (if predicate-name
- (check (assq 'PREDICATE options-seen)))
- (if (and (not (eq? print-procedure default)) print-procedure)
- (check (assq 'PRINT-PROCEDURE options-seen)))))
- (make-structure name
- conc-name
- (map cdr keyword-constructors)
- (cond ((or (not (null? boa-constructors))
- (not (null? keyword-constructors)))
- (map cdr boa-constructors))
- ((not default-constructor-disabled?)
- (list (list (symbol-append 'MAKE- name))))
- (else
- '()))
- copier-name
- (and named? predicate-name)
- (and named?
- (cond ((not (eq? print-procedure default))
- print-procedure)
- ((eq? type 'RECORD)
- false)
- (else
- (make-default-defstruct-unparser-text
- name))))
- type
- named?
- (and named? type-name)
- (and named? tag-expression)
- safe-accessors?
- offset
- slots)))))
-
-(define default
- (list 'DEFAULT))
+(define (define-option keyword duplicates? transformer)
+ (let ((entry (assq keyword known-options))
+ (tail (cons duplicates? transformer)))
+ (if entry
+ (set-cdr! entry tail)
+ (begin
+ (set! known-options (cons (cons keyword tail) known-options))
+ unspecific))))
+
+(define known-options '())
+
+(define (one-required-argument option if-1)
+ (case (length (cdr option))
+ ((1) (if-1 (cadr option)))
+ (else #f)))
+
+(define (one-optional-argument option if-0 if-1)
+ (case (length (cdr option))
+ ((0) (if-0))
+ ((1) (if-1 (cadr option)))
+ (else #f)))
+
+(define (two-optional-arguments option if-0 if-1 if-2)
+ (case (length (cdr option))
+ ((0) (if-0))
+ ((1) (if-1 (cadr option)))
+ ((2) (if-2 (cadr option) (caddr option)))
+ (else #f)))
+\f
+(define-option 'CONC-NAME #f
+ (lambda (option context)
+ context
+ (one-required-argument option
+ (lambda (arg)
+ (cond ((false-marker? arg) `(CONC-NAME #F))
+ ((symbol? arg) `(CONC-NAME ,arg))
+ (else #f))))))
+
+(define-option 'CONSTRUCTOR #t
+ (lambda (option context)
+ (two-optional-arguments option
+ (lambda ()
+ `(CONSTRUCTOR ,(default-constructor-name context)))
+ (lambda (arg1)
+ (cond ((false-expression? arg1 context) `(CONSTRUCTOR #F))
+ ((identifier? arg1) `(CONSTRUCTOR ,(close arg1 context)))
+ (else #f)))
+ (lambda (arg1 arg2)
+ (if (and (identifier? arg1) (mit-lambda-list? arg2))
+ `(CONSTRUCTOR ,(close arg1 context) ,arg2)
+ #f)))))
+
+(define-option 'KEYWORD-CONSTRUCTOR #t
+ (lambda (option context)
+ (one-optional-argument option
+ (lambda ()
+ `(KEYWORD-CONSTRUCTOR ,(default-constructor-name context)))
+ (lambda (arg)
+ (if (identifier? arg)
+ `(KEYWORD-CONSTRUCTOR ,(close arg context))
+ #f)))))
+
+(define-option 'COPIER #f
+ (lambda (option context)
+ (one-optional-argument option
+ (lambda ()
+ `(COPIER ,(default-copier-name context)))
+ (lambda (arg)
+ (cond ((false-expression? arg context) `(COPIER #F))
+ ((identifier? arg) `(COPIER ,(close arg context)))
+ (else #f))))))
+
+(define-option 'PREDICATE #f
+ (lambda (option context)
+ (one-optional-argument option
+ (lambda ()
+ `(PREDICATE ,(default-predicate-name context)))
+ (lambda (arg)
+ (cond ((false-expression? arg context) `(PREDICATE #F))
+ ((identifier? arg) `(PREDICATE ,(close arg context)))
+ (else #f))))))
\f
-;;;; Parse Slot-Descriptions
+(define-option 'PRINT-PROCEDURE #f
+ (lambda (option context)
+ (one-required-argument option
+ (lambda (arg)
+ `(PRINT-PROCEDURE ,(if (false-expression? arg context)
+ #f
+ (close arg context)))))))
+
+(define-option 'TYPE #f
+ (lambda (option context)
+ context
+ (one-required-argument option
+ (lambda (arg)
+ (if (memq arg '(VECTOR LIST))
+ `(TYPE ,arg)
+ #f)))))
+
+(define-option 'TYPE-DESCRIPTOR #f
+ (lambda (option context)
+ (one-required-argument option
+ (lambda (arg)
+ (if (identifier? arg)
+ `(TYPE-DESCRIPTOR ,(close arg context))
+ #f)))))
+
+(define-option 'NAMED #f
+ (lambda (option context)
+ (one-optional-argument option
+ (lambda ()
+ `(NAMED))
+ (lambda (arg)
+ `(NAMED ,(if (false-expression? arg context)
+ #f
+ (close arg context)))))))
+
+(define-option 'SAFE-ACCESSORS #f
+ (lambda (option context)
+ context
+ (one-optional-argument option
+ (lambda ()
+ `(SAFE-ACCESSORS #T))
+ (lambda (arg)
+ (cond ((true-marker? arg) `(SAFE-ACCESSORS #T))
+ ((false-marker? arg) `(SAFE-ACCESSORS #F))
+ (else #f))))))
+
+(define-option 'INITIAL-OFFSET #f
+ (lambda (option context)
+ context
+ (one-required-argument option
+ (lambda (arg)
+ (if (exact-nonnegative-integer? arg)
+ `(INITIAL-OFFSET ,arg)
+ #f)))))
+\f
+;;;; Parse slot descriptions
+
+(define (parse/slot-descriptions slot-descriptions)
+ (let ((slots
+ (map (lambda (description)
+ (cons (parse/slot-description description)
+ description))
+ slot-descriptions)))
+ (do ((slots slots (cdr slots)))
+ ((not (pair? slots)))
+ (let ((name (slot/name (caar slots))))
+ (let ((slot*
+ (find-matching-item (cdr slots)
+ (lambda (slot)
+ (eq? (slot/name (car slot)) name)))))
+ (if slot*
+ (error "Structure slots must not have duplicate names:"
+ (cdar slots)
+ (cdr slot*))))))
+ (map car slots)))
(define (parse/slot-description slot-description)
- (with-values
+ (call-with-values
(lambda ()
(if (pair? slot-description)
(if (pair? (cdr slot-description))
(values (car slot-description)
(cadr slot-description)
(cddr slot-description))
- (values (car slot-description) false '()))
- (values slot-description false '())))
+ (values (car slot-description) #f '()))
+ (values slot-description #f '())))
(lambda (name default options)
(if (not (list? options))
(error "Structure slot options must be a list:" options))
- (let ((type true)
- (read-only? false)
+ (let ((type #t)
+ (read-only? #f)
(options-seen '()))
(do ((options options (cddr options)))
- ((null? options))
- (if (null? (cdr options))
+ ((not (pair? options)))
+ (if (not (pair? (cdr options)))
(error "Missing slot option argument:" (car options)))
- (let ((previous (assq (car options) options-seen))
- (option (list (car options) (cadr options))))
- (if previous
- (error "Duplicate slot option:" previous option))
- (set! options-seen (cons option options-seen))
- (case (car options)
- ((TYPE)
- (set! type
- (let ((argument (cadr options)))
- (cond ((memq argument '(#T TRUE T)) true)
+ (let ((keyword (car options))
+ (argument (cadr options)))
+ (let ((option (list keyword argument)))
+ (let ((previous (assq keyword options-seen)))
+ (if previous
+ (error "Duplicate slot option:" previous option)))
+ (set! options-seen (cons option options-seen))
+ (case keyword
+ ((TYPE)
+ (set! type
+ (cond ((true-marker? argument) #t)
((symbol? argument) argument)
- (else (error "Illegal slot option:" option))))))
- ((READ-ONLY)
- (set! read-only?
- (let ((argument (cadr options)))
- (cond ((memq argument names-meaning-false) false)
- ((memq argument '(#T TRUE T)) true)
- (else (error "Illegal slot option:" option))))))
- (else
- (error "Unrecognized structure slot option:" option)))))
+ (else (error "Illegal slot option:" option)))))
+ ((READ-ONLY)
+ (set! read-only?
+ (cond ((false-marker? argument) #f)
+ ((true-marker? argument) #t)
+ (else (error "Illegal slot option:" option)))))
+ (else
+ (error "Unrecognized structure slot option:" option))))))
(make-slot name default type read-only?)))))
+
+(define (get-slot-default slot structure)
+ (make-syntactic-closure
+ (parser-context/environment (structure/context structure))
+ (map slot/name (structure/slots structure))
+ (slot/default slot)))
\f
;;;; Descriptive Structure
(define structure-rtd
(make-record-type
"structure"
- '(NAME CONC-NAME KEYWORD-CONSTRUCTORS BOA-CONSTRUCTORS COPIER-NAME
- PREDICATE-NAME PRINT-PROCEDURE TYPE NAMED? TYPE-NAME
- TAG-EXPRESSION SAFE-ACCESSORS? OFFSET SLOTS)))
+ '(CONTEXT CONC-NAME CONSTRUCTORS KEYWORD-CONSTRUCTORS COPIER-NAME
+ PREDICATE-NAME PRINT-PROCEDURE TYPE NAMED? TYPE-NAME
+ TAG-EXPRESSION SAFE-ACCESSORS? OFFSET SLOTS)))
(define make-structure
(record-constructor structure-rtd))
(define structure?
(record-predicate structure-rtd))
-(define structure/name
- (record-accessor structure-rtd 'NAME))
+(define structure/context
+ (record-accessor structure-rtd 'CONTEXT))
(define structure/conc-name
(record-accessor structure-rtd 'CONC-NAME))
+(define structure/constructors
+ (record-accessor structure-rtd 'CONSTRUCTORS))
+
(define structure/keyword-constructors
(record-accessor structure-rtd 'KEYWORD-CONSTRUCTORS))
-(define structure/boa-constructors
- (record-accessor structure-rtd 'BOA-CONSTRUCTORS))
-
-(define structure/copier-name
+(define structure/copier
(record-accessor structure-rtd 'COPIER-NAME))
-(define structure/predicate-name
+(define structure/predicate
(record-accessor structure-rtd 'PREDICATE-NAME))
(define structure/print-procedure
(define structure/type
(record-accessor structure-rtd 'TYPE))
-(define structure/named?
+(define structure/tagged?
(record-accessor structure-rtd 'NAMED?))
-(define structure/type-name
+(define structure/type-descriptor
(record-accessor structure-rtd 'TYPE-NAME))
(define structure/tag-expression
(define structure/slots
(record-accessor structure-rtd 'SLOTS))
\f
+(define parser-context-rtd
+ (make-record-type "parser-context"
+ '(NAME ENVIRONMENT CLOSING-ENVIRONMENT)))
+
+(define make-parser-context
+ (record-constructor parser-context-rtd))
+
+(define parser-context?
+ (record-predicate parser-context-rtd))
+
+(define parser-context/name
+ (record-accessor parser-context-rtd 'NAME))
+
+(define parser-context/environment
+ (record-accessor parser-context-rtd 'ENVIRONMENT))
+
+(define parser-context/closing-environment
+ (record-accessor parser-context-rtd 'CLOSING-ENVIRONMENT))
+
+
+(define option-rtd
+ (make-record-type "option" '(KEYWORD ARGUMENTS ORIGINAL)))
+
+(define make-option
+ (record-constructor option-rtd))
+
+(define option?
+ (record-predicate option-rtd))
+
+(define option/keyword
+ (record-accessor option-rtd 'KEYWORD))
+
+(define option/arguments
+ (record-accessor option-rtd 'ARGUMENTS))
+
+(define option/original
+ (record-accessor option-rtd 'ORIGINAL))
+
+
(define slot-rtd
(make-record-type "slot" '(NAME DEFAULT TYPE READ-ONLY? INDEX)))
\f
;;;; Code Generation
-(define (absolute name)
- `(ACCESS ,name #F))
+(define (absolute name context)
+ (make-syntactic-closure (parser-context/closing-environment context) '()
+ `(ACCESS ,name #F)))
(define (accessor-definitions structure)
- (map (lambda (slot)
- (let* ((name (slot/name slot))
- (accessor-name
- (if (structure/conc-name structure)
- (symbol-append (structure/conc-name structure) name)
- name)))
- (if (structure/safe-accessors? structure)
- `(DEFINE ,accessor-name
- (,(absolute
- (case (structure/type structure)
- ((RECORD) 'RECORD-ACCESSOR)
- ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-ACCESSOR)
- ((LIST) 'DEFINE-STRUCTURE/LIST-ACCESSOR)))
- ,(or (structure/tag-expression structure)
- (slot/index slot))
- ',name))
- `(DEFINE-INTEGRABLE (,accessor-name STRUCTURE)
- (,(absolute
- (case (structure/type structure)
- ((RECORD) '%RECORD-REF)
- ((VECTOR) 'VECTOR-REF)
- ((LIST) 'LIST-REF)))
- STRUCTURE
- ,(slot/index slot))))))
- (structure/slots structure)))
+ (let ((context (structure/context structure)))
+ (map (lambda (slot)
+ (let* ((name (slot/name slot))
+ (accessor-name
+ (close (let ((conc-name (structure/conc-name structure)))
+ (if conc-name
+ (symbol-append conc-name name)
+ name))
+ context)))
+ (if (structure/safe-accessors? structure)
+ `(DEFINE ,accessor-name
+ (,(absolute (case (structure/type structure)
+ ((RECORD) 'RECORD-ACCESSOR)
+ ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-ACCESSOR)
+ ((LIST) 'DEFINE-STRUCTURE/LIST-ACCESSOR))
+ context)
+ ,(or (structure/tag-expression structure)
+ (slot/index slot))
+ ',name))
+ `(DEFINE-INTEGRABLE (,accessor-name STRUCTURE)
+ (,(absolute (case (structure/type structure)
+ ((RECORD) '%RECORD-REF)
+ ((VECTOR) 'VECTOR-REF)
+ ((LIST) 'LIST-REF))
+ context)
+ STRUCTURE
+ ,(slot/index slot))))))
+ (structure/slots structure))))
(define (modifier-definitions structure)
- (append-map!
- (lambda (slot)
- (if (slot/read-only? slot)
- '()
- (list
- (let* ((name (slot/name slot))
- (modifier-name
- (if (structure/conc-name structure)
- (symbol-append 'SET-
- (structure/conc-name structure)
- name
- '!)
- (symbol-append 'SET- name '!))))
- (if (structure/safe-accessors? structure)
- `(DEFINE ,modifier-name
- (,(absolute
- (case (structure/type structure)
- ((RECORD) 'RECORD-MODIFIER)
- ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-MODIFIER)
- ((LIST) 'DEFINE-STRUCTURE/LIST-MODIFIER)))
- ,(or (structure/tag-expression structure)
- (slot/index slot))
- ',name))
- `(DEFINE-INTEGRABLE (,modifier-name STRUCTURE VALUE)
- ,(case (structure/type structure)
- ((RECORD)
- `(,(absolute '%RECORD-SET!) STRUCTURE
- ,(slot/index slot)
- VALUE))
- ((VECTOR)
- `(,(absolute 'VECTOR-SET!) STRUCTURE
- ,(slot/index slot)
- VALUE))
- ((LIST)
- `(,(absolute 'SET-CAR!)
- (,(absolute 'LIST-TAIL) STRUCTURE
- ,(slot/index slot))
- VALUE)))))))))
- (structure/slots structure)))
+ (let ((context (structure/context structure)))
+ (map (lambda (slot)
+ (let* ((name (slot/name slot))
+ (modifier-name
+ (close (let ((conc-name (structure/conc-name structure)))
+ (if conc-name
+ (symbol-append 'SET- conc-name name '!)
+ (symbol-append 'SET- name '!)))
+ context)))
+ (if (structure/safe-accessors? structure)
+ `(DEFINE ,modifier-name
+ (,(absolute (case (structure/type structure)
+ ((RECORD) 'RECORD-MODIFIER)
+ ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-MODIFIER)
+ ((LIST) 'DEFINE-STRUCTURE/LIST-MODIFIER))
+ context)
+ ,(or (structure/tag-expression structure)
+ (slot/index slot))
+ ',name))
+ `(DEFINE-INTEGRABLE (,modifier-name STRUCTURE VALUE)
+ ,(case (structure/type structure)
+ ((RECORD)
+ `(,(absolute '%RECORD-SET! context) STRUCTURE
+ ,(slot/index slot)
+ VALUE))
+ ((VECTOR)
+ `(,(absolute 'VECTOR-SET! context) STRUCTURE
+ ,(slot/index slot)
+ VALUE))
+ ((LIST)
+ `(,(absolute 'SET-CAR! context)
+ (,(absolute 'LIST-TAIL context) STRUCTURE
+ ,(slot/index slot))
+ VALUE)))))))
+ (delete-matching-items (structure/slots structure) slot/read-only?))))
\f
(define (constructor-definitions structure)
- `(,@(map (lambda (boa-constructor)
- (if (null? (cdr boa-constructor))
- (constructor-definition/default structure
- (car boa-constructor))
+ `(,@(map (lambda (constructor)
+ (if (pair? (cdr constructor))
(constructor-definition/boa structure
- (car boa-constructor)
- (cadr boa-constructor))))
- (structure/boa-constructors structure))
- ,@(map (lambda (keyword-constructor)
- (constructor-definition/keyword structure
- (car keyword-constructor)))
+ (car constructor)
+ (cadr constructor))
+ (constructor-definition/default structure (car constructor))))
+ (structure/constructors structure))
+ ,@(map (lambda (constructor)
+ (constructor-definition/keyword structure (car constructor)))
(structure/keyword-constructors structure))))
(define (constructor-definition/default structure name)
- (let ((slot-names
- (map (lambda (slot)
- (string->uninterned-symbol (symbol->string (slot/name slot))))
- (structure/slots structure))))
+ (let ((slot-names (map slot/name (structure/slots structure))))
(make-constructor structure name slot-names
(lambda (tag-expression)
- `(,(absolute
- (case (structure/type structure)
- ((RECORD) '%RECORD)
- ((VECTOR) 'VECTOR)
- ((LIST) 'LIST)))
+ `(,(absolute (case (structure/type structure)
+ ((RECORD) '%RECORD)
+ ((VECTOR) 'VECTOR)
+ ((LIST) 'LIST))
+ (structure/context structure))
,@(constructor-prefix-slots structure tag-expression)
,@slot-names)))))
(define (constructor-definition/keyword structure name)
- (let ((keyword-list (string->uninterned-symbol "keyword-list")))
- (make-constructor structure name keyword-list
- (lambda (tag-expression)
+ (make-constructor structure name 'KEYWORD-LIST
+ (lambda (tag-expression)
+ (let ((context (structure/context structure)))
(let ((list-cons
`(,@(constructor-prefix-slots structure tag-expression)
- (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER)
- ,keyword-list
- (,(absolute 'LIST)
+ (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER context)
+ KEYWORD-LIST
+ (,(absolute 'LIST context)
,@(map (lambda (slot)
- `(,(absolute 'CONS) ',(slot/name slot)
- ,(slot/default slot)))
+ `(,(absolute 'CONS context)
+ ',(slot/name slot)
+ ,(get-slot-default slot structure)))
(structure/slots structure)))))))
(case (structure/type structure)
((RECORD)
- `(,(absolute 'APPLY) ,(absolute '%RECORD) ,@list-cons))
+ `(,(absolute 'APPLY context) ,(absolute '%RECORD context)
+ ,@list-cons))
((VECTOR)
- `(,(absolute 'APPLY) ,(absolute 'VECTOR) ,@list-cons))
+ `(,(absolute 'APPLY context) ,(absolute 'VECTOR context)
+ ,@list-cons))
((LIST)
- `(,(absolute 'CONS*) ,@list-cons))))))))
+ `(,(absolute 'CONS* context) ,@list-cons))))))))
+
+(define (define-structure/keyword-parser argument-list default-alist)
+ (if (null? argument-list)
+ (map cdr default-alist)
+ (let ((alist
+ (map (lambda (entry) (cons (car entry) (cdr entry)))
+ default-alist)))
+ (let loop ((arguments argument-list))
+ (if (pair? arguments)
+ (begin
+ (if (not (pair? (cdr arguments)))
+ (error "Keyword list does not have even length:"
+ argument-list))
+ (set-cdr! (or (assq (car arguments) alist)
+ (error "Unknown keyword:" (car arguments)))
+ (cadr arguments))
+ (loop (cddr arguments)))))
+ (map cdr alist))))
\f
(define (constructor-definition/boa structure name lambda-list)
(make-constructor structure name lambda-list
(lambda (tag-expression)
- `(,(absolute
- (case (structure/type structure)
- ((RECORD) '%RECORD)
- ((VECTOR) 'VECTOR)
- ((LIST) 'LIST)))
+ `(,(absolute (case (structure/type structure)
+ ((RECORD) '%RECORD)
+ ((VECTOR) 'VECTOR)
+ ((LIST) 'LIST))
+ (structure/context structure))
,@(constructor-prefix-slots structure tag-expression)
- ,@(parse-lambda-list lambda-list
+ ,@(call-with-values (lambda () (parse-mit-lambda-list lambda-list))
(lambda (required optional rest)
(let ((name->slot
(lambda (name)
(slot/name slot))
((memq slot optional)
`(IF (DEFAULT-OBJECT? ,(slot/name slot))
- ,(slot/default slot)
+ ,(get-slot-default slot structure)
,(slot/name slot)))
(else
- (slot/default slot))))
+ (get-slot-default slot structure))))
(structure/slots structure))))))))))
-(define (make-constructor structure name arguments generate-body)
+(define (make-constructor structure name lambda-list generate-body)
(let ((tag-expression (structure/tag-expression structure)))
(if (eq? (structure/type structure) 'RECORD)
- (let ((tag (generate-uninterned-symbol 'TAG-)))
+ (let ((tag (make-synthetic-identifier 'TAG)))
`(DEFINE ,name
(LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
- (NAMED-LAMBDA (,name ,@arguments)
+ (NAMED-LAMBDA (,name ,@lambda-list)
,(generate-body tag)))))
- `(DEFINE (,name ,@arguments)
+ `(DEFINE (,name ,@lambda-list)
,(generate-body tag-expression)))))
(define (constructor-prefix-slots structure tag-expression)
- (let ((offsets (make-list (structure/offset structure) false)))
- (if (structure/named? structure)
+ (let ((offsets (make-list (structure/offset structure) '#F)))
+ (if (structure/tagged? structure)
(cons tag-expression offsets)
offsets)))
\f
(define (copier-definitions structure)
- (let ((copier-name (structure/copier-name structure)))
+ (let ((copier-name (structure/copier structure)))
(if copier-name
`((DEFINE ,copier-name
- ,(absolute
- (case (structure/type structure)
- ((RECORD) 'RECORD-COPY)
- ((VECTOR) 'VECTOR-COPY)
- ((LIST) 'LIST-COPY)))))
+ ,(absolute (case (structure/type structure)
+ ((RECORD) 'RECORD-COPY)
+ ((VECTOR) 'VECTOR-COPY)
+ ((LIST) 'LIST-COPY))
+ (structure/context structure))))
'())))
(define (predicate-definitions structure)
- (let ((predicate-name (structure/predicate-name structure)))
+ (let ((predicate-name (structure/predicate structure)))
(if predicate-name
(let ((tag-expression (structure/tag-expression structure))
- (variable (string->uninterned-symbol "object")))
+ (context (structure/context structure)))
(case (structure/type structure)
((RECORD)
- (let ((tag (generate-uninterned-symbol 'TAG-)))
- `((DEFINE ,predicate-name
- (LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
- (NAMED-LAMBDA (,predicate-name ,variable)
- (AND (,(absolute '%RECORD?) ,variable)
- (,(absolute 'EQ?)
- (,(absolute '%RECORD-REF) ,variable 0)
- ,tag))))))))
+ `((DEFINE ,predicate-name
+ (LET ((TAG (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
+ (NAMED-LAMBDA (,predicate-name OBJECT)
+ (AND (,(absolute '%RECORD? context) OBJECT)
+ (,(absolute 'EQ? context)
+ (,(absolute '%RECORD-REF context) OBJECT 0)
+ TAG)))))))
((VECTOR)
- `((DEFINE (,predicate-name ,variable)
- (AND (,(absolute 'VECTOR?) ,variable)
- (,(absolute 'NOT)
- (,(absolute 'ZERO?)
- (,(absolute 'VECTOR-LENGTH) ,variable)))
- (,(absolute 'EQ?) (,(absolute 'VECTOR-REF) ,variable 0)
- ,tag-expression)))))
+ `((DEFINE (,predicate-name OBJECT)
+ (AND (,(absolute 'VECTOR? context) OBJECT)
+ (,(absolute 'NOT context)
+ (,(absolute 'ZERO? context)
+ (,(absolute 'VECTOR-LENGTH context) OBJECT)))
+ (,(absolute 'EQ? context)
+ (,(absolute 'VECTOR-REF context) OBJECT 0)
+ ,tag-expression)))))
((LIST)
- `((DEFINE (,predicate-name ,variable)
- (AND (,(absolute 'PAIR?) ,variable)
- (,(absolute 'EQ?) (,(absolute 'CAR) ,variable)
- ,tag-expression)))))))
+ `((DEFINE (,predicate-name OBJECT)
+ (AND (,(absolute 'PAIR? context) OBJECT)
+ (,(absolute 'EQ? context)
+ (,(absolute 'CAR context) OBJECT)
+ ,tag-expression)))))))
'())))
(define (type-definitions structure)
- (if (structure/named? structure)
+ (if (structure/tagged? structure)
(let ((type (structure/type structure))
- (type-name (structure/type-name structure))
- (name (symbol->string (structure/name structure)))
- (field-names (map slot/name (structure/slots structure))))
+ (type-name (structure/type-descriptor structure))
+ (name
+ (symbol->string
+ (parser-context/name (structure/context structure))))
+ (field-names (map slot/name (structure/slots structure)))
+ (context (structure/context structure)))
(if (eq? type 'RECORD)
`((DEFINE ,type-name
- (,(absolute 'MAKE-RECORD-TYPE)
+ (,(absolute 'MAKE-RECORD-TYPE context)
',name ',field-names
- ,@(let ((print-procedure
- (structure/print-procedure structure)))
- (if (not print-procedure)
+ ,@(let ((expression (structure/print-procedure structure)))
+ (if (not expression)
`()
- `(,print-procedure))))))
+ `(,expression))))))
(let ((type-expression
- `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE)
+ `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context)
',type
',name
',field-names
,(structure/print-procedure structure))))
(if type-name
`((DEFINE ,type-name ,type-expression))
- `((DEFINE ,(string->uninterned-symbol name)
- (NAMED-STRUCTURE/SET-TAG-DESCRIPTION!
- ,(structure/tag-expression structure)
- ,type-expression)))))))
+ `((NAMED-STRUCTURE/SET-TAG-DESCRIPTION!
+ ,(structure/tag-expression structure)
+ ,type-expression))))))
'()))
\ No newline at end of file
#| -*- Scheme -*-
-$Id: ed-ffi.scm,v 1.31 2001/12/18 18:39:26 cph Exp $
+$Id: ed-ffi.scm,v 1.32 2002/02/03 03:38:55 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
("lambdx" (runtime alternative-lambda))
("list" (runtime list))
("load" (runtime load))
- ("macros" (runtime macros))
("mime-codec" (runtime mime-codec))
+ ("mit-syntax" (runtime syntactic-closures))
("msort" (runtime merge-sort))
("ntdir" (runtime directory))
("ntprm" (runtime os-primitives))
("strout" (runtime string-output))
("symbol" (runtime symbol))
("syncproc" (runtime synchronous-subprocess))
- ("syntab" (runtime syntax-table))
- ("syntax" (runtime syntaxer))
+ ("syntactic-closures" (runtime syntactic-closures))
+ ("syntax-check" (runtime syntactic-closures))
+ ("syntax-output" (runtime syntactic-closures))
+ ("syntax-rules" (runtime syntactic-closures))
+ ("syntax-transforms" (runtime syntactic-closures))
("sysclk" (runtime system-clock))
("sysmac" (runtime system-macros))
("system" (runtime system))
#| -*-Scheme-*-
-$Id: error.scm,v 14.56 2002/01/07 03:38:28 cph Exp $
+$Id: error.scm,v 14.57 2002/02/03 03:38:55 cph Exp $
Copyright (c) 1988-2002 Massachusetts Institute of Technology
(loop (cdr restarts))))))
(define-syntax restarts-default
- (non-hygienic-macro-transformer
- (lambda (restarts name)
- ;; This is a macro because DEFAULT-OBJECT? is.
- `(COND ((OR (DEFAULT-OBJECT? ,restarts)
- (EQ? 'BOUND-RESTARTS ,restarts))
- *BOUND-RESTARTS*)
- ((CONDITION? ,restarts)
- (%CONDITION/RESTARTS ,restarts))
- (ELSE
- (GUARANTEE-RESTARTS ,restarts ',name)
- ,restarts)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((restarts (close-syntax (cadr form) environment))
+ (name (close-syntax (caddr form) environment)))
+ ;; This is a macro because DEFAULT-OBJECT? is.
+ `(COND ((OR (DEFAULT-OBJECT? ,restarts)
+ (EQ? 'BOUND-RESTARTS ,restarts))
+ *BOUND-RESTARTS*)
+ ((CONDITION? ,restarts)
+ (%CONDITION/RESTARTS ,restarts))
+ (ELSE
+ (GUARANTEE-RESTARTS ,restarts ,name)
+ ,restarts))))))
\f
(define (find-restart name #!optional restarts)
(guarantee-symbol name 'FIND-RESTART)
#| -*-Scheme-*-
-$Id: graphics.scm,v 1.19 2001/12/23 17:20:59 cph Exp $
+$Id: graphics.scm,v 1.20 2002/02/03 03:38:55 cph Exp $
-Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1989-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(let-syntax
((define-graphics-operation
- (non-hygienic-macro-transformer
- (lambda (name)
- `(DEFINE-INTEGRABLE
- (,(symbol-append 'GRAPHICS-DEVICE/OPERATION/ name) DEVICE)
- (,(symbol-append 'GRAPHICS-DEVICE-TYPE/OPERATION/ name)
- (GRAPHICS-DEVICE/TYPE DEVICE)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE-INTEGRABLE
+ (,(close-syntax (symbol-append 'GRAPHICS-DEVICE/OPERATION/ name)
+ environment)
+ DEVICE)
+ (,(close-syntax (symbol-append 'GRAPHICS-DEVICE-TYPE/OPERATION/
+ name)
+ environment)
+ (GRAPHICS-DEVICE/TYPE DEVICE))))))))
(define-graphics-operation clear)
(define-graphics-operation close)
(define-graphics-operation coordinate-limits)
+++ /dev/null
-#| -*-Scheme-*-
-
-$Id: illdef.scm,v 1.5 2001/12/20 16:28:22 cph Exp $
-
-Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-This program is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-|#
-
-;;;; Check for Illegal Definitions
-;;; package: (runtime illegal-definitions)
-
-(declare (usual-integrations))
-\f
-(define walker)
-
-(define (initialize-package!)
- (set! walker
- (make-scode-walker walk/constant
- `((ACCESS ,walk/access)
- (ASSIGNMENT ,walk/assignment)
- (COMBINATION ,walk/combination)
- (COMMENT ,walk/comment)
- (CONDITIONAL ,walk/conditional)
- (DEFINITION ,walk/definition)
- (DELAY ,walk/delay)
- (DISJUNCTION ,walk/disjunction)
- (LAMBDA ,walk/lambda)
- (SEQUENCE ,walk/sequence))))
- unspecific)
-
-(define (check-for-illegal-definitions expression)
- (walk/expression (if (open-block? expression)
- (open-block-components expression unscan-defines)
- expression)
- 'LEGAL))
-
-(define (walk/expression expression context)
- ((scode-walk walker expression) expression context))
-
-(define-integrable (walk/no-definitions expression)
- (walk/expression expression 'ILLEGAL))
-
-(define (walk/lambda expression context)
- context
- (let loop
- ((expressions
- (sequence-actions
- (lambda-components expression
- (lambda (name required optional rest auxiliary declarations body)
- name required optional rest
- (unscan-defines auxiliary declarations body))))))
- (if (pair? (cdr expressions))
- (begin
- (walk/expression (car expressions) 'LEGAL)
- (loop (cdr expressions)))
- (walk/no-definitions (car expressions)))))
-
-(define (walk/definition expression context)
- (case context
- ((ILLEGAL)
- (error "Definition appears in illegal context:"
- (unsyntax expression)))
- ((UNUSUAL)
- (warn "Definition appears in unusual context:"
- (unsyntax expression))))
- (walk/no-definitions (definition-value expression)))
-\f
-(define (walk/sequence expression context)
- (for-each (lambda (expression)
- (walk/expression expression context))
- (sequence-actions expression)))
-
-(define (walk/constant expression context)
- expression context
- unspecific)
-
-(define (walk/access expression context)
- context
- (walk/no-definitions (access-environment expression)))
-
-(define (walk/assignment expression context)
- context
- (walk/no-definitions (assignment-value expression)))
-
-(define (walk/combination expression context)
- context
- (walk/no-definitions (combination-operator expression))
- (for-each walk/no-definitions (combination-operands expression)))
-
-(define (walk/comment expression context)
- (walk/expression (comment-expression expression) context))
-
-(define (walk/conditional expression context)
- (walk/no-definitions (conditional-predicate expression))
- (let ((context (if (eq? 'LEGAL context) 'UNUSUAL context)))
- (walk/expression (conditional-consequent expression) context)
- (walk/expression (conditional-alternative expression) context)))
-
-(define (walk/delay expression context)
- context
- (walk/no-definitions (delay-expression expression)))
-
-(define (walk/disjunction expression context)
- (walk/no-definitions (disjunction-predicate expression))
- (walk/expression (disjunction-alternative expression)
- (if (eq? 'LEGAL context) 'UNUSUAL context)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: infstr.scm,v 1.13 2001/12/23 17:20:59 cph Exp $
+$Id: infstr.scm,v 1.14 2002/02/03 03:38:55 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(let-syntax
((dbg-block-name
- (non-hygienic-macro-transformer
- (lambda (name)
- (let ((symbol (symbol-append 'DBG-BLOCK-NAME/ name)))
- `(DEFINE-INTEGRABLE ,symbol
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((symbol (symbol-append 'DBG-BLOCK-NAME/ (cadr form))))
+ `(DEFINE-INTEGRABLE ,(close-syntax symbol environment)
',((ucode-primitive string->symbol)
(string-append "#[(runtime compiler-info)"
(string-downcase (symbol-name symbol))
#| -*-Scheme-*-
-$Id: list.scm,v 14.29 2001/12/23 17:20:59 cph Exp $
+$Id: list.scm,v 14.30 2002/02/03 03:38:55 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(map-1 first)))
\f
(let-syntax
- ((mapping-procedure
- (non-hygienic-macro-transformer
- (lambda (name combiner initial-value procedure first rest)
- `(BEGIN
- (DEFINE (MAP-1 L)
- (COND ((PAIR? L)
- (,combiner (,procedure (CAR L))
- (MAP-1 (CDR L))))
- ((NULL? L) ,initial-value)
- (ELSE (BAD-END))))
-
- (DEFINE (MAP-2 L1 L2)
- (COND ((AND (PAIR? L1) (PAIR? L2))
- (,combiner (,procedure (CAR L1) (CAR L2))
- (MAP-2 (CDR L1) (CDR L2))))
- ((AND (NULL? L1) (NULL? L2)) ,initial-value)
- (ELSE (BAD-END))))
-
- (DEFINE (MAP-N LISTS)
- (LET N-LOOP ((LISTS LISTS))
- (IF (PAIR? (CAR LISTS))
- (DO ((LISTS LISTS (CDR LISTS))
- (CARS '() (CONS (CAAR LISTS) CARS))
- (CDRS '() (CONS (CDAR LISTS) CDRS)))
- ((NOT (PAIR? LISTS))
- (,combiner (APPLY ,procedure (REVERSE! CARS))
- (N-LOOP (REVERSE! CDRS))))
- (IF (NOT (PAIR? (CAR LISTS)))
- (BAD-END)))
- (DO ((LISTS LISTS (CDR LISTS)))
- ((NOT (PAIR? LISTS)) ,initial-value)
- (IF (NOT (NULL? (CAR LISTS)))
- (BAD-END))))))
-
- (DEFINE (BAD-END)
- (DO ((LISTS (CONS ,first ,rest) (CDR LISTS)))
- ((NOT (PAIR? LISTS)))
- (IF (NOT (LIST? (CAR LISTS)))
- (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list" ',name)))
- (LET ((N (LENGTH ,first)))
- (DO ((LISTS ,rest (CDR LISTS)))
+ ((mapper
+ (rsc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((name (list-ref form 1))
+ (combiner (list-ref form 2))
+ (initial-value (list-ref form 3))
+ (procedure (list-ref form 4))
+ (first (list-ref form 5))
+ (rest (list-ref form 6)))
+ `(BEGIN
+ (DEFINE (MAP-1 L)
+ (COND ((PAIR? L)
+ (,combiner (,procedure (CAR L))
+ (MAP-1 (CDR L))))
+ ((NULL? L) ,initial-value)
+ (ELSE (BAD-END))))
+
+ (DEFINE (MAP-2 L1 L2)
+ (COND ((AND (PAIR? L1) (PAIR? L2))
+ (,combiner (,procedure (CAR L1) (CAR L2))
+ (MAP-2 (CDR L1) (CDR L2))))
+ ((AND (NULL? L1) (NULL? L2)) ,initial-value)
+ (ELSE (BAD-END))))
+
+ (DEFINE (MAP-N LISTS)
+ (LET N-LOOP ((LISTS LISTS))
+ (IF (PAIR? (CAR LISTS))
+ (DO ((LISTS LISTS (CDR LISTS))
+ (CARS '() (CONS (CAAR LISTS) CARS))
+ (CDRS '() (CONS (CDAR LISTS) CDRS)))
+ ((NOT (PAIR? LISTS))
+ (,combiner (APPLY ,procedure (REVERSE! CARS))
+ (N-LOOP (REVERSE! CDRS))))
+ (IF (NOT (PAIR? (CAR LISTS)))
+ (BAD-END)))
+ (DO ((LISTS LISTS (CDR LISTS)))
+ ((NOT (PAIR? LISTS)) ,initial-value)
+ (IF (NOT (NULL? (CAR LISTS)))
+ (BAD-END))))))
+
+ (DEFINE (BAD-END)
+ (DO ((LISTS (CONS ,first ,rest) (CDR LISTS)))
((NOT (PAIR? LISTS)))
- (IF (NOT (= N (LENGTH (CAR LISTS))))
- (ERROR:BAD-RANGE-ARGUMENT (CAR LISTS) ',name)))))
+ (IF (NOT (LIST? (CAR LISTS)))
+ (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list" ',name)))
+ (LET ((N (LENGTH ,first)))
+ (DO ((LISTS ,rest (CDR LISTS)))
+ ((NOT (PAIR? LISTS)))
+ (IF (NOT (= N (LENGTH (CAR LISTS))))
+ (ERROR:BAD-RANGE-ARGUMENT (CAR LISTS) ',name)))))
- (IF (PAIR? ,rest)
- (IF (PAIR? (CDR ,rest))
- (MAP-N (CONS ,first ,rest))
- (MAP-2 ,first (CAR ,rest)))
- (MAP-1 ,first)))))))
+ (IF (PAIR? ,rest)
+ (IF (PAIR? (CDR ,rest))
+ (MAP-N (CONS ,first ,rest))
+ (MAP-2 ,first (CAR ,rest)))
+ (MAP-1 ,first))))))))
-(define (for-each procedure first . rest)
- (mapping-procedure for-each begin unspecific procedure first rest))
+ (define (for-each procedure first . rest)
+ (mapper for-each begin unspecific procedure first rest))
-;;(define (map procedure first . rest)
-;; (mapping-procedure map cons '() procedure first rest))
+ ;;(define (map procedure first . rest)
+ ;; (mapper map cons '() procedure first rest))
-(define (map* initial-value procedure first . rest)
- (mapping-procedure map* cons initial-value procedure first rest))
+ (define (map* initial-value procedure first . rest)
+ (mapper map* cons initial-value procedure first rest))
-(define (append-map procedure first . rest)
- (mapping-procedure append-map append '() procedure first rest))
+ (define (append-map procedure first . rest)
+ (mapper append-map append '() procedure first rest))
-(define (append-map* initial-value procedure first . rest)
- (mapping-procedure append-map* append initial-value procedure first rest))
+ (define (append-map* initial-value procedure first . rest)
+ (mapper append-map* append initial-value procedure first rest))
-(define (append-map! procedure first . rest)
- (mapping-procedure append-map! append! '() procedure first rest))
-
-(define (append-map*! initial-value procedure first . rest)
- (mapping-procedure append-map*! append! initial-value procedure first rest))
-
-;;; end LET-SYNTAX
-)
+ (define (append-map! procedure first . rest)
+ (mapper append-map! append! '() procedure first rest))
+ (define (append-map*! initial-value procedure first . rest)
+ (mapper append-map*! append! initial-value procedure first rest)))
+\f
(define mapcan append-map!)
(define mapcan* append-map*!)
-\f
+
(define (reduce procedure initial list)
(if (pair? list)
(let loop ((value (car list)) (l (cdr list)))
+++ /dev/null
-#| -*-Scheme-*-
-
-$Id: macros.scm,v 1.6 2001/12/21 18:22:15 cph Exp $
-
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-This program is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-|#
-
-;;;; More Special Forms
-;;; package: (runtime macros)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (for-each (lambda (keyword transform)
- (environment-define-macro system-global-environment
- keyword
- transform))
- '(AND
- CASE
- CONS-STREAM
- DEFINE-INTEGRABLE
- DO
- LET*
- LETREC
- QUASIQUOTE
- SEQUENCE)
- (list transform/and
- transform/case
- transform/cons-stream
- transform/define-integrable
- transform/do
- transform/let*
- transform/letrec
- transform/quasiquote
- transform/sequence)))
-
-(define (make-absolute-reference name)
- `(ACCESS ,name #F))
-
-(define (transform/and . expressions)
- (if (null? expressions)
- '#T
- (let loop ((expressions expressions))
- (if (null? (cdr expressions))
- (car expressions)
- `(IF ,(car expressions)
- ,(loop (cdr expressions))
- #F)))))
-
-(define (transform/cons-stream head tail)
- `(,(make-absolute-reference 'CONS) ,head (DELAY ,tail)))
-
-(define (transform/sequence . actions)
- `(BEGIN . ,actions))
-\f
-;;;; Quasiquote
-
-(define (transform/quasiquote expression)
- (descend-quasiquote expression 0 finalize-quasiquote))
-
-(define (descend-quasiquote x level return)
- (cond ((pair? x) (descend-quasiquote-pair x level return))
- ((vector? x) (descend-quasiquote-vector x level return))
- (else (return 'QUOTE x))))
-
-(define (descend-quasiquote-pair x level return)
- (define (descend-quasiquote-pair* level)
- (descend-quasiquote (car x) level
- (lambda (car-mode car-arg)
- (descend-quasiquote (cdr x) level
- (lambda (cdr-mode cdr-arg)
- (cond ((and (eq? car-mode 'QUOTE)
- (eq? cdr-mode 'QUOTE))
- (return 'QUOTE x))
- ((eq? car-mode 'UNQUOTE-SPLICING)
- (if (and (eq? cdr-mode 'QUOTE)
- (null? cdr-arg))
- (return 'UNQUOTE car-arg)
- (return (make-absolute-reference 'APPEND)
- (list car-arg
- (finalize-quasiquote cdr-mode cdr-arg)))))
- ((and (eq? cdr-mode 'QUOTE)
- (null? cdr-arg))
- (return 'LIST
- (list (finalize-quasiquote car-mode car-arg))))
- ((and (eq? cdr-mode 'QUOTE)
- (list? cdr-arg))
- (return 'LIST
- (cons (finalize-quasiquote car-mode car-arg)
- (map (lambda (el)
- (finalize-quasiquote 'QUOTE el))
- cdr-arg))))
- ((memq cdr-mode '(LIST CONS))
- (return cdr-mode
- (cons (finalize-quasiquote car-mode car-arg)
- cdr-arg)))
- (else
- (return
- 'CONS
- (list (finalize-quasiquote car-mode car-arg)
- (finalize-quasiquote cdr-mode cdr-arg))))))))))
- (cond ((and (eq? (car x) 'QUASIQUOTE)
- (pair? (cdr x))
- (null? (cddr x)))
- (descend-quasiquote-pair* (1+ level)))
- ((and (or (eq? (car x) 'UNQUOTE)
- (eq? (car x) 'UNQUOTE-SPLICING))
- (pair? (cdr x))
- (null? (cddr x)))
- (if (zero? level)
- (return (car x) (cadr x))
- (descend-quasiquote-pair* (- level 1))))
- (else
- (descend-quasiquote-pair* level))))
-\f
-(define (descend-quasiquote-vector x level return)
- (descend-quasiquote (vector->list x) level
- (lambda (mode arg)
- (case mode
- ((QUOTE)
- (return 'QUOTE x))
- ((LIST)
- (return (make-absolute-reference 'VECTOR) arg))
- (else
- (return (make-absolute-reference 'LIST->VECTOR)
- (list (finalize-quasiquote mode arg))))))))
-
-(define (finalize-quasiquote mode arg)
- (case mode
- ((QUOTE) `',arg)
- ((UNQUOTE) arg)
- ((UNQUOTE-SPLICING) (error ",@ in illegal context" arg))
- ((LIST) `(,(make-absolute-reference 'LIST) ,@arg))
- ((CONS)
- (if (= (length arg) 2)
- `(,(make-absolute-reference 'CONS) ,@arg)
- `(,(make-absolute-reference 'CONS*) ,@arg)))
- (else `(,mode ,@arg))))
-\f
-(define (transform/case expr . clauses)
- (let ((need-temp? (not (symbol? expr))))
- (let ((the-expression (if need-temp? (generate-uninterned-symbol) expr)))
- (define (process-clauses clauses)
- (if (null? clauses)
- '()
- (let ((selector (caar clauses))
- (rest (process-clauses (cdr clauses))))
- (if (null? selector)
- rest
- `((,(cond ((eq? selector 'ELSE)
- (if (not (null? (cdr clauses)))
- (error "CASE SYNTAX: ELSE not last clause"
- clauses))
- 'ELSE)
- ((pair? selector)
- (transform selector))
- (else
- (single-clause selector)))
- ,@(cdar clauses))
- ,@rest)))))
-
- (define (check-selector selector)
- (or (null? selector)
- (and (eq-testable? (car selector))
- (check-selector (cdr selector)))))
-
- (define (eq-testable? selector)
- (or (symbol? selector)
- (char? selector) ;**** implementation dependent.
- (fix:fixnum? selector) ;**** implementation dependent.
- (eq? selector false)
- (eq? selector true)))
-
- (define (single-clause selector)
- `(,(if (eq-testable? selector) 'EQ? 'EQV?) ,the-expression ',selector))
-
- (define (transform selector)
- ;; Optimized for speed in compiled code.
- (cond ((null? (cdr selector))
- (single-clause (car selector)))
- ((null? (cddr selector))
- `(OR ,(single-clause (car selector))
- ,(single-clause (cadr selector))))
- ((null? (cdddr selector))
- `(OR ,(single-clause (car selector))
- ,(single-clause (cadr selector))
- ,(single-clause (caddr selector))))
- ((null? (cddddr selector))
- `(OR ,(single-clause (car selector))
- ,(single-clause (cadr selector))
- ,(single-clause (caddr selector))
- ,(single-clause (cadddr selector))))
- (else
- `(,(if (check-selector selector) 'MEMQ 'MEMV)
- ,the-expression ',selector))))
-
- (let ((body `(COND ,@(process-clauses clauses))))
- (if need-temp?
- `(let ((,the-expression ,expr))
- ,body)
- body)))))
-\f
-(define (transform/let* bindings . body)
- (guarantee-let-bindings bindings 'LET* #f)
- (define (do-one bindings)
- (if (null? bindings)
- `(BEGIN ,@body)
- `(LET (,(car bindings))
- ,(do-one (cdr bindings)))))
- (if (null? bindings)
- `(LET () ,@body) ; To allow internal definitions
- (do-one bindings)))
-
-(define (transform/letrec bindings . body)
- (guarantee-let-bindings bindings 'LETREC #f)
- `(LET ()
- ,@(map (lambda (binding) `(DEFINE ,@binding)) bindings)
- (LET () ; Internal definitions must be in
- ; nested contour.
- ,@body)))
-
-(define (transform/do bindings test . body)
- (guarantee-let-bindings bindings 'DO #t)
- (let ((the-name (string->uninterned-symbol "do-loop")))
- `(LET ,the-name
- ,(map (lambda (binding)
- (if (or (null? (cdr binding))
- (null? (cddr binding)))
- binding
- `(,(car binding) ,(cadr binding))))
- bindings)
- ,(process-cond-clause test false
- `(BEGIN
- ,@body
- (,the-name ,@(map (lambda (binding)
- (if (or (null? (cdr binding))
- (null? (cddr binding)))
- (car binding)
- (caddr binding)))
- bindings)))))))
-
-(define (guarantee-let-bindings bindings keyword do-like?)
- (if (not (and (list? bindings)
- (for-all? bindings
- (lambda (binding)
- (and (list? binding)
- (not (null? binding))
- (symbol? (car binding))
- (or (null? (cdr binding))
- (null? (cddr binding))
- (and do-like? (null? (cdddr binding)))))))))
- (error "SYNTAX: Bad bindings:" keyword bindings)))
-
-(define (process-cond-clause clause else-permitted? rest)
- (if (or (null? clause) (not (list? clause)))
- (error "cond-clause syntax: not a non-empty list:" clause))
- (cond ((eq? 'ELSE (car clause))
- (if (not else-permitted?)
- (error "cond-clause syntax: ELSE not permitted:" clause))
- (if (null? (cdr clause))
- (error "cond-clause syntax: ELSE missing expressions:" clause))
- `(BEGIN ,@(cdr clause)))
- ((null? (cdr clause))
- `(OR ,(car clause) ,rest))
- ((eq? '=> (cadr clause))
- (if (null? (cddr clause))
- (error "cond-clause syntax: => missing recipient:" clause))
- (if (not (null? (cdddr clause)))
- (error "cond-clause syntax: misformed => clause:" clause))
- (let ((predicate (string->uninterned-symbol "predicate")))
- `(LET ((,predicate ,(car clause)))
- (IF ,predicate
- (,(caddr clause) ,predicate)
- ,rest))))
- (else
- (if (null? (cdr clause))
- (error "cond-clause syntax: missing expressions:" clause))
- `(IF ,(car clause)
- (BEGIN ,@(cdr clause))
- ,rest))))
-\f
-(define transform/define-integrable
- (lambda (pattern . body)
- (parse-define-syntax pattern body
- (lambda (name body)
- `(BEGIN (DECLARE (INTEGRATE ,pattern))
- (DEFINE ,name ,@body)))
- (lambda (pattern body)
- `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern)))
- (DEFINE ,pattern
- ,@(if (list? (cdr pattern))
- `((DECLARE
- (INTEGRATE
- ,@(lambda-list->bound-names (cdr pattern)))))
- '())
- ,@body))))))
-
-(define (parse-define-syntax pattern body if-variable if-lambda)
- (cond ((pair? pattern)
- (let loop ((pattern pattern) (body body))
- (cond ((pair? (car pattern))
- (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body))))
- ((symbol? (car pattern))
- (if-lambda pattern body))
- (else
- (error "Illegal name" (car pattern))))))
- ((symbol? pattern)
- (if-variable pattern body))
- (else
- (error "Illegal name" pattern))))
-
-(define (lambda-list->bound-names lambda-list)
- (cond ((null? lambda-list)
- '())
- ((pair? lambda-list)
- (let ((lambda-list
- (if (eq? (car lambda-list) lambda-optional-tag)
- (begin (if (not (pair? (cdr lambda-list)))
- (error "Missing optional variable" lambda-list))
- (cdr lambda-list))
- lambda-list)))
- (cons (let ((parameter (car lambda-list)))
- (if (pair? parameter) (car parameter) parameter))
- (lambda-list->bound-names (cdr lambda-list)))))
- (else
- (if (not (symbol? lambda-list))
- (error "Illegal rest variable" lambda-list))
- (list lambda-list))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: make.scm,v 14.83 2002/01/12 02:56:18 cph Exp $
+$Id: make.scm,v 14.84 2002/02/03 03:38:56 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(define system-global-environment #f)
-(define (non-hygienic-macro-transformer transformer)
- transformer)
-
;; *MAKE-ENVIRONMENT is referred to by compiled code. It must go
;; before the uses of the-environment later, and after apply above.
(define (*make-environment parent names . values)
(let-syntax
((ucode-type
- (non-hygienic-macro-transformer
- (lambda (name) (microcode-type name)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (microcode-type (cadr form))))))
(system-list->vector
(ucode-type environment)
(cons (system-pair-cons (ucode-type procedure)
(vector lambda-tag:unnamed))))
(define-syntax ucode-primitive
- (non-hygienic-macro-transformer
- (lambda arguments
- (apply make-primitive-procedure arguments))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply make-primitive-procedure (cdr form)))))
(define-syntax ucode-type
- (non-hygienic-macro-transformer
- (lambda (name)
- (microcode-type name))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (microcode-type (cadr form)))))
(define-integrable + (ucode-primitive integer-add))
(define-integrable - (ucode-primitive integer-subtract))
(package/add-child! system-global-package 'PACKAGE environment-for-package)
(define packages-file
- (fasload (case os-name
- ((NT) "runtime-w32.pkd")
- ((OS/2) "runtime-os2.pkd")
- ((UNIX) "runtime-unx.pkd")
- (else "runtime-unk.pkd"))
+ (fasload (cond ((eq? os-name 'NT) "runtime-w32.pkd")
+ ((eq? os-name 'OS/2) "runtime-os2.pkd")
+ ((eq? os-name 'UNIX) "runtime-unx.pkd")
+ (else "runtime-unk.pkd"))
#f))
((lexical-reference environment-for-package 'CONSTRUCT-PACKAGES-FROM-FILE)
packages-file)
("random" . (RUNTIME RANDOM-NUMBER))
("gentag" . (RUNTIME GENERIC-PROCEDURE))
("poplat" . (RUNTIME POPULATION))
- ("record" . (RUNTIME RECORD))))
+ ("record" . (RUNTIME RECORD))
+ ("syntax-transforms" . (RUNTIME SYNTACTIC-CLOSURES))))
(files2
'(("prop1d" . (RUNTIME 1D-PROPERTY))
("events" . (RUNTIME EVENT-DISTRIBUTOR))
#t)
(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! #t)
(package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
+ (package-initialize '(RUNTIME SYNTACTIC-CLOSURES)
+ 'INITIALIZE-SYNTAX-TRANSFORMS!
+ #t)
(load-files files2)
(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! #t)
(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! #t)
(RUNTIME NUMBER-PARSER)
(RUNTIME PARSER)
(RUNTIME UNPARSER)
- (RUNTIME SYNTAXER)
- (RUNTIME ILLEGAL-DEFINITIONS)
- (RUNTIME MACROS)
(RUNTIME UNSYNTAXER)
(RUNTIME PRETTY-PRINTER)
(RUNTIME EXTENDED-SCODE-EVAL)
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: mit-syntax.scm,v 14.1 2002/02/03 03:38:56 cph Exp $
+;;;
+;;; Copyright (c) 1989-1991, 2001, 2002 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
+
+;;;; MIT Scheme Syntax
+
+(declare (usual-integrations))
+\f
+;;;; Macro transformers
+
+(define (define-er-macro-transformer keyword environment transformer)
+ (syntactic-environment/define environment keyword
+ (er-macro-transformer->expander transformer environment)))
+
+(define (transformer-keyword transformer->expander-name transformer->expander)
+ (lambda (form environment definition-environment history)
+ definition-environment ;ignore
+ (syntax-check '(KEYWORD EXPRESSION) form history)
+ (let ((item
+ (classify/subexpression (cadr form)
+ environment
+ history
+ select-cadr)))
+ (make-transformer-item
+ (transformer->expander
+ (transformer-eval (compile-item/expression item)
+ (syntactic-environment->environment environment))
+ environment)
+ (make-expression-item history
+ (lambda ()
+ (output/combination
+ (output/access-reference transformer->expander-name
+ system-global-environment)
+ (list (compile-item/expression item)
+ (output/the-environment)))))))))
+
+(define-classifier 'SC-MACRO-TRANSFORMER system-global-environment
+ ;; "Syntactic Closures" transformer
+ (transformer-keyword 'SC-MACRO-TRANSFORMER->EXPANDER
+ sc-macro-transformer->expander))
+
+(define-classifier 'RSC-MACRO-TRANSFORMER system-global-environment
+ ;; "Reversed Syntactic Closures" transformer
+ (transformer-keyword 'RSC-MACRO-TRANSFORMER->EXPANDER
+ rsc-macro-transformer->expander))
+
+(define-classifier 'ER-MACRO-TRANSFORMER system-global-environment
+ ;; "Explicit Renaming" transformer
+ (transformer-keyword 'ER-MACRO-TRANSFORMER->EXPANDER
+ er-macro-transformer->expander))
+
+(define-classifier 'NON-HYGIENIC-MACRO-TRANSFORMER system-global-environment
+ (transformer-keyword 'NON-HYGIENIC-MACRO-TRANSFORMER->EXPANDER
+ non-hygienic-macro-transformer->expander))
+\f
+;;;; Core primitives
+
+(define-compiler 'LAMBDA system-global-environment
+ (lambda (form environment history)
+ (syntax-check '(KEYWORD MIT-BVL + FORM) form history)
+ (call-with-values
+ (lambda ()
+ (compile/lambda (cadr form)
+ (cddr form)
+ select-cddr
+ environment
+ history))
+ (lambda (bvl body)
+ (output/lambda bvl body)))))
+
+(define-compiler 'NAMED-LAMBDA system-global-environment
+ (lambda (form environment history)
+ (syntax-check '(KEYWORD (IDENTIFIER . MIT-BVL) + FORM) form history)
+ (call-with-values
+ (lambda ()
+ (compile/lambda (cdadr form)
+ (cddr form)
+ select-cddr
+ environment
+ history))
+ (lambda (bvl body)
+ (output/named-lambda (identifier->symbol (caadr form)) bvl body)))))
+
+(define (compile/lambda bvl body select-body environment history)
+ (let ((environment (make-internal-syntactic-environment environment)))
+ ;; Force order -- bind names before classifying body.
+ (let ((bvl
+ (map-mit-lambda-list (lambda (identifier)
+ (bind-variable! environment identifier))
+ bvl)))
+ (values bvl
+ (compile-body-item
+ (classify/body body
+ environment
+ environment
+ history
+ select-body))))))
+
+(define (map-mit-lambda-list procedure bvl)
+ (let loop ((bvl bvl))
+ (if (pair? bvl)
+ (cons (if (or (eq? (car bvl) lambda-optional-tag)
+ (eq? (car bvl) lambda-rest-tag))
+ (car bvl)
+ (procedure (car bvl)))
+ (loop (cdr bvl)))
+ (if (identifier? bvl)
+ (procedure bvl)
+ '()))))
+\f
+(define-classifier 'BEGIN system-global-environment
+ (lambda (form environment definition-environment history)
+ (syntax-check '(KEYWORD * FORM) form history)
+ (make-body-item history
+ (classify/subforms (cdr form)
+ environment
+ definition-environment
+ history
+ select-cdr))))
+
+(define-compiler 'IF system-global-environment
+ (lambda (form environment history)
+ (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION)
+ form history)
+ (output/conditional
+ (compile/subexpression (cadr form) environment history select-cadr)
+ (compile/subexpression (caddr form) environment history select-caddr)
+ (if (pair? (cdddr form))
+ (compile/subexpression (cadddr form)
+ environment
+ history
+ select-cadddr)
+ (output/unspecific)))))
+
+(define-compiler 'QUOTE system-global-environment
+ (lambda (form environment history)
+ environment ;ignore
+ (syntax-check '(KEYWORD DATUM) form history)
+ (output/constant (strip-syntactic-closures (cadr form)))))
+
+(define-compiler 'SET! system-global-environment
+ (lambda (form environment history)
+ (syntax-check '(KEYWORD FORM ? EXPRESSION) form history)
+ (call-with-values
+ (lambda ()
+ (classify/sublocation (cadr form) environment history select-cadr))
+ (lambda (name environment-item)
+ (let ((value
+ (if (pair? (cddr form))
+ (compile/subexpression (caddr form)
+ environment
+ history
+ select-caddr)
+ (output/unassigned))))
+ (if environment-item
+ (output/access-assignment
+ name
+ (compile-item/expression environment-item)
+ value)
+ (output/assignment name value)))))))
+
+(define (classify/sublocation form environment history selector)
+ (classify/location form
+ environment
+ (history/add-subproblem form
+ environment
+ history
+ selector)))
+
+(define (classify/location form environment history)
+ (let ((item (classify/expression form environment history)))
+ (cond ((variable-item? item)
+ (values (variable-item/name item) #f))
+ ((access-item? item)
+ (values (access-item/name item) (access-item/environment item)))
+ (else
+ (syntax-error history "Variable required in this context:" form)))))
+
+(define-compiler 'DELAY system-global-environment
+ (lambda (form environment history)
+ (syntax-check '(KEYWORD EXPRESSION) form history)
+ (output/delay
+ (compile/subexpression (cadr form)
+ environment
+ history
+ select-cadr))))
+\f
+;;;; Definitions
+
+(define-er-macro-transformer 'DEFINE system-global-environment
+ (let ((keyword
+ (classifier->keyword
+ (lambda (form environment definition-environment history)
+ (classify/define form environment definition-environment history
+ variable-binding-theory)))))
+ (lambda (form rename compare)
+ compare ;ignore
+ (cond ((syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
+ `(,(car form) ,(caadr form)
+ (,(rename 'NAMED-LAMBDA) ,@(cdr form))))
+ ((syntax-match? '((DATUM . MIT-BVL) + FORM) (cdr form))
+ `(,(car form) ,(caadr form)
+ (,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form))))
+ ((syntax-match? '(IDENTIFIER) (cdr form))
+ `(,keyword ,(cadr form) ,(unassigned-expression)))
+ ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
+ `(,keyword ,(cadr form) ,(caddr form)))
+ (else
+ (ill-formed-syntax form))))))
+
+(define-classifier 'DEFINE-SYNTAX system-global-environment
+ (lambda (form environment definition-environment history)
+ (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form history)
+ (classify/define form environment definition-environment history
+ syntactic-binding-theory)))
+
+(define (classify/define form environment definition-environment history
+ binding-theory)
+ (syntactic-environment/define definition-environment
+ (cadr form)
+ (make-reserved-name-item history))
+ (binding-theory definition-environment
+ (cadr form)
+ (classify/subexpression (caddr form)
+ environment
+ history
+ select-caddr)
+ history))
+
+(define (syntactic-binding-theory environment name item history)
+ (if (not (keyword-item? item))
+ (let ((history (item/history item)))
+ (syntax-error history
+ "Syntactic binding value must be a keyword:"
+ (history/original-form history))))
+ (overloaded-binding-theory environment name item history))
+
+(define (variable-binding-theory environment name item history)
+ (if (keyword-item? item)
+ (let ((history (item/history item)))
+ (syntax-error history
+ "Binding value may not be a keyword:"
+ (history/original-form history))))
+ (overloaded-binding-theory environment name item history))
+
+(define (overloaded-binding-theory environment name item history)
+ (if (keyword-item? item)
+ (begin
+ (syntactic-environment/define environment
+ name
+ (item/new-history item #f))
+ ;; User-defined macros at top level are preserved in the output.
+ (if (and (transformer-item? item)
+ (syntactic-environment/top-level? environment))
+ (make-binding-item history name item)
+ (make-null-binding-item history)))
+ (make-binding-item history (bind-variable! environment name) item)))
+\f
+;;;; LET-like
+
+(define-er-macro-transformer 'LET system-global-environment
+ (let ((keyword
+ (classifier->keyword
+ (lambda (form environment definition-environment history)
+ definition-environment
+ (let ((body-environment
+ (make-internal-syntactic-environment environment)))
+ (classify/let-like form
+ environment
+ body-environment
+ body-environment
+ history
+ variable-binding-theory
+ output/let))))))
+ (lambda (form rename compare)
+ compare ;ignore
+ (cond ((syntax-match? '(IDENTIFIER (* (IDENTIFIER EXPRESSION)) + FORM)
+ (cdr form))
+ (let ((name (cadr form))
+ (bindings (caddr form))
+ (body (cdddr form)))
+ `((,(rename 'LETREC)
+ ((,name (,(rename 'LAMBDA) ,(map car bindings) ,@body)))
+ ,name)
+ ,@(map cadr bindings))))
+ ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form))
+ `(,keyword ,@(cdr (normalize-let-bindings form))))
+ (else
+ (ill-formed-syntax form))))))
+
+(define-er-macro-transformer 'LET* system-global-environment
+ (lambda (form rename compare)
+ compare ;ignore
+ (expand/let* form rename 'LET)))
+
+(define-classifier 'LETREC system-global-environment
+ (lambda (form environment definition-environment history)
+ definition-environment
+ (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form history)
+ (let ((body-environment (make-internal-syntactic-environment environment)))
+ (for-each (let ((item (make-reserved-name-item history)))
+ (lambda (binding)
+ (syntactic-environment/define body-environment
+ (car binding)
+ item)))
+ (cadr form))
+ (classify/let-like form
+ body-environment
+ body-environment
+ body-environment
+ history
+ variable-binding-theory
+ output/letrec))))
+
+(define (normalize-let-bindings form)
+ `(,(car form) ,(map (lambda (binding)
+ (if (pair? (cdr binding))
+ binding
+ (list (car binding) (unassigned-expression))))
+ (cadr form))
+ ,@(cddr form)))
+\f
+(define-classifier 'LET-SYNTAX system-global-environment
+ (lambda (form environment definition-environment history)
+ definition-environment
+ (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form history)
+ (classify/let-like form
+ environment
+ definition-environment
+ (make-internal-syntactic-environment environment)
+ history
+ syntactic-binding-theory
+ output/let)))
+
+(define-er-macro-transformer 'LET*-SYNTAX system-global-environment
+ (lambda (form rename compare)
+ compare ;ignore
+ (expand/let* form rename 'LET-SYNTAX)))
+
+(define-classifier 'LETREC-SYNTAX system-global-environment
+ (lambda (form environment definition-environment history)
+ definition-environment
+ (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form history)
+ (let ((body-environment (make-internal-syntactic-environment environment)))
+ (for-each (let ((item (make-reserved-name-item history)))
+ (lambda (binding)
+ (syntactic-environment/define body-environment
+ (car binding)
+ item)))
+ (cadr form))
+ (classify/let-like form
+ body-environment
+ definition-environment
+ body-environment
+ history
+ syntactic-binding-theory
+ output/letrec))))
+\f
+(define (classify/let-like form environment definition-environment
+ body-environment history binding-theory output/let)
+ ;; Classify right-hand sides first, in order to catch references to
+ ;; reserved names. Then bind names prior to classifying body.
+ (let* ((bindings
+ (delete-matching-items!
+ (map (lambda (binding item)
+ (binding-theory body-environment
+ (car binding)
+ item
+ history))
+ (cadr form)
+ (select-map (lambda (binding selector)
+ (classify/subexpression (cadr binding)
+ environment
+ history
+ (selector/add-cadr
+ selector)))
+ (cadr form)
+ select-cadr))
+ null-binding-item?))
+ (body
+ (classify/body (cddr form)
+ body-environment
+ definition-environment
+ history
+ select-cddr)))
+ (if (eq? binding-theory syntactic-binding-theory)
+ body
+ (make-expression-item history
+ (lambda ()
+ (output/let (map binding-item/name bindings)
+ (map (lambda (binding)
+ (compile-item/expression
+ (binding-item/value binding)))
+ bindings)
+ (compile-body-item body)))))))
+
+(define (expand/let* form rename let-keyword)
+ (capture-expansion-history
+ (lambda (history)
+ (syntax-check '(KEYWORD (* DATUM) + FORM) form history)
+ (let ((bindings (cadr form))
+ (body (cddr form))
+ (keyword (rename let-keyword)))
+ (if (pair? bindings)
+ (let loop ((bindings bindings))
+ (if (pair? (cdr bindings))
+ `(,keyword (,(car bindings)) ,(loop (cdr bindings)))
+ `(,keyword ,bindings ,@body)))
+ `(,keyword ,bindings ,@body))))))
+
+;;;; Bodies
+
+(define (compile-body-item item)
+ (call-with-values
+ (lambda ()
+ (extract-declarations-from-body (body-item/components item)))
+ (lambda (declaration-items items)
+ (output/body (map declaration-item/text declaration-items)
+ (compile-body-items item items)))))
+\f
+;;;; Derived syntax
+
+(define-er-macro-transformer 'AND system-global-environment
+ (lambda (form rename compare)
+ compare ;ignore
+ (capture-expansion-history
+ (lambda (history)
+ (syntax-check '(KEYWORD * EXPRESSION) form history)
+ (let ((operands (cdr form)))
+ (if (pair? operands)
+ (let ((if-keyword (rename 'IF)))
+ (let loop ((operands operands))
+ (if (pair? (cdr operands))
+ `(,if-keyword ,(car operands)
+ ,(loop (cdr operands))
+ #F)
+ (car operands))))
+ `#T))))))
+
+(define-er-macro-transformer 'OR system-global-environment
+ (lambda (form rename compare)
+ compare ;ignore
+ (capture-expansion-history
+ (lambda (history)
+ (syntax-check '(KEYWORD * EXPRESSION) form history)
+ (let ((operands (cdr form)))
+ (if (pair? operands)
+ (let ((let-keyword (rename 'LET))
+ (if-keyword (rename 'IF))
+ (temp (rename 'TEMP)))
+ (let loop ((operands operands))
+ (if (pair? (cdr operands))
+ `(,let-keyword ((,temp ,(car operands)))
+ (,if-keyword ,temp
+ ,temp
+ ,(loop (cdr operands))))
+ (car operands))))
+ `#F))))))
+
+(define-er-macro-transformer 'CASE system-global-environment
+ (lambda (form rename compare)
+ (capture-expansion-history
+ (lambda (history)
+ (syntax-check '(KEYWORD EXPRESSION + (DATUM + EXPRESSION)) form history)
+ (call-with-syntax-error-procedure
+ (lambda (syntax-error)
+ (letrec
+ ((process-clause
+ (lambda (clause rest)
+ (cond ((null? (car clause))
+ (process-rest rest))
+ ((and (identifier? (car clause))
+ (compare (rename 'ELSE) (car clause))
+ (null? rest))
+ `(,(rename 'BEGIN) ,@(cdr clause)))
+ ((list? (car clause))
+ `(,(rename 'IF) (,(rename 'MEMV) ,(rename 'TEMP)
+ ',(car clause))
+ (,(rename 'BEGIN) ,@(cdr clause))
+ ,(process-rest rest)))
+ (else
+ (syntax-error "Ill-formed clause:" clause)))))
+ (process-rest
+ (lambda (rest)
+ (if (pair? rest)
+ (process-clause (car rest) (cdr rest))
+ (unspecific-expression)))))
+ `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form)))
+ ,(process-clause (caddr form)
+ (cdddr form))))))))))
+\f
+(define-er-macro-transformer 'COND system-global-environment
+ (lambda (form rename compare)
+ (capture-expansion-history
+ (lambda (history)
+ (let ((clauses (cdr form)))
+ (if (not (pair? clauses))
+ (syntax-error history "Form must have at least one clause:" form))
+ (let loop ((clause (car clauses)) (rest (cdr clauses)))
+ (expand/cond-clause clause rename compare history (null? rest)
+ (if (pair? rest)
+ (loop (car rest) (cdr rest))
+ (unspecific-expression)))))))))
+
+(define-er-macro-transformer 'DO system-global-environment
+ (lambda (form rename compare)
+ (capture-expansion-history
+ (lambda (history)
+ (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION ? EXPRESSION))
+ (+ FORM)
+ * FORM)
+ form history)
+ (let ((bindings (cadr form))
+ (r-loop (rename 'DO-LOOP)))
+ `(,(rename 'LET)
+ ,r-loop
+ ,(map (lambda (binding)
+ (list (car binding) (cadr binding)))
+ bindings)
+ ,(expand/cond-clause (caddr form) rename compare history #f
+ `(,(rename 'BEGIN)
+ ,@(cdddr form)
+ (,r-loop ,@(map (lambda (binding)
+ (if (pair? (cddr binding))
+ (caddr binding)
+ (car binding)))
+ bindings))))))))))
+
+(define (expand/cond-clause clause rename compare history else-allowed?
+ alternative)
+ (if (not (and (pair? clause) (list? (cdr clause))))
+ (syntax-error history "Ill-formed clause:" clause))
+ (cond ((and (identifier? (car clause))
+ (compare (rename 'ELSE) (car clause)))
+ (if (not else-allowed?)
+ (syntax-error history "Misplaced ELSE clause:" clause))
+ (if (or (not (pair? (cdr clause)))
+ (and (identifier? (cadr clause))
+ (compare (rename '=>) (cadr clause))))
+ (syntax-error history "Ill-formed ELSE clause:" clause))
+ `(,(rename 'BEGIN) ,@(cdr clause)))
+ ((not (pair? (cdr clause)))
+ (let ((r-temp (rename 'TEMP)))
+ `(,(rename 'LET) ((,r-temp ,(car clause)))
+ (,(rename 'IF) ,r-temp ,r-temp ,alternative))))
+ ((and (identifier? (cadr clause))
+ (compare (rename '=>) (cadr clause)))
+ (if (not (and (pair? (cddr clause))
+ (null? (cdddr clause))))
+ (syntax-error history "Ill-formed => clause:" clause))
+ (let ((r-temp (rename 'TEMP)))
+ `(,(rename 'LET) ((,r-temp ,(car clause)))
+ (,(rename 'IF) ,r-temp
+ (,(caddr clause) ,r-temp)
+ ,alternative))))
+ (else
+ `(,(rename 'IF) ,(car clause)
+ (,(rename 'BEGIN) ,@(cdr clause))
+ ,alternative))))
+\f
+(define-er-macro-transformer 'QUASIQUOTE system-global-environment
+ (lambda (form rename compare)
+ (call-with-syntax-error-procedure
+ (lambda (syntax-error)
+ (define (descend-quasiquote x level return)
+ (cond ((pair? x) (descend-quasiquote-pair x level return))
+ ((vector? x) (descend-quasiquote-vector x level return))
+ (else (return 'QUOTE x))))
+ (define (descend-quasiquote-pair x level return)
+ (cond ((not (and (pair? x)
+ (identifier? (car x))
+ (pair? (cdr x))
+ (null? (cddr x))))
+ (descend-quasiquote-pair* x level return))
+ ((compare (rename 'QUASIQUOTE) (car x))
+ (descend-quasiquote-pair* x (+ level 1) return))
+ ((compare (rename 'UNQUOTE) (car x))
+ (if (zero? level)
+ (return 'UNQUOTE (cadr x))
+ (descend-quasiquote-pair* x (- level 1) return)))
+ ((compare (rename 'UNQUOTE-SPLICING) (car x))
+ (if (zero? level)
+ (return 'UNQUOTE-SPLICING (cadr x))
+ (descend-quasiquote-pair* x (- level 1) return)))
+ (else
+ (descend-quasiquote-pair* x level return))))
+ (define (descend-quasiquote-pair* x level return)
+ (descend-quasiquote (car x) level
+ (lambda (car-mode car-arg)
+ (descend-quasiquote (cdr x) level
+ (lambda (cdr-mode cdr-arg)
+ (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE))
+ (return 'QUOTE x))
+ ((eq? car-mode 'UNQUOTE-SPLICING)
+ (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg))
+ (return 'UNQUOTE car-arg)
+ (return 'APPEND
+ (list car-arg
+ (finalize-quasiquote cdr-mode
+ cdr-arg)))))
+ ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg))
+ (return 'LIST
+ (cons (finalize-quasiquote car-mode car-arg)
+ (map (lambda (element)
+ (finalize-quasiquote 'QUOTE
+ element))
+ cdr-arg))))
+ ((eq? cdr-mode 'LIST)
+ (return 'LIST
+ (cons (finalize-quasiquote car-mode car-arg)
+ cdr-arg)))
+ (else
+ (return
+ 'CONS
+ (list (finalize-quasiquote car-mode car-arg)
+ (finalize-quasiquote cdr-mode cdr-arg))))))))))
+ (define (descend-quasiquote-vector x level return)
+ (descend-quasiquote (vector->list x) level
+ (lambda (mode arg)
+ (case mode
+ ((QUOTE) (return 'QUOTE x))
+ ((LIST) (return 'VECTOR arg))
+ (else
+ (return 'LIST->VECTOR
+ (list (finalize-quasiquote mode arg))))))))
+ (define (finalize-quasiquote mode arg)
+ (case mode
+ ((QUOTE) `(,(rename 'QUOTE) ,arg))
+ ((UNQUOTE) arg)
+ ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context:" arg))
+ (else `(,(rename mode) ,@arg))))
+ (capture-expansion-history
+ (lambda (history)
+ (syntax-check '(KEYWORD EXPRESSION) form history)
+ (descend-quasiquote (cadr form) 0 finalize-quasiquote)))))))
+\f
+;;;; MIT-specific syntax
+
+(define-er-macro-transformer 'ACCESS system-global-environment
+ (let ((keyword
+ (classifier->keyword
+ (lambda (form environment definition-environment history)
+ definition-environment
+ (make-access-item history
+ (cadr form)
+ (classify/subexpression (caddr form)
+ environment
+ history
+ select-caddr))))))
+ (lambda (form rename compare)
+ rename compare ;ignore
+ (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
+ `(,keyword ,@(cdr form)))
+ ((syntax-match? '(IDENTIFIER IDENTIFIER + FORM) (cdr form))
+ `(,keyword ,(cadr form) (,(car form) ,@(cddr form))))
+ (else
+ (ill-formed-syntax form))))))
+
+(define access-item-rtd
+ (make-item-type "access-item" '(NAME ENVIRONMENT)
+ (lambda (item)
+ (output/access-reference
+ (access-item/name item)
+ (compile-item/expression (access-item/environment item))))))
+
+(define make-access-item
+ (item-constructor access-item-rtd '(NAME ENVIRONMENT)))
+
+(define access-item?
+ (item-predicate access-item-rtd))
+
+(define access-item/name
+ (item-accessor access-item-rtd 'NAME))
+
+(define access-item/environment
+ (item-accessor access-item-rtd 'ENVIRONMENT))
+
+(define-er-macro-transformer 'CONS-STREAM system-global-environment
+ (lambda (form rename compare)
+ compare ;ignore
+ (capture-expansion-history
+ (lambda (history)
+ (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form history)
+ `(,(rename 'CONS) ,(cadr form)
+ (,(rename 'DELAY) ,(caddr form)))))))
+
+(define-compiler 'DEFAULT-OBJECT? system-global-environment
+ (lambda (form environment history)
+ (syntax-check '(KEYWORD IDENTIFIER) form history)
+ (let ((item
+ (classify/subexpression (cadr form)
+ environment
+ history
+ select-cadr)))
+ (if (not (variable-item? item))
+ (syntax-error history "Variable required in this context:" form))
+ (output/unassigned-test (variable-item/name item)))))
+\f
+(define-er-macro-transformer 'DEFINE-INTEGRABLE system-global-environment
+ (lambda (form rename compare)
+ compare ;ignore
+ (let ((r-declare (rename 'DECLARE)))
+ (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
+ `(,(rename 'BEGIN)
+ (,r-declare (INTEGRATE ,(cadr form)))
+ (,(rename 'DEFINE) ,@(cdr form))))
+ ((syntax-match? '((IDENTIFIER * IDENTIFIER) + FORM) (cdr form))
+ `(,(rename 'BEGIN)
+ (,r-declare (INTEGRATE-OPERATOR ,(caadr form)))
+ (,(rename 'DEFINE) ,(cadr form)
+ (,r-declare (INTEGRATE ,@(cdadr form)))
+ ,@(cddr form))))
+ (else
+ (ill-formed-syntax form))))))
+
+(define-er-macro-transformer 'FLUID-LET system-global-environment
+ (lambda (form rename compare)
+ compare
+ (capture-expansion-history
+ (lambda (history)
+ (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM)
+ form history)
+ (let ((names (map car (cadr form)))
+ (r-let (rename 'LET))
+ (r-lambda (rename 'LAMBDA))
+ (r-set! (rename 'SET!)))
+ (let ((out-temps (map (make-name-generator) names))
+ (in-temps (map (make-name-generator) names))
+ (swap
+ (lambda (tos names froms)
+ `(,r-lambda ()
+ ,@(map (lambda (to name from)
+ `(,r-set! ,to
+ (,r-set! ,name
+ (,r-set! ,from))))
+ tos
+ names
+ froms)
+ ,(unspecific-expression)))))
+ `(,r-let (,@(map cons in-temps (map cdr (cadr form)))
+ ,@(map list out-temps))
+ (,(rename 'SHALLOW-FLUID-BIND)
+ ,(swap out-temps names in-temps)
+ (,r-lambda () ,@(cddr form))
+ ,(swap in-temps names out-temps)))))))))
+
+(define-compiler 'THE-ENVIRONMENT system-global-environment
+ (lambda (form environment history)
+ environment
+ (syntax-check '(KEYWORD) form history)
+ (if (not (syntactic-environment/top-level? environment))
+ (syntax-error history "This form allowed only at top level:" form))
+ (output/the-environment)))
+
+(define (unspecific-expression)
+ (compiler->form
+ (lambda (form environment history)
+ form environment history ;ignore
+ (output/unspecific))))
+
+(define (unassigned-expression)
+ (compiler->form
+ (lambda (form environment history)
+ form environment history ;ignore
+ (output/unassigned))))
+\f
+;;;; Declarations
+
+(define-classifier 'DECLARE system-global-environment
+ (lambda (form environment definition-environment history)
+ definition-environment
+ (syntax-check '(KEYWORD * (SYMBOL * DATUM)) form history)
+ (make-declaration-item history
+ (lambda ()
+ (map-declaration-references (cdr form)
+ environment
+ history
+ select-cdr)))))
+
+(define-classifier 'LOCAL-DECLARE system-global-environment
+ (lambda (form environment definition-environment history)
+ (syntax-check '(KEYWORD (* (SYMBOL * DATUM)) + FORM) form history)
+ (let ((body
+ (classify/body (cddr form)
+ environment
+ definition-environment
+ history
+ select-cddr)))
+ (make-expression-item history
+ (lambda ()
+ (output/local-declare (map-declaration-references (cadr form)
+ environment
+ history
+ select-cadr)
+ (compile-body-item body)))))))
+
+(define (map-declaration-references declarations environment history selector)
+ (select-map (lambda (declaration selector)
+ (let ((entry (assq (car declaration) known-declarations)))
+ (if entry
+ ((cdr entry) declaration environment history selector)
+ (begin
+ (warn "Ill-formed declaration:" declaration)
+ declaration))))
+ declarations
+ selector))
+
+(define (define-declaration name mapper)
+ (let ((entry (assq name known-declarations)))
+ (if entry
+ (set-cdr! entry mapper)
+ (begin
+ (set! known-declarations
+ (cons (cons name mapper) known-declarations))
+ unspecific))))
+
+(define known-declarations '())
+
+(define (classify/variable-subexpressions forms environment history selector)
+ (select-map (lambda (form selector)
+ (classify/variable-subexpression form
+ environment
+ history
+ selector))
+ forms
+ selector))
+
+(define (classify/variable-subexpression form environment history selector)
+ (let ((item (classify/subexpression form environment history selector)))
+ (if (not (variable-item? item))
+ (syntax-error history "Variable required in this context:" form))
+ (variable-item/name item)))
+\f
+(let ((ignore
+ (lambda (declaration environment history selector)
+ environment history selector
+ declaration)))
+ ;; The names in USUAL-INTEGRATIONS are always global.
+ (define-declaration 'USUAL-INTEGRATIONS ignore)
+ (define-declaration 'AUTOMAGIC-INTEGRATIONS ignore)
+ (define-declaration 'ETA-SUBSTITUTION ignore)
+ (define-declaration 'OPEN-BLOCK-OPTIMIZATIONS ignore)
+ (define-declaration 'NO-AUTOMAGIC-INTEGRATIONS ignore)
+ (define-declaration 'NO-ETA-SUBSTITUTION ignore)
+ (define-declaration 'NO-OPEN-BLOCK-OPTIMIZATIONS ignore))
+
+(let ((tail-identifiers
+ (lambda (declaration environment history selector)
+ (if (not (syntax-match? '(* IDENTIFIER) (cdr declaration)))
+ (syntax-error history "Ill-formed declaration:" declaration))
+ `(,(car declaration)
+ ,@(classify/variable-subexpressions (cdr declaration)
+ environment
+ history
+ (selector/add-cdr selector))))))
+ (define-declaration 'INTEGRATE tail-identifiers)
+ (define-declaration 'INTEGRATE-OPERATOR tail-identifiers)
+ (define-declaration 'INTEGRATE-SAFELY tail-identifiers)
+ (define-declaration 'IGNORE tail-identifiers))
+
+(define-declaration 'INTEGRATE-EXTERNAL
+ (lambda (declaration environment history selector)
+ environment selector
+ (if (not (list-of-type? (cdr declaration)
+ (lambda (object)
+ (or (string? object)
+ (pathname? object)))))
+ (syntax-error history "Ill-formed declaration:" declaration))
+ declaration))
+
+(let ((varset
+ (lambda (declaration environment history selector)
+ (if (not (syntax-match? '(DATUM) (cdr declaration)))
+ (syntax-error history "Ill-formed declaration:" declaration))
+ `(,(car declaration)
+ ,(let loop
+ ((varset (cadr declaration))
+ (selector (selector/add-cadr selector)))
+ (cond ((syntax-match? '('SET * IDENTIFIER) varset)
+ `(,(car varset)
+ ,@(classify/variable-subexpressions
+ (cdr varset)
+ environment
+ history
+ (selector/add-cdr selector))))
+ ((or (syntax-match? '('UNION * DATUM) varset)
+ (syntax-match? '('INTERSECTION * DATUM) varset)
+ (syntax-match? '('DIFFERENCE DATUM DATUM) varset))
+ `(,(car varset)
+ ,@(select-map loop
+ (cdr varset)
+ (selector/add-cdr selector))))
+ (else varset)))))))
+ (define-declaration 'IGNORE-REFERENCE-TRAPS varset)
+ (define-declaration 'IGNORE-ASSIGNMENT-TRAPS varset))
+\f
+(define-declaration 'REPLACE-OPERATOR
+ (lambda (declaration environment history selector)
+ (if (not (syntax-match? '(* DATUM) (cdr declaration)))
+ (syntax-error history "Ill-formed declaration:" declaration))
+ `(,(car declaration)
+ ,@(select-map
+ (lambda (rule selector)
+ (if (not (syntax-match? '(IDENTIFIER * (DATUM DATUM)) rule))
+ (syntax-error history "Ill-formed declaration:" declaration))
+ `(,(classify/variable-subexpression (car rule)
+ environment
+ history
+ (selector/add-car selector))
+ ,@(select-map
+ (lambda (clause selector)
+ `(,(car clause)
+ ,(if (identifier? (cadr clause))
+ (classify/variable-subexpression (cadr clause)
+ environment
+ history
+ (selector/add-cadr
+ selector))
+ (cadr clause))))
+ (cdr rule)
+ (selector/add-cdr selector))))
+ (cdr declaration)
+ (selector/add-cdr selector)))))
+
+(define-declaration 'REDUCE-OPERATOR
+ (lambda (declaration environment history selector)
+ `(,(car declaration)
+ ,@(select-map
+ (lambda (rule selector)
+ (if (not (syntax-match? '(IDENTIFIER DATUM * DATUM) rule))
+ (syntax-error history "Ill-formed declaration:" declaration))
+ `(,(classify/variable-subexpression (car rule)
+ environment
+ history
+ (selector/add-car selector))
+ ,(if (identifier? (cadr rule))
+ (classify/variable-subexpression (cadr rule)
+ environment
+ history
+ (selector/add-cadr
+ selector))
+ (cadr rule))
+ ,@(select-map
+ (lambda (clause selector)
+ (if (or (syntax-match? '('NULL-VALUE IDENTIFIER DATUM)
+ clause)
+ (syntax-match? '('SINGLETON IDENTIFIER) clause)
+ (syntax-match? '('WRAPPER IDENTIFIER ? DATUM)
+ clause))
+ `(,(car clause)
+ ,(classify/variable-subexpression (cadr clause)
+ environment
+ history
+ (selector/add-cadr
+ selector))
+ ,@(cddr clause))
+ clause))
+ (cddr rule)
+ (selector/add-cddr selector))))
+ (cdr declaration)
+ (selector/add-cdr selector)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: os2winp.scm,v 1.17 2001/12/23 17:20:59 cph Exp $
+$Id: os2winp.scm,v 1.18 2002/02/03 03:38:56 cph Exp $
-Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1995-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(define-integrable (set-event-wid! event wid) (vector-set! event 1 wid))
(define-syntax define-event
- (non-hygienic-macro-transformer
- (lambda (name type . slots)
- `(BEGIN
- (DEFINE-INTEGRABLE ,(symbol-append 'EVENT-TYPE: name) ,type)
- ,@(let loop ((slots slots) (index 2))
- (if (null? slots)
- '()
- (cons `(DEFINE-INTEGRABLE
- (,(symbol-append name '-EVENT/ (car slots)) EVENT)
- (VECTOR-REF EVENT ,index))
- (loop (cdr slots) (+ index 1)))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (type (close-syntax (caddr form) environment))
+ (slots (cdddr form)))
+ `(BEGIN
+ (DEFINE-INTEGRABLE ,(symbol-append 'EVENT-TYPE: name) ,type)
+ ,@(let loop ((slots slots) (index 2))
+ (if (pair? slots)
+ (cons `(DEFINE-INTEGRABLE
+ (,(symbol-append name '-EVENT/ (car slots)) EVENT)
+ (VECTOR-REF EVENT ,index))
+ (loop (cdr slots) (+ index 1)))
+ '())))))))
;; These must match "microcode/pros2pm.c"
(define-event button 0 number type x y flags)
#| -*-Scheme-*-
-$Id: parse.scm,v 14.35 2001/12/23 17:20:59 cph Exp $
+$Id: parse.scm,v 14.36 2002/02/03 03:38:56 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(define *parser-current-position*)
(define-syntax define-accretor
- (non-hygienic-macro-transformer
- (lambda (param-list-1 param-list-2 . body)
- (let ((real-param-list (if (number? param-list-1)
- param-list-2
- param-list-1))
- (real-body (if (number? param-list-1)
- body
- (cons param-list-2 body)))
- (offset (if (number? param-list-1)
- param-list-1
- 0)))
- `(DEFINE ,real-param-list
- (LET ((CORE (LAMBDA () ,@real-body)))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((offset (cadr form))
+ (param-list (caddr form))
+ (body (cdddr form)))
+ `(DEFINE ,(map (lambda (name)
+ (close-syntax name environment))
+ param-list)
+ (LET ((CORE
+ (LAMBDA ()
+ ,@(map (lambda (expression)
+ (close-syntax expression environment))
+ body))))
(IF *PARSER-ASSOCIATE-POSITIONS?*
(RECORDING-OBJECT-POSITION ,offset CORE)
(CORE))))))))
\f
;;;; Symbols/Numbers
-(define-accretor (parse-object/atom)
+(define-accretor 0 (parse-object/atom)
(build-atom (read-atom)))
(define-integrable (read-atom)
(substring-downcase! string 0 (string-length string)))
(string->symbol string))
-(define-accretor (parse-object/symbol)
+(define-accretor 0 (parse-object/symbol)
(intern-string! (read-atom)))
(define-accretor 1 (parse-object/numeric-prefix)
\f
;;;; Lists/Vectors
-(define-accretor (parse-object/list-open)
+(define-accretor 0 (parse-object/list-open)
(discard-char)
(collect-list/top-level))
\f
;;;; Quoting
-(define-accretor (parse-object/quote)
+(define-accretor 0 (parse-object/quote)
(discard-char)
(list 'QUOTE (parse-object/dispatch)))
-(define-accretor (parse-object/quasiquote)
+(define-accretor 0 (parse-object/quasiquote)
(discard-char)
(list 'QUASIQUOTE (parse-object/dispatch)))
-(define-accretor (parse-object/unquote)
+(define-accretor 0 (parse-object/unquote)
(discard-char)
(if (char=? #\@ (peek-char))
(begin
(list 'UNQUOTE (parse-object/dispatch))))
-(define-accretor (parse-object/string-quote)
+(define-accretor 0 (parse-object/string-quote)
;; This version uses a string output port to collect the string fragments
;; because string ports store the string efficiently and append the
;; string fragments in amortized linear time.
\f
;;;; Constants
-(define-accretor (parse-object/false)
+(define-accretor 0 (parse-object/false)
(discard-char)
false)
-(define-accretor (parse-object/true)
+(define-accretor 0 (parse-object/true)
(discard-char)
true)
;;; -*-Scheme-*-
;;;
-;;; $Id: parser-buffer.scm,v 1.2 2001/12/23 17:20:59 cph Exp $
+;;; $Id: parser-buffer.scm,v 1.3 2002/02/03 03:38:56 cph Exp $
;;;
-;;; Copyright (c) 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
\f
(let-syntax
((char-matcher
- (non-hygienic-macro-transformer
- (lambda (name test)
- `(BEGIN
- (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name '-NO-ADVANCE)
- BUFFER REFERENCE)
- (AND (GUARANTEE-BUFFER-CHARS BUFFER 1)
- (LET ((CHAR
- (STRING-REF (PARSER-BUFFER-STRING BUFFER)
- (PARSER-BUFFER-INDEX BUFFER))))
- (DECLARE (INTEGRATE CHAR))
- ,test)))
- (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name)
- BUFFER REFERENCE)
- (AND (GUARANTEE-BUFFER-CHARS BUFFER 1)
- (LET ((CHAR
- (STRING-REF (PARSER-BUFFER-STRING BUFFER)
- (PARSER-BUFFER-INDEX BUFFER))))
- (AND ,test
- (BEGIN
- (INCREMENT-BUFFER-INDEX! BUFFER CHAR)
- #T))))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (test
+ (make-syntactic-closure environment '(REFERENCE CHAR)
+ (caddr form))))
+ `(BEGIN
+ (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name '-NO-ADVANCE)
+ BUFFER REFERENCE)
+ (AND (GUARANTEE-BUFFER-CHARS BUFFER 1)
+ (LET ((CHAR
+ (STRING-REF (PARSER-BUFFER-STRING BUFFER)
+ (PARSER-BUFFER-INDEX BUFFER))))
+ (DECLARE (INTEGRATE CHAR))
+ ,test)))
+ (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name)
+ BUFFER REFERENCE)
+ (AND (GUARANTEE-BUFFER-CHARS BUFFER 1)
+ (LET ((CHAR
+ (STRING-REF (PARSER-BUFFER-STRING BUFFER)
+ (PARSER-BUFFER-INDEX BUFFER))))
+ (AND ,test
+ (BEGIN
+ (INCREMENT-BUFFER-INDEX! BUFFER CHAR)
+ #T)))))))))))
(char-matcher char (char=? char reference))
(char-matcher char-ci (char-ci=? char reference))
(char-matcher not-char (not (char=? char reference)))
\f
(let-syntax
((string-matcher
- (non-hygienic-macro-transformer
- (lambda (suffix)
- (let ((name
- (intern (string-append "match-parser-buffer-string" suffix)))
- (match-substring
- (intern
- (string-append "match-parser-buffer-substring" suffix))))
- `(DEFINE (,name BUFFER STRING)
- (,match-substring BUFFER STRING 0 (STRING-LENGTH STRING))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((suffix (cadr form)))
+ `(DEFINE (,(close-syntax
+ (intern
+ (string-append "match-parser-buffer-string" suffix))
+ environment)
+ BUFFER STRING)
+ (,(close-syntax
+ (intern
+ (string-append "match-parser-buffer-substring" suffix))
+ environment)
+ BUFFER STRING 0 (STRING-LENGTH STRING))))))))
(string-matcher "")
(string-matcher "-ci")
(string-matcher "-no-advance")
(let-syntax
((substring-matcher
- (non-hygienic-macro-transformer
- (lambda (suffix)
- `(DEFINE (,(intern
- (string-append "match-parser-buffer-substring" suffix))
- BUFFER STRING START END)
- (LET ((N (FIX:- END START)))
- (AND (GUARANTEE-BUFFER-CHARS BUFFER N)
- (,(intern (string-append "substring" suffix "=?"))
- STRING START END
- (PARSER-BUFFER-STRING BUFFER)
- (PARSER-BUFFER-INDEX BUFFER)
- (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N))
- (BEGIN
- (BUFFER-INDEX+N! BUFFER N)
- #T))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((suffix (cadr form)))
+ `(DEFINE (,(close-syntax
+ (intern
+ (string-append "match-parser-buffer-substring" suffix))
+ environment)
+ BUFFER STRING START END)
+ (LET ((N (FIX:- END START)))
+ (AND (GUARANTEE-BUFFER-CHARS BUFFER N)
+ (,(close-syntax
+ (intern (string-append "substring" suffix "=?"))
+ environment)
+ STRING START END
+ (PARSER-BUFFER-STRING BUFFER)
+ (PARSER-BUFFER-INDEX BUFFER)
+ (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N))
+ (BEGIN
+ (BUFFER-INDEX+N! BUFFER N)
+ #T)))))))))
(substring-matcher "")
(substring-matcher "-ci"))
(let-syntax
((substring-matcher
- (non-hygienic-macro-transformer
- (lambda (suffix)
- `(DEFINE (,(intern
- (string-append "match-parser-buffer-substring"
- suffix
- "-no-advance"))
- BUFFER STRING START END)
- (LET ((N (FIX:- END START)))
- (AND (GUARANTEE-BUFFER-CHARS BUFFER N)
- (,(intern (string-append "substring" suffix "=?"))
- STRING START END
- (PARSER-BUFFER-STRING BUFFER)
- (PARSER-BUFFER-INDEX BUFFER)
- (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N)))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((suffix (cadr form)))
+ `(DEFINE (,(close-syntax
+ (intern
+ (string-append "match-parser-buffer-substring"
+ suffix
+ "-no-advance"))
+ environment)
+ BUFFER STRING START END)
+ (LET ((N (FIX:- END START)))
+ (AND (GUARANTEE-BUFFER-CHARS BUFFER N)
+ (,(close-syntax
+ (intern (string-append "substring" suffix "=?"))
+ environment)
+ STRING START END
+ (PARSER-BUFFER-STRING BUFFER)
+ (PARSER-BUFFER-INDEX BUFFER)
+ (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N))))))))))
(substring-matcher "")
(substring-matcher "-ci"))
\f
#| -*-Scheme-*-
-$Id: port.scm,v 1.21 2001/12/23 17:20:59 cph Exp $
+$Id: port.scm,v 1.22 2002/02/03 03:38:56 cph Exp $
-Copyright (c) 1991-2001 Massachusetts Institute of Technology
+Copyright (c) 1991-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(define (port/operation-names port)
(port-type/operation-names (port/type port)))
-(let-syntax ((define-port-operation
- (non-hygienic-macro-transformer
- (lambda (dir name)
- `(DEFINE (,(symbol-append dir '-PORT/OPERATION/ name) PORT)
- (,(symbol-append 'PORT-TYPE/ name) (PORT/TYPE PORT)))))))
+(let-syntax
+ ((define-port-operation
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((dir (cadr form))
+ (name (caddr form)))
+ `(DEFINE (,(close-syntax (symbol-append dir '-PORT/OPERATION/ name)
+ environment)
+ PORT)
+ (,(close-syntax (symbol-append 'PORT-TYPE/ name) environment)
+ (PORT/TYPE PORT))))))))
(define-port-operation input char-ready?)
(define-port-operation input peek-char)
(define-port-operation input read-char)
(set-port/state! port state)
(set-port/thread-mutex! port (make-thread-mutex))
port))
-
+\f
(define (close-port port)
(let ((close (port/operation port 'CLOSE)))
(if close
(begin
(close-output-port port)
(close-input-port port)))))
-\f
+
(define (close-input-port port)
(let ((close-input (port/operation port 'CLOSE-INPUT)))
(if close-input
((BUFFERED-CHARS) 'BUFFERED-OUTPUT-CHARS)
((CHANNEL) 'OUTPUT-CHANNEL)
(else name))))
-
+\f
(define (input-port? object)
(and (port? object)
(port-type/supports-input? (port/type object))))
;;; -*-Scheme-*-
;;;
-;;; $Id: recslot.scm,v 1.6 2001/12/23 17:20:59 cph Exp $
+;;; $Id: recslot.scm,v 1.7 2002/02/03 03:38:56 cph Exp $
;;;
-;;; Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1995-1999, 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(%record-initpred index)))))
(define-syntax generate-index-cases
- (non-hygienic-macro-transformer
- (lambda (index limit expand-case)
- `(CASE ,index
- ,@(let loop ((i 1))
- (if (= i limit)
- `((ELSE (,expand-case ,index)))
- `(((,i) (,expand-case ,i)) ,@(loop (+ i 1)))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((index (close-syntax (cadr form) environment))
+ (limit (caddr form))
+ (expand-case (close-syntax (cadddr form) environment)))
+ `(CASE ,index
+ ,@(let loop ((i 1))
+ (if (= i limit)
+ `((ELSE (,expand-case ,index)))
+ `(((,i) (,expand-case ,i)) ,@(loop (+ i 1))))))))))
(define (%record-accessor index)
(generate-index-cases index 16
;;; -*-Scheme-*-
;;;
-;;; $Id: rgxcmp.scm,v 1.118 2001/12/23 17:20:59 cph Exp $
+;;; $Id: rgxcmp.scm,v 1.119 2002/02/03 03:38:56 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;; Compiled Opcodes
(define-syntax define-enumeration
- (non-hygienic-macro-transformer
- (lambda (name prefix . suffixes)
- `(BEGIN
- ,@(let loop ((n 0) (suffixes suffixes))
- (if (pair? suffixes)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append prefix (car suffixes))
- ,n)
- (loop (+ n 1) (cdr suffixes)))
- '()))
- (DEFINE ,name
- (VECTOR ,@(map (lambda (suffix) `',suffix) suffixes)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (close-syntax (cadr form) environment))
+ (prefix (caddr form))
+ (suffixes (cdddr form)))
+ `(BEGIN
+ ,@(let loop ((n 0) (suffixes suffixes))
+ (if (pair? suffixes)
+ (cons `(DEFINE-INTEGRABLE
+ ,(close-syntax (symbol-append prefix (car suffixes))
+ environment)
+ ,n)
+ (loop (+ n 1) (cdr suffixes)))
+ '()))
+ (DEFINE ,name
+ (VECTOR ,@(map (lambda (suffix) `',suffix) suffixes))))))))
(define-enumeration re-codes re-code:
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.406 2002/01/12 02:56:35 cph Exp $
+$Id: runtime.pkg,v 14.407 2002/02/03 03:38:56 cph Exp $
Copyright (c) 1988-2002 Massachusetts Institute of Technology
stack-frame/debugging-info)
(initialization (initialize-package!)))
-(define-package (runtime defstruct)
- (files "defstr")
- (parent (runtime))
- (export ()
- define-structure))
-
(define-package (runtime directory)
(parent (runtime))
(export (runtime pathname)
lambda-wrapper-components)
(export (runtime environment)
internal-lambda?)
- (export (runtime syntaxer)
- make-block-declaration)
(export (runtime compiler-info)
lambda-tag:internal-lambda
lambda-tag:internal-lexpr)
simple-command-line-parser)
(initialization (initialize-package!)))
-(define-package (runtime macros)
- (files "macros")
- (parent (runtime))
- #|
- (export ()
- and
- case
- cons-stream
- define-integrable
- do
- let*
- letrec
- quasiquote
- sequence)
- |#
- (initialization (initialize-package!)))
-
(define-package (runtime microcode-errors)
(files "uerror")
(parent (runtime error-handler))
system-global-parser-table)
(export (runtime character)
char-set/atom-delimiters)
- (export (runtime syntaxer)
- lambda-auxiliary-tag
+ (export (runtime syntactic-closures)
lambda-optional-tag
lambda-rest-tag)
(export (runtime unparser)
lambda-auxiliary-tag
lambda-optional-tag
lambda-rest-tag)
- (export (runtime macros)
- lambda-auxiliary-tag
- lambda-optional-tag
- lambda-rest-tag)
(export (runtime unsyntaxer)
lambda-auxiliary-tag
lambda-optional-tag
unmapped-macro-reference-trap?
unmapped-unassigned-reference-trap?
unmapped-unbound-reference-trap?)
- (export (runtime syntaxer)
+ (export (runtime syntactic-closures)
make-macro-reference-trap-expression)
(export (runtime unsyntaxer)
macro-reference-trap-expression-transformer
with-output-to-string)
(initialization (initialize-package!)))
-(define-package (runtime syntax-table)
- (files "syntab")
- (parent (runtime))
- (export (runtime syntaxer)
- guarantee-syntax-table
- make-syntax-table
- syntax-table/define
- syntax-table/environment
- syntax-table/extend
- syntax-table/ref))
-
-(define-package (runtime syntaxer)
- (files "syntax")
+(define-package (runtime syntactic-closures)
+ (files "syntactic-closures"
+ "syntax-output"
+ "syntax-transforms"
+ "mit-syntax"
+ "syntax-rules"
+ "syntax-check")
(parent (runtime))
(export ()
- hook/syntax-expression
+ call-with-syntax-error-procedure
+ capture-syntactic-environment
+ close-syntax
+ er-macro-transformer->expander
+ identifier->symbol
+ identifier=?
+ identifier?
+ ill-formed-syntax
lambda-tag:fluid-let
lambda-tag:let
lambda-tag:unnamed
- make-syntax-closure
+ make-syntactic-closure
+ make-synthetic-identifier
+ mit-lambda-list?
+ non-hygienic-macro-transformer->expander
+ parse-mit-lambda-list
+ r4rs-lambda-list?
+ sc-macro-transformer->expander
+ rsc-macro-transformer->expander
+ strip-syntactic-closures
+ syntactic-closure-rtd
+ syntactic-closure/environment
+ syntactic-closure/free-names
+ syntactic-closure/form
+ syntactic-closure?
+ synthetic-identifier?
syntax
syntax*
- syntax-closure/expression
- syntax-closure?
- syntax/top-level?)
+ syntax-match?)
(export (runtime defstruct)
- parse-lambda-list)
- (initialization (initialize-package!)))
+ define-expander
+ parse-mit-lambda-list))
-(define-package (runtime illegal-definitions)
- (files "illdef")
+(define-package (runtime defstruct)
+ (files "defstr")
(parent (runtime))
- (export (runtime syntaxer)
- check-for-illegal-definitions)
- (initialization (initialize-package!)))
+ (export ()
+ ;;define-structure
+ ))
+
+(define-package (runtime system-macros)
+ (files "sysmac")
+ (parent (runtime))
+ (export (runtime)
+ define-primitives
+ ucode-primitive
+ ucode-return-address
+ ucode-type))
(define-package (runtime system)
(files "system")
increment-non-runtime!)
(initialization (initialize-package!)))
-(define-package (runtime system-macros)
- (files "sysmac")
- (parent (runtime))
- (export (runtime)
- define-primitives
- ucode-primitive
- ucode-return-address
- ucode-type))
-
(define-package (runtime truncated-string-output)
(files "strott")
(parent (runtime))
#| -*-Scheme-*-
-$Id: scomb.scm,v 14.18 2001/12/23 17:20:59 cph Exp $
+$Id: scomb.scm,v 14.19 2002/02/03 03:38:56 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
\f
(let-syntax
((combination-dispatch
- (non-hygienic-macro-transformer
- (lambda (name combination case-0 case-1 case-2 case-n)
- `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0)
- ,combination)
- ,case-0)
- ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination)
- (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1)
- ,combination))
- ,case-1)
- ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination)
- (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2)
- ,combination))
- ,case-2)
- ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination)
- (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3)
- ,combination))
- ,case-n)
- (ELSE
- (ERROR:WRONG-TYPE-ARGUMENT ,combination "SCode combination"
- ',name)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1))
+ (combination (close-syntax (list-ref form 2) environment))
+ (case-0 (close-syntax (list-ref form 3) environment))
+ (case-1 (close-syntax (list-ref form 4) environment))
+ (case-2 (close-syntax (list-ref form 5) environment))
+ (case-n (close-syntax (list-ref form 6) environment)))
+ `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0)
+ ,combination)
+ ,case-0)
+ ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination)
+ (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1)
+ ,combination))
+ ,case-1)
+ ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination)
+ (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2)
+ ,combination))
+ ,case-2)
+ ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination)
+ (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3)
+ ,combination))
+ ,case-n)
+ (ELSE
+ (ERROR:WRONG-TYPE-ARGUMENT ,combination "SCode combination"
+ ',name))))))))
(define (combination-size combination)
(combination-dispatch combination-size combination
#| -*-Scheme-*-
-$Id: starbase.scm,v 1.15 2001/12/23 17:20:59 cph Exp $
+$Id: starbase.scm,v 1.16 2002/02/03 03:38:56 cph Exp $
-Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1989-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(let-syntax
((define-accessors-and-mutators
- (non-hygienic-macro-transformer
- (lambda (name)
- `(BEGIN
- (DEFINE (,(symbol-append 'STARBASE-DEVICE/ name) DEVICE)
- (,(symbol-append 'STARBASE-GRAPHICS-DESCRIPTOR/ name)
- (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)))
- (DEFINE (,(symbol-append 'SET-STARBASE-DEVICE/ name '!)
- DEVICE VALUE)
- (,(symbol-append 'SET-STARBASE-GRAPHICS-DESCRIPTOR/ name '!)
- (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)
- VALUE)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(BEGIN
+ (DEFINE (,(close-syntax (symbol-append 'STARBASE-DEVICE/ name)
+ environment)
+ DEVICE)
+ (,(close-syntax
+ (symbol-append 'STARBASE-GRAPHICS-DESCRIPTOR/ name)
+ environment)
+ (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)))
+ (DEFINE (,(close-syntax
+ (symbol-append 'SET-STARBASE-DEVICE/ name '!)
+ environment)
+ DEVICE VALUE)
+ (,(close-syntax
+ (symbol-append 'SET-STARBASE-GRAPHICS-DESCRIPTOR/ name '!)
+ environment)
+ (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)
+ VALUE))))))))
(define-accessors-and-mutators x-left)
(define-accessors-and-mutators y-bottom)
(define-accessors-and-mutators x-right)
#| -*-Scheme-*-
-$Id: string.scm,v 14.46 2001/12/23 17:20:59 cph Exp $
+$Id: string.scm,v 14.47 2002/02/03 03:38:57 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
;; Calling the primitive is expensive, so avoid it for small copies.
(let-syntax
((unrolled-move-left
- (non-hygienic-macro-transformer
- (lambda (n)
- `(BEGIN
- (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1))
- ,@(let loop ((i 1))
- (if (< i n)
- `((STRING-SET! STRING2 (FIX:+ START2 ,i)
- (STRING-REF STRING1 (FIX:+ START1 ,i)))
- ,@(loop (+ i 1)))
- '()))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((n (cadr form)))
+ `(BEGIN
+ (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1))
+ ,@(let loop ((i 1))
+ (if (< i n)
+ `((STRING-SET! STRING2 (FIX:+ START2 ,i)
+ (STRING-REF STRING1 (FIX:+ START1 ,i)))
+ ,@(loop (+ i 1)))
+ '())))))))
(unrolled-move-right
- (non-hygienic-macro-transformer
- (lambda (n)
- `(BEGIN
- ,@(let loop ((i 1))
- (if (< i n)
- `(,@(loop (+ i 1))
- (STRING-SET! STRING2 (FIX:+ START2 ,i)
- (STRING-REF STRING1 (FIX:+ START1 ,i))))
- '()))
- (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((n (cadr form)))
+ `(BEGIN
+ ,@(let loop ((i 1))
+ (if (< i n)
+ `(,@(loop (+ i 1))
+ (STRING-SET! STRING2 (FIX:+ START2 ,i)
+ (STRING-REF STRING1 (FIX:+ START1 ,i))))
+ '()))
+ (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1))))))))
(let ((n (fix:- end1 start1)))
(if (or (not (eq? string2 string1)) (fix:< start2 start1))
(cond ((fix:> n 4)
+++ /dev/null
-#| -*-Scheme-*-
-
-$Id: syntab.scm,v 14.9 2001/12/21 18:22:36 cph Exp $
-
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-This program is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-USA.
-|#
-
-;;;; Syntax Table
-;;; package: (runtime syntax-table)
-
-(declare (usual-integrations))
-\f
-(define-structure (syntax-table (constructor %make-syntax-table)
- (predicate %syntax-table?)
- (conc-name syntax-table/))
- alist
- (parent #f read-only #t))
-
-(define (syntax-table? object)
- (or (%syntax-table? object)
- (environment? object)))
-
-(define (make-syntax-table parent)
- (guarantee-syntax-table parent 'MAKE-SYNTAX-TABLE)
- (%make-syntax-table '() parent))
-
-(define (guarantee-syntax-table table procedure)
- (if (not (syntax-table? table))
- (error:wrong-type-argument table "syntax table" procedure))
- table)
-
-(define (syntax-table/ref table name)
- (guarantee-syntax-table table 'SYNTAX-TABLE/REF)
- (let loop ((table table))
- (if (%syntax-table? table)
- (let ((entry (assq name (syntax-table/alist table))))
- (if entry
- (cdr entry)
- (let ((parent (syntax-table/parent table)))
- (if (eq? parent 'NONE)
- #f
- (loop parent)))))
- (and (environment-bound? table name)
- (environment-lookup-macro table name)))))
-
-(define (syntax-table/define table name transform)
- (guarantee-syntax-table table 'SYNTAX-TABLE/DEFINE)
- (if (%syntax-table? table)
- (let ((entry (assq name (syntax-table/alist table))))
- (if entry
- (set-cdr! entry transform)
- (set-syntax-table/alist! table
- (cons (cons name transform)
- (syntax-table/alist table)))))
- (environment-define-macro table name transform)))
-
-(define (syntax-table/extend table alist)
- (guarantee-syntax-table table 'SYNTAX-TABLE/EXTEND)
- (%make-syntax-table (alist-copy alist) table))
-
-(define (syntax-table/environment table)
- (guarantee-syntax-table table 'SYNTAX-TABLE/ENVIRONMENT)
- (let loop ((table table))
- (if (%syntax-table? table)
- (loop (syntax-table/parent table))
- table)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: syntactic-closures.scm,v 14.1 2002/02/03 03:38:57 cph Exp $
+;;;
+;;; Copyright (c) 1989-1991, 2001, 2002 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
+
+;;;; Syntactic Closures
+;;; Based on a design by Alan Bawden.
+
+;;; This is a two-stage program: the first stage classifies input
+;;; expressions into types, e.g. "definition", "lambda body",
+;;; "expression", etc., and the second stage compiles those classified
+;;; expressions ("items") into output code. The classification stage
+;;; permits discovery of internal definitions prior to code
+;;; generation. It also identifies keywords and variables, which
+;;; allows a powerful form of syntactic binding to be implemented.
+
+;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in
+;;; Proceedings of the 1988 ACM Conference on Lisp and Functional
+;;; Programming, page 86.
+
+(declare (usual-integrations))
+\f
+;;;; Compiler
+
+(define (syntax form environment)
+ (syntax* (list form) environment))
+
+(define (syntax* forms environment)
+ (if (not (list? forms))
+ (error:wrong-type-argument forms "list" 'SYNTAX*))
+ (guarantee-syntactic-environment environment 'SYNTAX*)
+ (fluid-let ((*rename-suffix* 0))
+ (if (syntactic-environment/top-level? environment)
+ (let ((environment (make-top-level-syntactic-environment environment)))
+ (compile-body-items/top-level
+ (classify/body-forms forms
+ environment
+ environment
+ (make-top-level-history forms environment)
+ select-object)))
+ (output/sequence
+ (compile/expressions forms
+ environment
+ (make-top-level-history forms environment))))))
+
+(define (compile-item/top-level item)
+ (if (binding-item? item)
+ (let ((name (binding-item/name item))
+ (value (binding-item/value item)))
+ (if (transformer-item? value)
+ (output/top-level-syntax-definition
+ name
+ (compile-item/expression (transformer-item/expression value)))
+ (output/top-level-definition
+ name
+ (compile-item/expression value))))
+ (compile-item/expression item)))
+
+(define (compile-body-items/top-level body-items)
+ (call-with-values (lambda () (extract-declarations-from-body body-items))
+ (lambda (declaration-items body-items)
+ (output/top-level-sequence (map declaration-item/text declaration-items)
+ (map compile-item/top-level body-items)))))
+\f
+(define (compile-item/expression item)
+ (if (not (item? item))
+ (error:wrong-type-argument item "item" 'COMPILE-ITEM/EXPRESSION))
+ (let ((compiler (get-item-compiler item)))
+ (if (not compiler)
+ (error:bad-range-argument item 'COMPILE-ITEM/EXPRESSION))
+ (compiler item)))
+
+(define (get-item-compiler item)
+ (let ((entry
+ (assq (record-type-descriptor (item/record item)) item-compilers)))
+ (and entry
+ (cdr entry))))
+
+(define (define-item-compiler rtd compiler)
+ (let ((entry (assq rtd item-compilers)))
+ (if entry
+ (set-cdr! entry compiler)
+ (begin
+ (set! item-compilers (cons (cons rtd compiler) item-compilers))
+ unspecific))))
+
+(define item-compilers '())
+
+(define (compile/expression expression environment history)
+ (compile-item/expression
+ (classify/expression expression environment history)))
+
+(define (compile/expressions expressions environment history)
+ (compile/subexpressions expressions environment history select-object))
+
+(define (compile/subexpression expression environment history selector)
+ (compile-item/expression
+ (classify/subexpression expression environment history selector)))
+
+(define (compile/subexpressions expressions environment history selector)
+ (select-map (lambda (expression selector)
+ (compile/subexpression expression
+ environment
+ history
+ selector))
+ expressions
+ selector))
+\f
+;;;; Classifier
+
+(define (classify/form form environment definition-environment history)
+ (cond ((identifier? form)
+ (item/new-history (lookup-identifier environment form) history))
+ ((syntactic-closure? form)
+ (let ((form (syntactic-closure/form form))
+ (environment
+ (make-filtered-syntactic-environment
+ (syntactic-closure/free-names form)
+ environment
+ (syntactic-closure/environment form))))
+ (classify/form form
+ environment
+ definition-environment
+ (history/replace-reduction form
+ environment
+ history))))
+ ((pair? form)
+ (let ((item
+ (classify/subexpression (car form) environment history
+ select-car)))
+ (cond ((classifier-item? item)
+ ((classifier-item/classifier item) form
+ environment
+ definition-environment
+ history))
+ ((compiler-item? item)
+ (classify/compiler item form environment history))
+ ((expander-item? item)
+ (classify/expander item
+ form
+ environment
+ definition-environment
+ history))
+ ((transformer-item? item)
+ (classify/expander (transformer-item/expander item)
+ form
+ environment
+ definition-environment
+ history))
+ (else
+ (if (not (list? (cdr form)))
+ (syntax-error history
+ "Combination must be a proper list:"
+ form))
+ (let ((items
+ (classify/subexpressions (cdr form)
+ environment
+ history
+ select-cdr)))
+ (make-expression-item
+ history
+ (lambda ()
+ (output/combination
+ (compile-item/expression item)
+ (map compile-item/expression items)))))))))
+ (else
+ (make-expression-item history (lambda () (output/constant form))))))
+
+(define (classify/compiler item form environment history)
+ (make-expression-item history
+ (lambda ()
+ ((compiler-item/compiler item) form environment history))))
+
+(define (classify/expander item form environment definition-environment
+ history)
+ (let ((form
+ ((expander-item/expander item) form
+ environment
+ (expander-item/environment item))))
+ (classify/form form
+ environment
+ definition-environment
+ (history/add-reduction form environment history))))
+\f
+(define (classify/subform form environment definition-environment
+ history selector)
+ (classify/form form
+ environment
+ definition-environment
+ (history/add-subproblem form environment history selector)))
+
+(define (classify/subforms forms environment definition-environment
+ history selector)
+ (select-map (lambda (form selector)
+ (classify/subform form environment definition-environment
+ history selector))
+ forms
+ selector))
+
+(define (classify/expression expression environment history)
+ (classify/form expression environment null-syntactic-environment history))
+
+(define (classify/subexpression expression environment history selector)
+ (classify/subform expression environment null-syntactic-environment
+ history selector))
+
+(define (classify/subexpressions expressions environment history selector)
+ (classify/subforms expressions environment null-syntactic-environment
+ history selector))
+
+(define (classify/body forms environment definition-environment history
+ selector)
+ (make-body-item history
+ (classify/body-forms forms
+ environment
+ definition-environment
+ history
+ selector)))
+
+(define (classify/body-forms forms environment definition-environment history
+ selector)
+ ;; Top-level syntactic definitions affect all forms that appear
+ ;; after them, so classify FORMS in order.
+ (let forms-loop ((forms forms) (selector selector) (body-items '()))
+ (if (pair? forms)
+ (let items-loop
+ ((items
+ (item->list
+ (classify/subform (car forms)
+ environment
+ definition-environment
+ history
+ (selector/add-car selector))))
+ (body-items body-items))
+ (if (pair? items)
+ (items-loop (cdr items)
+ (if (null-binding-item? (car items))
+ body-items
+ (cons (car items) body-items)))
+ (forms-loop (cdr forms)
+ (selector/add-cdr selector)
+ body-items)))
+ (reverse! body-items))))
+
+(define (extract-declarations-from-body items)
+ (let loop ((items items) (declarations '()) (items* '()))
+ (if (pair? items)
+ (if (declaration-item? (car items))
+ (loop (cdr items)
+ (cons (car items) declarations)
+ items*)
+ (loop (cdr items)
+ declarations
+ (cons (car items) items*)))
+ (values (reverse! declarations) (reverse! items*)))))
+\f
+;;;; Syntactic Closures
+
+(define syntactic-closure-rtd
+ (make-record-type "syntactic-closure" '(ENVIRONMENT FREE-NAMES FORM)))
+
+(define make-syntactic-closure
+ (let ((constructor
+ (record-constructor syntactic-closure-rtd
+ '(ENVIRONMENT FREE-NAMES FORM))))
+ (lambda (environment free-names form)
+ (guarantee-syntactic-environment environment 'MAKE-SYNTACTIC-CLOSURE)
+ (if (not (list-of-type? free-names identifier?))
+ (error:wrong-type-argument free-names "list of identifiers"
+ 'MAKE-SYNTACTIC-CLOSURE))
+ (if (or (memq form free-names) ;LOOKUP-IDENTIFIER assumes this.
+ (and (syntactic-closure? form)
+ (null? (syntactic-closure/free-names form))
+ (not (identifier? (syntactic-closure/form form))))
+ (not (or (syntactic-closure? form)
+ (pair? form)
+ (symbol? form))))
+ form
+ (constructor environment free-names form)))))
+
+(define syntactic-closure?
+ (record-predicate syntactic-closure-rtd))
+
+(define syntactic-closure/environment
+ (record-accessor syntactic-closure-rtd 'ENVIRONMENT))
+
+(define syntactic-closure/free-names
+ (record-accessor syntactic-closure-rtd 'FREE-NAMES))
+
+(define syntactic-closure/form
+ (record-accessor syntactic-closure-rtd 'FORM))
+
+(define (strip-syntactic-closures object)
+ (cond ((syntactic-closure? object)
+ (strip-syntactic-closures (syntactic-closure/form object)))
+ ((pair? object)
+ (cons (strip-syntactic-closures (car object))
+ (strip-syntactic-closures (cdr object))))
+ (else object)))
+
+(define (close-syntax form environment)
+ (make-syntactic-closure environment '() form))
+
+(define (identifier? object)
+ (or (symbol? object)
+ (synthetic-identifier? object)))
+
+(define (synthetic-identifier? object)
+ (and (syntactic-closure? object)
+ (identifier? (syntactic-closure/form object))))
+
+(define (make-synthetic-identifier identifier)
+ (close-syntax identifier null-syntactic-environment))
+
+(define (identifier->symbol identifier)
+ (or (let loop ((identifier identifier))
+ (if (syntactic-closure? identifier)
+ (loop (syntactic-closure/form identifier))
+ (and (symbol? identifier)
+ identifier)))
+ (error:wrong-type-argument identifier "identifier" 'IDENTIFIER->SYMBOL)))
+
+(define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
+ (let ((item-1 (lookup-identifier environment-1 identifier-1))
+ (item-2 (lookup-identifier environment-2 identifier-2)))
+ (or (item=? item-1 item-2)
+ ;; This is necessary because an identifier that is not
+ ;; explicitly bound by an environment is mapped to a variable
+ ;; item, and the variable items are not cached. Therefore
+ ;; two references to the same variable result in two
+ ;; different variable items.
+ (and (variable-item? item-1)
+ (variable-item? item-2)
+ (eq? (variable-item/name item-1)
+ (variable-item/name item-2))))))
+\f
+;;;; Syntactic Environments
+
+(define (syntactic-environment? object)
+ (or (internal-syntactic-environment? object)
+ (top-level-syntactic-environment? object)
+ (environment? object)
+ (filtered-syntactic-environment? object)
+ (null-syntactic-environment? object)))
+
+(define (guarantee-syntactic-environment object name)
+ (if (not (syntactic-environment? object))
+ (error:wrong-type-argument object "syntactic environment" name)))
+
+(define (syntactic-environment/top-level? object)
+ (or (top-level-syntactic-environment? object)
+ (interpreter-environment? object)))
+
+(define (lookup-identifier environment identifier)
+ (let ((item (syntactic-environment/lookup environment identifier)))
+ (cond (item
+ (if (reserved-name-item? item)
+ (syntax-error (item/history item)
+ "Premature reference to reserved name:"
+ identifier)
+ item))
+ ((symbol? identifier)
+ (make-variable-item identifier))
+ ((syntactic-closure? identifier)
+ (lookup-identifier (syntactic-closure/environment identifier)
+ (syntactic-closure/form identifier)))
+ (else
+ (error:wrong-type-argument identifier "identifier"
+ 'LOOKUP-IDENTIFIER)))))
+
+(define (syntactic-environment/lookup environment name)
+ (cond ((internal-syntactic-environment? environment)
+ (internal-syntactic-environment/lookup environment name))
+ ((top-level-syntactic-environment? environment)
+ (top-level-syntactic-environment/lookup environment name))
+ ((environment? environment)
+ (and (symbol? name)
+ (environment/lookup environment name)))
+ ((filtered-syntactic-environment? environment)
+ (filtered-syntactic-environment/lookup environment name))
+ ((null-syntactic-environment? environment)
+ (null-syntactic-environment/lookup environment name))
+ (else
+ (error:wrong-type-argument environment "syntactic environment"
+ 'SYNTACTIC-ENVIRONMENT/LOOKUP))))
+\f
+(define (syntactic-environment/define environment name item)
+ (cond ((internal-syntactic-environment? environment)
+ (internal-syntactic-environment/define environment name item))
+ ((top-level-syntactic-environment? environment)
+ (top-level-syntactic-environment/define environment name item))
+ ((environment? environment)
+ (environment/define environment name item))
+ ((filtered-syntactic-environment? environment)
+ (filtered-syntactic-environment/define environment name item))
+ ((null-syntactic-environment? environment)
+ (null-syntactic-environment/define environment name item))
+ (else
+ (error:wrong-type-argument environment "syntactic environment"
+ 'SYNTACTIC-ENVIRONMENT/DEFINE))))
+
+(define (syntactic-environment/rename environment name)
+ (let ((name (identifier->symbol name)))
+ (cond ((internal-syntactic-environment? environment)
+ (internal-syntactic-environment/rename environment name))
+ ((top-level-syntactic-environment? environment)
+ (top-level-syntactic-environment/rename environment name))
+ ((environment? environment)
+ (environment/rename environment name))
+ ((filtered-syntactic-environment? environment)
+ (filtered-syntactic-environment/rename environment name))
+ ((null-syntactic-environment? environment)
+ (null-syntactic-environment/rename environment name))
+ (else
+ (error:wrong-type-argument environment "syntactic environment"
+ 'SYNTACTIC-ENVIRONMENT/RENAME)))))
+
+(define (syntactic-environment->environment environment)
+ (cond ((internal-syntactic-environment? environment)
+ (internal-syntactic-environment->environment environment))
+ ((top-level-syntactic-environment? environment)
+ (top-level-syntactic-environment->environment environment))
+ ((environment? environment)
+ environment)
+ ((filtered-syntactic-environment? environment)
+ (filtered-syntactic-environment->environment environment))
+ ((null-syntactic-environment? environment)
+ (null-syntactic-environment->environment environment))
+ (else
+ (error:wrong-type-argument environment "syntactic environment"
+ 'SYNTACTIC-ENVIRONMENT->ENVIRONMENT))))
+\f
+;;; Null syntactic environments signal an error for any operation.
+;;; They are used as the definition environment for expressions (to
+;;; prevent illegal use of definitions) and to seal off environments
+;;; used in magic keywords.
+
+(define null-syntactic-environment-rtd
+ (make-record-type "null-syntactic-environment" '()))
+
+(define null-syntactic-environment
+ ((record-constructor null-syntactic-environment-rtd '())))
+
+(define null-syntactic-environment?
+ (record-predicate null-syntactic-environment-rtd))
+
+(define (null-syntactic-environment/lookup environment name)
+ environment
+ (error "Can't lookup name in null syntactic environment:" name))
+
+(define (null-syntactic-environment/define environment name item)
+ environment
+ (error "Can't bind name in null syntactic environment:" name item))
+
+(define (null-syntactic-environment/rename environment name)
+ environment
+ (error "Can't rename name in null syntactic environment:" name))
+
+(define (null-syntactic-environment->environment environment)
+ environment
+ (error "Can't evaluate in null syntactic environment."))
+
+;;; Runtime environments can be used to look up keywords, but can't be
+;;; modified.
+
+(define (environment/lookup environment name)
+ (and (environment-bound? environment name)
+ (let ((item (environment-lookup-macro environment name)))
+ (cond ((or (item? item) (not item))
+ item)
+ ;; **** Kludge to support bootstrapping.
+ ((procedure? item)
+ (non-hygienic-macro-transformer->expander item environment))
+ (else
+ (error:wrong-type-datum item "syntactic keyword"))))))
+
+(define (environment/define environment name item)
+ (environment-define-macro environment name item))
+
+(define (environment/rename environment name)
+ environment
+ name)
+\f
+;;; Top-level syntactic environments represent top-level environments.
+;;; They are always layered over a real syntactic environment.
+
+(define top-level-syntactic-environment-rtd
+ (make-record-type "top-level-syntactic-environment" '(PARENT BOUND)))
+
+(define make-top-level-syntactic-environment
+ (let ((constructor
+ (record-constructor top-level-syntactic-environment-rtd
+ '(PARENT BOUND))))
+ (lambda (parent)
+ (guarantee-syntactic-environment parent
+ 'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT)
+ (if (not (or (syntactic-environment/top-level? parent)
+ (null-syntactic-environment? parent)))
+ (error:bad-range-argument parent "top-level syntactic environment"
+ 'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT))
+ (constructor parent '()))))
+
+(define top-level-syntactic-environment?
+ (record-predicate top-level-syntactic-environment-rtd))
+
+(define top-level-syntactic-environment/parent
+ (record-accessor top-level-syntactic-environment-rtd 'PARENT))
+
+(define top-level-syntactic-environment/bound
+ (record-accessor top-level-syntactic-environment-rtd 'BOUND))
+
+(define set-top-level-syntactic-environment/bound!
+ (record-modifier top-level-syntactic-environment-rtd 'BOUND))
+
+(define (top-level-syntactic-environment/lookup environment name)
+ (let ((binding
+ (assq name (top-level-syntactic-environment/bound environment))))
+ (if binding
+ (cdr binding)
+ (syntactic-environment/lookup
+ (top-level-syntactic-environment/parent environment)
+ name))))
+
+(define (top-level-syntactic-environment/define environment name item)
+ (let ((bound (top-level-syntactic-environment/bound environment)))
+ (let ((binding (assq name bound)))
+ (if binding
+ (set-cdr! binding item)
+ (set-top-level-syntactic-environment/bound!
+ environment
+ (cons (cons name item) bound))))))
+
+(define (top-level-syntactic-environment/rename environment name)
+ environment
+ name)
+
+(define (top-level-syntactic-environment->environment environment)
+ (syntactic-environment->environment
+ (top-level-syntactic-environment/parent environment)))
+\f
+;;; Internal syntactic environments represent environments created by
+;;; procedure application.
+
+(define internal-syntactic-environment-rtd
+ (make-record-type "internal-syntactic-environment"
+ '(PARENT BOUND FREE RENAME-STATE)))
+
+(define make-internal-syntactic-environment
+ (let ((constructor
+ (record-constructor internal-syntactic-environment-rtd
+ '(PARENT BOUND FREE RENAME-STATE))))
+ (lambda (parent)
+ (guarantee-syntactic-environment parent
+ 'MAKE-INTERNAL-SYNTACTIC-ENVIRONMENT)
+ (constructor parent '() '() (make-rename-state)))))
+
+(define internal-syntactic-environment?
+ (record-predicate internal-syntactic-environment-rtd))
+
+(define internal-syntactic-environment/parent
+ (record-accessor internal-syntactic-environment-rtd 'PARENT))
+
+(define internal-syntactic-environment/bound
+ (record-accessor internal-syntactic-environment-rtd 'BOUND))
+
+(define set-internal-syntactic-environment/bound!
+ (record-modifier internal-syntactic-environment-rtd 'BOUND))
+
+(define internal-syntactic-environment/free
+ (record-accessor internal-syntactic-environment-rtd 'FREE))
+
+(define set-internal-syntactic-environment/free!
+ (record-modifier internal-syntactic-environment-rtd 'FREE))
+
+(define internal-syntactic-environment/rename-state
+ (record-accessor internal-syntactic-environment-rtd 'RENAME-STATE))
+
+(define (internal-syntactic-environment/lookup environment name)
+ (let ((binding
+ (or (assq name (internal-syntactic-environment/bound environment))
+ (assq name (internal-syntactic-environment/free environment)))))
+ (if binding
+ (cdr binding)
+ (let ((item
+ (syntactic-environment/lookup
+ (internal-syntactic-environment/parent environment)
+ name)))
+ (set-internal-syntactic-environment/free!
+ environment
+ (cons (cons name item)
+ (internal-syntactic-environment/free environment)))
+ item))))
+
+(define (internal-syntactic-environment/define environment name item)
+ (cond ((assq name (internal-syntactic-environment/bound environment))
+ => (lambda (binding)
+ (set-cdr! binding item)))
+ ((assq name (internal-syntactic-environment/free environment))
+ (if (reserved-name-item? item)
+ (syntax-error (item/history item)
+ "Premature reference to reserved name:"
+ name)
+ (error "Can't define name; already free:" name)))
+ (else
+ (set-internal-syntactic-environment/bound!
+ environment
+ (cons (cons name item)
+ (internal-syntactic-environment/bound environment))))))
+
+(define (internal-syntactic-environment/rename environment name)
+ (rename-symbol name
+ (internal-syntactic-environment/rename-state environment)))
+
+(define (internal-syntactic-environment->environment environment)
+ (syntactic-environment->environment
+ (internal-syntactic-environment/parent environment)))
+\f
+;;; Filtered syntactic environments are used to implement syntactic
+;;; closures that have free names.
+
+(define filtered-syntactic-environment-rtd
+ (make-record-type "filtered-syntactic-environment"
+ '(NAMES NAMES-ENVIRONMENT ELSE-ENVIRONMENT)))
+
+(define make-filtered-syntactic-environment
+ (let ((constructor
+ (record-constructor filtered-syntactic-environment-rtd
+ '(NAMES NAMES-ENVIRONMENT ELSE-ENVIRONMENT))))
+ (lambda (names names-environment else-environment)
+ (if (or (null? names)
+ (eq? names-environment else-environment))
+ else-environment
+ (constructor names names-environment else-environment)))))
+
+(define filtered-syntactic-environment?
+ (record-predicate filtered-syntactic-environment-rtd))
+
+(define filtered-syntactic-environment/names
+ (record-accessor filtered-syntactic-environment-rtd 'NAMES))
+
+(define filtered-syntactic-environment/names-environment
+ (record-accessor filtered-syntactic-environment-rtd 'NAMES-ENVIRONMENT))
+
+(define filtered-syntactic-environment/else-environment
+ (record-accessor filtered-syntactic-environment-rtd 'ELSE-ENVIRONMENT))
+
+(define (filtered-syntactic-environment/lookup environment name)
+ (syntactic-environment/lookup
+ (if (memq name (filtered-syntactic-environment/names environment))
+ (filtered-syntactic-environment/names-environment environment)
+ (filtered-syntactic-environment/else-environment environment))
+ name))
+
+(define (filtered-syntactic-environment/define environment name item)
+ ;; **** Shouldn't this be a syntax error? It can happen as the
+ ;; result of a misplaced definition. ****
+ (error "Can't bind name in filtered syntactic environment:"
+ environment name item))
+
+(define (filtered-syntactic-environment/rename environment name)
+ (syntactic-environment/rename
+ (if (memq name (filtered-syntactic-environment/names environment))
+ (filtered-syntactic-environment/names-environment environment)
+ (filtered-syntactic-environment/else-environment environment))
+ name))
+
+(define (filtered-syntactic-environment->environment environment)
+ ;; **** Shouldn't this be a syntax error? It can happen as the
+ ;; result of a partially-closed transformer. ****
+ (error "Can't evaluate in filtered syntactic environment:" environment))
+\f
+;;;; Items
+
+;;; Some of the item code is in "syntax-transform.scm" because it is
+;;; needed during the cold load.
+
+(define item?
+ (record-predicate item-rtd))
+
+(define item/history
+ (record-accessor item-rtd 'HISTORY))
+
+(define (item/new-history item history)
+ (make-item history (item/record item)))
+
+(define item/record
+ (record-accessor item-rtd 'RECORD))
+
+(define (item=? x y)
+ (eq? (item/record x) (item/record y)))
+
+(define (make-item-type name fields compiler)
+ (let ((rtd (make-record-type name fields)))
+ (define-item-compiler rtd compiler)
+ rtd))
+
+(define (item-predicate rtd)
+ (let ((predicate (record-predicate rtd)))
+ (lambda (item)
+ (predicate (item/record item)))))
+
+(define (item-accessor rtd field)
+ (let ((accessor (record-accessor rtd field)))
+ (lambda (item)
+ (accessor (item/record item)))))
+
+(define (illegal-expression-item item description)
+ (let ((history (item/history item)))
+ (syntax-error history
+ (string-append description
+ " may not be used as an expression:")
+ (history/original-form history))))
+
+;;; Reserved name items do not represent any form, but instead are
+;;; used to reserve a particular name in a syntactic environment. If
+;;; the classifier refers to a reserved name, a syntax error is
+;;; signalled. This is used in the implementation of LETREC-SYNTAX
+;;; to signal a meaningful error when one of the <init>s refers to
+;;; one of the names being bound.
+
+(define reserved-name-item-rtd
+ (make-item-type "reserved-name-item" '()
+ (lambda (item)
+ (illegal-expression-item item "Reserved name"))))
+
+(define make-reserved-name-item
+ (item-constructor reserved-name-item-rtd '()))
+
+(define reserved-name-item?
+ (item-predicate reserved-name-item-rtd))
+\f
+;;; Keyword items represent macro keywords. There are several flavors
+;;; of keyword item.
+
+(define (keyword-item? item)
+ (or (classifier-item? item)
+ (compiler-item? item)
+ (expander-item? item)
+ (transformer-item? item)))
+
+(define (make-keyword-type name fields)
+ (make-item-type name fields keyword-item-compiler))
+
+(define (keyword-item-compiler item)
+ (illegal-expression-item item "Syntactic keyword"))
+
+
+(define classifier-item-rtd
+ (make-keyword-type "classifier-item" '(CLASSIFIER)))
+
+(define make-classifier-item
+ (keyword-constructor classifier-item-rtd '(CLASSIFIER)))
+
+(define classifier-item?
+ (item-predicate classifier-item-rtd))
+
+(define classifier-item/classifier
+ (item-accessor classifier-item-rtd 'CLASSIFIER))
+
+
+(define compiler-item-rtd
+ (make-keyword-type "compiler-item" '(COMPILER)))
+
+(define make-compiler-item
+ (keyword-constructor compiler-item-rtd '(COMPILER)))
+
+(define compiler-item?
+ (item-predicate compiler-item-rtd))
+
+(define compiler-item/compiler
+ (item-accessor compiler-item-rtd 'COMPILER))
+
+
+(define-item-compiler expander-item-rtd
+ keyword-item-compiler)
+
+(define expander-item?
+ (item-predicate expander-item-rtd))
+
+(define expander-item/expander
+ (item-accessor expander-item-rtd 'EXPANDER))
+
+(define expander-item/environment
+ (item-accessor expander-item-rtd 'ENVIRONMENT))
+
+
+(define transformer-item-rtd
+ (make-keyword-type "transformer-item" '(EXPANDER EXPRESSION)))
+
+(define make-transformer-item
+ (keyword-constructor transformer-item-rtd '(EXPANDER EXPRESSION)))
+
+(define transformer-item?
+ (item-predicate transformer-item-rtd))
+
+(define transformer-item/expander
+ (item-accessor transformer-item-rtd 'EXPANDER))
+
+(define transformer-item/expression
+ (item-accessor transformer-item-rtd 'EXPRESSION))
+\f
+;;; Variable items represent run-time variables.
+
+(define variable-item-rtd
+ (make-item-type "variable-item" '(NAME)
+ (lambda (item)
+ (output/variable (variable-item/name item)))))
+
+(define make-variable-item
+ (let ((constructor (item-constructor variable-item-rtd '(NAME))))
+ (lambda (name)
+ (constructor #f name))))
+
+(define variable-item?
+ (item-predicate variable-item-rtd))
+
+(define variable-item/name
+ (item-accessor variable-item-rtd 'NAME))
+
+;;; Expression items represent any kind of expression other than a
+;;; run-time variable or a sequence. The ANNOTATION field is used to
+;;; make expression items that can appear in non-expression contexts
+;;; (for example, this could be used in the implementation of SETF).
+
+(define expression-item-rtd
+ (make-item-type "expression-item" '(COMPILER ANNOTATION)
+ (lambda (item)
+ ((expression-item/compiler item)))))
+
+(define make-special-expression-item
+ (item-constructor expression-item-rtd '(COMPILER ANNOTATION)))
+
+(define expression-item?
+ (item-predicate expression-item-rtd))
+
+(define expression-item/compiler
+ (item-accessor expression-item-rtd 'COMPILER))
+
+(define expression-item/annotation
+ (item-accessor expression-item-rtd 'ANNOTATION))
+
+(define (make-expression-item history compiler)
+ (make-special-expression-item history compiler #f))
+
+;;; Unassigned items represent the right hand side of a binding that
+;;; has no explicit value.
+
+(define unassigned-item-rtd
+ (make-item-type "unassigned-item" '()
+ (lambda (item)
+ item ;ignore
+ (output/unassigned))))
+
+(define make-unassigned-item
+ (item-constructor unassigned-item-rtd '()))
+
+(define unassigned-item?
+ (item-predicate unassigned-item-rtd))
+
+;;; Declaration items represent block-scoped declarations that are to
+;;; be passed through to the compiler.
+
+(define declaration-item-rtd
+ (make-item-type "declaration-item" '(TEXT)
+ (lambda (item)
+ (illegal-expression-item item "Declaration"))))
+
+(define make-declaration-item
+ (item-constructor declaration-item-rtd '(TEXT)))
+
+(define declaration-item?
+ (item-predicate declaration-item-rtd))
+
+(define declaration-item/text
+ (let ((accessor (item-accessor declaration-item-rtd 'TEXT)))
+ (lambda (item)
+ ((accessor item)))))
+\f
+;;; Body items represent sequences (e.g. BEGIN).
+
+(define body-item-rtd
+ (make-item-type "body-item" '(COMPONENTS)
+ (lambda (item)
+ (compile-body-items item (body-item/components item)))))
+
+(define (compile-body-items item items)
+ (let ((items (flatten-body-items items)))
+ (if (not (pair? items))
+ (illegal-expression-item item "Empty sequence"))
+ (output/sequence
+ (map (lambda (item)
+ (if (binding-item? item)
+ (let ((value (binding-item/value item)))
+ (if (transformer-item? value)
+ (output/sequence '())
+ (output/definition (binding-item/name item)
+ (compile-item/expression value))))
+ (compile-item/expression item)))
+ items))))
+
+(define make-body-item
+ (item-constructor body-item-rtd '(COMPONENTS)))
+
+(define body-item?
+ (item-predicate body-item-rtd))
+
+(define body-item/components
+ (item-accessor body-item-rtd 'COMPONENTS))
+
+;;; Binding items represent definitions, whether top-level or
+;;; internal, keyword or variable. Null binding items are for
+;;; definitions that don't emit code.
+
+(define binding-item-rtd
+ (make-item-type "binding-item" '(NAME VALUE)
+ (lambda (item)
+ (illegal-expression-item item "Definition"))))
+
+(define make-binding-item
+ (item-constructor binding-item-rtd '(NAME VALUE)))
+
+(define binding-item?
+ (item-predicate binding-item-rtd))
+
+(define binding-item/name
+ (item-accessor binding-item-rtd 'NAME))
+
+(define binding-item/value
+ (item-accessor binding-item-rtd 'VALUE))
+
+(define null-binding-item-rtd
+ (make-item-type "null-binding-item" '()
+ (lambda (item)
+ (illegal-expression-item item "Definition"))))
+
+(define make-null-binding-item
+ (item-constructor null-binding-item-rtd '()))
+
+(define null-binding-item?
+ (item-predicate null-binding-item-rtd))
+
+(define (bind-variable! environment name)
+ (let ((rename (syntactic-environment/rename environment name)))
+ (syntactic-environment/define environment
+ name
+ (make-variable-item rename))
+ rename))
+\f
+;;;; Expansion History
+;;; This records each step of the expansion process, separating it
+;;; into subproblems (really, subforms) and reductions. The history
+;;; is attached to the items that are the result of classification,
+;;; so that meaningful debugging information is available after
+;;; classification has been performed. The history is NOT preserved
+;;; by the compilation process, although it might be useful to
+;;; extract a small part of the recorded information and store it in
+;;; the output (for example, keeping track of what input form each
+;;; output form corresponds to).
+
+;;; Note: this abstraction could be implemented in a much simpler
+;;; way, to reduce memory usage. A history need not remember
+;;; anything other than the original-form for the current reduction,
+;;; plus a bit saying whether that original-form is also the current
+;;; one (for replace-reduction).
+
+(define (make-top-level-history forms environment)
+ (list (list (cons forms environment))))
+
+(define (history/add-reduction form environment history)
+ (cons (cons (cons form environment)
+ (car history))
+ (cdr history)))
+
+(define (history/replace-reduction form environment history)
+ ;; This is like ADD-REDUCTION, but it discards the current reduction
+ ;; before adding a new one. This is used when the current reduction
+ ;; is not interesting, such as when reducing a syntactic closure.
+ (cons (cons (cons form environment)
+ (cdar history))
+ (cdr history)))
+
+(define (history/add-subproblem form environment history selector)
+ (cons (list (cons form environment))
+ (cons (cons selector (car history))
+ (cdr history))))
+
+(define (history/original-form history)
+ (caar (last-pair (car history))))
+\f
+;;;; Selectors
+;;; These are used by the expansion history to record subproblem
+;;; nesting so that debugging tools can show that nesting usefully.
+;;; By using abstract selectors, it is possible to locate the cell
+;;; that holds the pointer to a given subform.
+
+(define (selector/apply selector object)
+ (if (pair? selector)
+ (selector/apply (cdr selector)
+ (if (>= (car selector) 0)
+ (list-ref object (car selector))
+ (list-tail object (- (car selector)))))
+ object))
+
+(define (selector/add-car selector)
+ (if (and (pair? selector) (< (car selector) 0))
+ (cons (- (car selector)) (cdr selector))
+ (cons 0 selector)))
+
+(define (selector/add-cdr selector)
+ (if (and (pair? selector) (< (car selector) 0))
+ (cons (- (car selector) 1) (cdr selector))
+ (cons -1 selector)))
+
+(define select-object '())
+(define select-car (selector/add-car select-object))
+(define select-cdr (selector/add-cdr select-object))
+(define select-caar (selector/add-car select-car))
+(define select-cadr (selector/add-car select-cdr))
+(define select-cdar (selector/add-cdr select-car))
+(define select-cddr (selector/add-cdr select-cdr))
+(define select-caaar (selector/add-car select-caar))
+(define select-caadr (selector/add-car select-cadr))
+(define select-cadar (selector/add-car select-cdar))
+(define select-caddr (selector/add-car select-cddr))
+(define select-cdaar (selector/add-cdr select-caar))
+(define select-cdadr (selector/add-cdr select-cadr))
+(define select-cddar (selector/add-cdr select-cdar))
+(define select-cdddr (selector/add-cdr select-cddr))
+(define select-caaaar (selector/add-car select-caaar))
+(define select-caaadr (selector/add-car select-caadr))
+(define select-caadar (selector/add-car select-cadar))
+(define select-caaddr (selector/add-car select-caddr))
+(define select-cadaar (selector/add-car select-cdaar))
+(define select-cadadr (selector/add-car select-cdadr))
+(define select-caddar (selector/add-car select-cddar))
+(define select-cadddr (selector/add-car select-cdddr))
+(define select-cdaaar (selector/add-cdr select-caaar))
+(define select-cdaadr (selector/add-cdr select-caadr))
+(define select-cdadar (selector/add-cdr select-cadar))
+(define select-cdaddr (selector/add-cdr select-caddr))
+(define select-cddaar (selector/add-cdr select-cdaar))
+(define select-cddadr (selector/add-cdr select-cdadr))
+(define select-cdddar (selector/add-cdr select-cddar))
+(define select-cddddr (selector/add-cdr select-cdddr))
+
+(define (selector/add-cadr selector)
+ (selector/add-car (selector/add-cdr selector)))
+
+(define (selector/add-cddr selector)
+ (selector/add-cdr (selector/add-cdr selector)))
+
+(define (select-map procedure items selector)
+ (let loop ((items items) (selector selector))
+ (if (pair? items)
+ (cons (procedure (car items) (selector/add-car selector))
+ (loop (cdr items) (selector/add-cdr selector)))
+ '())))
+
+(define (select-for-each procedure items selector)
+ (let loop ((items items) (selector selector))
+ (if (pair? items)
+ (begin
+ (procedure (car items) (selector/add-car selector))
+ (loop (cdr items) (selector/add-cdr selector))))))
+\f
+;;;; Utilities
+
+(define (define-classifier keyword environment classifier)
+ (syntactic-environment/define environment
+ keyword
+ (make-classifier-item classifier)))
+
+(define (define-compiler keyword environment compiler)
+ (syntactic-environment/define environment
+ keyword
+ (make-compiler-item compiler)))
+
+(define (define-expander keyword environment expander)
+ (syntactic-environment/define environment
+ keyword
+ (make-expander-item expander environment)))
+
+(define (classifier->keyword classifier)
+ (item->keyword (make-classifier-item classifier)))
+
+(define (compiler->keyword compiler)
+ (item->keyword (make-compiler-item compiler)))
+
+(define (expander->keyword expander environment)
+ (item->keyword (make-expander-item expander environment)))
+
+(define (item->keyword item)
+ (let ((environment
+ (make-internal-syntactic-environment null-syntactic-environment)))
+ (syntactic-environment/define environment 'KEYWORD item)
+ (close-syntax 'KEYWORD environment)))
+
+(define (classifier->form classifier)
+ `(,(classifier->keyword classifier)))
+
+(define (compiler->form compiler)
+ `(,(compiler->keyword compiler)))
+
+(define (expander->form expander environment)
+ `(,(expander->keyword expander environment)))
+
+(define (capture-syntactic-environment expander)
+ (classifier->form
+ (lambda (form environment definition-environment history)
+ form ;ignore
+ (let ((form (expander environment)))
+ (classify/form form
+ environment
+ definition-environment
+ (history/replace-reduction form environment history))))))
+
+(define (capture-expansion-history expander)
+ (classifier->form
+ (lambda (form environment definition-environment history)
+ form ;ignore
+ (let ((form (expander history)))
+ (classify/form form
+ environment
+ definition-environment
+ (history/replace-reduction form environment history))))))
+
+(define (call-with-syntax-error-procedure expander)
+ (capture-expansion-history
+ (lambda (history)
+ (expander
+ (lambda rest
+ (apply syntax-error history rest))))))
+\f
+(define (flatten-body-items items)
+ (append-map item->list items))
+
+(define (item->list item)
+ (if (body-item? item)
+ (flatten-body-items (body-item/components item))
+ (list item)))
+
+(define *rename-suffix*)
+
+(define (make-rename-state)
+ (delay
+ (let ((n (+ *rename-suffix* 1)))
+ (set! *rename-suffix* n)
+ (string-append "." (number->string n)))))
+
+(define (rename-symbol symbol state)
+ (string->symbol
+ (string-append "."
+ (symbol->string symbol)
+ (force state))))
+
+(define (make-name-generator)
+ (let ((state (make-rename-state)))
+ (lambda (identifier)
+ (rename-symbol (identifier->symbol identifier) state))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: syntax-check.scm,v 14.1 2002/02/03 03:38:57 cph Exp $
+;;;
+;;; Copyright (c) 1989-1991, 2001 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
+
+;;;; Syntax Checking
+;;; Based on a design by Alan Bawden.
+
+(declare (usual-integrations))
+\f
+(define (syntax-check pattern form history)
+ (if (not (syntax-match? (cdr pattern) (cdr form)))
+ (syntax-error history "Ill-formed special form:" form)))
+
+(define (ill-formed-syntax form)
+ (call-with-syntax-error-procedure
+ (lambda (syntax-error)
+ (syntax-error "Ill-formed special form:" form))))
+
+(define (syntax-match? pattern object)
+ (let ((match-error
+ (lambda ()
+ (error:bad-range-argument pattern 'SYNTAX-MATCH?))))
+ (cond ((procedure? pattern)
+ (pattern object))
+ ((symbol? pattern)
+ (case pattern
+ ((SYMBOL) (symbol? object))
+ ((IDENTIFIER) (identifier? object))
+ ((DATUM EXPRESSION FORM) #t)
+ ((R4RS-BVL) (r4rs-lambda-list? object))
+ ((MIT-BVL) (mit-lambda-list? object))
+ (else (match-error))))
+ ((pair? pattern)
+ (case (car pattern)
+ ((*)
+ (if (pair? (cdr pattern))
+ (let ((head (cadr pattern))
+ (tail (cddr pattern)))
+ (let loop ((object object))
+ (or (and (pair? object)
+ (syntax-match? head (car object))
+ (loop (cdr object)))
+ (syntax-match? tail object))))
+ (match-error)))
+ ((+)
+ (if (pair? (cdr pattern))
+ (let ((head (cadr pattern))
+ (tail (cddr pattern)))
+ (and (pair? object)
+ (syntax-match? head (car object))
+ (let loop ((object (cdr object)))
+ (or (and (pair? object)
+ (syntax-match? head (car object))
+ (loop (cdr object)))
+ (syntax-match? tail object)))))
+ (match-error)))
+ ((?)
+ (if (pair? (cdr pattern))
+ (or (and (pair? object)
+ (syntax-match? (cadr pattern) (car object))
+ (syntax-match? (cddr pattern) (cdr object)))
+ (syntax-match? (cddr pattern) object))
+ (match-error)))
+ ((QUOTE)
+ (if (and (pair? (cdr pattern))
+ (null? (cddr pattern)))
+ (eqv? (cadr pattern) object)
+ (match-error)))
+ (else
+ (and (pair? object)
+ (syntax-match? (car pattern) (car object))
+ (syntax-match? (cdr pattern) (cdr object))))))
+ (else
+ (eqv? pattern object)))))
+\f
+;;;; Lambda lists
+
+(define (r4rs-lambda-list? object)
+ (let loop ((object object) (seen '()))
+ (or (null? object)
+ (if (identifier? object)
+ (not (memq object seen))
+ (and (pair? object)
+ (identifier? (car object))
+ (not (memq (car object) seen))
+ (loop (cdr object) (cons (car object) seen)))))))
+
+(define (mit-lambda-list? object)
+ (letrec
+ ((parse-required
+ (lambda (object seen)
+ (or (null? object)
+ (if (identifier? object)
+ (not (memq object seen))
+ (and (pair? object)
+ (cond ((eq? (car object) lambda-optional-tag)
+ (and (pair? (cdr object))
+ (parse-parameter (cadr object) seen
+ (lambda (seen)
+ (parse-optional (cddr object) seen)))))
+ ((eq? (car object) lambda-rest-tag)
+ (parse-rest (cdr object) seen))
+ (else
+ (parse-parameter (car object) seen
+ (lambda (seen)
+ (parse-required (cdr object) seen))))))))))
+ (parse-optional
+ (lambda (object seen)
+ (or (null? object)
+ (if (identifier? object)
+ (not (memq object seen))
+ (and (pair? object)
+ (cond ((eq? (car object) lambda-optional-tag)
+ #f)
+ ((eq? (car object) lambda-rest-tag)
+ (parse-rest (cdr object) seen))
+ (else
+ (parse-parameter (car object) seen
+ (lambda (seen)
+ (parse-optional (cdr object) seen))))))))))
+ (parse-rest
+ (lambda (object seen)
+ (and (pair? object)
+ (parse-parameter (car object) seen
+ (lambda (seen)
+ seen
+ (null? (cdr object)))))))
+ (parse-parameter
+ (lambda (object seen k)
+ (if (identifier? object)
+ (and (not (memq object seen))
+ (k (cons object seen)))
+ (and (pair? object)
+ (identifier? (car object))
+ (list? (cdr object))
+ (not (memq (car object) seen))
+ (k (cons (car object) seen)))))))
+ (parse-required object '())))
+\f
+(define (parse-mit-lambda-list lambda-list)
+ (let ((required (list '()))
+ (optional (list '())))
+ (define (parse-parameters cell pattern)
+ (let loop ((pattern pattern))
+ (cond ((null? pattern) (finish #f))
+ ((identifier? pattern) (finish pattern))
+ ((not (pair? pattern)) (bad-lambda-list pattern))
+ ((eq? (car pattern) lambda-rest-tag)
+ (if (and (pair? (cdr pattern)) (null? (cddr pattern)))
+ (cond ((identifier? (cadr pattern)) (finish (cadr pattern)))
+ ((and (pair? (cadr pattern))
+ (identifier? (caadr pattern)))
+ (finish (caadr pattern)))
+ (else (bad-lambda-list (cdr pattern))))
+ (bad-lambda-list (cdr pattern))))
+ ((eq? (car pattern) lambda-optional-tag)
+ (if (eq? cell required)
+ (parse-parameters optional (cdr pattern))
+ (bad-lambda-list pattern)))
+ ((identifier? (car pattern))
+ (set-car! cell (cons (car pattern) (car cell)))
+ (loop (cdr pattern)))
+ ((and (pair? (car pattern)) (identifier? (caar pattern)))
+ (set-car! cell (cons (caar pattern) (car cell)))
+ (loop (cdr pattern)))
+ (else (bad-lambda-list pattern)))))
+
+ (define (finish rest)
+ (let ((required (reverse! (car required)))
+ (optional (reverse! (car optional))))
+ (do ((parameters
+ (append required optional (if rest (list rest) '()))
+ (cdr parameters)))
+ ((null? parameters))
+ (if (memq (car parameters) (cdr parameters))
+ (syntax-error "lambda list has duplicate parameter:"
+ (car parameters)
+ (error-irritant/noise " in")
+ lambda-list)))
+ (values required optional rest)))
+
+ (define (bad-lambda-list pattern)
+ (error "Ill-formed lambda list:" pattern))
+
+ (parse-parameters required lambda-list)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: syntax-output.scm,v 14.1 2002/02/03 03:38:57 cph Exp $
+;;;
+;;; Copyright (c) 1989-1991, 2001, 2002 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
+
+;;;; Syntaxer Output Interface
+
+(declare (usual-integrations))
+\f
+(define (syntax-error history . rest)
+ history ;ignore
+ (apply error rest))
+
+(define (transformer-eval expression environment)
+ (eval expression environment))
+
+(define (output/variable name)
+ (make-variable name))
+
+(define (output/constant datum)
+ datum)
+
+(define (output/assignment name value)
+ (make-assignment name value))
+
+(define (output/top-level-definition name value)
+ (make-definition name
+ (if (lambda? value)
+ (lambda-components* value
+ (lambda (name* required optional rest body)
+ (if (eq? name* lambda-tag:unnamed)
+ (make-lambda* name required optional rest body)
+ value)))
+ value)))
+
+(define (output/top-level-syntax-definition name value)
+ (make-definition name (make-macro-reference-trap-expression value)))
+
+(define (output/conditional predicate consequent alternative)
+ (make-conditional predicate consequent alternative))
+
+(define (output/sequence expressions)
+ (make-sequence expressions))
+
+(define (output/combination operator operands)
+ (make-combination operator operands))
+
+(define (output/lambda lambda-list body)
+ (output/named-lambda lambda-tag:unnamed lambda-list body))
+
+(define (output/named-lambda name lambda-list body)
+ (output/lambda-internal name lambda-list '() body))
+
+(define (output/lambda-internal name lambda-list declarations body)
+ (call-with-values (lambda () (parse-mit-lambda-list lambda-list))
+ (lambda (required optional rest)
+ (make-lambda* name required optional rest
+ (let ((declarations (apply append declarations)))
+ (if (pair? declarations)
+ (make-sequence (make-block-declaration declarations)
+ body)
+ body))))))
+
+(define (output/delay expression)
+ (make-delay expression))
+
+(define (output/unassigned-test name)
+ (make-unassigned? name))
+
+(define (output/unassigned)
+ (make-unassigned-reference-trap))
+
+(define (output/unspecific)
+ unspecific)
+\f
+(define (output/let names values body)
+ (output/combination (output/named-lambda lambda-tag:let names body) values))
+
+(define (output/letrec names values body)
+ (output/let '() '()
+ (output/body '()
+ (make-sequence
+ (append! (map make-definition names values)
+ (list body))))))
+
+(define (output/body declarations body)
+ (scan-defines (let ((declarations (apply append declarations)))
+ (if (pair? declarations)
+ (make-sequence
+ (list (make-block-declaration declarations)
+ body))
+ body))
+ make-open-block))
+
+(define (output/definition name value)
+ (make-definition name value))
+
+(define (output/top-level-sequence declarations expressions)
+ (let ((declarations (apply append declarations))
+ (make-open-block
+ (lambda (expressions)
+ (scan-defines (make-sequence expressions) make-open-block))))
+ (if (pair? declarations)
+ (if (pair? expressions)
+ (make-open-block
+ (cons (make-block-declaration declarations)
+ expressions))
+ (make-block-declaration declarations))
+ (if (pair? expressions)
+ (if (pair? (cdr expressions))
+ (make-open-block expressions)
+ (car expressions))
+ (output/unspecific)))))
+
+(define (output/the-environment)
+ (make-the-environment))
+
+(define (output/access-reference name environment)
+ (make-access environment name))
+
+(define (output/access-assignment name environment value)
+ (make-combination lexical-assignment (list environment name value)))
+
+(define (output/local-declare declarations body)
+ (make-declaration declarations body))
+
+(define lambda-tag:unnamed
+ ((ucode-primitive string->symbol) "#[unnamed-procedure]"))
+
+(define lambda-tag:let
+ ((ucode-primitive string->symbol) "#[let-procedure]"))
+
+(define lambda-tag:fluid-let
+ ((ucode-primitive string->symbol) "#[fluid-let-procedure]"))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: syntax-rules.scm,v 14.1 2002/02/03 03:38:57 cph Exp $
+;;;
+;;; Copyright (c) 1989-1991, 2001, 2002 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
+
+;;;; Rule-based Syntactic Expanders
+
+;;; See "Syntactic Extensions in the Programming Language Lisp", by
+;;; Eugene Kohlbecker, Ph.D. dissertation, Indiana University, 1986.
+;;; See also "Macros That Work", by William Clinger and Jonathan Rees
+;;; (reference? POPL?). This implementation is derived from an
+;;; implementation by Kent Dybvig, and includes some ideas from
+;;; another implementation by Jonathan Rees.
+
+(declare (usual-integrations))
+\f
+(define-er-macro-transformer 'SYNTAX-RULES system-global-environment
+ (lambda (form rename compare)
+ (call-with-syntax-error-procedure
+ (lambda (syntax-error)
+ (expand/syntax-rules form rename compare syntax-error)))))
+
+(define (expand/syntax-rules form rename compare syntax-error)
+ (if (syntax-match? '((* IDENTIFIER) + ((IDENTIFIER . DATUM) EXPRESSION))
+ (cdr form))
+ (let ((keywords (cadr form))
+ (clauses (cddr form)))
+ (if (let loop ((keywords keywords))
+ (and (pair? keywords)
+ (or (memq (car keywords) (cdr keywords))
+ (loop (cdr keywords)))))
+ (syntax-error "Keywords list contains duplicates:" keywords)
+ (let ((r-form (rename 'FORM))
+ (r-rename (rename 'RENAME))
+ (r-compare (rename 'COMPARE)))
+ `(,(rename 'ER-MACRO-TRANSFORMER)
+ (,(rename 'LAMBDA)
+ (,r-form ,r-rename ,r-compare)
+ ,r-compare ;prevent compiler warnings
+ ,(let loop ((clauses clauses))
+ (if (null? clauses)
+ `(,(rename 'BEGIN)
+ ,r-rename ;prevent compiler warnings
+ (,(rename 'ILL-FORMED-SYNTAX) ,r-form))
+ (let ((pattern (caar clauses)))
+ (let ((sids
+ (parse-pattern rename compare keywords
+ pattern r-form)))
+ `(,(rename 'IF)
+ ,(generate-match rename compare keywords
+ r-rename r-compare
+ pattern r-form)
+ ,(generate-output rename compare r-rename
+ sids (cadar clauses)
+ syntax-error)
+ ,(loop (cdr clauses))))))))))))
+ (syntax-error "Ill-formed special form:" form)))
+
+(define (parse-pattern rename compare keywords pattern expression)
+ (let loop
+ ((pattern pattern)
+ (expression expression)
+ (sids '())
+ (control #f))
+ (cond ((identifier? pattern)
+ (if (memq pattern keywords)
+ sids
+ (cons (make-sid pattern expression control) sids)))
+ ((and (or (zero-or-more? pattern rename compare)
+ (at-least-one? pattern rename compare))
+ (null? (cddr pattern)))
+ (let ((variable ((make-name-generator) 'CONTROL)))
+ (loop (car pattern)
+ variable
+ sids
+ (make-sid variable expression control))))
+ ((pair? pattern)
+ (loop (car pattern)
+ `(,(rename 'CAR) ,expression)
+ (loop (cdr pattern)
+ `(,(rename 'CDR) ,expression)
+ sids
+ control)
+ control))
+ (else sids))))
+\f
+(define (generate-match rename compare keywords r-rename r-compare
+ pattern expression)
+ (letrec
+ ((loop
+ (lambda (pattern expression)
+ (cond ((identifier? pattern)
+ (if (memq pattern keywords)
+ (let ((temp (rename 'TEMP)))
+ `((,(rename 'LAMBDA)
+ (,temp)
+ (,(rename 'IF)
+ (,(rename 'IDENTIFIER?) ,temp)
+ (,r-compare ,temp
+ (,r-rename ,(syntax-quote pattern)))
+ #f))
+ ,expression))
+ `#t))
+ ((and (zero-or-more? pattern rename compare)
+ (null? (cddr pattern)))
+ (do-list (car pattern) expression))
+ ((and (at-least-one? pattern rename compare)
+ (null? (cddr pattern)))
+ `(,(rename 'IF) (,(rename 'NULL?) ,expression)
+ #F
+ ,(do-list (car pattern) expression)))
+ ((pair? pattern)
+ (let ((generate-pair
+ (lambda (expression)
+ (conjunction
+ `(,(rename 'PAIR?) ,expression)
+ (conjunction
+ (loop (car pattern)
+ `(,(rename 'CAR) ,expression))
+ (loop (cdr pattern)
+ `(,(rename 'CDR) ,expression)))))))
+ (if (identifier? expression)
+ (generate-pair expression)
+ (let ((temp (rename 'TEMP)))
+ `((,(rename 'LAMBDA) (,temp) ,(generate-pair temp))
+ ,expression)))))
+ ((null? pattern)
+ `(,(rename 'NULL?) ,expression))
+ (else
+ `(,(rename 'EQUAL?) ,expression
+ (,(rename 'QUOTE) ,pattern))))))
+ (do-list
+ (lambda (pattern expression)
+ (let ((r-loop (rename 'LOOP))
+ (r-l (rename 'L))
+ (r-lambda (rename 'LAMBDA)))
+ `(((,r-lambda
+ (,r-loop)
+ (,(rename 'BEGIN)
+ (,(rename 'SET!)
+ ,r-loop
+ (,r-lambda
+ (,r-l)
+ (,(rename 'IF)
+ (,(rename 'NULL?) ,r-l)
+ #T
+ ,(conjunction
+ `(,(rename 'PAIR?) ,r-l)
+ (conjunction (loop pattern `(,(rename 'CAR) ,r-l))
+ `(,r-loop (,(rename 'CDR) ,r-l)))))))
+ ,r-loop))
+ #F)
+ ,expression))))
+ (conjunction
+ (lambda (predicate consequent)
+ (cond ((eq? predicate #T) consequent)
+ ((eq? consequent #T) predicate)
+ (else `(,(rename 'IF) ,predicate ,consequent #F))))))
+ (loop pattern expression)))
+\f
+(define (generate-output rename compare r-rename sids template syntax-error)
+ (let loop ((template template) (ellipses '()))
+ (cond ((identifier? template)
+ (let ((sid
+ (let loop ((sids sids))
+ (and (not (null? sids))
+ (if (eq? (sid-name (car sids)) template)
+ (car sids)
+ (loop (cdr sids)))))))
+ (if sid
+ (begin
+ (add-control! sid ellipses syntax-error)
+ (sid-expression sid))
+ `(,r-rename ,(syntax-quote template)))))
+ ((or (zero-or-more? template rename compare)
+ (at-least-one? template rename compare))
+ (optimized-append rename compare
+ (let ((ellipsis (make-ellipsis '())))
+ (generate-ellipsis rename
+ ellipsis
+ (loop (car template)
+ (cons ellipsis
+ ellipses))))
+ (loop (cddr template) ellipses)))
+ ((pair? template)
+ (optimized-cons rename compare
+ (loop (car template) ellipses)
+ (loop (cdr template) ellipses)))
+ (else
+ `(,(rename 'QUOTE) ,template)))))
+
+(define (add-control! sid ellipses syntax-error)
+ (let loop ((sid sid) (ellipses ellipses))
+ (let ((control (sid-control sid)))
+ (cond (control
+ (if (pair? ellipses)
+ (let ((sids (ellipsis-sids (car ellipses))))
+ (cond ((not (memq control sids))
+ (set-ellipsis-sids! (car ellipses)
+ (cons control sids)))
+ ((not (eq? control (car sids)))
+ (error "illegal control/ellipsis combination"
+ control sids))))
+ (syntax-error "Missing ellipsis in expansion." #f))
+ (loop control (cdr ellipses)))
+ ((pair? ellipses)
+ (syntax-error "Extra ellipsis in expansion." #f))))))
+
+(define (generate-ellipsis rename ellipsis body)
+ (let ((sids (ellipsis-sids ellipsis)))
+ (let ((name (sid-name (car sids)))
+ (expression (sid-expression (car sids))))
+ (cond ((and (null? (cdr sids))
+ (eq? body name))
+ expression)
+ ((and (null? (cdr sids))
+ (pair? body)
+ (pair? (cdr body))
+ (eq? (cadr body) name)
+ (null? (cddr body)))
+ `(,(rename 'MAP) ,(car body) ,expression))
+ (else
+ `(,(rename 'MAP) (,(rename 'LAMBDA) ,(map sid-name sids) ,body)
+ ,@(map sid-expression sids)))))))
+\f
+(define (zero-or-more? pattern rename compare)
+ (and (pair? pattern)
+ (pair? (cdr pattern))
+ (identifier? (cadr pattern))
+ (compare (cadr pattern) (rename '...))))
+
+(define (at-least-one? pattern rename compare)
+;;; (and (pair? pattern)
+;;; (pair? (cdr pattern))
+;;; (identifier? (cadr pattern))
+;;; (compare (cadr pattern) (rename '+)))
+ pattern rename compare ;ignore
+ #f)
+
+(define (syntax-quote expression)
+ `(,(compiler->keyword
+ (lambda (form environment history)
+ environment ;ignore
+ (syntax-check '(KEYWORD DATUM) form history)
+ (output/constant (cadr form))))
+ ,expression))
+
+(define (optimized-cons rename compare a d)
+ (cond ((and (pair? d)
+ (compare (car d) (rename 'QUOTE))
+ (pair? (cdr d))
+ (null? (cadr d))
+ (null? (cddr d)))
+ `(,(rename 'LIST) ,a))
+ ((and (pair? d)
+ (compare (car d) (rename 'LIST))
+ (list? (cdr d)))
+ `(,(car d) ,a ,@(cdr d)))
+ (else
+ `(,(rename 'CONS) ,a ,d))))
+
+(define (optimized-append rename compare x y)
+ (if (and (pair? y)
+ (compare (car y) (rename 'QUOTE))
+ (pair? (cdr y))
+ (null? (cadr y))
+ (null? (cddr y)))
+ x
+ `(,(rename 'APPEND) ,x ,y)))
+
+(define sid-type
+ (make-record-type "sid" '(NAME EXPRESSION CONTROL OUTPUT-EXPRESSION)))
+
+(define make-sid
+ (record-constructor sid-type '(NAME EXPRESSION CONTROL)))
+
+(define sid-name
+ (record-accessor sid-type 'NAME))
+
+(define sid-expression
+ (record-accessor sid-type 'EXPRESSION))
+
+(define sid-control
+ (record-accessor sid-type 'CONTROL))
+
+(define sid-output-expression
+ (record-accessor sid-type 'OUTPUT-EXPRESSION))
+
+(define set-sid-output-expression!
+ (record-updater sid-type 'OUTPUT-EXPRESSION))
+
+(define ellipsis-type
+ (make-record-type "ellipsis" '(SIDS)))
+
+(define make-ellipsis
+ (record-constructor ellipsis-type '(SIDS)))
+
+(define ellipsis-sids
+ (record-accessor ellipsis-type 'SIDS))
+
+(define set-ellipsis-sids!
+ (record-updater ellipsis-type 'SIDS))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: syntax-transforms.scm,v 14.1 2002/02/03 03:38:57 cph Exp $
+;;;
+;;; Copyright (c) 1989-1991, 2001, 2002 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
+
+;;;; MIT Scheme syntax
+
+;;; Procedures to convert transformers to internal form. Required
+;;; during cold load, so must be loaded very early in the sequence.
+
+(declare (usual-integrations))
+\f
+;;;; Items
+
+(define (item-constructor rtd fields)
+ (let ((constructor (record-constructor rtd fields)))
+ (lambda (history . arguments)
+ (make-item history (apply constructor arguments)))))
+
+(define (keyword-constructor type fields)
+ (let ((constructor (item-constructor type fields)))
+ (lambda arguments
+ (apply constructor #f arguments))))
+
+(define item-rtd)
+(define make-item)
+(define expander-item-rtd)
+(define make-expander-item)
+
+(define (initialize-syntax-transforms!)
+ (set! item-rtd
+ (make-record-type "item" '(HISTORY RECORD)))
+ (set! make-item
+ (record-constructor item-rtd '(HISTORY RECORD)))
+ (set! expander-item-rtd
+ (make-record-type "expander-item" '(EXPANDER ENVIRONMENT)))
+ (set! make-expander-item
+ (keyword-constructor expander-item-rtd '(EXPANDER ENVIRONMENT)))
+ unspecific)
+
+(define (sc-macro-transformer->expander transformer closing-environment)
+ (make-expander-item (lambda (form environment closing-environment)
+ (make-syntactic-closure closing-environment '()
+ (transformer form environment)))
+ closing-environment))
+
+(define (rsc-macro-transformer->expander transformer closing-environment)
+ (make-expander-item (lambda (form environment closing-environment)
+ (make-syntactic-closure environment '()
+ (transformer form closing-environment)))
+ closing-environment))
+
+(define (er-macro-transformer->expander transformer closing-environment)
+ (make-expander-item
+ (lambda (form environment closing-environment)
+ (make-syntactic-closure environment '()
+ (transformer
+ form
+ (let ((renames '()))
+ (lambda (identifier)
+ (let ((association (assq identifier renames)))
+ (if association
+ (cdr association)
+ (let ((rename
+ (make-syntactic-closure closing-environment '()
+ identifier)))
+ (set! renames (cons (cons identifier rename) renames))
+ rename)))))
+ (lambda (x y)
+ (identifier=? environment x environment y)))))
+ closing-environment))
+
+(define (non-hygienic-macro-transformer->expander transformer
+ closing-environment)
+ (make-expander-item (lambda (form environment closing-environment)
+ closing-environment
+ (make-syntactic-closure environment '()
+ (apply transformer (cdr form))))
+ closing-environment))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Id: syntax.scm,v 14.52 2001/12/29 04:16:32 cph Exp $
-
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-This program is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-|#
-
-;;;; SYNTAX: S-Expressions -> SCODE
-;;; package: (runtime syntaxer)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (enable-scan-defines!)
- (set! *disallow-illegal-definitions?* #t)
- (set! hook/syntax-expression default/syntax-expression)
- (install-system-global-syntax!))
-
-(define *syntax-table*)
-(define *current-keyword* #f)
-(define *syntax-top-level?*)
-(define *disallow-illegal-definitions?*)
-
-(define (install-system-global-syntax!)
- (for-each
- (lambda (entry)
- (environment-define-macro system-global-environment
- (car entry)
- (make-primitive-syntaxer (cadr entry))))
- `(
- ;; R*RS special forms
- (BEGIN ,syntax/begin)
- (COND ,syntax/cond)
- (DEFINE ,syntax/define)
- (DELAY ,syntax/delay)
- (IF ,syntax/if)
- (LAMBDA ,syntax/lambda)
- (LET ,syntax/let)
- (OR ,syntax/or)
- (QUOTE ,syntax/quote)
- (SET! ,syntax/set!)
-
- ;; Syntax extensions
- (DEFINE-SYNTAX ,syntax/define-syntax)
- (LET-SYNTAX ,syntax/let-syntax)
-
- ;; Environment extensions
- (ACCESS ,syntax/access)
- (THE-ENVIRONMENT ,syntax/the-environment)
- ;; To facilitate upgrade to new option argument mechanism.
- (DEFAULT-OBJECT? ,syntax/unassigned?)
-
- ;; Miscellaneous extensions
- (DECLARE ,syntax/declare)
- (FLUID-LET ,syntax/fluid-let)
- (LOCAL-DECLARE ,syntax/local-declare)
- (NAMED-LAMBDA ,syntax/named-lambda))))
-\f
-;;;; Top Level Syntaxers
-
-(define (syntax expression #!optional table)
- (syntax-top-level 'SYNTAX syntax-expression expression
- (if (default-object? table) 'DEFAULT table)))
-
-(define (syntax* expressions #!optional table)
- (syntax-top-level 'SYNTAX* syntax-sequence expressions
- (if (default-object? table) 'DEFAULT table)))
-
-(define (syntax-top-level name syntaxer expression table)
- (let ((scode
- (fluid-let ((*syntax-table*
- (make-syntax-table
- (if (eq? table 'DEFAULT)
- (nearest-repl/environment)
- (guarantee-syntax-table table name))))
- (*current-keyword* #f))
- (syntaxer #t expression))))
- (if *disallow-illegal-definitions?*
- (check-for-illegal-definitions scode))
- scode))
-
-(define (syntax/top-level?)
- *syntax-top-level?*)
-
-(define-integrable (syntax-subsequence expressions)
- (syntax-sequence #f expressions))
-
-(define (syntax-sequence top-level? original-expressions)
- (make-scode-sequence
- (syntax-sequence-internal top-level? original-expressions)))
-
-(define (syntax-sequence-internal top-level? original-expressions)
- (if (null? original-expressions)
- (syntax-error "no subforms in sequence")
- (let process ((expressions original-expressions))
- (cond ((pair? expressions)
- ;; Force eval order. This is required so that special
- ;; forms such as `define-syntax' work correctly.
- (let ((first (syntax-expression top-level? (car expressions))))
- (cons first (process (cdr expressions)))))
- ((null? expressions)
- '())
- (else
- (syntax-error "bad sequence" original-expressions))))))
-
-(define-integrable (syntax-subexpression expression)
- (syntax-expression #f expression))
-
-(define (syntax-expression top-level? expression)
- (hook/syntax-expression top-level? expression *syntax-table*))
-
-(define hook/syntax-expression)
-(define (default/syntax-expression top-level? expression syntax-table)
- (cond
- ((pair? expression)
- (if (not (list? expression))
- (error "syntax-expression: not a valid expression" expression))
- (let ((transform
- (and (symbol? (car expression))
- (syntax-table/ref syntax-table (car expression)))))
- (if transform
- (if (primitive-syntaxer? transform)
- (transform-apply (primitive-syntaxer/transform transform)
- (car expression)
- (cons top-level? (cdr expression)))
- (let ((result
- (fluid-let ((*syntax-top-level?* top-level?))
- (transform-apply transform
- (car expression)
- (cdr expression)))))
- (if (syntax-closure? result)
- (syntax-closure/expression result)
- (syntax-expression top-level? result))))
- (make-combination (syntax-subexpression (car expression))
- (map syntax-subexpression (cdr expression))))))
- ((symbol? expression)
- (make-variable expression))
- (else
- expression)))
-\f
-;;; Two overlapping kludges here. This should go away and be replaced
-;;; by a true syntactic closure mechanism like that described by
-;;; Bawden and Rees.
-
-(define-integrable (make-syntax-closure expression)
- (cons syntax-closure-tag expression))
-
-(define (syntax-closure? expression)
- (and (pair? expression)
- (eq? (car expression) syntax-closure-tag)))
-
-(define-integrable (syntax-closure/expression syntax-closure)
- (cdr syntax-closure))
-
-(define syntax-closure-tag
- "syntax-closure")
-
-(define-integrable (make-primitive-syntaxer expression)
- (cons primitive-syntaxer-tag expression))
-
-(define (primitive-syntaxer? expression)
- (and (pair? expression)
- (eq? (car expression) primitive-syntaxer-tag)))
-
-(define-integrable (primitive-syntaxer/transform primitive-syntaxer)
- (cdr primitive-syntaxer))
-
-(define primitive-syntaxer-tag
- "primitive-syntaxer")
-
-(define (transform-apply transform keyword arguments)
- (fluid-let ((*current-keyword* keyword))
- (let ((n-arguments (length arguments)))
- (if (not (procedure-arity-valid? transform n-arguments))
- (syntax-error "incorrect number of subforms" n-arguments)))
- (apply transform arguments)))
-
-(define (syntax-error message . irritants)
- (apply error
- (cons
- (string-append "SYNTAX: "
- (if *current-keyword*
- (string-append (symbol-name *current-keyword*)
- ": "
- message)
- message))
- irritants)))
-
-(define (syntax-bindings bindings receiver)
- (if (not (list? bindings))
- (syntax-error "bindings must be a list" bindings)
- (let loop ((bindings bindings) (receiver receiver))
- (cond ((null? bindings)
- (receiver '() '()))
- ((and (pair? (car bindings))
- (symbol? (caar bindings)))
- (loop (cdr bindings)
- (lambda (names values)
- (receiver (cons (caar bindings) names)
- (cons (expand-binding-value (cdar bindings))
- values)))))
- (else
- (syntax-error "badly formed binding" (car bindings)))))))
-\f
-;;;; Expanders
-
-(define (expand-access chain cont)
- (if (symbol? (car chain))
- (cont (if (null? (cddr chain))
- (syntax-subexpression (cadr chain))
- (expand-access (cdr chain) make-access))
- (car chain))
- (syntax-error "non-symbolic variable" (car chain))))
-
-(define (expand-binding-value rest)
- (cond ((null? rest) (make-unassigned-reference-trap))
- ((null? (cdr rest)) (syntax-subexpression (car rest)))
- (else (syntax-error "too many forms in value" rest))))
-
-(define (expand-disjunction forms)
- (if (null? forms)
- #f
- (let process ((forms forms))
- (if (null? (cdr forms))
- (syntax-subexpression (car forms))
- (make-disjunction (syntax-subexpression (car forms))
- (process (cdr forms)))))))
-
-(define (expand-lambda pattern actions receiver)
- ((if (pair? pattern)
- (letrec ((loop
- (lambda (pattern body)
- (if (pair? (car pattern))
- (loop (car pattern)
- (make-simple-lambda (cdr pattern) body))
- (receiver pattern body)))))
- loop)
- receiver)
- pattern
- (syntax-lambda-body actions)))
-
-(define (syntax-lambda-body body)
- (syntax-subsequence
- (if (and (not (null? body))
- (not (null? (cdr body)))
- (string? (car body)))
- (cdr body) ;discard documentation string.
- body)))
-\f
-;;;; Basic Syntax
-
-(define (syntax/quote top-level? expression)
- top-level?
- expression)
-
-(define (syntax/the-environment top-level?)
- top-level?
- (make-the-environment))
-
-(define (syntax/unassigned? top-level? name)
- top-level?
- (make-unassigned? name))
-
-(define (syntax/access top-level? . chain)
- top-level?
- (if (not (and (pair? chain) (pair? (cdr chain))))
- (syntax-error "too few forms" chain))
- (expand-access chain make-access))
-
-(define (syntax/set! top-level? name . rest)
- top-level?
- ((invert-expression (syntax-subexpression name))
- (expand-binding-value rest)))
-
-(define (syntax/define top-level? pattern . rest)
- top-level?
- (let ((make-definition
- (lambda (name value)
- (make-definition name value))))
- (cond ((symbol? pattern)
- (make-definition
- pattern
- (let ((value
- (expand-binding-value
- (if (and (= (length rest) 2)
- (string? (cadr rest)))
- (list (car rest))
- rest))))
- (if (lambda? value)
- (lambda-components* value
- (lambda (name required optional rest body)
- (if (eq? name lambda-tag:unnamed)
- (make-lambda* pattern required optional rest body)
- value)))
- value))))
- ((pair? pattern)
- (expand-lambda pattern rest
- (lambda (pattern body)
- (make-definition (car pattern)
- (make-named-lambda (car pattern) (cdr pattern)
- body)))))
- (else
- (syntax-error "bad pattern" pattern)))))
-
-(define (syntax/begin top-level? . actions)
- (syntax-sequence top-level? actions))
-
-(define (syntax/delay top-level? expression)
- top-level?
- (make-delay (syntax-subexpression expression)))
-\f
-;;;; Conditionals
-
-(define (syntax/if top-level? predicate consequent . rest)
- top-level?
- (make-conditional (syntax-subexpression predicate)
- (syntax-subexpression consequent)
- (cond ((null? rest)
- undefined-conditional-branch)
- ((null? (cdr rest))
- (syntax-subexpression (car rest)))
- (else
- (syntax-error "too many forms" (cdr rest))))))
-
-(define (syntax/or top-level? . expressions)
- top-level?
- (expand-disjunction expressions))
-
-(define (syntax/cond top-level? . clauses)
- top-level?
- (define (loop clause rest)
- (cond ((not (pair? clause))
- (syntax-error "bad COND clause" clause))
- ((eq? (car clause) 'ELSE)
- (if (not (null? rest))
- (syntax-error "ELSE not last clause" rest))
- (syntax-subsequence (cdr clause)))
- ((null? (cdr clause))
- (make-disjunction (syntax-subexpression (car clause)) (next rest)))
- ((and (pair? (cdr clause))
- (eq? (cadr clause) '=>))
- (if (not (and (pair? (cddr clause))
- (null? (cdddr clause))))
- (syntax-error "misformed => clause" clause))
- (let ((predicate (string->uninterned-symbol "PREDICATE")))
- (make-closed-block lambda-tag:let
- (list predicate)
- (list (syntax-subexpression (car clause)))
- (let ((predicate (syntax-subexpression predicate)))
- (make-conditional
- predicate
- (make-combination* (syntax-subexpression (caddr clause))
- predicate)
- (next rest))))))
- (else
- (make-conditional (syntax-subexpression (car clause))
- (syntax-subsequence (cdr clause))
- (next rest)))))
-
- (define (next rest)
- (if (null? rest)
- undefined-conditional-branch
- (loop (car rest) (cdr rest))))
-
- (next clauses))
-\f
-;;;; Procedures
-
-(define (syntax/lambda top-level? pattern . body)
- top-level?
- (make-simple-lambda pattern (syntax-lambda-body body)))
-
-(define (syntax/named-lambda top-level? pattern . body)
- top-level?
- (expand-lambda pattern body
- (lambda (pattern body)
- (if (pair? pattern)
- (make-named-lambda (car pattern) (cdr pattern) body)
- (syntax-error "illegal named-lambda list" pattern)))))
-
-(define (syntax/let top-level? name-or-pattern pattern-or-first . rest)
- top-level?
- (if (symbol? name-or-pattern)
- (syntax-bindings pattern-or-first
- (lambda (names values)
- (if (memq name-or-pattern names)
- (syntax-error "name conflicts with binding"
- name-or-pattern))
- (make-combination
- (make-letrec (list name-or-pattern)
- (list (make-named-lambda name-or-pattern names
- (syntax-subsequence rest)))
- (make-variable name-or-pattern))
- values)))
- (syntax-bindings name-or-pattern
- (lambda (names values)
- (make-closed-block
- lambda-tag:let names values
- (syntax-subsequence (cons pattern-or-first rest)))))))
-\f
-;;;; Syntax Extensions
-
-(define (syntax/let-syntax top-level? bindings . body)
- (syntax-bindings bindings
- (lambda (names values)
- (fluid-let ((*syntax-table*
- (syntax-table/extend
- *syntax-table*
- (map (lambda (name value)
- (cons name (syntax-eval value)))
- names
- values))))
- (syntax-sequence top-level? body)))))
-
-(define (syntax/define-syntax top-level? name value)
- (if (not (symbol? name))
- (syntax-error "illegal name" name))
- (let ((value (syntax-subexpression value)))
- (syntax-table/define *syntax-table* name (syntax-eval value))
- (if top-level?
- (make-definition name (make-macro-reference-trap-expression value))
- name)))
-
-(define (syntax-eval scode)
- (extended-scode-eval scode (syntax-table/environment *syntax-table*)))
-\f
-;;;; FLUID-LET
-
-(define (syntax/fluid-let top-level? bindings . body)
- (if (null? bindings)
- (syntax-sequence top-level? body)
- (syntax-fluid-bindings/shallow bindings
- (lambda (names values transfers-in transfers-out)
- (make-closed-block lambda-tag:fluid-let names values
- (make-combination*
- (make-absolute-reference 'SHALLOW-FLUID-BIND)
- (make-thunk (make-scode-sequence transfers-in))
- (make-thunk (syntax-subsequence body))
- (make-thunk (make-scode-sequence transfers-out))))))))
-
-(define (syntax-fluid-bindings/shallow bindings receiver)
- (if (pair? bindings)
- (syntax-fluid-bindings/shallow (cdr bindings)
- (lambda (names values transfers-in transfers-out)
- (let ((binding (car bindings)))
- (if (pair? binding)
- (let ((transfer
- (let ((reference (syntax-subexpression (car binding))))
- (let ((assignment (invert-expression reference)))
- (lambda (target source)
- (make-assignment
- target
- (assignment (make-assignment source)))))))
- (value (expand-binding-value (cdr binding)))
- (inside-name
- (string->uninterned-symbol "INSIDE-PLACEHOLDER"))
- (outside-name
- (string->uninterned-symbol "OUTSIDE-PLACEHOLDER")))
- (receiver (cons* inside-name outside-name names)
- (cons* value (make-unassigned-reference-trap)
- values)
- (cons (transfer outside-name inside-name)
- transfers-in)
- (cons (transfer inside-name outside-name)
- transfers-out)))
- (syntax-error "binding not a pair" binding)))))
- (receiver '() '() '() '())))
-
-;;;; Extended Assignment Syntax
-
-(define (invert-expression target)
- (cond ((variable? target)
- (invert-variable (variable-name target)))
- ((access? target)
- (access-components target invert-access))
- (else
- (syntax-error "bad target" target))))
-
-(define ((invert-variable name) value)
- (make-assignment name value))
-
-(define ((invert-access environment name) value)
- (make-combination* lexical-assignment environment name value))
-\f
-;;;; Declarations
-
-;;; All declarations are syntactically checked; the resulting
-;;; DECLARATION objects all contain lists of standard declarations.
-;;; Each standard declaration is a proper list with symbolic keyword.
-
-(define (syntax/declare top-level? . declarations)
- top-level?
- (make-block-declaration (map process-declaration declarations)))
-
-(define (syntax/local-declare top-level? declarations . body)
- (make-declaration (process-declarations declarations)
- (syntax-sequence top-level? body)))
-
-;;; These two procedures use `error' instead of `syntax-error' because
-;;; they are also called when the syntaxer is not running.
-
-(define (process-declarations declarations)
- (if (list? declarations)
- (map process-declaration declarations)
- (error "SYNTAX: Illegal declaration list" declarations)))
-
-(define (process-declaration declaration)
- (cond ((symbol? declaration)
- (list declaration))
- ((and (list? declaration)
- (not (null? declaration))
- (symbol? (car declaration)))
- declaration)
- (else
- (error "SYNTAX: Illegal declaration" declaration))))
-\f
-;;;; SCODE Constructors
-
-(define (make-conjunction first second)
- (make-conditional first second #f))
-
-(define (make-combination* operator . operands)
- (make-combination operator operands))
-
-(define (make-scode-sequence* . operands)
- (make-scode-sequence operands))
-
-(define (make-absolute-reference name . rest)
- (let loop ((reference (make-access #f name)) (rest rest))
- (if (null? rest)
- reference
- (loop (make-access reference (car rest)) (cdr rest)))))
-
-(define (make-thunk body)
- (make-simple-lambda '() body))
-
-(define (make-simple-lambda pattern body)
- (make-named-lambda lambda-tag:unnamed pattern body))
-
-(define (make-named-lambda name pattern body)
- (if (not (symbol? name))
- (syntax-error "name of lambda expression must be a symbol" name))
- (parse-lambda-list pattern
- (lambda (required optional rest)
- (internal-make-lambda name required optional rest body))))
-
-(define (make-closed-block tag names values body)
- (make-combination (internal-make-lambda tag names '() #f body) values))
-
-(define (make-letrec names values body)
- (make-closed-block lambda-tag:let '() '()
- (make-scode-sequence
- (append! (map make-definition names values)
- (list body)))))
-
-(define-integrable lambda-tag:unnamed
- ((ucode-primitive string->symbol) "#[unnamed-procedure]"))
-
-(define-integrable lambda-tag:let
- ((ucode-primitive string->symbol) "#[let-procedure]"))
-
-(define-integrable lambda-tag:fluid-let
- ((ucode-primitive string->symbol) "#[fluid-let-procedure]"))
-\f
-;;;; Lambda List Parser
-
-(define (parse-lambda-list lambda-list receiver)
- (let ((required (list '()))
- (optional (list '())))
- (define (parse-parameters cell pattern)
- (let loop ((pattern pattern))
- (cond ((null? pattern) (finish #f))
- ((symbol? pattern) (finish pattern))
- ((not (pair? pattern)) (bad-lambda-list pattern))
- ((eq? (car pattern) lambda-rest-tag)
- (if (and (pair? (cdr pattern)) (null? (cddr pattern)))
- (cond ((symbol? (cadr pattern)) (finish (cadr pattern)))
- ((and (pair? (cadr pattern))
- (symbol? (caadr pattern)))
- (finish (caadr pattern)))
- (else (bad-lambda-list (cdr pattern))))
- (bad-lambda-list (cdr pattern))))
- ((eq? (car pattern) lambda-optional-tag)
- (if (eq? cell required)
- (parse-parameters optional (cdr pattern))
- (bad-lambda-list pattern)))
- ((symbol? (car pattern))
- (set-car! cell (cons (car pattern) (car cell)))
- (loop (cdr pattern)))
- ((and (pair? (car pattern)) (symbol? (caar pattern)))
- (set-car! cell (cons (caar pattern) (car cell)))
- (loop (cdr pattern)))
- (else (bad-lambda-list pattern)))))
-
- (define (finish rest)
- (let ((required (reverse! (car required)))
- (optional (reverse! (car optional))))
- (do ((parameters
- (append required optional (if rest (list rest) '()))
- (cdr parameters)))
- ((null? parameters))
- (if (memq (car parameters) (cdr parameters))
- (syntax-error "lambda list has duplicate parameter:"
- (car parameters)
- (error-irritant/noise " in")
- lambda-list)))
- (receiver required optional rest)))
-
- (define (bad-lambda-list pattern)
- (syntax-error "illegally-formed lambda list" pattern))
-
- (parse-parameters required lambda-list)))
-
-;;;; Scan Defines
-
-(define (make-sequence/scan actions)
- (scan-defines (make-sequence actions)
- make-open-block))
-
-(define (make-lambda/no-scan name required optional rest body)
- (make-lambda name required optional rest '() '() body))
-
-(define (make-lambda/scan name required optional rest body)
- (make-lambda* name required optional rest body))
-
-(define make-scode-sequence)
-(define internal-make-lambda)
-
-(define (enable-scan-defines!)
- (set! make-scode-sequence make-sequence/scan)
- (set! internal-make-lambda make-lambda/scan)
- unspecific)
-
-(define (disable-scan-defines!)
- (set! make-scode-sequence make-sequence)
- (set! internal-make-lambda make-lambda/no-scan)
- unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: sysmac.scm,v 14.7 2001/12/23 17:20:59 cph Exp $
+$Id: sysmac.scm,v 14.8 2002/02/03 03:38:57 cph Exp $
-Copyright (c) 1988, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988, 1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(declare (usual-integrations))
(define-syntax define-primitives
- (non-hygienic-macro-transformer
- (let ((primitive-definition
- (lambda (variable-name primitive-args)
- `(DEFINE-INTEGRABLE ,variable-name
- ,(apply make-primitive-procedure primitive-args)))))
- (lambda names
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((primitive-definition
+ (lambda (variable-name primitive-args)
+ `(DEFINE-INTEGRABLE ,(close-syntax variable-name environment)
+ ,(apply make-primitive-procedure primitive-args)))))
`(BEGIN ,@(map (lambda (name)
(cond ((not (pair? name))
(primitive-definition name (list name)))
(primitive-definition (car name) name))
(else
(primitive-definition (car name) (cdr name)))))
- names))))))
+ (cdr form)))))))
(define-syntax ucode-type
- (non-hygienic-macro-transformer
- (lambda arguments
- (apply microcode-type arguments))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form)))))
(define-syntax ucode-primitive
- (non-hygienic-macro-transformer
- (lambda arguments
- (apply make-primitive-procedure arguments))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply make-primitive-procedure (cdr form)))))
(define-syntax ucode-return-address
- (non-hygienic-macro-transformer
- (lambda arguments
- (make-return-address (apply microcode-return arguments)))))
\ No newline at end of file
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (make-return-address (apply microcode-return (cdr form))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: unsyn.scm,v 14.27 2001/12/24 04:17:53 cph Exp $
+$Id: unsyn.scm,v 14.28 2002/02/03 03:38:57 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(define (unexpand-definition name value)
(cond ((macro-reference-trap-expression? value)
`(DEFINE-SYNTAX ,name
- ,(macro-reference-trap-expression-transformer value)))
+ ,(unsyntax-object
+ (macro-reference-trap-expression-transformer value))))
((and (eq? #t unsyntaxer:macroize?)
(lambda? value)
(not (has-substitution? value)))
#| -*-Scheme-*-
-$Id: vector.scm,v 14.19 2001/12/23 17:20:59 cph Exp $
+$Id: vector.scm,v 14.20 2002/02/03 03:38:57 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(let-syntax
((iref
- (non-hygienic-macro-transformer
- (lambda (name index)
- `(DEFINE-INTEGRABLE (,name VECTOR)
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(DEFINE-INTEGRABLE (,(close-syntax (cadr form) environment) VECTOR)
(GUARANTEE-VECTOR VECTOR 'SAFE-VECTOR-REF)
- (VECTOR-REF VECTOR ,index))))))
+ (VECTOR-REF VECTOR ,(caddr form)))))))
(iref vector-first 0)
(iref vector-second 1)
(iref vector-third 2)
#| -*-Scheme-*-
-$Id: version.scm,v 14.205 2002/01/28 20:24:00 cph Exp $
+$Id: version.scm,v 14.206 2002/02/03 03:38:57 cph Exp $
Copyright (c) 1988-2002 Massachusetts Institute of Technology
(add-subsystem-identification! "Release" '(7 7 0 "pre"))
(snarf-microcode-version!)
(add-event-receiver! event:after-restore snarf-microcode-version!)
- (add-subsystem-identification! "Runtime" '(14 193)))
+ (add-subsystem-identification! "Runtime" '(15 0)))
(define (snarf-microcode-version!)
(add-subsystem-identification! "Microcode"
#| -*-Scheme-*-
-$Id: make.scm,v 4.40 2001/12/17 17:40:59 cph Exp $
+$Id: make.scm,v 4.41 2002/02/03 03:38:58 cph Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(load-package-set "sf")))
((package/reference (find-package '(SCODE-OPTIMIZER))
'USUAL-INTEGRATIONS/CACHE!))))
-(add-subsystem-identification! "SF" '(4 39))
\ No newline at end of file
+(add-subsystem-identification! "SF" '(4 40))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: object.scm,v 4.12 2001/12/23 17:20:59 cph Exp $
+$Id: object.scm,v 4.13 2002/02/03 03:38:58 cph Exp $
-Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(let-syntax
((define-enumeration
- (non-hygienic-macro-transformer
- (lambda (enumeration-name enumerand-names)
- `(BEGIN
- (DEFINE ,enumeration-name
- (ENUMERATION/MAKE ',enumerand-names))
- ,@(map (lambda (enumerand-name)
- `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND)
- (ENUMERATION/NAME->ENUMERAND ,enumeration-name
- ',enumerand-name)))
- enumerand-names))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((enumeration-name (close-syntax (cadr form) environment))
+ (enumerand-names (caddr form)))
+ `(BEGIN
+ (DEFINE ,enumeration-name
+ (ENUMERATION/MAKE ',enumerand-names))
+ ,@(map (lambda (enumerand-name)
+ `(DEFINE ,(close-syntax
+ (symbol-append enumerand-name '/ENUMERAND)
+ environment)
+ (ENUMERATION/NAME->ENUMERAND ,enumeration-name
+ ',enumerand-name)))
+ enumerand-names)))))))
(define-enumeration enumeration/random
(block
delayed-integration
(let-syntax
((define-simple-type
- (non-hygienic-macro-transformer
- (lambda (name slots #!optional scode?)
- `(DEFINE-STRUCTURE (,name (TYPE VECTOR)
- (NAMED ,(symbol-append name '/ENUMERAND))
- (CONC-NAME ,(symbol-append name '/))
- (CONSTRUCTOR ,(symbol-append name '/MAKE)))
- ,@(if (or (default-object? scode?) scode?)
- `((scode #f read-only #t))
- `())
- ,@slots)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (slots (caddr form))
+ (scode? (if (pair? (cdddr form)) (cadddr form) #t)))
+ `(DEFINE-STRUCTURE
+ (,name
+ (TYPE VECTOR)
+ (NAMED
+ ,(close-syntax (symbol-append name '/ENUMERAND) environment))
+ (CONC-NAME ,(symbol-append name '/))
+ (CONSTRUCTOR
+ ,(close-syntax (symbol-append name '/MAKE) environment)))
+ ,@(if scode?
+ `((scode #f read-only #t))
+ `())
+ ,@slots))))))
(define-simple-type variable (block name flags) #F)
(define-simple-type access (environment name))
(define-simple-type assignment (block variable value))
(let-syntax
((define-flag
- (non-hygienic-macro-transformer
- (lambda (name tester setter)
- `(BEGIN
- (DEFINE (,tester VARIABLE)
- (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
- (DEFINE (,setter VARIABLE)
- (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
- (SET-VARIABLE/FLAGS! VARIABLE
- (CONS ',name
- (VARIABLE/FLAGS VARIABLE))))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (tester (close-syntax (caddr form) environment))
+ (setter (close-syntax (cadddr form) environment)))
+ `(BEGIN
+ (DEFINE (,tester VARIABLE)
+ (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
+ (DEFINE (,setter VARIABLE)
+ (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
+ (SET-VARIABLE/FLAGS!
+ VARIABLE
+ (CONS ',name (VARIABLE/FLAGS VARIABLE)))))))))))
(define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!)
(define-flag REFERENCED variable/referenced variable/reference!)
(define-flag INTEGRATED variable/integrated variable/integrated!)
#| -*-Scheme-*-
-$Id: sf.pkg,v 4.16 2002/01/09 05:11:38 cph Exp $
+$Id: sf.pkg,v 4.17 2002/02/03 03:38:58 cph Exp $
Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology
(parent (scode-optimizer))
(export ()
sf
- sf/add-file-declarations!
sf/default-declarations
sf/default-syntax-table
sf/pathname-defaulting
integrate/file
integrate/sexp
integrate/scode
- read-externs-file)
- (import (runtime syntaxer)
- process-declarations))
+ read-externs-file))
(define-package (scode-optimizer transform)
(files "xform")
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.22 2002/01/09 05:11:21 cph Exp $
+$Id: toplev.scm,v 4.23 2002/02/03 03:38:58 cph Exp $
Copyright (c) 1988-2002 Massachusetts Institute of Technology
(define bin-pathname-type "bin")
-(define (integrate/procedure procedure declarations)
+(define (integrate/procedure procedure)
(procedure-components procedure
(lambda (*lambda environment)
- (scode-eval (integrate/scode *lambda declarations false) environment))))
+ (scode-eval (integrate/scode *lambda false) environment))))
(define (integrate/sexp s-expression environment declarations receiver)
(integrate/simple (lambda (s-expressions)
- (phase:syntax s-expressions environment))
- (list s-expression) declarations receiver))
+ (phase:syntax s-expressions environment declarations))
+ (list s-expression)
+ receiver))
-(define (integrate/scode scode declarations receiver)
- (integrate/simple identity-procedure scode declarations receiver))
+(define (integrate/scode scode receiver)
+ (integrate/simple identity-procedure scode receiver))
(define (sf input-string #!optional bin-string spec-string)
(syntax-file input-string
(if (not (list-of-symbols? del-list))
(error "sf/set-usual-integrations-default-deletions!: Bad deletion list"
del-list))
- (set! sf/usual-integrations-default-deletions del-list))
-
-(define (sf/add-file-declarations! pathname declarations)
- (let ((pathname (pathname/normalize pathname)))
- (pathname-map/insert! file-info/declarations
- pathname
- (append! (file-info/get-declarations pathname)
- (list-copy declarations)))))
-
-(define (sf/file-declarations pathname)
- (file-info/get-declarations (pathname/normalize pathname)))
-
-(define (file-info/get-declarations pathname)
- (pathname-map/lookup file-info/declarations
- pathname
- identity-procedure
- (lambda () sf/default-declarations)))
+ (set! sf/usual-integrations-default-deletions del-list)
+ unspecific)
(define (pathname/normalize pathname)
(pathname-default-type (merge-pathnames pathname) "scm"))
-(define file-info/declarations
- (pathname-map/make))
-
(define sf/default-syntax-table
system-global-environment)
(lambda (input-pathname bin-pathname spec-pathname)
(sf/internal input-pathname bin-pathname spec-pathname
sf/default-syntax-table
- (sf/file-declarations input-pathname)))))
+ sf/default-declarations))))
(if (pair? input-string)
input-string
(list input-string))))
;;;; Optimizer Top Level
(define (integrate/file file-name environment declarations)
- (integrate/kernel (lambda ()
- (phase:syntax (phase:read file-name) environment))
- declarations))
+ (integrate/kernel
+ (lambda ()
+ (phase:syntax (phase:read file-name)
+ environment
+ declarations))))
-(define (integrate/simple preprocessor input declarations receiver)
+(define (integrate/simple preprocessor input receiver)
(call-with-values
(lambda ()
- (integrate/kernel (lambda () (preprocessor input)) declarations))
+ (integrate/kernel (lambda () (preprocessor input))))
(or receiver
(lambda (expression externs-block externs)
externs-block externs ;ignored
expression))))
-(define (integrate/kernel get-scode declarations)
+(define (integrate/kernel get-scode)
(fluid-let ((previous-name false)
(previous-process-time false)
(previous-real-time false))
(lambda ()
(call-with-values
(lambda ()
- (call-with-values
- (lambda ()
- (phase:transform (canonicalize-scode (get-scode)
- declarations)))
+ (call-with-values (lambda () (phase:transform (get-scode)))
phase:optimize))
phase:generate-scode))
(lambda (expression externs-block externs)
(end-phase)
(values expression externs-block externs)))))
-
-(define (canonicalize-scode scode declarations)
- (let ((declarations (process-declarations declarations)))
- (if (null? declarations)
- scode
- (scan-defines (make-sequence
- (list (make-block-declaration declarations)
- scode))
- make-open-block))))
\f
(define (phase:read filename)
(mark-phase "Read")
(read-file filename))
-(define (phase:syntax s-expression environment)
+(define (phase:syntax s-expressions environment declarations)
(mark-phase "Syntax")
- (syntax* s-expression environment))
+ (syntax* (if (null? declarations)
+ s-expressions
+ (cons (cons (make-syntactic-closure system-global-environment
+ '()
+ 'DECLARE)
+ declarations)
+ s-expressions))
+ environment))
(define (phase:transform scode)
(mark-phase "Transform")
;;; -*-Scheme-*-
;;;
-;;; $Id: class.scm,v 1.11 2001/12/23 17:20:59 cph Exp $
+;;; $Id: class.scm,v 1.12 2002/02/03 03:38:58 cph Exp $
;;;
-;;; Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1995-1999, 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(let-syntax
((define-primitive-class
- (non-hygienic-macro-transformer
- (lambda (name . superclasses)
- `(DEFINE ,name (MAKE-CLASS ',name (LIST ,@superclasses) '()))))))
+ (syntax-rules ()
+ ((define-primitive-class name superclass ...)
+ (define name
+ (make-class 'name (list superclass ...) '()))))))
(define-primitive-class <boolean> <object>)
(define-primitive-class <char> <object>)
;;; -*-Scheme-*-
;;;
-;;; $Id: instance.scm,v 1.13 2001/12/23 17:20:59 cph Exp $
+;;; $Id: instance.scm,v 1.14 2002/02/03 03:38:58 cph Exp $
;;;
-;;; Copyright (c) 1995-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1995-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; requires them to appear before their first reference.
(define-syntax constructor-case
- (non-hygienic-macro-transformer
- (lambda (n low high generator . generator-args)
- ;; Assumes that (< LOW HIGH).
- (let loop ((low low) (high high))
- (let ((mid (quotient (+ high low) 2)))
- (if (= mid low)
- `(,generator ,@generator-args ,low)
- `(IF (< ,n ,mid)
- ,(loop low mid)
- ,(loop mid high))))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (let ((n (cadr form))
+ (low (caddr form))
+ (high (cadddr form))
+ (generator (cddddr form))
+ (r-if (close-syntax 'IF environment))
+ (r-< (close-syntax '< environment)))
+ ;; Assumes that (< LOW HIGH).
+ (let loop ((low low) (high high))
+ (let ((mid (quotient (+ high low) 2)))
+ (if (= mid low)
+ `(,@generator ,low)
+ `(,r-if (,r-< ,n ,mid)
+ ,(loop low mid)
+ ,(loop mid high)))))))))
(define-syntax instance-constructor-1
- (non-hygienic-macro-transformer
- (lambda (n-slots)
- `(IF N-INIT-ARGS
- (IF (< N-INIT-ARGS 4)
- (CONSTRUCTOR-CASE N-INIT-ARGS 0 4 INSTANCE-CONSTRUCTOR-2
- ,n-slots)
- (INSTANCE-CONSTRUCTOR-2 ,n-slots #F))
- (INSTANCE-CONSTRUCTOR-2 ,n-slots NO-INITIALIZE-INSTANCE)))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (let ((n-slots (cadr form))
+ (r-if (close-syntax 'IF environment))
+ (r-< (close-syntax '< environment))
+ (r-cc (close-syntax 'CONSTRUCTOR-CASE environment))
+ (r-ic2 (close-syntax 'INSTANCE-CONSTRUCTOR-2 environment)))
+ `(,r-if N-INIT-ARGS
+ (,r-if (,r-< N-INIT-ARGS 4)
+ (,r-cc N-INIT-ARGS 0 4 ,r-ic2 ,n-slots)
+ (,r-ic2 ,n-slots #F))
+ (,r-ic2 ,n-slots NO-INITIALIZE-INSTANCE))))))
\f
(define-syntax instance-constructor-2
- (non-hygienic-macro-transformer
- (lambda (n-slots n-init-args)
- (let ((make-names
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((n-slots (cadr form))
+ (n-init-args (caddr form))
+ (make-names
(lambda (n prefix)
(make-initialized-list n
(lambda (index)
(lambda ()
(cond ((eq? 'NO-INITIALIZE-INSTANCE n-init-args)
(values '() '()))
- (n-init-args
- (let ((ivs (make-names n-init-args "iv")))
- (values ivs `((INITIALIZE-INSTANCE INSTANCE ,@ivs)))))
+ ((not n-init-args)
+ (values 'IVS `((APPLY INITIALIZE-INSTANCE INSTANCE IVS))))
(else
- (values 'IVS
- `((APPLY INITIALIZE-INSTANCE INSTANCE IVS))))))
+ (let ((ivs (make-names n-init-args "iv")))
+ (values ivs `((INITIALIZE-INSTANCE INSTANCE ,@ivs)))))))
(lambda (ivs ixs)
(let ((generator
- (lambda (initialization)
- (let ((sis (make-names n-slots "si"))
- (svs (make-names n-slots "sv")))
- (let ((l
- `(LAMBDA (,@svs . ,ivs)
- (LET ((INSTANCE
- (OBJECT-NEW-TYPE
- (UCODE-TYPE RECORD)
- (MAKE-VECTOR
- INSTANCE-LENGTH
- RECORD-SLOT-UNINITIALIZED))))
- (%RECORD-SET! INSTANCE 0 INSTANCE-TAG)
- ,@(map (lambda (index value)
- `(%RECORD-SET! INSTANCE
- ,index
- ,value))
- sis
- svs)
- ,@initialization
- ,@ixs
- INSTANCE))))
- (if (null? sis)
- l
- `(LET (,@(make-initialized-list n-slots
- (lambda (i)
- `(,(list-ref sis i)
- (LIST-REF INDEXES ,i)))))
- ,l)))))))
- `(IF INITIALIZATION
- ,(generator '((INITIALIZATION INSTANCE)))
+ (let ((instance-length
+ (close-syntax 'INSTANCE-LENGTH environment)))
+ (lambda (initialization)
+ (let ((sis (make-names n-slots "si"))
+ (svs (make-names n-slots "sv")))
+ (let ((l
+ `(LAMBDA (,@svs . ,ivs)
+ (LET ((INSTANCE
+ (OBJECT-NEW-TYPE
+ (UCODE-TYPE RECORD)
+ (MAKE-VECTOR
+ ,instance-length
+ RECORD-SLOT-UNINITIALIZED))))
+ (%RECORD-SET! INSTANCE 0
+ ,(close-syntax 'INSTANCE-TAG
+ environment))
+ ,@(map (lambda (index value)
+ `(%RECORD-SET! INSTANCE
+ ,index
+ ,value))
+ sis
+ svs)
+ ,@initialization
+ ,@ixs
+ INSTANCE))))
+ (if (null? sis)
+ l
+ `(LET (,@(make-initialized-list n-slots
+ (let ((indexes
+ (close-syntax 'INDEXES
+ environment)))
+ (lambda (i)
+ `(,(list-ref sis i)
+ (LIST-REF ,indexes ,i))))))
+ ,l)))))))
+ (initialization (close-syntax 'INITIALIZATION environment)))
+ `(IF ,initialization
+ ,(generator `((,initialization INSTANCE)))
,(generator '())))))))))
-
-(define-syntax ucode-type
- (non-hygienic-macro-transformer
- (lambda arguments
- (apply microcode-type arguments))))
\f
(define-syntax instance-constructor-3
- (non-hygienic-macro-transformer
- (lambda (test arity initialization ixs)
- `(LETREC
- ((PROCEDURE
- (LAMBDA ARGS
- (IF (NOT (,@test (LENGTH ARGS)))
- (ERROR:WRONG-NUMBER-OF-ARGUMENTS PROCEDURE ,arity ARGS))
- (LET ((INSTANCE
- (OBJECT-NEW-TYPE
- (UCODE-TYPE RECORD)
- (MAKE-VECTOR INSTANCE-LENGTH
- RECORD-SLOT-UNINITIALIZED))))
- (%RECORD-SET! INSTANCE 0 INSTANCE-TAG)
- (DO ((INDEXES INDEXES (CDR INDEXES))
- (ARGS ARGS (CDR ARGS)))
- ((NULL? INDEXES)
- ,@initialization
- ,@ixs)
- (%RECORD-SET! INSTANCE (CAR INDEXES) (CAR ARGS)))
- INSTANCE))))
- PROCEDURE))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((test
+ (map (lambda (form) (close-syntax form environment))
+ (cadr form)))
+ (arity (close-syntax (caddr form) environment))
+ (initialization
+ (map (lambda (form)
+ (make-syntactic-closure environment '(INSTANCE) form))
+ (cadddr form)))
+ (ixs
+ (map (lambda (form)
+ (make-syntactic-closure environment '(INSTANCE ARGS) form))
+ (car (cddddr form))))
+ (instance-length (close-syntax 'INSTANCE-LENGTH environment))
+ (instance-tag (close-syntax 'INSTANCE-TAG environment))
+ (indexes (close-syntax 'INDEXES environment)))
+ `(LETREC
+ ((PROCEDURE
+ (LAMBDA ARGS
+ (IF (NOT (,@test (LENGTH ARGS)))
+ (ERROR:WRONG-NUMBER-OF-ARGUMENTS PROCEDURE ,arity ARGS))
+ (LET ((INSTANCE
+ (OBJECT-NEW-TYPE
+ (UCODE-TYPE RECORD)
+ (MAKE-VECTOR ,instance-length
+ RECORD-SLOT-UNINITIALIZED))))
+ (%RECORD-SET! INSTANCE 0 ,instance-tag)
+ (DO ((INDEXES ,indexes (CDR INDEXES))
+ (ARGS ARGS (CDR ARGS)))
+ ((NOT (PAIR? INDEXES))
+ ,@initialization
+ ,@ixs)
+ (%RECORD-SET! INSTANCE (CAR INDEXES) (CAR ARGS)))
+ INSTANCE))))
+ PROCEDURE)))))
+(define-syntax ucode-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (map strip-syntactic-closures (cdr form))))))
+\f
(define (instance-constructor class slot-names #!optional init-arg-names)
(if (not (subclass? class <instance>))
(error:bad-range-argument class 'INSTANCE-CONSTRUCTOR))
(cond ((eq? #t n-init-args)
(if initialization
(instance-constructor-3
- (fix:<= n-slots) (cons n-slots #f)
+ (fix:<= n-slots)
+ (cons n-slots #f)
((initialization instance))
((apply initialize-instance instance args)))
(instance-constructor-3
- (fix:<= n-slots) (cons n-slots #f)
+ (fix:<= n-slots)
+ (cons n-slots #f)
()
((apply initialize-instance instance args)))))
((< n-slots 8)
(let ((n-args (+ n-slots n-init-args)))
(if initialization
(instance-constructor-3
- (fix:= n-args) n-args
+ (fix:= n-args)
+ n-args
((initialization instance))
((apply initialize-instance instance args)))
(instance-constructor-3
- (fix:= n-args) n-args
+ (fix:= n-args)
+ n-args
()
((apply initialize-instance instance args))))))
(initialization
- (instance-constructor-3 (fix:= n-slots) n-slots
+ (instance-constructor-3 (fix:= n-slots)
+ n-slots
((initialization instance))
()))
(else
- (instance-constructor-3 (fix:= n-slots) n-slots () ()))))))
+ (instance-constructor-3 (fix:= n-slots)
+ n-slots
+ ()
+ ()))))))
\f
(define-syntax make-initialization-1
- (non-hygienic-macro-transformer
- (lambda (if-n)
- `(IF (< IV-N 8)
- (CONSTRUCTOR-CASE IV-N 0 8 MAKE-INITIALIZATION-2 ,if-n)
- (MAKE-INITIALIZATION-2 ,if-n #F)))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (let ((if-n (cadr form))
+ (r-if (close-syntax 'IF environment))
+ (r-< (close-syntax '< environment))
+ (r-cc (close-syntax 'CONSTRUCTOR-CASE environment))
+ (r-mi2 (close-syntax 'MAKE-INITIALIZATION-2 environment)))
+ `(,r-if (,r-< IV-N 8)
+ (,r-cc IV-N 0 8 ,r-mi2 ,if-n)
+ (,r-mi2 ,if-n #F))))))
(define-syntax make-initialization-2
- (non-hygienic-macro-transformer
- (lambda (if-n iv-n)
- (if (and if-n iv-n)
- (let ((generate
- (let ((make-names
- (lambda (n prefix)
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((if-n (close-syntax (cadr form) environment))
+ (iv-n (close-syntax (caddr form) environment))
+ (if-indexes (close-syntax 'IF-INDEXES environment))
+ (initializers (close-syntax 'INITIALIZERS environment))
+ (iv-indexes (close-syntax 'IV-INDEXES environment))
+ (initial-values (close-syntax 'INITIAL-VALUES environment)))
+ (if (and if-n iv-n)
+ (let ((generate
+ (let ((make-names
+ (lambda (n prefix)
+ (make-initialized-list n
+ (lambda (index)
+ (intern
+ (string-append prefix
+ (number->string index))))))))
+ (lambda (n prefix isn vsn fv)
+ (let ((is (make-names n (string-append prefix "i")))
+ (vs (make-names n (string-append prefix "v"))))
+ (values
+ (append (make-initialized-list n
+ (lambda (i)
+ `(,(list-ref is i) (LIST-REF ,isn ,i))))
+ (make-initialized-list n
+ (lambda (i)
+ `(,(list-ref vs i) (LIST-REF ,vsn ,i)))))
(make-initialized-list n
- (lambda (index)
- (intern
- (string-append prefix
- (number->string index))))))))
- (lambda (n prefix isn vsn fv)
- (let ((is (make-names n (string-append prefix "i")))
- (vs (make-names n (string-append prefix "v"))))
- (values
- (append (make-initialized-list n
- (lambda (i)
- `(,(list-ref is i) (LIST-REF ,isn ,i))))
- (make-initialized-list n
- (lambda (i)
- `(,(list-ref vs i) (LIST-REF ,vsn ,i)))))
- (make-initialized-list n
- (lambda (i)
- `(%RECORD-SET! INSTANCE
- ,(list-ref is i)
- ,(fv (list-ref vs i)))))))))))
+ (lambda (i)
+ `(%RECORD-SET! INSTANCE
+ ,(list-ref is i)
+ ,(fv (list-ref vs i)))))))))))
- (call-with-values
- (lambda ()
- (generate if-n "f" 'IF-INDEXES 'INITIALIZERS
- (lambda (expr) `(,expr))))
- (lambda (if-bindings if-body)
- (call-with-values
- (lambda ()
- (generate iv-n "v" 'IV-INDEXES 'INITIAL-VALUES
- (lambda (expr) expr)))
- (lambda (iv-bindings iv-body)
- (if (and (null? if-bindings) (null? iv-bindings))
- '#F
- `(LET (,@if-bindings ,@iv-bindings)
- (LAMBDA (INSTANCE)
- ,@if-body
- ,@iv-body))))))))
- `(LAMBDA (INSTANCE)
- (DO ((IS IF-INDEXES (CDR IS))
- (VS INITIALIZERS (CDR VS)))
- ((NULL? IS) UNSPECIFIC)
- (%RECORD-SET! INSTANCE (CAR IS) ((CAR VS))))
- (DO ((IS IV-INDEXES (CDR IS))
- (VS INITIAL-VALUES (CDR VS)))
- ((NULL? IS) UNSPECIFIC)
- (%RECORD-SET! INSTANCE (CAR IS) (CAR VS))))))))
+ (call-with-values
+ (lambda ()
+ (generate if-n "f" if-indexes initializers
+ (lambda (expr) `(,expr))))
+ (lambda (if-bindings if-body)
+ (call-with-values
+ (lambda ()
+ (generate iv-n "v" iv-indexes initial-values
+ (lambda (expr) expr)))
+ (lambda (iv-bindings iv-body)
+ (if (and (null? if-bindings) (null? iv-bindings))
+ '#F
+ `(LET (,@if-bindings ,@iv-bindings)
+ (LAMBDA (INSTANCE)
+ ,@if-body
+ ,@iv-body))))))))
+ `(LAMBDA (INSTANCE)
+ (DO ((IS ,if-indexes (CDR IS))
+ (VS ,initializers (CDR VS)))
+ ((NULL? IS) UNSPECIFIC)
+ (%RECORD-SET! INSTANCE (CAR IS) ((CAR VS))))
+ (DO ((IS ,iv-indexes (CDR IS))
+ (VS ,initial-values (CDR VS)))
+ ((NULL? IS) UNSPECIFIC)
+ (%RECORD-SET! INSTANCE (CAR IS) (CAR VS)))))))))
\f
(define (make-initialization class arg-slots)
(let ((if-slots
;;; -*-Scheme-*-
;;;
-;;; $Id: macros.scm,v 1.12 2001/12/23 17:21:00 cph Exp $
+;;; $Id: macros.scm,v 1.13 2002/02/03 03:38:58 cph Exp $
;;;
-;;; Copyright (c) 1993-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1993-2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(declare (usual-integrations))
\f
(define-syntax define-class
- (non-hygienic-macro-transformer
- (lambda (name superclasses . slot-arguments)
- (let ((lose
- (lambda (s a)
- (error (string-append "Malformed " s ":") a))))
- (call-with-values (lambda () (parse-define-class-name name lose))
- (lambda (name post-definitions separator)
- (if (not (list? superclasses))
- (lose "superclasses" superclasses))
- (let ((pre-definitions
- (extract-generic-definitions! slot-arguments name separator
- lose)))
- `(BEGIN
- ,@pre-definitions
- (DEFINE ,name
- (,(make-absolute-reference 'MAKE-CLASS)
- ',name
- (,(make-absolute-reference 'LIST) ,@superclasses)
- (,(make-absolute-reference 'LIST)
- ,@(map
- (lambda (arg)
- (cond ((symbol? arg)
- `',arg)
- ((and (pair? arg)
- (symbol? (car arg))
- (list? (cdr arg)))
- `(,(make-absolute-reference 'LIST)
- ',(car arg)
- ,@(let loop ((plist (cdr arg)))
- (cond ((null? plist)
- '())
- ((and (symbol? (car plist))
- (pair? (cdr plist)))
- (cons* `',(car plist)
- (cadr plist)
- (loop (cddr plist))))
- (else
- (lose "slot argument" arg))))))
- (else
- (lose "slot argument" arg))))
- slot-arguments))))
- ,@post-definitions))))))))
+ (rsc-macro-transformer
+ (let ((lose
+ (lambda (s a)
+ (error (string-append "Malformed " s ":") a))))
+ (lambda (form environment)
+ (if (syntax-match? '(DATUM (* EXPRESSION) * DATUM) (cdr form))
+ (let ((name (cadr form))
+ (superclasses (caddr form))
+ (slot-arguments
+ (map (lambda (arg) (canonicalize-slot-argument arg lose))
+ (cdddr form))))
+ (call-with-values
+ (lambda ()
+ (parse-define-class-name name environment lose))
+ (lambda (name post-definitions separator)
+ (let ((pre-definitions
+ (extract-generic-definitions!
+ slot-arguments name separator environment lose)))
+ `(,(close-syntax 'BEGIN environment)
+ ,@pre-definitions
+ (,(close-syntax 'DEFINE environment)
+ ,name
+ (,(absolute 'MAKE-CLASS environment)
+ ',name
+ (,(absolute 'LIST environment) ,@superclasses)
+ (,(absolute 'LIST environment)
+ ,@(map (lambda (arg)
+ (if (null? (cdr arg))
+ `',arg
+ `(,(absolute 'LIST environment)
+ ',(car arg)
+ ,@(let loop ((plist (cdr arg)))
+ (if (pair? plist)
+ (cons* `',(car plist)
+ (cadr plist)
+ (loop (cddr plist)))
+ '())))))
+ slot-arguments))))
+ ,@post-definitions)))))
+ (ill-formed-syntax form))))))
+
+(define (canonicalize-slot-argument arg lose)
+ (cond ((symbol? arg)
+ (list arg))
+ ((and (pair? arg)
+ (symbol? (car arg))
+ (list? (cdr arg)))
+ (let loop ((plist (cdr arg)))
+ (if (pair? plist)
+ (begin
+ (if (not (and (symbol? (car plist))
+ (pair? (cdr plist))))
+ (lose "slot argument" arg))
+ (loop (cddr plist)))))
+ (list-copy arg))
+ (else
+ (lose "slot argument" arg))))
\f
-(define (parse-define-class-name name lose)
+(define (parse-define-class-name name environment lose)
(call-with-values (lambda () (parse-define-class-name-1 name lose))
(lambda (class-name alist)
(let ((post-definitions '())
(separator #f))
- (let ((alist
- (if (assq 'PREDICATE alist)
- alist
- (cons '(PREDICATE) alist)))
- (post-def
+ (let ((post-def
(lambda (def)
(set! post-definitions (cons def post-definitions))
unspecific)))
(false? (cadr option)))
(null? (cddr option)))
(cadr option))
- (else (lose "class option" option)))))
+ (else
+ (lose "class option" option)))))
(if pn
(post-def
- `(DEFINE ,pn
- (,(make-absolute-reference 'INSTANCE-PREDICATE)
- ,class-name))))))
+ `(,(close-syntax 'DEFINE environment)
+ ,pn
+ (,(absolute 'INSTANCE-PREDICATE environment)
+ ,class-name))))))
((CONSTRUCTOR)
(call-with-values
(lambda ()
(parse-constructor-option class-name lose option))
(lambda (name slots ii-args)
(post-def
- `(DEFINE ,name
- (,(make-absolute-reference 'INSTANCE-CONSTRUCTOR)
- ,class-name
- ',slots
- ,@(map (lambda (x) `',x) ii-args)))))))
+ `(,(close-syntax 'DEFINE environment)
+ ,name
+ (,(absolute 'INSTANCE-CONSTRUCTOR environment)
+ ,class-name
+ ',slots
+ ,@(map (lambda (x) `',x) ii-args)))))))
((SEPARATOR)
(if (or separator
- (null? (cdr option))
- (not (string? (cadr option)))
- (not (null? (cddr option))))
+ (not (and (pair? (cdr option))
+ (string? (cadr option))
+ (null? (cddr option)))))
(lose "class option" option))
(set! separator (cadr option))
unspecific)
- (else (lose "class option" option))))
- alist))
+ (else
+ (lose "class option" option))))
+ (if (assq 'PREDICATE alist)
+ alist
+ (cons '(PREDICATE) alist))))
(values class-name post-definitions (or separator "-"))))))
\f
(define (parse-define-class-name-1 name lose)
(else (lose "class name" name))))
(define (parse-constructor-option class-name lose option)
- (cond ((match `(,symbol? ,list-of-symbols? . ,optional?) (cdr option))
+ (cond ((syntax-match? `(SYMBOL (* SYMBOL) . ,optional?) (cdr option))
(values (cadr option) (caddr option) (cdddr option)))
- ((match `(,list-of-symbols? . ,optional?) (cdr option))
+ ((syntax-match? `((* SYMBOL) . ,optional?) (cdr option))
(values (default-constructor-name class-name)
(cadr option)
(cddr option)))
(else
(lose "class option" option))))
-(define (list-of-symbols? x)
- (list-of-type? x symbol?))
-
(define (optional? x)
(or (null? x) (and (pair? x) (null? (cdr x)))))
(define (default-constructor-name class-name)
(intern (string-append "make-" (strip-angle-brackets class-name))))
-(define (make-named-lambda name required optional rest body)
+(define (make-named-lambda name required optional rest body environment)
(let ((bvl
(append required
(if (null? optional)
`(#!OPTIONAL ,@optional))
(or rest '()))))
(if name
- `(NAMED-LAMBDA (,name ,@bvl) ,@body)
- `(LAMBDA ,bvl ,@body))))
+ `(,(close-syntax 'NAMED-LAMBDA environment) (,name ,@bvl) ,@body)
+ `(,(close-syntax 'LAMBDA environment) ,bvl ,@body))))
-(define (make-absolute-reference name)
- `(ACCESS ,name #F))
+(define (absolute name environment)
+ (close-syntax `(ACCESS ,name #F) environment))
\f
-(define (extract-generic-definitions! slot-arguments name separator lose)
+(define (extract-generic-definitions! slot-arguments name separator environment
+ lose)
(let ((definitions '()))
(for-each
(lambda (arg)
(append! (translate-define-arg (cadr plist)
name
separator
- arg)
+ arg
+ environment)
definitions)))
(loop (cddr plist) (cdr plist)))))))
slot-arguments)
definitions))
-(define (translate-define-arg arg name separator slot-argument)
+(define (translate-define-arg arg name separator slot-argument environment)
(let ((translate
(lambda (keyword standard? arity generate)
(if (or (and standard? (eq? 'STANDARD arg))
(eq? keyword arg)
(and (pair? arg) (memq keyword arg)))
- `((DEFINE
+ `((,(close-syntax 'DEFINE environment)
,(or (plist-lookup keyword (cdr slot-argument) #f)
(let ((name
(intern
(set-cdr! slot-argument
(cons* keyword name (cdr slot-argument)))
name))
- (,(make-absolute-reference 'MAKE-GENERIC-PROCEDURE)
- ,arity)))
+ (,(absolute 'MAKE-GENERIC-PROCEDURE environment) ,arity)))
'()))))
(append (translate 'ACCESSOR #t 1
(lambda (root) root))
s)))
\f
(define-syntax define-generic
- (non-hygienic-macro-transformer
- (lambda (name lambda-list)
- (if (not (symbol? name))
- (error "Malformed generic procedure name:" name))
- (call-with-values (lambda () (parse-lambda-list lambda-list #f))
- (lambda (required optional rest)
- `(DEFINE ,name
- (,(make-absolute-reference 'MAKE-GENERIC-PROCEDURE)
- ',(let ((low (length required)))
- (cond (rest (cons low #f))
- ((null? optional) low)
- (else (cons low (+ low (length optional))))))
- ',name)))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(IDENTIFIER MIT-BVL) (cdr form))
+ (call-with-values (lambda () (parse-mit-lambda-list (caddr form)))
+ (lambda (required optional rest)
+ `(,(close-syntax 'DEFINE environment)
+ ,(cadr form)
+ (,(absolute 'MAKE-GENERIC-PROCEDURE environment)
+ ',(let ((low (length required)))
+ (if rest
+ (cons low #f)
+ (let ((n (length optional)))
+ (if (> n 0)
+ (cons low (+ low n))
+ low))))
+ ',(cadr form)))))
+ (ill-formed-syntax form)))))
(define-syntax define-method
- (non-hygienic-macro-transformer
- (lambda (name lambda-list . body)
- (transform-define-method name lambda-list body
- (lambda (name required specializers optional rest body)
- `(,(make-absolute-reference 'ADD-METHOD)
- ,name
- ,(make-method-sexp name required optional rest specializers
- body)))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(IDENTIFIER DATUM + EXPRESSION) (cdr form))
+ (call-with-values
+ (lambda () (parse-specialized-lambda-list (caddr form)))
+ (lambda (required specializers optional rest)
+ (let ((name (cadr form)))
+ (capture-syntactic-environment
+ (lambda (instance-environment)
+ `(,(absolute 'ADD-METHOD environment)
+ ,name
+ ,(make-method-sexp name required optional rest specializers
+ (cdddr form)
+ environment
+ instance-environment)))))))
+ (ill-formed-syntax form)))))
(define-syntax define-computed-method
- (non-hygienic-macro-transformer
- (lambda (name lambda-list . body)
- (transform-define-method name lambda-list body
- (lambda (name required specializers optional rest body)
- `(,(make-absolute-reference 'ADD-METHOD)
- ,name
- (,(make-absolute-reference 'MAKE-COMPUTED-METHOD)
- (,(make-absolute-reference 'LIST) ,@specializers)
- ,(make-named-lambda name required optional rest body))))))))
-
-(define (transform-define-method name lambda-list body generator)
- (if (not (symbol? name))
- (error "Malformed generic procedure name:" name))
- (call-with-values (lambda () (parse-lambda-list lambda-list #t))
- (lambda (required optional rest)
- (call-with-values (lambda () (extract-required-specializers required))
- (lambda (required specializers)
- (generator name required specializers optional rest body))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(IDENTIFIER DATUM + EXPRESSION) (cdr form))
+ (call-with-values
+ (lambda () (parse-specialized-lambda-list (caddr form)))
+ (lambda (required specializers optional rest)
+ (let ((name (cadr form)))
+ `(,(absolute 'ADD-METHOD environment)
+ ,name
+ (,(absolute 'MAKE-COMPUTED-METHOD environment)
+ (,(absolute 'LIST environment) ,@specializers)
+ ,(make-named-lambda name required optional rest (cdddr form)
+ environment))))))
+ (ill-formed-syntax form)))))
(define-syntax define-computed-emp
- (non-hygienic-macro-transformer
- (lambda (name key lambda-list . body)
- (if (not (symbol? name))
- (error "Malformed generic procedure name:" name))
- (call-with-values (lambda () (parse-lambda-list lambda-list #t))
- (lambda (required optional rest)
- (call-with-values (lambda () (extract-required-specializers required))
- (lambda (required specializers)
- `(,(make-absolute-reference 'ADD-METHOD)
- ,name
- (,(make-absolute-reference 'MAKE-COMPUTED-EMP)
- ,key
- (,(make-absolute-reference 'LIST) ,@specializers)
- ,(make-named-lambda name required optional rest body))))))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(IDENTIFIER EXPRESSION DATUM + EXPRESSION) (cdr form))
+ (call-with-values
+ (lambda () (parse-specialized-lambda-list (cadddr form)))
+ (lambda (required specializers optional rest)
+ (let ((name (cadr form)))
+ `(,(absolute 'ADD-METHOD environment)
+ ,name
+ (,(absolute 'MAKE-COMPUTED-EMP environment)
+ ,(caddr form)
+ (,(absolute 'LIST environment) ,@specializers)
+ ,(make-named-lambda name required optional rest (cddddr form)
+ environment))))))
+ (ill-formed-syntax form)))))
(define-syntax method
- (non-hygienic-macro-transformer
- (lambda (lambda-list . body)
- (call-with-values (lambda () (parse-lambda-list lambda-list #t))
- (lambda (required optional rest)
- (call-with-values (lambda () (extract-required-specializers required))
- (lambda (required specializers)
- (make-method-sexp #f required optional rest specializers
- body))))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(DATUM + EXPRESSION) (cdr form))
+ (call-with-values
+ (lambda () (parse-specialized-lambda-list (cadr form)))
+ (lambda (required specializers optional rest)
+ (capture-syntactic-environment
+ (lambda (instance-environment)
+ (make-method-sexp #f required optional rest specializers
+ (caddr form)
+ environment
+ instance-environment)))))
+ (ill-formed-syntax form)))))
\f
-(define (extract-required-specializers required)
- (let loop ((required required) (names '()) (specializers '()))
- (cond ((null? required)
- (values (reverse! names)
- (reverse! (let loop ((specializers specializers))
- (if (and (not (null? specializers))
- (eq? '<OBJECT> (car specializers))
- (not (null? (cdr specializers))))
- (loop (cdr specializers))
- specializers)))))
- ((pair? (car required))
- (loop (cdr required)
- (cons (caar required) names)
- (cons (cadar required) specializers)))
- (else
- (loop (cdr required)
- (cons (car required) names)
- (cons '<OBJECT> specializers))))))
-
-(define (make-method-sexp name required optional rest specializers body)
+(define (make-method-sexp name required optional rest specializers body
+ environment instance-environment)
(let ((normal
(lambda ()
- (call-with-values (lambda () (call-next-method-used? body))
+ (call-with-values
+ (lambda ()
+ (call-next-method-used? body
+ environment
+ instance-environment))
(lambda (body used?)
- (let ((s `(,(make-absolute-reference 'LIST) ,@specializers))
- (l (make-named-lambda name required optional rest body)))
+ (let ((s `(,(absolute 'LIST environment) ,@specializers))
+ (l
+ (make-named-lambda name required optional rest body
+ environment)))
(if used?
- `(,(make-absolute-reference 'MAKE-CHAINED-METHOD)
+ `(,(absolute 'MAKE-CHAINED-METHOD environment)
,s
- (LAMBDA (CALL-NEXT-METHOD) ,l))
- `(,(make-absolute-reference 'MAKE-METHOD) ,s ,l))))))))
+ (,(close-syntax 'LAMBDA environment) (CALL-NEXT-METHOD)
+ ,l))
+ `(,(absolute 'MAKE-METHOD environment) ,s ,l)))))))
+ (match-identifier
+ (lambda (identifier)
+ (lambda (identifier*)
+ (identifier=? environment identifier
+ instance-environment identifier*)))))
(if (and (null? optional)
(not rest)
- (not (eq? '<OBJECT> (car specializers))))
+ (not (and (pair? specializers)
+ (eq? '<OBJECT> (car specializers)))))
(case (length required)
((1)
- (cond ((match `((SLOT-VALUE ,(car required) ',symbol?)) body)
- `(,(make-absolute-reference 'SLOT-ACCESSOR-METHOD)
+ (cond ((match `((,(match-identifier 'SLOT-VALUE)
+ ,(car required)
+ ',symbol?))
+ body)
+ `(,(absolute 'SLOT-ACCESSOR-METHOD environment)
,(car specializers)
,(caddar body)))
- ((match `((SLOT-INITIALIZED? ,(car required) ',symbol?)) body)
- `(,(make-absolute-reference 'SLOT-INITPRED-METHOD)
+ ((match `((,(match-identifier 'SLOT-INITIALIZED?)
+ ,(car required)
+ ',symbol?))
+ body)
+ `(,(absolute 'SLOT-INITPRED-METHOD environment)
,(car specializers)
,(caddar body)))
(else (normal))))
((2)
(if (and (null? (cdr specializers))
- (match `((SET-SLOT-VALUE! ,(car required)
- ',symbol?
- ,(cadr required)))
- body))
- `(,(make-absolute-reference 'SLOT-MODIFIER-METHOD)
+ (match
+ `((,(match-identifier 'SET-SLOT-VALUE!)
+ ,(car required)
+ ',symbol?
+ ,(cadr required)))
+ body))
+ `(,(absolute 'SLOT-MODIFIER-METHOD environment)
,(car specializers)
,(caddar body))
(normal)))
(else (normal)))
(normal))))
-
+\f
(define (match pattern instance)
(cond ((procedure? pattern)
(pattern instance))
(match (cdr pattern) (cdr instance))))
(else
(eqv? pattern instance))))
-\f
-(define (call-next-method-used? body)
- (if (null? body)
- (values body #f)
+
+(define (call-next-method-used? body environment instance-environment)
+ (if (pair? body)
(let ((body
(let loop ((body body))
- (cond ((or (not (symbol? (car body)))
- (null? (cdr body)))
- body)
- ((eq? (car body) 'CALL-NEXT-METHOD)
- (loop (cdr body)))
- (else
- (cons (car body) (loop (cdr body))))))))
+ (if (and (identifier? (car body))
+ (pair? (cdr body)))
+ (if (identifier=? instance-environment (car body)
+ environment 'CALL-NEXT-METHOD)
+ (loop (cdr body))
+ (cons (car body) (loop (cdr body))))
+ body))))
(values body
- (free-variable? 'CALL-NEXT-METHOD (syntax* body))))))
-
+ (let ((l
+ (syntax `(,(make-syntactic-closure environment '()
+ 'LAMBDA)
+ (CALL-NEXT-METHOD)
+ ,@body)
+ instance-environment)))
+ (free-variable? (car (lambda-bound l))
+ (lambda-body l)))))
+ (values body #f)))
+\f
(define free-variable?
(letrec
((do-expr
((scode-walk scode-walker expr) name expr)))
(do-exprs
(lambda (name exprs)
- (if (null? exprs)
- '()
+ (if (pair? exprs)
(or (do-expr name (car exprs))
- (do-exprs name (cdr exprs))))))
+ (do-exprs name (cdr exprs)))
+ '())))
(scode-walker
(make-scode-walker
(lambda (name expr) name expr #f)
(illegal (lambda (expr) (error "Illegal expression:" expr))))
do-expr))
\f
-(define (parse-lambda-list lambda-list allow-specializers?)
- (let ((required '())
- (optional '())
- (rest #f))
- (letrec
- ((parse-required
- (lambda (lambda-list)
- (cond ((null? lambda-list)
- (finish))
- ((pair? lambda-list)
- (cond ((or (valid-name? (car lambda-list))
- (and allow-specializers?
- (pair? (car lambda-list))
- (valid-name? (caar lambda-list))
- (pair? (cdar lambda-list))
- (null? (cddar lambda-list))))
- (set! required (cons (car lambda-list) required))
- (parse-required (cdr lambda-list)))
- ((eq? #!optional (car lambda-list))
- (parse-optional (cdr lambda-list)))
- ((eq? #!rest (car lambda-list))
- (parse-rest (cdr lambda-list)))
- (else
- (illegal-element lambda-list))))
- ((symbol? lambda-list)
- (set! rest lambda-list)
- (finish))
- (else
- (illegal-tail lambda-list)))))
- (parse-optional
- (lambda (lambda-list)
- (cond ((null? lambda-list)
- (finish))
- ((pair? lambda-list)
- (cond ((valid-name? (car lambda-list))
- (set! optional (cons (car lambda-list) optional))
- (parse-optional (cdr lambda-list)))
- ((eq? #!optional (car lambda-list))
- (error "#!optional may not recur:" lambda-list))
- ((eq? #!rest (car lambda-list))
- (parse-rest (cdr lambda-list)))
- (else
- (illegal-element lambda-list))))
- ((symbol? lambda-list)
- (set! rest lambda-list)
- (finish))
- (else
- (illegal-tail lambda-list)))))
- (parse-rest
- (lambda (lambda-list)
- (if (and (pair? lambda-list)
- (null? (cdr lambda-list)))
- (if (valid-name? (car lambda-list))
- (begin
- (set! rest (car lambda-list))
- (finish))
- (illegal-element lambda-list))
- (illegal-tail lambda-list))))
- (valid-name?
- (lambda (element)
- (and (symbol? element)
- (not (eq? #!optional element))
- (not (eq? #!rest element)))))
- (finish
- (lambda ()
- (values (reverse! required)
- (reverse! optional)
- rest)))
- (illegal-tail
- (lambda (lambda-list)
- (error "Illegal parameter list tail:" lambda-list)))
- (illegal-element
- (lambda (lambda-list)
- (error "Illegal parameter list element:" (car lambda-list)))))
- (parse-required lambda-list))))
\ No newline at end of file
+(define (parse-specialized-lambda-list bvl)
+ (letrec
+ ((parse-required
+ (lambda (bvl required)
+ (cond ((null? bvl)
+ (finish required '() #f))
+ ((pair? bvl)
+ (cond ((eq? #!optional (car bvl))
+ (parse-optional (cdr bvl) required '()))
+ ((eq? #!rest (car bvl))
+ (parse-rest (cdr bvl) required '()))
+ ((or (identifier? (car bvl))
+ (and (pair? (car bvl))
+ (identifier? (caar bvl))
+ (pair? (cdar bvl))
+ (null? (cddar bvl))))
+ (parse-required (cdr bvl)
+ (cons (car bvl) required)))
+ (else
+ (illegal-element bvl))))
+ ((identifier? bvl)
+ (finish required '() bvl))
+ (else
+ (illegal-tail bvl)))))
+ (parse-optional
+ (lambda (bvl required optional)
+ (cond ((null? bvl)
+ (finish required optional #f))
+ ((pair? bvl)
+ (cond ((eq? #!optional (car bvl))
+ (error "#!optional may not recur:" bvl))
+ ((eq? #!rest (car bvl))
+ (parse-rest (cdr bvl) required optional))
+ ((identifier? (car bvl))
+ (parse-optional (cdr bvl)
+ required
+ (cons (car bvl) optional)))
+ (else
+ (illegal-element bvl))))
+ ((identifier? bvl)
+ (finish required optional bvl))
+ (else
+ (illegal-tail bvl)))))
+ (parse-rest
+ (lambda (bvl required optional)
+ (if (and (pair? bvl)
+ (null? (cdr bvl)))
+ (if (identifier? (car bvl))
+ (finish required optional (car bvl))
+ (illegal-element bvl))
+ (illegal-tail bvl))))
+ (finish
+ (lambda (required optional rest)
+ (let ((required (reverse! required))
+ (optional (reverse! optional)))
+ (do ((names (append required optional (if rest (list rest) '()))
+ (cdr names)))
+ ((null? names))
+ (if (memq (car names) (cdr names))
+ (error "Lambda list has duplicate parameter:"
+ (car names)
+ (error-irritant/noise " in")
+ bvl)))
+ (call-with-values
+ (lambda () (extract-required-specializers required))
+ (lambda (required specializers)
+ (values required specializers optional rest))))))
+ (illegal-tail
+ (lambda (bvl)
+ (error "Illegal parameter list tail:" bvl)))
+ (illegal-element
+ (lambda (bvl)
+ (error "Illegal parameter list element:" (car bvl)))))
+ (parse-required bvl '())))
+
+(define (extract-required-specializers required)
+ (let loop ((required required) (names '()) (specializers '()))
+ (if (pair? required)
+ (if (pair? (car required))
+ (loop (cdr required)
+ (cons (caar required) names)
+ (cons (cadar required) specializers))
+ (loop (cdr required)
+ (cons (car required) names)
+ (cons '<OBJECT> specializers)))
+ (values (reverse! names)
+ (reverse! (let loop ((specializers specializers))
+ (if (and (pair? specializers)
+ (eq? '<OBJECT> (car specializers))
+ (pair? (cdr specializers)))
+ (loop (cdr specializers))
+ specializers)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: compile.scm,v 1.4 2001/11/11 06:00:08 cph Exp $
+;;; $Id: compile.scm,v 1.5 2002/02/03 03:38:58 cph Exp $
;;;
-;;; Copyright (c) 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(for-each compile-file
'("matcher"
"parser"
- "shared"
- "synchk"))
+ "shared"))
(cref/generate-constructors "parser")))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: load.scm,v 1.11 2001/11/09 21:37:51 cph Exp $
+;;; $Id: load.scm,v 1.12 2002/02/03 03:38:58 cph Exp $
;;;
-;;; Copyright (c) 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
(package/system-loader "parser" '() 'QUERY)))
-(add-subsystem-identification! "*Parser" '(0 10))
\ No newline at end of file
+(add-subsystem-identification! "*Parser" '(0 11))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: matcher.scm,v 1.28 2001/12/23 17:21:00 cph Exp $
+;;; $Id: matcher.scm,v 1.29 2002/02/03 03:38:58 cph Exp $
;;;
-;;; Copyright (c) 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(if preprocessor
(preprocessor expression external-bindings internal-bindings)
expression)))
+ ((identifier? expression)
+ expression)
((string? expression)
(preprocess-matcher-expression `(STRING ,expression)
external-bindings
name)
(define-syntax define-*matcher-macro
- (non-hygienic-macro-transformer
- (lambda (bvl expression)
- (cond ((symbol? bvl)
- `(DEFINE-*MATCHER-EXPANDER ',bvl
- (LAMBDA ()
- ,expression)))
- ((named-lambda-bvl? bvl)
- `(DEFINE-*MATCHER-EXPANDER ',(car bvl)
- (LAMBDA ,(cdr bvl)
- ,expression)))
- (else
- (error "Malformed bound-variable list:" bvl))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (let ((r-dme (close-syntax 'DEFINE-*MATCHER-EXPANDER environment))
+ (r-lambda (close-syntax 'LAMBDA environment)))
+ (cond ((syntax-match? '(SYMBOL EXPRESSION) (cdr form))
+ `(,r-dme ',(cadr form)
+ (,r-lambda ()
+ ,(caddr form))))
+ ((syntax-match? '((SYMBOL . MIT-BVL) + EXPRESSION) (cdr form))
+ `(,r-dme ',(car (cadr form))
+ (,r-lambda ,(cdr (cadr form))
+ ,@(cddr form))))
+ (else
+ (ill-formed-syntax form)))))))
(define (define-*matcher-expander name procedure)
(define-matcher-macro name
`(,(car expression)
,(handle-complex-expression
(if (string-prefix? "^" arg)
- `(RE-COMPILE-CHAR-SET ,(string-tail arg 1) #T)
- `(RE-COMPILE-CHAR-SET ,arg #F))
+ `(,(close 'RE-COMPILE-CHAR-SET) ,(string-tail arg 1) #T)
+ `(,(close 'RE-COMPILE-CHAR-SET) ,arg #F))
external-bindings))
expression))))
(define-matcher-preprocessor 'WITH-POINTER
(lambda (expression external-bindings internal-bindings)
- (check-2-args expression (lambda (expression) (symbol? (cadr expression))))
+ (check-2-args expression
+ (lambda (expression) (identifier? (cadr expression))))
`(,(car expression) ,(cadr expression)
,(preprocess-matcher-expression (caddr expression)
external-bindings
;;;; Compiler
(define-syntax *matcher
- (non-hygienic-macro-transformer
- (lambda (expression)
- (generate-matcher-code expression))))
-
-(define (generate-matcher-code expression)
- (generate-external-procedure expression preprocess-matcher-expression
- (lambda (expression)
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(EXPRESSION) (cdr form))
+ (generate-matcher-code (cadr form) environment)
+ (ill-formed-syntax form)))))
+
+(define (generate-matcher-code expression environment)
+ (generate-external-procedure expression environment
+ preprocess-matcher-expression
+ (lambda (expression free-names)
(call-with-pointer #f
(lambda (p)
(bind-delayed-lambdas
- (lambda (ks kf) (compile-matcher-expression expression #f ks kf))
+ (lambda (ks kf)
+ (compile-matcher-expression expression #f ks kf free-names))
(make-matcher-ks-lambda (lambda (kf) kf `#T))
(backtracking-kf p (lambda () `#F))))))))
-(define (compile-matcher-expression expression pointer ks kf)
+(define (compile-matcher-expression expression pointer ks kf free-names)
(cond ((and (pair? expression)
(symbol? (car expression))
(list? (cdr expression))
(compiler (cdr entry)))
(if (and arity (not (= (length (cdr expression)) arity)))
(error "Incorrect arity for matcher:" expression))
- (apply compiler pointer ks kf (cdr expression)))))
- ((or (symbol? expression)
+ (apply compiler pointer ks kf free-names (cdr expression)))))
+ ((or (identifier? expression)
(and (pair? expression) (eq? (car expression) 'SEXP)))
- (wrap-external-matcher `((PROTECT ,(if (pair? expression)
+ (wrap-external-matcher `(,(protect (if (pair? expression)
(cadr expression)
- expression))
+ expression)
+ free-names)
,*buffer-name*)
ks
kf))
,(delay-call kf)))
(define-syntax define-matcher
- (non-hygienic-macro-transformer
- (lambda (form . compiler-body)
- (let ((name (car form))
- (parameters (cdr form)))
- `(DEFINE-MATCHER-COMPILER ',name
- ,(if (symbol? parameters) `#F (length parameters))
- (LAMBDA (POINTER KS KF . ,parameters)
- ,@compiler-body))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '((SYMBOL . MIT-BVL) + EXPRESSION) (cdr form))
+ (let ((name (car (cadr form)))
+ (parameters (cdr (cadr form)))
+ (compiler-body (cddr form))
+ (r-dmc (close-syntax 'DEFINE-MATCHER-COMPILER environment))
+ (r-lambda (close-syntax 'LAMBDA environment)))
+ `(,r-dmc ',name
+ ,(if (identifier? parameters) `#F (length parameters))
+ (,r-lambda (POINTER KS KF FREE-NAMES . ,parameters)
+ ,@compiler-body)))
+ (ill-formed-syntax form)))))
(define (define-matcher-compiler keyword arity compiler)
(hash-table/put! matcher-compilers keyword (cons arity compiler))
(make-eq-hash-table))
\f
(define-syntax define-atomic-matcher
- (non-hygienic-macro-transformer
- (lambda (form test-expression)
- `(DEFINE-MATCHER ,form
- POINTER
- (WRAP-EXTERNAL-MATCHER ,test-expression KS KF)))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(DATUM + EXPRESSION) (cdr form))
+ (let ((r-dm (close-syntax 'DEFINE-MATCHER environment))
+ (r-wem (close-syntax 'WRAP-EXTERNAL-MATCHER environment)))
+ `(,r-dm ,(cadr form)
+ POINTER ,@(except-last-pair (cddr form))
+ (,r-wem ,(car (last-pair (cddr form))) KS KF)))
+ (ill-formed-syntax form)))))
(define-atomic-matcher (char char)
- `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* (PROTECT ,char)))
+ `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* ,(protect char free-names)))
(define-atomic-matcher (char-ci char)
- `(MATCH-PARSER-BUFFER-CHAR-CI ,*buffer-name* (PROTECT ,char)))
+ `(MATCH-PARSER-BUFFER-CHAR-CI ,*buffer-name* ,(protect char free-names)))
(define-atomic-matcher (not-char char)
- `(MATCH-PARSER-BUFFER-NOT-CHAR ,*buffer-name* (PROTECT ,char)))
+ `(MATCH-PARSER-BUFFER-NOT-CHAR ,*buffer-name* ,(protect char free-names)))
(define-atomic-matcher (not-char-ci char)
- `(MATCH-PARSER-BUFFER-NOT-CHAR-CI ,*buffer-name* (PROTECT ,char)))
+ `(MATCH-PARSER-BUFFER-NOT-CHAR-CI ,*buffer-name* ,(protect char free-names)))
(define-atomic-matcher (char-set char-set)
- `(MATCH-PARSER-BUFFER-CHAR-IN-SET ,*buffer-name* (PROTECT ,char-set)))
+ `(MATCH-PARSER-BUFFER-CHAR-IN-SET ,*buffer-name*
+ ,(protect char-set free-names)))
(define-atomic-matcher (alphabet alphabet)
- `(MATCH-UTF8-CHAR-IN-ALPHABET ,*buffer-name* (PROTECT ,alphabet)))
+ `(MATCH-UTF8-CHAR-IN-ALPHABET ,*buffer-name* ,(protect alphabet free-names)))
(define-atomic-matcher (string string)
- `(MATCH-PARSER-BUFFER-STRING ,*buffer-name* (PROTECT ,string)))
+ `(MATCH-PARSER-BUFFER-STRING ,*buffer-name* ,(protect string free-names)))
(define-atomic-matcher (string-ci string)
- `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* (PROTECT ,string)))
+ `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* ,(protect string free-names)))
(define-atomic-matcher (end-of-input)
+ free-names
`(NOT (PEEK-PARSER-BUFFER-CHAR ,*buffer-name*)))
(define-matcher (discard-matched)
- pointer
+ pointer free-names
`(BEGIN
(DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
,(delay-call ks kf)))
(define-matcher (with-pointer identifier expression)
`((LAMBDA (,identifier)
- ,(compile-matcher-expression expression (or pointer identifier) ks kf))
+ ,(compile-matcher-expression expression (or pointer identifier) ks kf
+ (cons identifier free-names)))
,(or pointer (fetch-pointer))))
\f
(define-matcher (seq . expressions)
(if (pair? expressions)
- (if (pair? (cdr expressions))
- (let loop ((expressions expressions) (pointer pointer) (kf kf))
- (if (pair? (cdr expressions))
- (bind-delayed-lambdas
- (lambda (ks)
- (compile-matcher-expression (car expressions)
- pointer
- ks
- kf))
- (make-matcher-ks-lambda
- (lambda (kf)
- (loop (cdr expressions) #f kf))))
- (compile-matcher-expression (car expressions) pointer ks kf)))
- (compile-matcher-expression (car expressions) pointer ks kf))
+ (let loop ((expressions expressions) (pointer pointer) (kf kf))
+ (if (pair? (cdr expressions))
+ (bind-delayed-lambdas
+ (lambda (ks)
+ (compile-matcher-expression (car expressions) pointer ks kf
+ free-names))
+ (make-matcher-ks-lambda
+ (lambda (kf)
+ (loop (cdr expressions) #f kf))))
+ (compile-matcher-expression (car expressions) pointer ks kf
+ free-names)))
(delay-call ks kf)))
(define-matcher (alt . expressions)
(if (pair? expressions)
- (if (pair? (cdr expressions))
- (let loop ((expressions expressions) (pointer pointer))
- (if (pair? (cdr expressions))
- (call-with-pointer pointer
- (lambda (pointer)
- (bind-delayed-lambdas
- (lambda (kf)
- (compile-matcher-expression (car expressions)
- pointer
- ks
- kf))
- (backtracking-kf pointer
- (lambda ()
- (loop (cdr expressions) pointer))))))
- (compile-matcher-expression (car expressions) pointer ks kf)))
- (compile-matcher-expression (car expressions) pointer ks kf))
+ (let loop ((expressions expressions) (pointer pointer))
+ (if (pair? (cdr expressions))
+ (call-with-pointer pointer
+ (lambda (pointer)
+ (bind-delayed-lambdas
+ (lambda (kf)
+ (compile-matcher-expression (car expressions) pointer ks kf
+ free-names))
+ (backtracking-kf pointer
+ (lambda ()
+ (loop (cdr expressions) pointer))))))
+ (compile-matcher-expression (car expressions) pointer ks kf
+ free-names)))
(delay-call kf)))
(define-matcher (* expression)
(lambda (pointer)
(bind-delayed-lambdas
(lambda (kf)
- (compile-matcher-expression expression #f ks2 kf))
+ (compile-matcher-expression expression #f ks2 kf free-names))
(backtracking-kf pointer
(lambda ()
(delay-call ks kf2)))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: parser.pkg,v 1.17 2001/12/23 17:21:00 cph Exp $
+;;; $Id: parser.pkg,v 1.18 2002/02/03 03:38:58 cph Exp $
;;;
-;;; Copyright (c) 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(global-definitions "../runtime/runtime")
(define-package (runtime *parser)
- (files "synchk" "shared" "matcher" "parser")
+ (files "shared" "matcher" "parser")
(parent (runtime))
(export ()
*matcher
;;; -*-Scheme-*-
;;;
-;;; $Id: parser.scm,v 1.31 2001/12/23 17:21:00 cph Exp $
+;;; $Id: parser.scm,v 1.32 2002/02/03 03:38:58 cph Exp $
;;;
-;;; Copyright (c) 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(if preprocessor
(preprocessor expression external-bindings internal-bindings)
expression)))
+ ((identifier? expression)
+ expression)
((or (string? expression)
(char? expression))
(preprocess-parser-expression `(NOISE ,expression)
name)
(define-syntax define-*parser-macro
- (non-hygienic-macro-transformer
- (lambda (bvl expression)
- (cond ((symbol? bvl)
- `(DEFINE-*PARSER-EXPANDER ',bvl
- (LAMBDA ()
- ,expression)))
- ((named-lambda-bvl? bvl)
- `(DEFINE-*PARSER-EXPANDER ',(car bvl)
- (LAMBDA ,(cdr bvl)
- ,expression)))
- (else
- (error "Malformed bound-variable list:" bvl))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (let ((r-dpe (close-syntax 'DEFINE-*PARSER-EXPANDER environment))
+ (r-lambda (close-syntax 'LAMBDA environment)))
+ (cond ((syntax-match? '(SYMBOL EXPRESSION) (cdr form))
+ `(,r-dpe ',(cadr form)
+ (,r-lambda ()
+ ,(caddr form))))
+ ((syntax-match? '((SYMBOL . MIT-BVL) + EXPRESSION) (cdr form))
+ `(,r-dpe ',(car (cadr form))
+ (,r-lambda ,(cdr (cadr form))
+ ,@(cddr form))))
+ (else
+ (ill-formed-syntax form)))))))
(define (define-*parser-expander name procedure)
(define-parser-macro name
;;;; Compiler
(define-syntax *parser
- (non-hygienic-macro-transformer
- (lambda (expression)
- (generate-parser-code expression))))
-
-(define (generate-parser-code expression)
- (generate-external-procedure expression preprocess-parser-expression
- (lambda (expression)
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(EXPRESSION) (cdr form))
+ (generate-parser-code (cadr form) environment)
+ (ill-formed-syntax form)))))
+
+(define (generate-parser-code expression environment)
+ (generate-external-procedure expression environment
+ preprocess-parser-expression
+ (lambda (expression free-names)
(call-with-pointer #f
(lambda (p)
(bind-delayed-lambdas
- (lambda (ks kf) (compile-parser-expression expression #f ks kf))
+ (lambda (ks kf)
+ (compile-parser-expression expression #f ks kf free-names))
(make-parser-ks-lambda (lambda (v kf) kf v))
(backtracking-kf p (lambda () #f))))))))
-(define (compile-parser-expression expression pointer ks kf)
+(define (compile-parser-expression expression pointer ks kf free-names)
(cond ((and (pair? expression)
(symbol? (car expression))
(list? (cdr expression))
(compiler (cdr entry)))
(if (and arity (not (= (length (cdr expression)) arity)))
(error "Incorrect arity for parser:" expression))
- (apply compiler pointer ks kf (cdr expression)))))
+ (apply compiler pointer ks kf free-names (cdr expression)))))
((or (symbol? expression)
(and (pair? expression) (eq? (car expression) 'SEXP)))
- (wrap-external-parser `((PROTECT ,(if (pair? expression)
+ (wrap-external-parser `(,(protect (if (pair? expression)
(cadr expression)
- expression))
+ expression)
+ free-names)
,*buffer-name*)
ks
kf))
,(delay-call kf)))))
(define-syntax define-parser
- (non-hygienic-macro-transformer
- (lambda (form . compiler-body)
- (let ((name (car form))
- (parameters (cdr form)))
- `(DEFINE-PARSER-COMPILER ',name
- ,(if (symbol? parameters) `#F (length parameters))
- (LAMBDA (POINTER KS KF . ,parameters)
- ,@compiler-body))))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '((SYMBOL . MIT-BVL) + EXPRESSION) (cdr form))
+ (let ((name (car (cadr form)))
+ (parameters (cdr (cadr form)))
+ (compiler-body (cddr form))
+ (r-dpc (close-syntax 'DEFINE-PARSER-COMPILER environment))
+ (r-lambda (close-syntax 'LAMBDA environment)))
+ `(,r-dpc ',name
+ ,(if (identifier? parameters) `#F (length parameters))
+ (,r-lambda (POINTER KS KF FREE-NAMES . ,parameters)
+ ,@compiler-body)))
+ (ill-formed-syntax form)))))
(define (define-parser-compiler keyword arity compiler)
(hash-table/put! parser-compilers keyword (cons arity compiler))
(lambda (pointer)
(bind-delayed-lambdas
(lambda (ks)
- (compile-matcher-expression expression pointer ks kf))
+ (compile-matcher-expression expression pointer ks kf free-names))
(make-matcher-ks-lambda
(lambda (kf)
(delay-call ks
(define-parser (noise expression)
(bind-delayed-lambdas
(lambda (ks)
- (compile-matcher-expression expression pointer ks kf))
+ (compile-matcher-expression expression pointer ks kf free-names))
(make-matcher-ks-lambda
(lambda (kf)
(delay-call ks `(VECTOR) kf)))))
pointer
(delay-call ks
`(VECTOR ,@(map (lambda (expression)
- `(PROTECT ,expression))
+ (protect expression free-names))
expressions))
kf))
(define-parser (transform transform expression)
- (post-processed-parser expression pointer ks kf
+ (post-processed-parser expression pointer ks kf free-names
(lambda (ks v kf)
- (wrap-external-parser `((PROTECT ,transform) ,v) ks kf))))
+ (wrap-external-parser `(,(protect transform free-names) ,v) ks kf))))
(define-parser (map transform expression)
- (post-processed-parser expression pointer ks kf
+ (post-processed-parser expression pointer ks kf free-names
(lambda (ks v kf)
- (delay-call ks `(VECTOR-MAP (PROTECT ,transform) ,v) kf))))
+ (delay-call ks `(VECTOR-MAP ,(protect transform free-names) ,v) kf))))
(define-parser (encapsulate transform expression)
- (post-processed-parser expression pointer ks kf
+ (post-processed-parser expression pointer ks kf free-names
(lambda (ks v kf)
- (delay-call ks `(VECTOR ((PROTECT ,transform) ,v)) kf))))
+ (delay-call ks `(VECTOR (,(protect transform free-names) ,v)) kf))))
-(define (post-processed-parser expression pointer ks kf procedure)
+(define (post-processed-parser expression pointer ks kf free-names procedure)
(bind-delayed-lambdas
(lambda (ks)
- (compile-parser-expression expression pointer ks kf))
+ (compile-parser-expression expression pointer ks kf free-names))
(make-parser-ks-lambda
(lambda (v kf)
(procedure ks v kf)))))
(define-parser (with-pointer identifier expression)
`((LAMBDA (,identifier)
- ,(compile-parser-expression expression (or pointer identifier) ks kf))
+ ,(compile-parser-expression expression (or pointer identifier) ks kf
+ (cons identifier free-names)))
,(or pointer (fetch-pointer))))
(define-parser (discard-matched)
- pointer
+ pointer free-names
`(BEGIN
(DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
,(delay-call ks `(VECTOR) kf)))
(kf kf))
(bind-delayed-lambdas
(lambda (ks)
- (compile-parser-expression (car expressions) pointer ks kf))
+ (compile-parser-expression (car expressions) pointer ks kf
+ free-names))
(make-parser-ks-lambda
(lambda (v kf)
(let ((vs (cons v vs)))
(if (pair? (cdr expressions))
(loop (cdr expressions) #f vs kf)
(delay-call ks `(VECTOR-APPEND ,@(reverse vs)) kf)))))))
- (compile-parser-expression (car expressions) pointer ks kf))
+ (compile-parser-expression (car expressions) pointer ks kf
+ free-names))
(delay-call ks `(VECTOR) kf)))
(define-parser (alt . expressions)
(compile-parser-expression (car expressions)
pointer
ks
- kf))
+ kf
+ free-names))
(backtracking-kf pointer
(lambda ()
(loop (cdr expressions) pointer))))))
(compile-parser-expression (car expressions)
pointer
ks
- kf)))
- (compile-parser-expression (car expressions) ks kf))
+ kf
+ free-names)))
+ (compile-parser-expression (car expressions) ks kf free-names))
(delay-call kf)))
(define-parser (* expression)
(lambda (pointer)
(bind-delayed-lambdas
(lambda (ks kf)
- (compile-parser-expression expression pointer ks kf))
+ (compile-parser-expression expression pointer ks kf free-names))
(make-parser-ks-lambda
(lambda (v2 kf)
(delay-call ks2 `(VECTOR-APPEND ,v ,(delay-reference v2)) kf)))
;;; -*-Scheme-*-
;;;
-;;; $Id: shared.scm,v 1.22 2001/12/20 16:13:18 cph Exp $
+;;; $Id: shared.scm,v 1.23 2002/02/03 03:38:58 cph Exp $
;;;
-;;; Copyright (c) 2001 Massachusetts Institute of Technology
+;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(declare (usual-integrations))
\f
(define *buffer-name*)
+(define *environment*)
+(define *closing-environment*)
(define debug:disable-substitution-optimizer? #f)
(define debug:disable-pointer-optimizer? #f)
(define debug:disable-peephole-optimizer? #f)
(define debug:trace-substitution? #f)
-(define (generate-external-procedure expression preprocessor generator)
- (fluid-let ((*id-counters* '()))
- (let ((external-bindings (list 'BINDINGS))
- (internal-bindings (list 'BINDINGS))
- (b (generate-identifier 'B)))
- (let ((expression
- (preprocessor expression external-bindings internal-bindings)))
- (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
- (cdr external-bindings))
- `(LAMBDA (,b)
- ;; Note that PROTECT is used here as a marker to identify
- ;; code that has potential side effects. See below for
- ;; an explanation.
- ,(fluid-let ((*buffer-name* `(PROTECT ,b)))
- (maybe-make-let (map (lambda (b)
- (list (cdr b) (car b)))
- (cdr internal-bindings))
- (strip-protection-wrappers
- (run-optimizers
- (generator expression)))))))))))
+(define (generate-external-procedure expression environment
+ preprocessor generator)
+ (capture-syntactic-environment
+ (lambda (closing-environment)
+ (fluid-let ((*id-counters* '())
+ (*environment* environment)
+ (*closing-environment* closing-environment))
+ (let ((external-bindings (list 'BINDINGS))
+ (internal-bindings (list 'BINDINGS))
+ (b (make-synthetic-identifier 'B)))
+ (let ((expression
+ (preprocessor expression external-bindings internal-bindings)))
+ (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+ (cdr external-bindings))
+ `(LAMBDA (,b)
+ ;; Note that PROTECT is used here as a marker to identify
+ ;; code that has potential side effects. See below for
+ ;; an explanation.
+ ,(fluid-let ((*buffer-name* `(PROTECT ,b)))
+ (maybe-make-let (map (lambda (b)
+ (list (cdr b) (car b)))
+ (cdr internal-bindings))
+ (strip-protection-wrappers
+ (run-optimizers
+ (generator
+ expression
+ (append (map cdr (cdr external-bindings))
+ (map cdr (cdr internal-bindings))))))))))))))))
(define (run-optimizers expression)
(let ((expression*
(cdr bindings)))
variable)))))
-(define (named-lambda-bvl? object)
- (and (pair? object)
- (symbol? (car object))
- (let loop ((object (cdr object)))
- (or (null? object)
- (symbol? object)
- (and (pair? object)
- (symbol? (car object))
- (loop (cdr object)))))))
+(define (close expression)
+ (close-syntax expression *closing-environment*))
\f
;;;; Parser macros
(make-delayed-lambda make-ks-identifier
(list make-value-identifier make-kf-identifier)
generator))
+
+(define (protect expression free-names)
+ `(PROTECT ,(make-syntactic-closure *environment* free-names expression)))
\f
(define (make-kf-identifier)
(generate-identifier 'KF))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Id: synchk.scm,v 1.1 2001/06/26 18:03:24 cph Exp $
-;;;
-;;; Copyright (c) 1989 Massachusetts Institute of Technology
-;;;
-;;; This program is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation; either version 2 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-;;; 02111-1307, USA.
-
-;;;; Syntax Checking
-;;; written by Alan Bawden
-;;; modified by Chris Hanson
-
-(declare (usual-integrations))
-\f
-(define (syntax-match? pattern object)
- (let ((match-error (lambda () (error "ill-formed pattern" pattern))))
- (cond ((symbol? pattern)
- (case pattern
- ((IDENTIFIER) (symbol? object))
- ((ANYTHING EXPRESSION FORM) true)
- ((BVL) (lambda-pattern? object))
- (else (match-error))))
- ((pair? pattern)
- (case (car pattern)
- ((QUOTE)
- (if (and (pair? (cdr pattern))
- (null? (cddr pattern)))
- (eqv? (cadr pattern) object)
- (match-error)))
- ((*)
- (if (pair? (cdr pattern))
- (let ((head (cadr pattern))
- (tail (cddr pattern)))
- (let loop ((object object))
- (or (and (pair? object)
- (syntax-match? head (car object))
- (loop (cdr object)))
- (syntax-match? tail object))))
- (match-error)))
- ((+)
- (if (pair? (cdr pattern))
- (let ((head (cadr pattern))
- (tail (cddr pattern)))
- (and (pair? object)
- (syntax-match? head (car object))
- (let loop ((object (cdr object)))
- (or (and (pair? object)
- (syntax-match? head (car object))
- (loop (cdr object)))
- (syntax-match? tail object)))))
- (match-error)))
- ((?)
- (if (pair? (cdr pattern))
- (or (and (syntax-match? (cadr pattern) (car object))
- (syntax-match? (cddr pattern) (cdr object)))
- (syntax-match? (cddr pattern) object))
- (match-error)))
- (else
- (and (pair? object)
- (syntax-match? (car pattern) (car object))
- (syntax-match? (cdr pattern) (cdr object))))))
- (else
- (eqv? pattern object)))))
\ No newline at end of file
(declare (usual-integrations))
(define-syntax deflap
- (non-hygienic-macro-transformer
- (lambda (name . lap)
- `(DEFINE ,name
- (SCODE-EVAL
- ',((access lap->code (->environment '(COMPILER TOP-LEVEL))) name lap)
- SYSTEM-GLOBAL-ENVIRONMENT)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((name (cadr form))
+ (lap (cddr form)))
+ `(DEFINE ,name
+ (SCODE-EVAL ',((access lap->code
+ (->environment '(COMPILER TOP-LEVEL)))
+ name lap)
+ SYSTEM-GLOBAL-ENVIRONMENT))))))
(define set-floating-error-mask!
(let ()
row-lists->col-lists
run-queue-trace
scc-define-structure ;macro
- scc-define-syntax ;macro
screen-area=
scrollable-canvas-canvas
scrollable-canvas-hscroll
(define (record-free-pointer trace)
(if allow-free-trace?
(let-syntax ((ucode-primitive
- (non-hygienic-macro-transformer
- (lambda arguments
- (apply make-primitive-procedure arguments)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply make-primitive-procedure (cdr form))))))
(vector-set! (cdr trace)
(car trace)
((ucode-primitive primitive-get-free 1) 26))
(restart-thread uitk-thread #T (lambda () (initial-thread-state 'go))))
(let-syntax ((last-reference
- (non-hygienic-macro-transformer
- (lambda (variable)
- `(let ((foo ,variable))
- (set! ,variable #F)
- foo)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((variable (close-syntax (cadr form) environment)))
+ `(LET ((FOO ,variable))
+ (SET! ,variable #F)
+ FOO))))))
(define (uitk-thread-main-loop)
(define (flush-all-displays)
;;;; -*-Scheme-*-
-;;; $Id: scc-macros.scm,v 1.3 2001/12/23 17:21:00 cph Exp $
+;;; $Id: scc-macros.scm,v 1.4 2002/02/03 03:38:58 cph Exp $
(define-syntax define-constant
- (non-hygienic-macro-transformer
- (lambda (name value)
- `(DEFINE-INTEGRABLE ,name ,value))))
+ define-integrable)
(define-syntax define-in-line
- (non-hygienic-macro-transformer
- (lambda (arg-list . body)
- `(DEFINE-INTEGRABLE ,arg-list . ,body))))
-
-(define-syntax scc-define-syntax
- (non-hygienic-macro-transformer
- (lambda (name-and-arglist . body)
- (let ((name (car name-and-arglist))
- (arglist (cdr name-and-arglist)))
- `(DEFINE-SYNTAX ,name
- (NON-HYGIENIC-MACRO-TRANSFORMER
- (LAMBDA ,arglist ,@body)))))))
+ define-integrable)
(define-integrable *running-in-mit-scheme* #t)
\ No newline at end of file
(DECLARE (USUAL-INTEGRATIONS)) ; MIT Scheme-ism: promise not to redefine prims
-;;; $Id: test-wabbit.scm,v 1.3 2001/12/23 17:21:00 cph Exp $
+;;; $Id: test-wabbit.scm,v 1.4 2002/02/03 03:38:58 cph Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; - Document dependencies
;; - [SCREWS] see last page
\f
-;;; $Id: test-wabbit.scm,v 1.3 2001/12/23 17:21:00 cph Exp $
+;;; $Id: test-wabbit.scm,v 1.4 2002/02/03 03:38:58 cph Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
(let-syntax
((ucode-type
- (non-hygienic-macro-transformer
- (lambda (name) (microcode-type name)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (microcode-type (cadr form))))))
(define apply-hook-tag
(access apply-hook-tag (->environment '(runtime procedure))))
#| -*-Scheme-*-
-$Id: ffimacro.scm,v 1.5 2001/12/23 17:21:00 cph Exp $
+$Id: ffimacro.scm,v 1.6 2002/02/03 03:38:58 cph Exp $
-Copyright (c) 1993, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1993, 1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(define ffi-module-entry-variable (string->symbol "[ffi entry]"))
(define ffi-result-variable (string->symbol "[ffi result]"))
-(define (type->checker type)
- (string->symbol (string-append (symbol-name type) ":check")))
+(define ((make-type-namer suffix) type environment)
+ (close-syntax (symbol-append type suffix) environment))
-(define (type->converter type)
- (string->symbol (string-append (symbol-name type) ":convert")))
-
-(define (type->check&converter type)
- (string->symbol (string-append (symbol-name type) ":check&convert")))
-
-(define (type->return-converter type)
- (string->symbol (string-append (symbol-name type) ":return-convert")))
-
-(define (type->reverter type)
- (string->symbol (string-append (symbol-name type) ":revert")))
+(define type->checker (make-type-namer ':CHECK))
+(define type->converter (make-type-namer ':CONVERT))
+(define type->check&converter (make-type-namer ':CHECK&CONVERT))
+(define type->return-converter (make-type-namer ':RETURN-CONVERT))
+(define type->reverter (make-type-namer ':REVERT))
(define-syntax windows-procedure
- (non-hygienic-macro-transformer
- (lambda (args return-type module entry-name . additional-specifications)
-
- (define (make-converted-name sym)
- (string->symbol (string-append "[converted " (symbol-name sym) "]")))
-
- (define (make-check type arg)
- `(if (not (,(type->checker type) ,arg))
- (windows-procedure-argument-type-check-error ',type ,arg)))
-
- (define (make-conversion type arg)
- `(,(type->converter type) ,arg))
-
- (define (make-reversion type sym representation)
- `(,(type->reverter type) ,sym ,representation))
-
- (define (make-return-conversion type expr)
- `(,(type->return-converter type) ,expr))
-
- (if additional-specifications
- ;; expanded version:
- (let* ((procedure-name (car args))
- (arg-names (map car (cdr args)))
- (arg-types (map cadr (cdr args)))
- (cvt-names (map make-converted-name arg-names))
- (checks (map make-check arg-types arg-names))
- (conversions (map (lambda (cvt-name arg-type arg-name)
- `(,cvt-name
- ,(make-conversion arg-type arg-name)))
- cvt-names arg-types arg-names))
- (reversions
- (map make-reversion arg-types arg-names cvt-names))
- (additional-checks
- (if (and (pair? additional-specifications)
- (symbol? (car additional-specifications)))
- (cdr additional-specifications)
- additional-specifications)))
-
- `((access parameterize-with-module-entry ())
- (lambda (,ffi-module-entry-variable)
- (named-lambda (,procedure-name . ,arg-names)
- ,@checks
- ,@additional-checks
- (let ,conversions
- (let ((,ffi-result-variable
- (%call-foreign-function
- (module-entry/machine-address
- ,ffi-module-entry-variable)
- . ,cvt-names)))
- ,@reversions
- ,(make-return-conversion return-type
- ffi-result-variable)))))
- ,module ,entry-name))
-
- ;; closure version:
- (let* ((arg-types (map cadr (cdr args))))
- `(make-windows-procedure ,module ,entry-name
- ,(type->return-converter return-type)
- ,@(map type->check&converter
- arg-types)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((args (cadr form))
+ (return-type (caddr form))
+ (module (close-syntax (cadddr form) environment))
+ (entry-name (close-syntax (car (cddddr form)) environment))
+ (additional-specifications (cdr (cddddr form))))
+ (if additional-specifications
+ ;; expanded version:
+ (let* ((procedure-name (car args))
+ (arg-names (map car (cdr args)))
+ (arg-types (map cadr (cdr args)))
+ (cvt-names
+ (map (lambda (sym)
+ (intern
+ (string-append "[converted "
+ (symbol-name sym)
+ "]")))
+ arg-names)))
+ `((ACCESS PARAMETERIZE-WITH-MODULE-ENTRY
+ SYSTEM-GLOBAL-ENVIRONMENT)
+ (LAMBDA (,ffi-module-entry-variable)
+ (NAMED-LAMBDA (,procedure-name ,@arg-names)
+ ,@(map (lambda (type arg)
+ `(IF (NOT (,(type->checker type environment) ,arg))
+ (WINDOWS-PROCEDURE-ARGUMENT-TYPE-CHECK-ERROR
+ ',type
+ ,arg)))
+ arg-types
+ arg-names)
+ ,@(if (and (pair? additional-specifications)
+ (symbol? (car additional-specifications)))
+ (cdr additional-specifications)
+ additional-specifications)
+ (LET ,(map (lambda (cvt-name arg-type arg-name)
+ `(,cvt-name
+ (,(type->converter arg-type environment)
+ ,arg-name)))
+ cvt-names
+ arg-types
+ arg-names)
+ (LET ((,ffi-result-variable
+ (%CALL-FOREIGN-FUNCTION
+ (MODULE-ENTRY/MACHINE-ADDRESS
+ ,ffi-module-entry-variable)
+ ,@cvt-names)))
+ ,@(map (lambda (type arg-name cvt-name)
+ `(,(type->reverter type environment)
+ ,arg-name
+ ,cvt-name))
+ arg-types
+ arg-names
+ cvt-names)
+ (,(type->return-converter return-type environment)
+ ,ffi-result-variable)))))
+ ,module
+ ,entry-name))
+ ;; closure version:
+ (let ((arg-types (map cadr (cdr args))))
+ `(MAKE-WINDOWS-PROCEDURE
+ ,module
+ ,entry-name
+ ,(type->return-converter return-type environment)
+ ,@(map (lambda (name)
+ (type->check&converter name environment))
+ arg-types))))))))
\f
(define-syntax define-windows-type
- (non-hygienic-macro-transformer
- (lambda (name #!optional check convert return revert)
- (let ((check (if (default-object? check) #f check))
- (convert (if (default-object? convert) #f convert))
- (return (if (default-object? return) #f return))
- (revert (if (default-object? revert) #f revert)))
- (let ((check (or check '(lambda (x) x #t)))
- (convert (or convert '(lambda (x) x)))
- (return (or return '(lambda (x) x)))
- (revert (or revert '(lambda (x y) x y unspecific))))
- `(begin
- (define-integrable (,(type->checker name) x)
- (,check x))
- (define-integrable (,(type->converter name) x)
- (,convert x))
- (define-integrable (,(type->check&converter name) x)
- (if (,(type->checker name) x)
- (,(type->converter name) x)
- (windows-procedure-argument-type-check-error ',name x)))
- (define-integrable (,(type->return-converter name) x)
- (,return x))
- (define-integrable (,(type->reverter name) x y)
- (,revert x y))))))))
-
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1))
+ (check
+ (if (> (length form) 2)
+ (list-ref form 2)
+ '(LAMBDA (X) X #T)))
+ (convert
+ (if (> (length form) 3)
+ (list-ref form 3)
+ '(LAMBDA (X) X)))
+ (return
+ (if (> (length form) 4)
+ (list-ref form 4)
+ '(LAMBDA (X) X)))
+ (revert
+ (if (> (length form) 5)
+ (list-ref form 5)
+ '(LAMBDA (X Y) X Y UNSPECIFIC))))
+ `(BEGIN
+ (DEFINE-INTEGRABLE (,(type->checker name environment) X)
+ (,check X))
+ (DEFINE-INTEGRABLE (,(type->converter name environment) X)
+ (,convert X))
+ (DEFINE-INTEGRABLE (,(type->check&converter name environment) X)
+ (IF (,(type->checker name environment) X)
+ (,(type->converter name environment) X)
+ (WINDOWS-PROCEDURE-ARGUMENT-TYPE-CHECK-ERROR ',name X)))
+ (DEFINE-INTEGRABLE (,(type->return-converter name environment) X)
+ (,return X))
+ (DEFINE-INTEGRABLE (,(type->reverter name environment) X Y)
+ (,revert X Y)))))))
(define-syntax define-similar-windows-type
- (non-hygienic-macro-transformer
- (lambda (name model #!optional check convert return revert)
- (let ((check (if (default-object? check) #f check))
- (convert (if (default-object? convert) #f convert))
- (return (if (default-object? return) #f return))
- (revert (if (default-object? revert) #f revert)))
- ;; eta conversion below are deliberate to persuade integration to chain
- (let ((check (or check (type->checker model)))
- (convert (or convert (type->converter model)))
- (return (or return (type->return-converter model)))
- (revert (or revert (type->reverter model))))
- `(begin
- (define-integrable (,(type->checker name) x)
- (,check x))
- (define-integrable (,(type->converter name) x)
- (,convert x))
- (define-integrable (,(type->check&converter name) x)
- (if (,(type->checker name) x)
- (,(type->converter name) x)
- (windows-procedure-argument-type-check-error ',name x)))
- (define-integrable (,(type->return-converter name) x)
- (,return x))
- (define-integrable (,(type->reverter name) x y)
- (,revert x y))))))))
\ No newline at end of file
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1))
+ (model (list-ref form 2)))
+ (let ((check
+ (if (> (length form) 3)
+ (list-ref form 3)
+ (type->checker model environment)))
+ (convert
+ (if (> (length form) 4)
+ (list-ref form 4)
+ (type->converter model environment)))
+ (return
+ (if (> (length form) 5)
+ (list-ref form 5)
+ (type->return-converter model environment)))
+ (revert
+ (if (> (length form) 6)
+ (list-ref form 6)
+ (type->reverter model environment))))
+ `(BEGIN
+ (DEFINE-INTEGRABLE (,(type->checker name environment) X)
+ (,check X))
+ (DEFINE-INTEGRABLE (,(type->converter name environment) X)
+ (,convert X))
+ (DEFINE-INTEGRABLE (,(type->check&converter name environment) X)
+ (IF (,(type->checker name environment) X)
+ (,(type->converter name environment) X)
+ (WINDOWS-PROCEDURE-ARGUMENT-TYPE-CHECK-ERROR ',name X)))
+ (DEFINE-INTEGRABLE (,(type->return-converter name environment) X)
+ (,return X))
+ (DEFINE-INTEGRABLE (,(type->reverter name environment) X Y)
+ (,revert X Y))))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: win32.sf,v 1.8 2001/12/23 17:21:00 cph Exp $
+$Id: win32.sf,v 1.9 2002/02/03 03:38:58 cph Exp $
-Copyright (c) 1993-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1993-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(construct-packages-from-file (fasload package-set))))
(fluid-let ((sf/default-syntax-table (->environment '(WIN32))))
- (for-each
- (lambda (names)
- (sf/add-file-declarations! (car names)
- `((integrate-external . ,(cdr names)))))
- '(("module" "winuser" "wingdi" "wt_user")
- ("graphics" "winuser" "wingdi" "wt_user")
- ("win_ffi" "winuser" "wingdi" "wt_user")
- ("wf_user" "win_ffi" "wt_user")
- ("dib" "win_ffi")))
-
(sf-conditionally "ffimacro")
(if (not (file-modification-time<? "ffimacro.bin" "ffimacro.com"))
(cbf "ffimacro"))
(sf-conditionally "winuser")
(sf-conditionally "wingdi")
(sf-conditionally "wt_user")
- (sf-conditionally "win_ffi")
+ (fluid-let ((sf/default-declarations
+ `((INTEGRATE-EXTERNAL "winuser" "wingdi" "wt_user"))))
+ (sf-conditionally "win_ffi")
+ (sf-conditionally "graphics")
+ (sf-conditionally "module"))
+ (fluid-let ((sf/default-declarations
+ `((INTEGRATE-EXTERNAL "win_ffi" "wt_user"))))
+ (sf-conditionally "wf_user"))
+ (fluid-let ((sf/default-declarations
+ `((INTEGRATE-EXTERNAL "win_ffi"))))
+ (sf-conditionally "dib"))
(sf-directory "."))
(cref/generate-constructors "win32")
\ No newline at end of file
#| -*-Scheme-*-
-$Id: win_ffi.scm,v 1.8 2001/12/23 17:21:00 cph Exp $
+$Id: win_ffi.scm,v 1.9 2002/02/03 03:38:58 cph Exp $
-Copyright (c) 1993, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1993, 1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(define-syntax call-case
- (non-hygienic-macro-transformer
- (lambda (n)
- #|
- ;; Generate code like this:
- (lambda (module-entry)
- (let ((arg1-type (list-ref arg-types 0))
- (arg2-type (list-ref arg-types 1)))
- (lambda (arg1 arg2)
- (result-type (%call-foreign-function
- (module-entry/machine-address module-entry)
- (arg1-type arg1)
- (arg2-type arg2)))))))
- |#
- (define (map-index f i n)
- (if (<= i n)
- (cons (f i) (map-index f (1+ i) n))
- '()))
- (define (->string thing)
- (cond ((string? thing) thing)
- ((symbol? thing) (symbol-name thing))
- ((number? thing) (number->string thing))))
- (define (concat . things)
- (string->symbol (apply string-append (map ->string things))))
-
- (let* ((arg-names (map-index (lambda (i) (concat "arg" i)) 1 n))
- (type-names (map-index (lambda (i) (concat "arg" i "-type")) 1 n))
- (indexes (map-index identity-procedure 1 n))
- (type-binds (map (lambda (type-name index)
- `(,type-name (list-ref arg-types ,(- index 1))))
- type-names indexes))
- (conversions (map list type-names arg-names)))
-
- `(lambda (module-entry)
- (let ,type-binds
- (lambda ,arg-names
- (result-type (%call-foreign-function
- (module-entry/machine-address module-entry)
- . ,conversions)))))))))
-
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((n (cadr form)))
+ (let* ((indexes
+ (let loop ((i 1))
+ (if (<= i n)
+ (cons i (loop (+ i 1)))
+ '())))
+ (arg-names
+ (map (lambda (i)
+ (intern (string-append "arg" (number->string i))))
+ indexes))
+ (type-names
+ (map (lambda (n) (symbol-append n '-TYPE))
+ arg-names)))
+ `(LAMBDA (MODULE-ENTRY)
+ (LET ,(map (lambda (type-name index)
+ `(,type-name
+ (LIST-REF ,(close-syntax 'ARG-TYPES environment)
+ ,(- index 1))))
+ type-names
+ indexes)
+ (LAMBDA ,arg-names
+ (,(close-syntax 'RESULT-TYPE environment)
+ (%CALL-FOREIGN-FUNCTION
+ (MODULE-ENTRY/MACHINE-ADDRESS MODULE-ENTRY)
+ ,@(map list type-names arg-names)))))))))))
(define (make-windows-procedure lib name result-type . arg-types)
(let* ((arg-count (length arg-types))
(procedure
(case arg-count
- (0 (call-case 0))
- (1 (call-case 1))
- (2 (call-case 2))
- (3 (call-case 3))
- (4 (call-case 4))
- (5 (call-case 5))
- (6 (call-case 6))
- (7 (call-case 7))
- (8 (call-case 8))
- (9 (call-case 9))
- (10 (call-case 10))
- (11 (call-case 11))
- (12 (call-case 12))
- (13 (call-case 13))
- (14 (call-case 14))
- (15 (call-case 15))
+ ((0) (call-case 0))
+ ((1) (call-case 1))
+ ((2) (call-case 2))
+ ((3) (call-case 3))
+ ((4) (call-case 4))
+ ((5) (call-case 5))
+ ((6) (call-case 6))
+ ((7) (call-case 7))
+ ((8) (call-case 8))
+ ((9) (call-case 9))
+ ((10) (call-case 10))
+ ((11) (call-case 11))
+ ((12) (call-case 12))
+ ((13) (call-case 13))
+ ((14) (call-case 14))
+ ((15) (call-case 15))
(else
(lambda args
(if (= (length args) arg-count)
projects / mit-scheme.git / commitdiff