#| -*-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
(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)))
"-"
#| -*-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
(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)
#| -*-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
\f
;; 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
#| -*-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
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
;; 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)))))
\f
;;;; Actual instructions
#| -*-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
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
(define-binary-flonum FSUB FSUBP FISUB 4 #xe0 #xe8)
(define-binary-flonum FSUBR FSUBPR FISUBR 5 #xe8 #xe0))
\f
-(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)
#| -*-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
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
(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))
(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))
#| -*-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
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
\f
;; 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
#| -*-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
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
(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))))))
\f
(define-instruction CVT
((B W (? src ea-r-b) (? dst ea-w-w))
#| -*-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
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
(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))))))
\f
(define-instruction ASH
((L (? cnt ea-r-b) (? src ea-r-l) (? dst ea-w-l))
;;; -*-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
;;;
(group-delete! group start (re-match-end-index 0))
(make-mark group start)))
\f
-(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)
;;; -*-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
;;;
(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))
;;; -*-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
;;;
\f
;;;; 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))
;;; -*-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
;;;
'(N-WORDS OPERATOR)
standard-error-handler))
\f
-(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))
#| -*-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
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.
\f
;;;; 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)
;;; -*-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
;;;
\f
;;; [] 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)
;;; 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 $"
#| -*-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
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
\f
;;;; Utilities
-(define-macro (copy x)
- `(LOCAL-DECLARE ((INTEGRATE ,x)) ,x))
+(define-syntax copy
+ (lambda (x)
+ `(LOCAL-DECLARE ((INTEGRATE ,x)) ,x)))
;;;; Primitives
#| -*-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
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
(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)))))
\f
;;;; Display commands
#| -*-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
(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))))
\f
(define (find-restart name #!optional restarts)
(guarantee-symbol name 'FIND-RESTART)
#| -*-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
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
(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)
#| -*-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
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
(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)
;;; -*-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
;;;
;;; 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
(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
;;; -*-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
;;;
\f
;;;; 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:
#| -*-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
;; Syntax extensions
(DEFINE-SYNTAX ,syntax/define-syntax)
- (DEFINE-MACRO ,syntax/define-macro)
(LET-SYNTAX ,syntax/let-syntax)
(MACRO ,syntax/lambda)
(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))
;;; -*-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
;;;
;;; 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
;;; 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)))
\f
-(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 <instance>))
(else
(instance-constructor-3 (fix:= n-slots) n-slots () ()))))))
\f
-(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
;;; -*-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
;;;
,(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))
(define matcher-compilers
(make-eq-hash-table))
\f
-(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)))
;;; -*-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
;;;
,(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))
(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 ()
#| -*-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
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
"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)
projects / mit-scheme.git / commitdiff