blob: 2a6a93dd6a996b88b20430232cfa779ecc8f9799 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
;;;; "macwork.scm": Will Clinger's macros that work. -*- Scheme -*-
;Copyright 1992 William Clinger
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful purpose, and to redistribute this software
; is granted subject to the restriction that all copies made of this
; software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
(require 'common-list-functions)
(define mw:every every)
(define mw:union union)
(define mw:remove-if-not remove-if-not)
(slib:load (in-vicinity (program-vicinity) "mwexpand"))
;;;; Miscellaneous routines.
(define (mw:warn msg . more)
(display "WARNING from macro expander:")
(newline)
(display msg)
(newline)
(for-each (lambda (x) (write x) (newline))
more))
(define (mw:error msg . more)
(display "ERROR detected during macro expansion:")
(newline)
(display msg)
(newline)
(for-each (lambda (x) (write x) (newline))
more)
(mw:quit #f))
(define (mw:bug msg . more)
(display "BUG in macro expander: ")
(newline)
(display msg)
(newline)
(for-each (lambda (x) (write x) (newline))
more)
(mw:quit #f))
; Given a <formals>, returns a list of bound variables.
(define (mw:make-null-terminated x)
(cond ((null? x) '())
((pair? x)
(cons (car x) (mw:make-null-terminated (cdr x))))
(else (list x))))
; Returns the length of the given list, or -1 if the argument
; is not a list. Does not check for circular lists.
(define (mw:safe-length x)
(define (loop x n)
(cond ((null? x) n)
((pair? x) (loop (cdr x) (+ n 1)))
(else -1)))
(loop x 0))
; Given an association list, copies the association pairs.
(define (mw:syntax-copy alist)
(map (lambda (x) (cons (car x) (cdr x)))
alist))
;;;; Implementation-dependent parameters and preferences that determine
; how identifiers are represented in the output of the macro expander.
;
; The basic problem is that there are no reserved words, so the
; syntactic keywords of core Scheme that are used to express the
; output need to be represented by data that cannot appear in the
; input. This file defines those data.
; The following definitions assume that identifiers of mixed case
; cannot appear in the input.
;(define mw:begin1 (string->symbol "Begin"))
;(define mw:define1 (string->symbol "Define"))
;(define mw:quote1 (string->symbol "Quote"))
;(define mw:lambda1 (string->symbol "Lambda"))
;(define mw:if1 (string->symbol "If"))
;(define mw:set!1 (string->symbol "Set!"))
(define mw:begin1 'begin)
(define mw:define1 'define)
(define mw:quote1 'quote)
(define mw:lambda1 'lambda)
(define mw:if1 'if)
(define mw:set!1 'set!)
; The following defines an implementation-dependent expression
; that evaluates to an undefined (not unspecified!) value, for
; use in expanding the (define x) syntax.
(define mw:undefined (list (string->symbol "Undefined")))
; A variable is renamed by suffixing a vertical bar followed by a unique
; integer. In IEEE and R4RS Scheme, a vertical bar cannot appear as part
; of an identifier, but presumably this is enforced by the reader and not
; by the compiler. Any other character that cannot appear as part of an
; identifier may be used instead of the vertical bar.
(define mw:suffix-character #\!)
(slib:load (in-vicinity (program-vicinity) "mwdenote"))
(slib:load (in-vicinity (program-vicinity) "mwsynrul"))
;@
(define macro:expand macwork:expand)
;;; Here are EVAL, EVAL! and LOAD which expand macros. You can replace the
;;; implementation's eval and load with them if you like.
(define base:eval slib:eval)
;;(define base:load load)
;@
(define (macwork:eval x) (base:eval (macwork:expand x)))
(define macro:eval macwork:eval)
;@
(define (macwork:load <pathname>)
(slib:eval-load <pathname> macwork:eval))
(define macro:load macwork:load)
(provide 'macros-that-work)
(provide 'macro)
|
