From 5d923c87dbebdda73f7e46afde85ee72c61b7223 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 3 Feb 2002 03:38:58 +0000 Subject: [PATCH] Merge hygienic-macros branch into trunk. --- v7/src/6001/arith.scm | 88 +- v7/src/compiler/base/constr.scm | 9 +- v7/src/compiler/base/macros.scm | 57 +- v7/src/compiler/machines/i386/compiler.pkg | 8 +- v7/src/edwin/buffer.scm | 15 +- v7/src/edwin/buffrm.scm | 17 +- v7/src/edwin/bufwin.scm | 18 +- v7/src/edwin/calias.scm | 12 +- v7/src/edwin/clscon.scm | 22 +- v7/src/edwin/clsmac.scm | 179 ++- v7/src/edwin/comman.scm | 63 +- v7/src/edwin/comwin.scm | 71 +- v7/src/edwin/dosproc.scm | 25 +- v7/src/edwin/edtfrm.scm | 9 +- v7/src/edwin/edwin.pkg | 22 +- v7/src/edwin/macros.scm | 336 +++-- v7/src/edwin/modes.scm | 29 +- v7/src/edwin/modwin.scm | 9 +- v7/src/edwin/regexp.scm | 56 +- v7/src/edwin/schmod.scm | 77 +- v7/src/edwin/search.scm | 181 +-- v7/src/edwin/syntax.scm | 40 +- v7/src/edwin/tterm.scm | 40 +- v7/src/edwin/utils.scm | 9 +- v7/src/edwin/utlwin.scm | 11 +- v7/src/edwin/window.scm | 36 +- v7/src/edwin/xcom.scm | 28 +- v7/src/edwin/xform.scm | 10 +- v7/src/microcode/cmpintmd/i386.h | 5 +- v7/src/microcode/os2pm.scm | 16 +- v7/src/microcode/utabmd.scm | 13 +- v7/src/runtime/apply.scm | 107 +- v7/src/runtime/arith.scm | 312 +++-- v7/src/runtime/debug.scm | 27 +- v7/src/runtime/defstr.scm | 1116 ++++++++++------ v7/src/runtime/ed-ffi.scm | 13 +- v7/src/runtime/error.scm | 26 +- v7/src/runtime/graphics.scm | 21 +- v7/src/runtime/illdef.scm | 120 -- v7/src/runtime/infstr.scm | 12 +- v7/src/runtime/list.scm | 142 +- v7/src/runtime/macros.scm | 343 ----- v7/src/runtime/make.scm | 45 +- v7/src/runtime/mit-syntax.scm | 978 ++++++++++++++ v7/src/runtime/os2winp.scm | 29 +- v7/src/runtime/parse.scm | 48 +- v7/src/runtime/parser-buffer.scm | 140 +- v7/src/runtime/port.scm | 26 +- v7/src/runtime/recslot.scm | 21 +- v7/src/runtime/rgxcmp.scm | 32 +- v7/src/runtime/runtime.pkg | 117 +- v7/src/runtime/scomb.scm | 50 +- v7/src/runtime/starbase.scm | 35 +- v7/src/runtime/string.scm | 48 +- v7/src/runtime/syntab.scm | 81 -- v7/src/runtime/syntactic-closures.scm | 1175 +++++++++++++++++ v7/src/runtime/syntax-check.scm | 202 +++ v7/src/runtime/syntax-output.scm | 150 +++ v7/src/runtime/syntax-rules.scm | 318 +++++ v7/src/runtime/syntax-transforms.scm | 95 ++ v7/src/runtime/syntax.scm | 652 --------- v7/src/runtime/sysmac.scm | 39 +- v7/src/runtime/unsyn.scm | 7 +- v7/src/runtime/vector.scm | 12 +- v7/src/runtime/version.scm | 4 +- v7/src/sf/make.scm | 6 +- v7/src/sf/object.scm | 78 +- v7/src/sf/sf.pkg | 7 +- v7/src/sf/toplev.scm | 78 +- v7/src/sos/class.scm | 11 +- v7/src/sos/instance.scm | 344 +++-- v7/src/sos/macros.scm | 594 +++++---- v7/src/star-parser/compile.scm | 7 +- v7/src/star-parser/load.scm | 6 +- v7/src/star-parser/matcher.scm | 184 +-- v7/src/star-parser/parser.pkg | 6 +- v7/src/star-parser/parser.scm | 125 +- v7/src/star-parser/shared.scm | 68 +- v7/src/star-parser/synchk.scm | 76 -- .../swat/scheme/control-floating-errors.scm | 16 +- v7/src/swat/scheme/load.scm | 1 - v7/src/swat/scheme/mit-xhooks.scm | 18 +- v7/src/swat/scheme/scc-macros.scm | 19 +- v7/src/wabbit/test-wabbit.scm | 10 +- v7/src/win32/ffimacro.scm | 263 ++-- v7/src/win32/win32.sf | 26 +- v7/src/win32/win_ffi.scm | 102 +- 87 files changed, 6158 insertions(+), 3941 deletions(-) delete mode 100644 v7/src/runtime/illdef.scm delete mode 100644 v7/src/runtime/macros.scm create mode 100644 v7/src/runtime/mit-syntax.scm delete mode 100644 v7/src/runtime/syntab.scm create mode 100644 v7/src/runtime/syntactic-closures.scm create mode 100644 v7/src/runtime/syntax-check.scm create mode 100644 v7/src/runtime/syntax-output.scm create mode 100644 v7/src/runtime/syntax-rules.scm create mode 100644 v7/src/runtime/syntax-transforms.scm delete mode 100644 v7/src/runtime/syntax.scm delete mode 100644 v7/src/star-parser/synchk.scm diff --git a/v7/src/6001/arith.scm b/v7/src/6001/arith.scm index 663a826c3..7516535f1 100644 --- a/v7/src/6001/arith.scm +++ b/v7/src/6001/arith.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -46,12 +46,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) @@ -78,16 +78,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 @@ -186,21 +188,28 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) @@ -218,12 +227,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) diff --git a/v7/src/compiler/base/constr.scm b/v7/src/compiler/base/constr.scm index 5c10634a0..88f16d1c7 100644 --- a/v7/src/compiler/base/constr.scm +++ b/v7/src/compiler/base/constr.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -16,8 +16,11 @@ 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., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# + +(declare (usual-integrations)) ;;; Procedures for managing a set of ordering constraints diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index 523e7bab5..d102eab3e 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -36,38 +36,33 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ,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)))))) (define-syntax define-vector-slots (non-hygienic-macro-transformer diff --git a/v7/src/compiler/machines/i386/compiler.pkg b/v7/src/compiler/machines/i386/compiler.pkg index a754fc5aa..343d3bcdc 100644 --- a/v7/src/compiler/machines/i386/compiler.pkg +++ b/v7/src/compiler/machines/i386/compiler.pkg @@ -1,8 +1,8 @@ #| -*-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 @@ -137,8 +137,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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") diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm index 553d38b36..55efaeb5c 100644 --- a/v7/src/edwin/buffer.scm +++ b/v7/src/edwin/buffer.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -46,10 +46,13 @@ (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) diff --git a/v7/src/edwin/buffrm.scm b/v7/src/edwin/buffrm.scm index 88fd63af6..dd66d43f1 100644 --- a/v7/src/edwin/buffrm.scm +++ b/v7/src/edwin/buffrm.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -16,7 +16,8 @@ ;;; ;;; 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 @@ -45,21 +46,21 @@ )) (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) @@ -109,7 +110,7 @@ (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))) @@ -142,7 +143,7 @@ (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)) diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm index 72bd9f6f9..772e019df 100644 --- a/v7/src/edwin/bufwin.scm +++ b/v7/src/edwin/bufwin.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -16,7 +16,8 @@ ;;; ;;; 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 @@ -652,7 +653,7 @@ ;;;; 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)) @@ -660,7 +661,7 @@ (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))) @@ -697,12 +698,12 @@ (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!)) ;;;; Update @@ -876,7 +877,8 @@ (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 diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm index e7dedbdd9..1d12c7159 100644 --- a/v7/src/edwin/calias.scm +++ b/v7/src/edwin/calias.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -256,9 +256,11 @@ ;; 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) diff --git a/v7/src/edwin/clscon.scm b/v7/src/edwin/clscon.scm index 690b03948..b705ea0fb 100644 --- a/v7/src/edwin/clscon.scm +++ b/v7/src/edwin/clscon.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -16,7 +16,8 @@ ;;; ;;; 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 @@ -71,16 +72,15 @@ 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))) diff --git a/v7/src/edwin/clsmac.scm b/v7/src/edwin/clsmac.scm index 60f45010d..3c5ceb9ff 100644 --- a/v7/src/edwin/clsmac.scm +++ b/v7/src/edwin/clsmac.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -30,104 +30,87 @@ ;;; ****************************************************************** (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))))))) -(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 diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm index 6933f8f89..3778a2534 100644 --- a/v7/src/edwin/comman.scm +++ b/v7/src/edwin/comman.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -70,21 +70,20 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) @@ -124,13 +123,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) @@ -144,11 +142,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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)) (define (normalize-variable-value variable value) @@ -175,13 +179,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) diff --git a/v7/src/edwin/comwin.scm b/v7/src/edwin/comwin.scm index 297505dcb..d42d5a58e 100644 --- a/v7/src/edwin/comwin.scm +++ b/v7/src/edwin/comwin.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -16,7 +16,8 @@ ;;; ;;; 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 @@ -27,7 +28,7 @@ ;;; 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. @@ -45,15 +46,15 @@ ;;; 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, @@ -299,14 +300,14 @@ (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) @@ -327,34 +328,34 @@ (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))))))) (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) @@ -389,10 +390,10 @@ 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) @@ -425,7 +426,7 @@ (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) @@ -438,15 +439,15 @@ (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))) @@ -624,16 +625,16 @@ (- new-room new-s))))))))))))) (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 @@ -654,10 +655,10 @@ 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) diff --git a/v7/src/edwin/dosproc.scm b/v7/src/edwin/dosproc.scm index d6319c95c..69dfff0f4 100644 --- a/v7/src/edwin/dosproc.scm +++ b/v7/src/edwin/dosproc.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -23,33 +23,34 @@ ;; package: (edwin process) (declare (usual-integrations)) - -(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 diff --git a/v7/src/edwin/edtfrm.scm b/v7/src/edwin/edtfrm.scm index b1b552240..37c19a9ed 100644 --- a/v7/src/edwin/edtfrm.scm +++ b/v7/src/edwin/edtfrm.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -16,7 +16,8 @@ ;;; ;;; 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 @@ -75,7 +76,7 @@ (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*) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index c575c14b9..318afd57d 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,8 +1,8 @@ #| -*-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 @@ -127,20 +127,25 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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") @@ -157,7 +162,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (files "macros") (parent (edwin)) (export (edwin) - canonicalize-name command-defined? command-name->scheme-name define-command diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm index 4623a6294..0384697e2 100644 --- a/v7/src/edwin/macros.scm +++ b/v7/src/edwin/macros.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -22,171 +22,223 @@ ;;;; Editor Macros (declare (usual-integrations)) - -(define edwin-syntax-table (->environment '(EDWIN))) ;upwards compatibility +;; Upwards compatibility: +(define edwin-syntax-table (->environment '(EDWIN))) + (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))))) (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))) (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 diff --git a/v7/src/edwin/modes.scm b/v7/src/edwin/modes.scm index aa1cd243e..8668ff8a1 100644 --- a/v7/src/edwin/modes.scm +++ b/v7/src/edwin/modes.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -74,19 +74,18 @@ (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) diff --git a/v7/src/edwin/modwin.scm b/v7/src/edwin/modwin.scm index a2d66240d..e41dc3d29 100644 --- a/v7/src/edwin/modwin.scm +++ b/v7/src/edwin/modwin.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -16,7 +16,8 @@ ;;; ;;; 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 @@ -34,7 +35,7 @@ (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)) diff --git a/v7/src/edwin/regexp.scm b/v7/src/edwin/regexp.scm index 45b4f1299..465d8d3e5 100644 --- a/v7/src/edwin/regexp.scm +++ b/v7/src/edwin/regexp.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -155,31 +155,37 @@ (make-mark group start))) (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) @@ -217,7 +223,7 @@ (mark-index end)))) (and index (make-mark group index))))) - + (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)) @@ -233,7 +239,7 @@ (mark-index end)))) (and index (make-mark group index))))) - + (define (re-search-buffer-forward regexp syntax-table group start end) (let ((index ((ucode-primitive re-search-buffer-forward) diff --git a/v7/src/edwin/schmod.scm b/v7/src/edwin/schmod.scm index c8c015fe0..0fa7bf297 100644 --- a/v7/src/edwin/schmod.scm +++ b/v7/src/edwin/schmod.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -145,56 +145,37 @@ The following commands evaluate Scheme expressions: (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 diff --git a/v7/src/edwin/search.scm b/v7/src/edwin/search.scm index 8d0d477e7..314ddfb7c 100644 --- a/v7/src/edwin/search.scm +++ b/v7/src/edwin/search.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -24,76 +24,79 @@ (declare (usual-integrations)) (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)) + (define-integrable (%find-next-newline group start end) (group-find-next-char group start end #\newline)) @@ -102,7 +105,7 @@ (let ((index (group-find-previous-char group end start #\newline))) (and index (fix:+ index 1)))) - + (define (group-match-substring-forward group start end string string-start string-end) (let ((text (group-text group)) @@ -268,24 +271,28 @@ (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)) diff --git a/v7/src/edwin/syntax.scm b/v7/src/edwin/syntax.scm index 840e3a96f..09c9e1b34 100644 --- a/v7/src/edwin/syntax.scm +++ b/v7/src/edwin/syntax.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -192,24 +192,28 @@ a comment ending." ;;;; 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)) diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm index 82dfb288b..7136eca55 100644 --- a/v7/src/edwin/tterm.scm +++ b/v7/src/edwin/tterm.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -442,19 +442,31 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 4536ff43d..7db16d618 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -55,8 +55,9 @@ standard-error-handler)) (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! diff --git a/v7/src/edwin/utlwin.scm b/v7/src/edwin/utlwin.scm index 4b9c3eb8e..8354bb590 100644 --- a/v7/src/edwin/utlwin.scm +++ b/v7/src/edwin/utlwin.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -16,7 +16,8 @@ ;;; ;;; 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 @@ -45,7 +46,7 @@ ()) (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) @@ -83,7 +84,7 @@ (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)) diff --git a/v7/src/edwin/window.scm b/v7/src/edwin/window.scm index 82853c3ef..1c66891fd 100644 --- a/v7/src/edwin/window.scm +++ b/v7/src/edwin/window.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -16,7 +16,8 @@ ;;; ;;; 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 @@ -51,11 +52,12 @@ (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)) @@ -97,13 +99,13 @@ (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))))) (define (window-size window receiver) (receiver (window-x-size window) (window-y-size window))) @@ -154,7 +156,7 @@ 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*) @@ -164,7 +166,7 @@ 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*) @@ -175,7 +177,7 @@ (define (replace-inferior! window old new) (set-inferior-window! (find-inferior (window-inferiors window) old) new) - (=> new :set-superior! window)) + (==> new :set-superior! window)) ;;; Returns #T if the redisplay finished, #F if aborted. ;;; Notice that the :UPDATE-DISPLAY! operation is assumed to return @@ -189,8 +191,8 @@ (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) @@ -236,7 +238,7 @@ (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) @@ -447,7 +449,7 @@ (%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))) @@ -456,13 +458,13 @@ (%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)) diff --git a/v7/src/edwin/xcom.scm b/v7/src/edwin/xcom.scm index 080ad736c..0a5b31d12 100644 --- a/v7/src/edwin/xcom.scm +++ b/v7/src/edwin/xcom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -310,10 +310,14 @@ When called interactively, completion is available on the input." (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) @@ -340,10 +344,14 @@ When called interactively, completion is available on the input." (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)) diff --git a/v7/src/edwin/xform.scm b/v7/src/edwin/xform.scm index fe66a85b7..c9eac1960 100644 --- a/v7/src/edwin/xform.scm +++ b/v7/src/edwin/xform.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -58,9 +58,7 @@ (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 @@ -70,7 +68,7 @@ (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))))))) diff --git a/v7/src/microcode/cmpintmd/i386.h b/v7/src/microcode/cmpintmd/i386.h index b95b69327..2ea14e087 100644 --- a/v7/src/microcode/cmpintmd/i386.h +++ b/v7/src/microcode/cmpintmd/i386.h @@ -1,8 +1,8 @@ /* -*-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 @@ -540,7 +540,6 @@ DEFUN_VOID (i386_reset_hook) { 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 ()); diff --git a/v7/src/microcode/os2pm.scm b/v7/src/microcode/os2pm.scm index 242ca667b..1f2eea8de 100644 --- a/v7/src/microcode/os2pm.scm +++ b/v7/src/microcode/os2pm.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -52,10 +52,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; 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) diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm index 10b3cc006..394de31e5 100644 --- a/v7/src/microcode/utabmd.scm +++ b/v7/src/microcode/utabmd.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -575,9 +575,10 @@ ;;; [] 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) @@ -608,4 +609,4 @@ ;;; 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 $" diff --git a/v7/src/runtime/apply.scm b/v7/src/runtime/apply.scm index cda18e9db..4ece965ad 100644 --- a/v7/src/runtime/apply.scm +++ b/v7/src/runtime/apply.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -30,59 +30,65 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;; 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 @@ -90,8 +96,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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 diff --git a/v7/src/runtime/arith.scm b/v7/src/runtime/arith.scm index 48695201c..86507f718 100644 --- a/v7/src/runtime/arith.scm +++ b/v7/src/runtime/arith.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -28,9 +28,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; 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 @@ -142,92 +145,106 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 &/)) (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)) @@ -518,30 +535,33 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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:-)) @@ -678,14 +698,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) @@ -930,12 +954,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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)) @@ -959,16 +983,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 @@ -1044,14 +1070,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) @@ -1073,23 +1101,25 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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)) (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) diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index c0b581d73..18dcc8906 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -207,14 +207,21 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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))))) ;;;; Display commands diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm index 9a9884d87..65ff84945 100644 --- a/v7/src/runtime/defstr.scm +++ b/v7/src/runtime/defstr.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -70,306 +70,497 @@ differences: |# -(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))))))) -;;;; 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))))))) + +(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)))))) + +(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)) + +(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))) + +(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)))))) -;;;; 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))))) + +;;;; 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))) ;;;; 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)) @@ -377,22 +568,22 @@ differences: (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 @@ -401,10 +592,10 @@ differences: (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 @@ -419,6 +610,45 @@ differences: (define structure/slots (record-accessor structure-rtd 'SLOTS)) +(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))) @@ -448,137 +678,153 @@ differences: ;;;; 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?)))) (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)))) (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) @@ -593,87 +839,90 @@ differences: (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))) (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 @@ -681,8 +930,7 @@ differences: ,(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 diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm index 5aade4f00..aac8fa603 100644 --- a/v7/src/runtime/ed-ffi.scm +++ b/v7/src/runtime/ed-ffi.scm @@ -1,8 +1,8 @@ #| -*- 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 @@ -88,8 +88,8 @@ USA. ("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)) @@ -140,8 +140,11 @@ USA. ("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)) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 8a81242d2..b3095de98 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -412,17 +412,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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)))))) (define (find-restart name #!optional restarts) (guarantee-symbol name 'FIND-RESTART) diff --git a/v7/src/runtime/graphics.scm b/v7/src/runtime/graphics.scm index 35bf71cfd..9e83474e8 100644 --- a/v7/src/runtime/graphics.scm +++ b/v7/src/runtime/graphics.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -253,12 +253,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) diff --git a/v7/src/runtime/illdef.scm b/v7/src/runtime/illdef.scm deleted file mode 100644 index df3aecaa0..000000000 --- a/v7/src/runtime/illdef.scm +++ /dev/null @@ -1,120 +0,0 @@ -#| -*-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)) - -(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))) - -(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 diff --git a/v7/src/runtime/infstr.scm b/v7/src/runtime/infstr.scm index fc109d020..43c6e714e 100644 --- a/v7/src/runtime/infstr.scm +++ b/v7/src/runtime/infstr.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -152,10 +152,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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)) diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm index d509471fc..8df89ea79 100644 --- a/v7/src/runtime/list.scm +++ b/v7/src/runtime/list.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -546,84 +546,88 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (map-1 first))) (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))) + (define mapcan append-map!) (define mapcan* append-map*!) - + (define (reduce procedure initial list) (if (pair? list) (let loop ((value (car list)) (l (cdr list))) diff --git a/v7/src/runtime/macros.scm b/v7/src/runtime/macros.scm deleted file mode 100644 index 4bbc6f871..000000000 --- a/v7/src/runtime/macros.scm +++ /dev/null @@ -1,343 +0,0 @@ -#| -*-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)) - -(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)) - -;;;; 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)))) - -(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)))) - -(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))))) - -(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)))) - -(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 diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index ad5ebbb2c..8eee8d1d4 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -50,16 +50,15 @@ USA. (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) @@ -74,14 +73,16 @@ USA. (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)) @@ -335,11 +336,10 @@ USA. (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) @@ -358,7 +358,8 @@ USA. ("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)) @@ -382,6 +383,9 @@ USA. #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) @@ -478,9 +482,6 @@ USA. (RUNTIME NUMBER-PARSER) (RUNTIME PARSER) (RUNTIME UNPARSER) - (RUNTIME SYNTAXER) - (RUNTIME ILLEGAL-DEFINITIONS) - (RUNTIME MACROS) (RUNTIME UNSYNTAXER) (RUNTIME PRETTY-PRINTER) (RUNTIME EXTENDED-SCODE-EVAL) diff --git a/v7/src/runtime/mit-syntax.scm b/v7/src/runtime/mit-syntax.scm new file mode 100644 index 000000000..61f7fc9ed --- /dev/null +++ b/v7/src/runtime/mit-syntax.scm @@ -0,0 +1,978 @@ +;;; -*-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)) + +;;;; 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)) + +;;;; 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) + '())))) + +(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)))) + +;;;; 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))) + +;;;; 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))) + +(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)))) + +(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))))) + +;;;; 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)))))))))) + +(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)))) + +(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))))))) + +;;;; 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))))) + +(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)))) + +;;;; 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))) + +(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)) + +(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 diff --git a/v7/src/runtime/os2winp.scm b/v7/src/runtime/os2winp.scm index e6915a091..aa39b77ac 100644 --- a/v7/src/runtime/os2winp.scm +++ b/v7/src/runtime/os2winp.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -113,17 +113,20 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index 7dea8f196..3e7fb6c19 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -276,19 +276,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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)))))))) @@ -328,7 +328,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Symbols/Numbers -(define-accretor (parse-object/atom) +(define-accretor 0 (parse-object/atom) (build-atom (read-atom))) (define-integrable (read-atom) @@ -358,7 +358,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) @@ -387,7 +387,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Lists/Vectors -(define-accretor (parse-object/list-open) +(define-accretor 0 (parse-object/list-open) (discard-char) (collect-list/top-level)) @@ -488,15 +488,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; 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 @@ -505,7 +505,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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. @@ -574,11 +574,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; 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) diff --git a/v7/src/runtime/parser-buffer.scm b/v7/src/runtime/parser-buffer.scm index bf3707177..3e7812718 100644 --- a/v7/src/runtime/parser-buffer.scm +++ b/v7/src/runtime/parser-buffer.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -143,27 +143,31 @@ (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))) @@ -185,15 +189,19 @@ (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") @@ -201,40 +209,50 @@ (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")) diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm index e1c096772..f741fc6ab 100644 --- a/v7/src/runtime/port.scm +++ b/v7/src/runtime/port.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -188,11 +188,17 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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) @@ -231,7 +237,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (set-port/state! port state) (set-port/thread-mutex! port (make-thread-mutex)) port)) - + (define (close-port port) (let ((close (port/operation port 'CLOSE))) (if close @@ -239,7 +245,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (begin (close-output-port port) (close-input-port port))))) - + (define (close-input-port port) (let ((close-input (port/operation port 'CLOSE-INPUT))) (if close-input @@ -280,7 +286,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ((BUFFERED-CHARS) 'BUFFERED-OUTPUT-CHARS) ((CHANNEL) 'OUTPUT-CHANNEL) (else name)))) - + (define (input-port? object) (and (port? object) (port-type/supports-input? (port/type object)))) diff --git a/v7/src/runtime/recslot.scm b/v7/src/runtime/recslot.scm index a74163ccb..c8c44bb10 100644 --- a/v7/src/runtime/recslot.scm +++ b/v7/src/runtime/recslot.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -45,13 +45,16 @@ (%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 diff --git a/v7/src/runtime/rgxcmp.scm b/v7/src/runtime/rgxcmp.scm index 8f99ffb10..21f26fb6b 100644 --- a/v7/src/runtime/rgxcmp.scm +++ b/v7/src/runtime/rgxcmp.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -27,18 +27,22 @@ ;;;; 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: diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 9152595de..e3170f0da 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -1237,12 +1237,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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) @@ -1945,8 +1939,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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) @@ -2111,23 +2103,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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)) @@ -2334,18 +2309,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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 @@ -2702,7 +2672,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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 @@ -3762,41 +3732,63 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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") @@ -3826,15 +3818,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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)) diff --git a/v7/src/runtime/scomb.scm b/v7/src/runtime/scomb.scm index b9080bf19..8360d22a1 100644 --- a/v7/src/runtime/scomb.scm +++ b/v7/src/runtime/scomb.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -281,26 +281,32 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 diff --git a/v7/src/runtime/starbase.scm b/v7/src/runtime/starbase.scm index 42acb0478..aa52cd6c1 100644 --- a/v7/src/runtime/starbase.scm +++ b/v7/src/runtime/starbase.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -106,17 +106,26 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm index 9056e2612..8dd90f849 100644 --- a/v7/src/runtime/string.scm +++ b/v7/src/runtime/string.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -203,27 +203,31 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 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) diff --git a/v7/src/runtime/syntab.scm b/v7/src/runtime/syntab.scm deleted file mode 100644 index 742c20aed..000000000 --- a/v7/src/runtime/syntab.scm +++ /dev/null @@ -1,81 +0,0 @@ -#| -*-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)) - -(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 diff --git a/v7/src/runtime/syntactic-closures.scm b/v7/src/runtime/syntactic-closures.scm new file mode 100644 index 000000000..b4184be92 --- /dev/null +++ b/v7/src/runtime/syntactic-closures.scm @@ -0,0 +1,1175 @@ +;;; -*-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)) + +;;;; 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))))) + +(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)) + +;;;; 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)))) + +(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*))))) + +;;;; 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)))))) + +;;;; 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)))) + +(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)))) + +;;; 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) + +;;; 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))) + +;;; 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))) + +;;; 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)) + +;;;; 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 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)) + +;;; 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)) + +;;; 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))))) + +;;; 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)) + +;;;; 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)))) + +;;;; 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)))))) + +;;;; 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)))))) + +(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 diff --git a/v7/src/runtime/syntax-check.scm b/v7/src/runtime/syntax-check.scm new file mode 100644 index 000000000..c4bfb5911 --- /dev/null +++ b/v7/src/runtime/syntax-check.scm @@ -0,0 +1,202 @@ +;;; -*-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)) + +(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))))) + +;;;; 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 '()))) + +(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 diff --git a/v7/src/runtime/syntax-output.scm b/v7/src/runtime/syntax-output.scm new file mode 100644 index 000000000..86284210a --- /dev/null +++ b/v7/src/runtime/syntax-output.scm @@ -0,0 +1,150 @@ +;;; -*-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)) + +(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) + +(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 diff --git a/v7/src/runtime/syntax-rules.scm b/v7/src/runtime/syntax-rules.scm new file mode 100644 index 000000000..fa2c1ad99 --- /dev/null +++ b/v7/src/runtime/syntax-rules.scm @@ -0,0 +1,318 @@ +;;; -*-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)) + +(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)))) + +(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))) + +(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))))))) + +(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 diff --git a/v7/src/runtime/syntax-transforms.scm b/v7/src/runtime/syntax-transforms.scm new file mode 100644 index 000000000..ffbec63de --- /dev/null +++ b/v7/src/runtime/syntax-transforms.scm @@ -0,0 +1,95 @@ +;;; -*-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)) + +;;;; 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 diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm deleted file mode 100644 index b605921ed..000000000 --- a/v7/src/runtime/syntax.scm +++ /dev/null @@ -1,652 +0,0 @@ -#| -*-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)) - -(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)))) - -;;;; 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))) - -;;; 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))))))) - -;;;; 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))) - -;;;; 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))) - -;;;; 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)) - -;;;; 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))))))) - -;;;; 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*))) - -;;;; 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)) - -;;;; 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)))) - -;;;; 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]")) - -;;;; 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 diff --git a/v7/src/runtime/sysmac.scm b/v7/src/runtime/sysmac.scm index 669fcebbb..9af6ceca3 100644 --- a/v7/src/runtime/sysmac.scm +++ b/v7/src/runtime/sysmac.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -26,12 +26,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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))) @@ -39,19 +39,22 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index d2aac5961..abd6fa2fb 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -165,7 +165,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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))) diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm index 4a2477ffd..209df3ad7 100644 --- a/v7/src/runtime/vector.scm +++ b/v7/src/runtime/vector.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -204,11 +204,11 @@ USA. (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) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 041d60916..9ef06f2a5 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -29,7 +29,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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" diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index 9e459b6fd..4549e098d 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -35,4 +35,4 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm index 8c238dbf5..2679541e6 100644 --- a/v7/src/sf/object.scm +++ b/v7/src/sf/object.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -65,16 +65,20 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 @@ -121,16 +125,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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)) @@ -167,16 +178,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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!) diff --git a/v7/src/sf/sf.pkg b/v7/src/sf/sf.pkg index 8a41b423f..05a5bc668 100644 --- a/v7/src/sf/sf.pkg +++ b/v7/src/sf/sf.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -48,7 +48,6 @@ USA. (parent (scode-optimizer)) (export () sf - sf/add-file-declarations! sf/default-declarations sf/default-syntax-table sf/pathname-defaulting @@ -62,9 +61,7 @@ USA. integrate/file integrate/sexp integrate/scode - read-externs-file) - (import (runtime syntaxer) - process-declarations)) + read-externs-file)) (define-package (scode-optimizer transform) (files "xform") diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index 460005f98..a91019caf 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -29,18 +29,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 @@ -62,30 +63,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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) @@ -122,7 +105,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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)))) @@ -249,20 +232,22 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; 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)) @@ -270,32 +255,27 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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)))) (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") diff --git a/v7/src/sos/class.scm b/v7/src/sos/class.scm index 9ec8c5ff3..262c033f7 100644 --- a/v7/src/sos/class.scm +++ b/v7/src/sos/class.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -273,9 +273,10 @@ (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 ) (define-primitive-class ) diff --git a/v7/src/sos/instance.scm b/v7/src/sos/instance.scm index 3bbf8b326..22becbf14 100644 --- a/v7/src/sos/instance.scm +++ b/v7/src/sos/instance.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -29,31 +29,43 @@ ;;; 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)))))) (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) @@ -62,74 +74,97 @@ (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)))) (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)))))) + (define (instance-constructor class slot-names #!optional init-arg-names) (if (not (subclass? class )) (error:bad-range-argument class 'INSTANCE-CONSTRUCTOR)) @@ -157,11 +192,13 @@ (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) @@ -170,80 +207,97 @@ (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 + () + ())))))) (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))))))))) (define (make-initialization class arg-slots) (let ((if-slots diff --git a/v7/src/sos/macros.scm b/v7/src/sos/macros.scm index ad64a5510..1dd96f11e 100644 --- a/v7/src/sos/macros.scm +++ b/v7/src/sos/macros.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -24,59 +24,70 @@ (declare (usual-integrations)) (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)))) -(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))) @@ -92,33 +103,39 @@ (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 "-")))))) (define (parse-define-class-name-1 name lose) @@ -136,18 +153,15 @@ (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))))) @@ -157,7 +171,7 @@ (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) @@ -165,13 +179,14 @@ `(#!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)) -(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) @@ -197,19 +212,20 @@ (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 @@ -221,8 +237,7 @@ (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)) @@ -248,134 +263,151 @@ s))) (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))))) -(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? ' (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 ' 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? ' (car specializers)))) + (not (and (pair? specializers) + (eq? ' (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)))) - + (define (match pattern instance) (cond ((procedure? pattern) (pattern instance)) @@ -385,22 +417,29 @@ (match (cdr pattern) (cdr instance)))) (else (eqv? pattern instance)))) - -(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))) + (define free-variable? (letrec ((do-expr @@ -408,10 +447,10 @@ ((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) @@ -464,78 +503,95 @@ (illegal (lambda (expr) (error "Illegal expression:" expr)))) do-expr)) -(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 ' specializers))) + (values (reverse! names) + (reverse! (let loop ((specializers specializers)) + (if (and (pair? specializers) + (eq? ' (car specializers)) + (pair? (cdr specializers))) + (loop (cdr specializers)) + specializers))))))) \ No newline at end of file diff --git a/v7/src/star-parser/compile.scm b/v7/src/star-parser/compile.scm index 82e0c4045..e31e20d95 100644 --- a/v7/src/star-parser/compile.scm +++ b/v7/src/star-parser/compile.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -27,6 +27,5 @@ (for-each compile-file '("matcher" "parser" - "shared" - "synchk")) + "shared")) (cref/generate-constructors "parser"))) \ No newline at end of file diff --git a/v7/src/star-parser/load.scm b/v7/src/star-parser/load.scm index 3b0900087..89e6f1676 100644 --- a/v7/src/star-parser/load.scm +++ b/v7/src/star-parser/load.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -23,4 +23,4 @@ (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 diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm index be830b22b..8c0109b78 100644 --- a/v7/src/star-parser/matcher.scm +++ b/v7/src/star-parser/matcher.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -47,6 +47,8 @@ (if preprocessor (preprocessor expression external-bindings internal-bindings) expression))) + ((identifier? expression) + expression) ((string? expression) (preprocess-matcher-expression `(STRING ,expression) external-bindings @@ -75,18 +77,20 @@ 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 @@ -158,8 +162,8 @@ `(,(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)))) @@ -171,7 +175,8 @@ (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 @@ -186,21 +191,25 @@ ;;;; 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)) @@ -210,12 +219,13 @@ (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)) @@ -228,14 +238,19 @@ ,(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)) @@ -245,86 +260,87 @@ (make-eq-hash-table)) (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)))) (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) @@ -336,7 +352,7 @@ (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 diff --git a/v7/src/star-parser/parser.pkg b/v7/src/star-parser/parser.pkg index db9cbdb0f..cbc7221e2 100644 --- a/v7/src/star-parser/parser.pkg +++ b/v7/src/star-parser/parser.pkg @@ -1,8 +1,8 @@ ;;; -*-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 @@ -24,7 +24,7 @@ (global-definitions "../runtime/runtime") (define-package (runtime *parser) - (files "synchk" "shared" "matcher" "parser") + (files "shared" "matcher" "parser") (parent (runtime)) (export () *matcher diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm index e0cfe6afb..fe0bbf61d 100644 --- a/v7/src/star-parser/parser.scm +++ b/v7/src/star-parser/parser.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -47,6 +47,8 @@ (if preprocessor (preprocessor expression external-bindings internal-bindings) expression))) + ((identifier? expression) + expression) ((or (string? expression) (char? expression)) (preprocess-parser-expression `(NOISE ,expression) @@ -72,18 +74,20 @@ 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 @@ -175,21 +179,25 @@ ;;;; 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)) @@ -199,12 +207,13 @@ (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)) @@ -219,14 +228,19 @@ ,(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)) @@ -240,7 +254,7 @@ (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 @@ -251,7 +265,7 @@ (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))))) @@ -260,40 +274,41 @@ 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))) @@ -308,14 +323,16 @@ (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) @@ -330,15 +347,17 @@ (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) @@ -351,7 +370,7 @@ (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))) diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm index 70743f892..0400177d1 100644 --- a/v7/src/star-parser/shared.scm +++ b/v7/src/star-parser/shared.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -24,31 +24,41 @@ (declare (usual-integrations)) (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* @@ -133,15 +143,8 @@ (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*)) ;;;; Parser macros @@ -259,6 +262,9 @@ (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))) (define (make-kf-identifier) (generate-identifier 'KF)) diff --git a/v7/src/star-parser/synchk.scm b/v7/src/star-parser/synchk.scm deleted file mode 100644 index 95b59251a..000000000 --- a/v7/src/star-parser/synchk.scm +++ /dev/null @@ -1,76 +0,0 @@ -;;; -*-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)) - -(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 diff --git a/v7/src/swat/scheme/control-floating-errors.scm b/v7/src/swat/scheme/control-floating-errors.scm index 7ad15d3f8..de6f8ea37 100644 --- a/v7/src/swat/scheme/control-floating-errors.scm +++ b/v7/src/swat/scheme/control-floating-errors.scm @@ -20,12 +20,16 @@ (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 () diff --git a/v7/src/swat/scheme/load.scm b/v7/src/swat/scheme/load.scm index c410ff5df..72582f337 100644 --- a/v7/src/swat/scheme/load.scm +++ b/v7/src/swat/scheme/load.scm @@ -611,7 +611,6 @@ row-lists->col-lists run-queue-trace scc-define-structure ;macro - scc-define-syntax ;macro screen-area= scrollable-canvas-canvas scrollable-canvas-hscroll diff --git a/v7/src/swat/scheme/mit-xhooks.scm b/v7/src/swat/scheme/mit-xhooks.scm index 6951a8d9a..e93c43443 100644 --- a/v7/src/swat/scheme/mit-xhooks.scm +++ b/v7/src/swat/scheme/mit-xhooks.scm @@ -122,9 +122,10 @@ This is some debugging stuff for probing the space usage. (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)) @@ -156,11 +157,12 @@ end of debugging stuff (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) diff --git a/v7/src/swat/scheme/scc-macros.scm b/v7/src/swat/scheme/scc-macros.scm index 3805ce149..fce8a4d35 100644 --- a/v7/src/swat/scheme/scc-macros.scm +++ b/v7/src/swat/scheme/scc-macros.scm @@ -1,23 +1,10 @@ ;;;; -*-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 diff --git a/v7/src/wabbit/test-wabbit.scm b/v7/src/wabbit/test-wabbit.scm index 815569d26..176122d83 100644 --- a/v7/src/wabbit/test-wabbit.scm +++ b/v7/src/wabbit/test-wabbit.scm @@ -2,7 +2,7 @@ (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 $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -22,7 +22,7 @@ ;; - Document dependencies ;; - [SCREWS] see last page -;;; $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 $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -206,8 +206,10 @@ (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)))) diff --git a/v7/src/win32/ffimacro.scm b/v7/src/win32/ffimacro.scm index 28fb4559f..02aa7bbaf 100644 --- a/v7/src/win32/ffimacro.scm +++ b/v7/src/win32/ffimacro.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -96,131 +96,148 @@ to inside a string that is being used as the buffer). (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)))))))) (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 diff --git a/v7/src/win32/win32.sf b/v7/src/win32/win32.sf index f6d18f85b..245b559c9 100644 --- a/v7/src/win32/win32.sf +++ b/v7/src/win32/win32.sf @@ -1,8 +1,8 @@ #| -*-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 @@ -29,16 +29,6 @@ USA. (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-timestring 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) -- 2.25.1