From: Chris Hanson Date: Thu, 20 Dec 2001 20:51:16 +0000 (+0000) Subject: Eliminate DEFINE-MACRO special form. X-Git-Tag: 20090517-FFI~2330 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7668b9c4c97b0fa334a7ca0559dca1d81e362bd4;p=mit-scheme.git Eliminate DEFINE-MACRO special form. --- diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 8022e7e73..597a6b445 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: utils.scm,v 4.20 1999/01/02 06:06:43 cph Exp $ +$Id: utils.scm,v 4.21 2001/12/20 20:51:15 cph Exp $ Copyright (c) 1987-1999 Massachusetts Institute of Technology @@ -62,7 +62,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (symbol->string (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA) ((eq? prefix lambda-tag:let) 'LET) - ((eq? prefix lambda-tag:make-environment) 'MAKE-ENVIRONMENT) ((eq? prefix lambda-tag:fluid-let) 'FLUID-LET) (else prefix))) "-" diff --git a/v7/src/compiler/etc/comcmp.scm b/v7/src/compiler/etc/comcmp.scm index 240c9e438..3e93a2b0b 100644 --- a/v7/src/compiler/etc/comcmp.scm +++ b/v7/src/compiler/etc/comcmp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: comcmp.scm,v 1.7 2001/08/10 17:28:20 cph Exp $ +$Id: comcmp.scm,v 1.8 2001/12/20 20:51:15 cph Exp $ Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology @@ -27,8 +27,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (if (unassigned? compiled-code-block/bytes-per-object) (set! compiled-code-block/bytes-per-object 4)) -(define-macro (ucode-type name) - (microcode-type name)) +(define-syntax ucode-type + (lambda (name) + (microcode-type name))) (define comcmp:ignore-debugging-info? #t) (define comcmp:show-differing-blocks? #f) diff --git a/v7/src/compiler/machines/i386/instr1.scm b/v7/src/compiler/machines/i386/instr1.scm index b7b06e01a..2b5f88f42 100644 --- a/v7/src/compiler/machines/i386/instr1.scm +++ b/v7/src/compiler/machines/i386/instr1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: instr1.scm,v 1.12 2001/12/16 06:01:31 cph Exp $ +$Id: instr1.scm,v 1.13 2001/12/20 20:51:15 cph Exp $ Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology @@ -30,13 +30,14 @@ USA. ;; Utility -(define-macro (define-trivial-instruction mnemonic opcode . extra) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode)) - ,@(map (lambda (extra) - `(BYTE (8 ,extra))) - extra)))) +(define-syntax define-trivial-instruction + (lambda (mnemonic opcode . extra) + `(define-instruction ,mnemonic + (() + (BYTE (8 ,opcode)) + ,@(map (lambda (extra) + `(BYTE (8 ,extra))) + extra))))) ;;;; Pseudo ops diff --git a/v7/src/compiler/machines/i386/instr2.scm b/v7/src/compiler/machines/i386/instr2.scm index 2669812a0..a54fa3300 100644 --- a/v7/src/compiler/machines/i386/instr2.scm +++ b/v7/src/compiler/machines/i386/instr2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: instr2.scm,v 1.6 1999/01/02 06:06:43 cph Exp $ +$Id: instr2.scm,v 1.7 2001/12/20 20:51:15 cph Exp $ -Copyright (c) 1992, 1999 Massachusetts Institute of Technology +Copyright (c) 1992, 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 @@ -16,7 +16,8 @@ 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. |# ;;;; Intel i386 Instruction Set, part II @@ -29,13 +30,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;; Utility -(define-macro (define-trivial-instruction mnemonic opcode . extra) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode)) - ,@(map (lambda (extra) - `(BYTE (8 ,extra))) - extra)))) +(define-syntax define-trivial-instruction + (lambda (mnemonic opcode . extra) + `(define-instruction ,mnemonic + (() + (BYTE (8 ,opcode)) + ,@(map (lambda (extra) + `(BYTE (8 ,extra))) + extra))))) ;;;; Actual instructions diff --git a/v7/src/compiler/machines/i386/instrf.scm b/v7/src/compiler/machines/i386/instrf.scm index 28a3c806f..f0477472a 100644 --- a/v7/src/compiler/machines/i386/instrf.scm +++ b/v7/src/compiler/machines/i386/instrf.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: instrf.scm,v 1.14 1999/01/02 06:06:43 cph Exp $ +$Id: instrf.scm,v 1.15 2001/12/20 20:51:15 cph Exp $ -Copyright (c) 1992, 1999 Massachusetts Institute of Technology +Copyright (c) 1992, 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 @@ -16,7 +16,6 @@ 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. |# ;;;; Intel i387/i486 Instruction Set @@ -88,13 +87,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define-binary-flonum FSUB FSUBP FISUB 4 #xe0 #xe8) (define-binary-flonum FSUBR FSUBPR FISUBR 5 #xe8 #xe0)) -(define-macro (define-trivial-instruction mnemonic opcode . extra) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode)) - ,@(map (lambda (extra) - `(BYTE (8 ,extra))) - extra)))) +(define-syntax define-trivial-instruction + (lambda (mnemonic opcode . extra) + `(define-instruction ,mnemonic + (() + (BYTE (8 ,opcode)) + ,@(map (lambda (extra) + `(BYTE (8 ,extra))) + extra))))) (define-trivial-instruction F2XM1 #xd9 #xf0) (define-trivial-instruction FABS #xd9 #xe1) diff --git a/v7/src/compiler/machines/spectrum/instr2.scm b/v7/src/compiler/machines/spectrum/instr2.scm index a91e3faf1..5457a55c6 100644 --- a/v7/src/compiler/machines/spectrum/instr2.scm +++ b/v7/src/compiler/machines/spectrum/instr2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: instr2.scm,v 1.7 1999/01/02 06:06:43 cph Exp $ +$Id: instr2.scm,v 1.8 2001/12/20 20:51:15 cph Exp $ -Copyright (c) 1987-1999 Massachusetts Institute of Technology +Copyright (c) 1987-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 @@ -16,7 +16,8 @@ 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. |# ;;;; HP Spectrum Instruction Set Description @@ -534,14 +535,16 @@ branch-extend-nullify in instr1. (1 (branch-extend-nullify disp (car compl))) (1 (branch-extend-disp disp) ASSEMBLE17:Z))))))))) - (define-macro (defcond name opcode1 opcode2 opr1) - `(defccbranch ,name complaltfb ,opcode1 ,opcode2 ,opr1)) + (define-syntax defcond + (lambda (name opcode1 opcode2 opr1) + `(defccbranch ,name complaltfb ,opcode1 ,opcode2 ,opr1))) - (define-macro (defpseudo name opcode opr1) - `(defccbranch ,name complalb - (TF-adjust ,opcode (cdr compl)) - (TF-adjust-inverted ,opcode (cdr compl)) - ,opr1)) + (define-syntax defpseudo + (lambda (name opcode opr1) + `(defccbranch ,name complalb + (TF-adjust ,opcode (cdr compl)) + (TF-adjust-inverted ,opcode (cdr compl)) + ,opr1))) (defcond COMBT #x20 #x22 (reg-1)) (defcond COMBF #x22 #x20 (reg-1)) @@ -644,14 +647,16 @@ Note: Only those currently used by the code generator are implemented. (1 1) (1 (branch-extend-disp disp) ASSEMBLE17:Z))))))))) - (define-macro (defcond name opcode1 opcode2 opr1) - `(defccbranch ,name complaltf ,opcode1 ,opcode2 ,opr1)) + (define-syntax defcond + (lambda (name opcode1 opcode2 opr1) + `(defccbranch ,name complaltf ,opcode1 ,opcode2 ,opr1))) - (define-macro (defpseudo name opcode opr1) - `(defccbranch ,name complal - (TF-adjust ,opcode compl) - (TF-adjust-inverted ,opcode compl) - ,opr1)) + (define-syntax defpseudo + (lambda (name opcode opr1) + `(defccbranch ,name complal + (TF-adjust ,opcode compl) + (TF-adjust-inverted ,opcode compl) + ,opr1))) (defcond COMIBTN #X21 #x23 (immed-5 right-signed)) (defcond COMIBFN #X23 #x21 (immed-5 right-signed)) diff --git a/v7/src/compiler/machines/vax/instr1.scm b/v7/src/compiler/machines/vax/instr1.scm index e5200b6a5..1139614f8 100644 --- a/v7/src/compiler/machines/vax/instr1.scm +++ b/v7/src/compiler/machines/vax/instr1.scm @@ -1,9 +1,8 @@ #| -*-Scheme-*- -$Id: instr1.scm,v 1.7 1999/01/02 06:06:43 cph Exp $ -$MC68020-Header: instr1.scm,v 1.66 88/06/14 08:47:12 GMT cph Exp $ +$Id: instr1.scm,v 1.8 2001/12/20 20:51:16 cph Exp $ -Copyright (c) 1987, 1989, 1999 Massachusetts Institute of Technology +Copyright (c) 1987, 1989, 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 @@ -17,7 +16,8 @@ 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. |# ;;;; VAX Instruction Set Description, Part 1 @@ -58,10 +58,11 @@ opcodes are ;; Utility -(define-macro (define-trivial-instruction mnemonic opcode) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode))))) +(define-syntax define-trivial-instruction + (lambda (mnemonic opcode) + `(define-instruction ,mnemonic + (() + (BYTE (8 ,opcode)))))) ;; Pseudo ops diff --git a/v7/src/compiler/machines/vax/instr2.scm b/v7/src/compiler/machines/vax/instr2.scm index 2193098bd..0aa5119d3 100644 --- a/v7/src/compiler/machines/vax/instr2.scm +++ b/v7/src/compiler/machines/vax/instr2.scm @@ -1,9 +1,8 @@ #| -*-Scheme-*- -$Id: instr2.scm,v 1.6 1999/01/02 06:06:43 cph Exp $ -$MC68020-Header: instr2.scm,v 1.16 88/10/20 16:11:07 GMT markf Exp $ +$Id: instr2.scm,v 1.7 2001/12/20 20:51:16 cph Exp $ -Copyright (c) 1987, 1989, 1999 Massachusetts Institute of Technology +Copyright (c) 1987, 1989, 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 @@ -17,7 +16,8 @@ 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. |# ;;;; VAX Instruction Set Description, Part 2 @@ -26,10 +26,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (declare (usual-integrations)) -(define-macro (define-trivial-instruction mnemonic opcode) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode))))) +(define-syntax define-trivial-instruction + (lambda (mnemonic opcode) + `(define-instruction ,mnemonic + (() + (BYTE (8 ,opcode)))))) (define-instruction CVT ((B W (? src ea-r-b) (? dst ea-w-w)) diff --git a/v7/src/compiler/machines/vax/instr3.scm b/v7/src/compiler/machines/vax/instr3.scm index 3d312d8bb..fde83baa6 100644 --- a/v7/src/compiler/machines/vax/instr3.scm +++ b/v7/src/compiler/machines/vax/instr3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: instr3.scm,v 1.10 1999/01/02 06:06:43 cph Exp $ +$Id: instr3.scm,v 1.11 2001/12/20 20:51:16 cph Exp $ -Copyright (c) 1987, 1989, 1991, 1999 Massachusetts Institute of Technology +Copyright (c) 1987, 1989, 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 @@ -16,7 +16,8 @@ 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. |# ;;;; VAX Instruction Set Description, Part 3 @@ -25,10 +26,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (declare (usual-integrations)) -(define-macro (define-trivial-instruction mnemonic opcode) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode))))) +(define-syntax define-trivial-instruction + (lambda (mnemonic opcode) + `(define-instruction ,mnemonic + (() + (BYTE (8 ,opcode)))))) (define-instruction ASH ((L (? cnt ea-r-b) (? src ea-r-l) (? dst ea-w-l)) diff --git a/v7/src/edwin/regexp.scm b/v7/src/edwin/regexp.scm index 6307bc2c9..fe086e548 100644 --- a/v7/src/edwin/regexp.scm +++ b/v7/src/edwin/regexp.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: regexp.scm,v 1.75 2001/02/05 18:16:00 cph Exp $ +;;; $Id: regexp.scm,v 1.76 2001/12/20 20:51:16 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -154,26 +154,29 @@ (group-delete! group start (re-match-end-index 0)) (make-mark group start))) -(define-macro (default-end-mark start end) - `(IF (DEFAULT-OBJECT? ,end) - (GROUP-END ,start) - (BEGIN - (IF (NOT (MARK<= ,start ,end)) - (ERROR "Marks incorrectly related:" ,start ,end)) - ,end))) +(define-syntax default-end-mark + (lambda (start end) + `(IF (DEFAULT-OBJECT? ,end) + (GROUP-END ,start) + (BEGIN + (IF (NOT (MARK<= ,start ,end)) + (ERROR "Marks incorrectly related:" ,start ,end)) + ,end)))) -(define-macro (default-start-mark start end) - `(IF (DEFAULT-OBJECT? ,start) - (GROUP-START ,end) - (BEGIN - (IF (NOT (MARK<= ,start ,end)) - (ERROR "Marks incorrectly related:" ,start ,end)) - ,start))) +(define-syntax default-start-mark + (lambda (start end) + `(IF (DEFAULT-OBJECT? ,start) + (GROUP-START ,end) + (BEGIN + (IF (NOT (MARK<= ,start ,end)) + (ERROR "Marks incorrectly related:" ,start ,end)) + ,start)))) -(define-macro (default-case-fold-search case-fold-search mark) - `(IF (DEFAULT-OBJECT? ,case-fold-search) - (GROUP-CASE-FOLD-SEARCH (MARK-GROUP ,mark)) - ,case-fold-search)) +(define-syntax default-case-fold-search + (lambda (case-fold-search mark) + `(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) diff --git a/v7/src/edwin/search.scm b/v7/src/edwin/search.scm index c9d9f16a1..6525a32dc 100644 --- a/v7/src/edwin/search.scm +++ b/v7/src/edwin/search.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;;$Id: search.scm,v 1.150 1999/01/02 06:11:34 cph Exp $ +;;;$Id: search.scm,v 1.151 2001/12/20 20:51:16 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -264,21 +264,23 @@ (and index (make-mark group index))))) -(define-macro (default-end-mark start end) - `(IF (DEFAULT-OBJECT? ,end) - (GROUP-END ,start) - (BEGIN - (IF (NOT (MARK<= ,start ,end)) - (ERROR "Marks incorrectly related:" ,start ,end)) - ,end))) +(define-syntax default-end-mark + (lambda (start end) + `(IF (DEFAULT-OBJECT? ,end) + (GROUP-END ,start) + (BEGIN + (IF (NOT (MARK<= ,start ,end)) + (ERROR "Marks incorrectly related:" ,start ,end)) + ,end)))) -(define-macro (default-start-mark start end) - `(IF (DEFAULT-OBJECT? ,start) - (GROUP-START ,end) - (BEGIN - (IF (NOT (MARK<= ,start ,end)) - (ERROR "Marks incorrectly related:" ,start ,end)) - ,start))) +(define-syntax default-start-mark + (lambda (start end) + `(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 3846b9513..f6fc0982c 100644 --- a/v7/src/edwin/syntax.scm +++ b/v7/src/edwin/syntax.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: syntax.scm,v 1.86 2001/12/18 22:12:30 cph Exp $ +;;; $Id: syntax.scm,v 1.87 2001/12/20 20:51:16 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -191,21 +191,23 @@ a comment ending." ;;;; Lisp Parsing -(define-macro (default-end/forward start end) - `(COND ((DEFAULT-OBJECT? ,end) - (GROUP-END ,start)) - ((MARK<= ,start ,end) - ,end) - (ELSE - (ERROR "Marks incorrectly related:" ,start ,end)))) - -(define-macro (default-end/backward start end) - `(COND ((DEFAULT-OBJECT? ,end) - (GROUP-START ,start)) - ((MARK>= ,start ,end) - ,end) - (ELSE - (ERROR "Marks incorrectly related:" ,start ,end)))) +(define-syntax default-end/forward + (lambda (start end) + `(COND ((DEFAULT-OBJECT? ,end) + (GROUP-END ,start)) + ((MARK<= ,start ,end) + ,end) + (ELSE + (ERROR "Marks incorrectly related:" ,start ,end))))) + +(define-syntax default-end/backward + (lambda (start end) + `(COND ((DEFAULT-OBJECT? ,end) + (GROUP-START ,start)) + ((MARK>= ,start ,end) + ,end) + (ELSE + (ERROR "Marks incorrectly related:" ,start ,end))))) (define (forward-prefix-chars start #!optional end) (let ((group (mark-group start)) diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 0b0642314..127e02b21 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: utils.scm,v 1.48 2001/05/10 18:22:34 cph Exp $ +;;; $Id: utils.scm,v 1.49 2001/12/20 20:51:16 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -54,15 +54,17 @@ '(N-WORDS OPERATOR) standard-error-handler)) -(define-macro (chars-to-words-shift) - ;; 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! - (let ((chars-per-word (vector-ref ((ucode-primitive gc-space-status 0)) 0))) - (case chars-per-word - ((4) -2) - ((8) -3) - (else (error "Can't support this word size:" chars-per-word))))) +(define-syntax chars-to-words-shift + (lambda () + ;; 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! + (let ((chars-per-word + (vector-ref ((ucode-primitive gc-space-status 0)) 0))) + (case chars-per-word + ((4) -2) + ((8) -3) + (else (error "Can't support this word size:" chars-per-word)))))) (define (edwin-string-allocate n-chars) (if (not (fix:fixnum? n-chars)) diff --git a/v7/src/microcode/os2pm.scm b/v7/src/microcode/os2pm.scm index d71036a7e..b8101c94b 100644 --- a/v7/src/microcode/os2pm.scm +++ b/v7/src/microcode/os2pm.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: os2pm.scm,v 1.8 1999/01/02 06:11:34 cph Exp $ +$Id: os2pm.scm,v 1.9 2001/12/20 20:51:16 cph Exp $ -Copyright (c) 1995-1999 Massachusetts Institute of Technology +Copyright (c) 1995-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 @@ -16,7 +16,8 @@ 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. |# ;;;; Program to generate OS/2 PM interface code. @@ -50,35 +51,37 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; Syntax -(define-macro (define-pm-procedure name . clauses) - (let ((external-name (if (pair? name) (car name) name)) - (internal-name (if (pair? name) (cadr name) name))) - `(BEGIN - (HASH-TABLE/PUT! PM-PROCEDURES ',external-name - (MAKE-PMP (TRANSLATE-NAME ',external-name) - (TRANSLATE-NAME ',internal-name) - ,(let ((clause (assq 'VALUE clauses))) - (if clause - (let ((val (cadr clause))) - (if (symbol? val) - (if (eq? val 'SYNC) - `',val - `(TRANSLATE-TYPE/NAME ',`((ID ,val) ,val))) - `(TRANSLATE-TYPE/NAME ',val))) - '#F)) - ,(let ((args - (let ((clause (assq 'ARGUMENTS clauses))) - (if (not clause) - (error "ARGUMENTS clause is required:" name)) - (cdr clause)))) - `(CONS (TRANSLATE-TYPE/NAME - ',(if (symbol? (car args)) - `((ID ,(car args)) ,(car args)) - (car args))) - (LIST ,@(map (lambda (arg) - `(TRANSLATE-TYPE/NAME ',arg)) - (cdr args))))))) - ',external-name))) +(define-syntax define-pm-procedure + (lambda (name . clauses) + (let ((external-name (if (pair? name) (car name) name)) + (internal-name (if (pair? name) (cadr name) name))) + `(BEGIN + (HASH-TABLE/PUT! PM-PROCEDURES ',external-name + (MAKE-PMP (TRANSLATE-NAME ',external-name) + (TRANSLATE-NAME ',internal-name) + ,(let ((clause (assq 'VALUE clauses))) + (if clause + (let ((val (cadr clause))) + (if (symbol? val) + (if (eq? val 'SYNC) + `',val + `(TRANSLATE-TYPE/NAME + ',`((ID ,val) ,val))) + `(TRANSLATE-TYPE/NAME ',val))) + '#F)) + ,(let ((args + (let ((clause (assq 'ARGUMENTS clauses))) + (if (not clause) + (error "ARGUMENTS clause is required:" name)) + (cdr clause)))) + `(CONS (TRANSLATE-TYPE/NAME + ',(if (symbol? (car args)) + `((ID ,(car args)) ,(car args)) + (car args))) + (LIST ,@(map (lambda (arg) + `(TRANSLATE-TYPE/NAME ',arg)) + (cdr args))))))) + ',external-name)))) (define (translate-type/name tn) (cond ((and (pair? tn) diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm index b8d6c8fb0..aaa4ba83a 100644 --- a/v7/src/microcode/utabmd.scm +++ b/v7/src/microcode/utabmd.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: utabmd.scm,v 9.79 2001/09/25 05:42:04 cph Exp $ +;;; $Id: utabmd.scm,v 9.80 2001/12/20 20:51:16 cph Exp $ ;;; ;;; Copyright (c) 1987-2001 Massachusetts Institute of Technology ;;; @@ -574,8 +574,9 @@ ;;; [] System-call names -(define-macro (ucode-primitive . args) - (apply make-primitive-procedure args)) +(define-syntax ucode-primitive + (lambda args + (apply make-primitive-procedure args))) (vector-set! (get-fixed-objects-vector) #x09 ;(fixed-objects-vector-slot 'SYSTEM-CALL-NAMES) @@ -606,4 +607,4 @@ ;;; This identification string is saved by the system. -"$Id: utabmd.scm,v 9.79 2001/09/25 05:42:04 cph Exp $" +"$Id: utabmd.scm,v 9.80 2001/12/20 20:51:16 cph Exp $" diff --git a/v7/src/runtime/arith.scm b/v7/src/runtime/arith.scm index 535dad4dd..f1a9b8b69 100644 --- a/v7/src/runtime/arith.scm +++ b/v7/src/runtime/arith.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: arith.scm,v 1.45 1999/01/02 06:11:34 cph Exp $ +$Id: arith.scm,v 1.46 2001/12/20 20:51:16 cph Exp $ -Copyright (c) 1989-1999 Massachusetts Institute of Technology +Copyright (c) 1989-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 @@ -16,7 +16,8 @@ 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. |# ;;;; Scheme Arithmetic @@ -26,8 +27,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; Utilities -(define-macro (copy x) - `(LOCAL-DECLARE ((INTEGRATE ,x)) ,x)) +(define-syntax copy + (lambda (x) + `(LOCAL-DECLARE ((INTEGRATE ,x)) ,x))) ;;;; Primitives diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index a98edb96d..63d78d782 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: debug.scm,v 14.40 1999/12/20 23:08:22 cph Exp $ +$Id: debug.scm,v 14.41 2001/12/20 20:51:16 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +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 @@ -16,7 +16,8 @@ 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. |# ;;;; Debugger @@ -205,13 +206,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define command-set) -(define-macro (define-command 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)))) +(define-syntax define-command + (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))))) ;;;; Display commands diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index ee599ae60..97890d62f 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.52 2001/12/19 05:21:37 cph Exp $ +$Id: error.scm,v 14.53 2001/12/20 20:51:16 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -411,16 +411,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (car restarts) (loop (cdr restarts)))))) -(define-macro (restarts-default 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))) +(define-syntax restarts-default + (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)))) (define (find-restart name #!optional restarts) (guarantee-symbol name 'FIND-RESTART) diff --git a/v7/src/runtime/os2winp.scm b/v7/src/runtime/os2winp.scm index a8760bbcf..1a82c5235 100644 --- a/v7/src/runtime/os2winp.scm +++ b/v7/src/runtime/os2winp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: os2winp.scm,v 1.15 1999/01/02 06:11:34 cph Exp $ +$Id: os2winp.scm,v 1.16 2001/12/20 20:51:16 cph Exp $ -Copyright (c) 1995-1999 Massachusetts Institute of Technology +Copyright (c) 1995-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 @@ -16,7 +16,8 @@ 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. |# ;;;; OS/2 PM Interface -- Primitives @@ -111,16 +112,17 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define-integrable (event-wid event) (vector-ref event 1)) (define-integrable (set-event-wid! event wid) (vector-set! event 1 wid)) -(define-macro (define-event 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))))))) +(define-syntax define-event + (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)))))))) ;; 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 9203a7ff2..a8f240f1b 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: parse.scm,v 14.33 1999/05/15 02:50:34 cph Exp $ +$Id: parse.scm,v 14.34 2001/12/20 20:51:16 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +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 @@ -16,7 +16,8 @@ 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. |# ;;;; Scheme Parser @@ -274,21 +275,22 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define *parser-associate-positions?*) (define *parser-current-position*) -(define-macro (define-accretor 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))) - (if *parser-associate-positions?* - (recording-object-position ,offset core) - (core)))))) +(define-syntax define-accretor + (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))) + (IF *PARSER-ASSOCIATE-POSITIONS?* + (RECORDING-OBJECT-POSITION ,offset CORE) + (CORE))))))) (define (current-position-getter port) (cond ((input-port/operation port 'POSITION) diff --git a/v7/src/runtime/recslot.scm b/v7/src/runtime/recslot.scm index 1e61f53ee..b4612dbf2 100644 --- a/v7/src/runtime/recslot.scm +++ b/v7/src/runtime/recslot.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: recslot.scm,v 1.4 1999/01/02 06:11:34 cph Exp $ +;;; $Id: recslot.scm,v 1.5 2001/12/20 20:51:16 cph Exp $ ;;; -;;; Copyright (c) 1995-1999 Massachusetts Institute of Technology +;;; Copyright (c) 1995-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 @@ -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. ;;;; Record Slot Access @@ -43,12 +44,13 @@ (and index (%record-initpred index))))) -(define-macro (generate-index-cases index limit expand-case) - `(CASE ,index - ,@(let loop ((i 1)) - (if (= i limit) - `((ELSE (,expand-case ,index))) - `(((,i) (,expand-case ,i)) ,@(loop (+ i 1))))))) +(define-syntax generate-index-cases + (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)))))))) (define (%record-accessor index) (generate-index-cases index 16 diff --git a/v7/src/runtime/rgxcmp.scm b/v7/src/runtime/rgxcmp.scm index b66c074db..93ae6cd8b 100644 --- a/v7/src/runtime/rgxcmp.scm +++ b/v7/src/runtime/rgxcmp.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rgxcmp.scm,v 1.116 2001/09/25 05:07:50 cph Exp $ +;;; $Id: rgxcmp.scm,v 1.117 2001/12/20 20:51:16 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -26,16 +26,17 @@ ;;;; Compiled Opcodes -(define-macro (define-enumeration name prefix . suffixes) - `(BEGIN - ,@(let loop ((n 0) (suffixes suffixes)) - (if (null? suffixes) - '() - (cons `(DEFINE-INTEGRABLE ,(symbol-append prefix (car suffixes)) - ,n) - (loop (1+ n) (cdr suffixes))))) - (DEFINE ,name - (VECTOR ,@(map (lambda (suffix) `',suffix) suffixes))))) +(define-syntax define-enumeration + (lambda (name prefix . suffixes) + `(BEGIN + ,@(let loop ((n 0) (suffixes suffixes)) + (if (null? suffixes) + '() + (cons `(DEFINE-INTEGRABLE ,(symbol-append prefix (car suffixes)) + ,n) + (loop (1+ n) (cdr suffixes))))) + (DEFINE ,name + (VECTOR ,@(map (lambda (suffix) `',suffix) suffixes)))))) (define-enumeration re-codes re-code: diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index 775cbdb03..b0c048d0c 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: syntax.scm,v 14.44 2001/12/20 20:38:29 cph Exp $ +$Id: syntax.scm,v 14.45 2001/12/20 20:51:16 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -63,7 +63,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; Syntax extensions (DEFINE-SYNTAX ,syntax/define-syntax) - (DEFINE-MACRO ,syntax/define-macro) (LET-SYNTAX ,syntax/let-syntax) (MACRO ,syntax/lambda) @@ -446,13 +445,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (syntax-eval (syntax-subexpression value))) name) -(define (syntax/define-macro top-level? pattern . body) - top-level? - (let ((keyword (car pattern))) - (syntax-table/define *syntax-table* keyword - (syntax-eval (apply syntax/named-lambda #f pattern body))) - keyword)) - (define-integrable (syntax-eval scode) (extended-scode-eval scode syntaxer/default-environment)) diff --git a/v7/src/sos/instance.scm b/v7/src/sos/instance.scm index d0cbee156..fd1f47e81 100644 --- a/v7/src/sos/instance.scm +++ b/v7/src/sos/instance.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: instance.scm,v 1.11 2001/12/20 03:13:05 cph Exp $ +;;; $Id: instance.scm,v 1.12 2001/12/20 20:51:16 cph Exp $ ;;; -;;; Copyright (c) 1995-2000 Massachusetts Institute of Technology +;;; Copyright (c) 1995-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 @@ -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. ;;;; Instances @@ -27,92 +28,100 @@ ;;; First define macros to be used below, because the syntaxer ;;; requires them to appear before their first reference. -(define-macro (constructor-case 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)))))) +(define-syntax constructor-case + (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))))))) -(define-macro (instance-constructor-1 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))) +(define-syntax instance-constructor-1 + (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)))) -(define-macro (instance-constructor-2 n-slots n-init-args) - (let ((make-names - (lambda (n prefix) - (make-initialized-list n - (lambda (index) - (intern (string-append prefix (number->string index)))))))) - (call-with-values - (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))))) - (else - (values 'IVS `((APPLY 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))) - ,(generator '()))))))) +(define-syntax instance-constructor-2 + (lambda (n-slots n-init-args) + (let ((make-names + (lambda (n prefix) + (make-initialized-list n + (lambda (index) + (intern (string-append prefix (number->string index)))))))) + (call-with-values + (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))))) + (else + (values 'IVS `((APPLY 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))) + ,(generator '())))))))) -(define-macro (ucode-type . arguments) - (apply microcode-type arguments)) +(define-syntax ucode-type + (lambda arguments + (apply microcode-type arguments))) -(define-macro (instance-constructor-3 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)) +(define-syntax instance-constructor-3 + (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))) (define (instance-constructor class slot-names #!optional init-arg-names) (if (not (subclass? class )) @@ -168,61 +177,64 @@ (else (instance-constructor-3 (fix:= n-slots) n-slots () ())))))) -(define-macro (make-initialization-1 if-n) - `(IF (< IV-N 8) - (CONSTRUCTOR-CASE IV-N 0 8 MAKE-INITIALIZATION-2 ,if-n) - (MAKE-INITIALIZATION-2 ,if-n #F))) +(define-syntax make-initialization-1 + (lambda (if-n) + `(IF (< IV-N 8) + (CONSTRUCTOR-CASE IV-N 0 8 MAKE-INITIALIZATION-2 ,if-n) + (MAKE-INITIALIZATION-2 ,if-n #F)))) -(define-macro (make-initialization-2 if-n iv-n) - (if (and if-n iv-n) - (let ((generate - (let ((make-names - (lambda (n prefix) +(define-syntax make-initialization-2 + (lambda (if-n iv-n) + (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/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm index bb712b1df..fe1795ebc 100644 --- a/v7/src/star-parser/matcher.scm +++ b/v7/src/star-parser/matcher.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: matcher.scm,v 1.26 2001/12/20 06:39:41 cph Exp $ +;;; $Id: matcher.scm,v 1.27 2001/12/20 20:51:16 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -225,13 +225,14 @@ ,(delay-call ks kf) ,(delay-call kf))) -(define-macro (define-matcher 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)))) +(define-syntax define-matcher + (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))))) (define (define-matcher-compiler keyword arity compiler) (hash-table/put! matcher-compilers keyword (cons arity compiler)) @@ -240,10 +241,11 @@ (define matcher-compilers (make-eq-hash-table)) -(define-macro (define-atomic-matcher form test-expression) - `(DEFINE-MATCHER ,form - POINTER - (WRAP-EXTERNAL-MATCHER ,test-expression KS KF))) +(define-syntax define-atomic-matcher + (lambda (form test-expression) + `(DEFINE-MATCHER ,form + POINTER + (WRAP-EXTERNAL-MATCHER ,test-expression KS KF)))) (define-atomic-matcher (char char) `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* (PROTECT ,char))) diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm index edcfc1b5f..f6eabf431 100644 --- a/v7/src/star-parser/parser.scm +++ b/v7/src/star-parser/parser.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: parser.scm,v 1.29 2001/12/20 06:40:11 cph Exp $ +;;; $Id: parser.scm,v 1.30 2001/12/20 20:51:16 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -216,13 +216,14 @@ ,(delay-call ks v kf) ,(delay-call kf))))) -(define-macro (define-parser 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)))) +(define-syntax define-parser + (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))))) (define (define-parser-compiler keyword arity compiler) (hash-table/put! parser-compilers keyword (cons arity compiler)) diff --git a/v7/src/swat/scheme/control-floating-errors.scm b/v7/src/swat/scheme/control-floating-errors.scm index a4cdc4b89..683955c8a 100644 --- a/v7/src/swat/scheme/control-floating-errors.scm +++ b/v7/src/swat/scheme/control-floating-errors.scm @@ -19,13 +19,14 @@ (declare (usual-integrations)) -(define-macro (deflap name . lap) - `(define ,name - (scode-eval - ',((access lap->code (->environment '(compiler top-level))) - name - lap) - system-global-environment))) +(define-syntax deflap + (lambda (name . lap) + `(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/win32/win_ffi.scm b/v7/src/win32/win_ffi.scm index c2d70b5ef..74e87e628 100644 --- a/v7/src/win32/win_ffi.scm +++ b/v7/src/win32/win_ffi.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: win_ffi.scm,v 1.6 1999/01/02 06:19:10 cph Exp $ +$Id: win_ffi.scm,v 1.7 2001/12/20 20:51:16 cph Exp $ -Copyright (c) 1993, 1999 Massachusetts Institute of Technology +Copyright (c) 1993, 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 @@ -16,7 +16,8 @@ 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. |# ;;;; Foreign function interface @@ -52,42 +53,44 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. "Bad argument type for foreign procedure: " type 'value: arg)) -(define-macro (call-case n) -;; Generate code like this: -;; (lambda (module-entry) -;; (let ((arg1-type (list-ref arg-types 0)) -;; (arg2-type (list-ref arg-types 1))) -;; (lambda (arg1 arg2) -;; (result-type (%call-foreign-function -;; (module-entry/machine-address module-entry) -;; (arg1-type arg1) -;; (arg2-type arg2))))))) - - (define (map-index f i n) - (if (<= i n) - (cons (f i) (map-index f (1+ i) n)) - '())) - (define (->string thing) - (cond ((string? thing) thing) - ((symbol? thing) (symbol-name thing)) - ((number? thing) (number->string thing)))) - (define (concat . things) - (string->symbol (apply string-append (map ->string things)))) - - (let* ((arg-names (map-index (lambda (i) (concat "arg" i)) 1 n)) - (type-names (map-index (lambda (i) (concat "arg" i "-type")) 1 n)) - (indexes (map-index identity-procedure 1 n)) - (type-binds (map (lambda (type-name index) - `(,type-name (list-ref arg-types ,(- index 1)))) - type-names indexes)) - (conversions (map list type-names arg-names))) - - `(lambda (module-entry) - (let ,type-binds - (lambda ,arg-names - (result-type (%call-foreign-function - (module-entry/machine-address module-entry) - . ,conversions))))))) +(define-syntax call-case + (lambda (n) + #| + ;; Generate code like this: + (lambda (module-entry) + (let ((arg1-type (list-ref arg-types 0)) + (arg2-type (list-ref arg-types 1))) + (lambda (arg1 arg2) + (result-type (%call-foreign-function + (module-entry/machine-address module-entry) + (arg1-type arg1) + (arg2-type arg2))))))) + |# + (define (map-index f i n) + (if (<= i n) + (cons (f i) (map-index f (1+ i) n)) + '())) + (define (->string thing) + (cond ((string? thing) thing) + ((symbol? thing) (symbol-name thing)) + ((number? thing) (number->string thing)))) + (define (concat . things) + (string->symbol (apply string-append (map ->string things)))) + + (let* ((arg-names (map-index (lambda (i) (concat "arg" i)) 1 n)) + (type-names (map-index (lambda (i) (concat "arg" i "-type")) 1 n)) + (indexes (map-index identity-procedure 1 n)) + (type-binds (map (lambda (type-name index) + `(,type-name (list-ref arg-types ,(- index 1)))) + type-names indexes)) + (conversions (map list type-names arg-names))) + + `(lambda (module-entry) + (let ,type-binds + (lambda ,arg-names + (result-type (%call-foreign-function + (module-entry/machine-address module-entry) + . ,conversions)))))))) (define (make-windows-procedure lib name result-type . arg-types)