summaryrefslogtreecommitdiffstats
path: root/macwork.scm
diff options
context:
space:
mode:
Diffstat (limited to 'macwork.scm')
-rw-r--r--macwork.scm126
1 files changed, 126 insertions, 0 deletions
diff --git a/macwork.scm b/macwork.scm
new file mode 100644
index 0000000..6336ae5
--- /dev/null
+++ b/macwork.scm
@@ -0,0 +1,126 @@
+;;;; "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.
+
+(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))
+
+(require 'common-list-functions)
+
+; 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)