[Wisp-cvs] wisp/src/builtin records.wisp,1.4,1.5 Makefile.am,1.37,1.38 ORDER,1.46,1.47 builtin.wisp,
Status: Alpha
Brought to you by:
digg
Menu
▾
▴
[Wisp-cvs] wisp/src/builtin records.wisp,1.4,1.5 Makefile.am,1.37,1.38 ORDER,1.46,1.47 builtin.wisp,1.208,1.209 macrobase.wisp,1.16,1.17 modular.wisp,1.60,1.61 preproc.wisp,1.5,1.6 stdenv.wisp,1.355,1.356 tostring.wisp,1.73,1.74
Update of /cvsroot/wisp/wisp/src/builtin
In directory usw-pr-cvs1:/tmp/cvs-serv29729/src/builtin
Modified Files:
Makefile.am ORDER builtin.wisp macrobase.wisp modular.wisp
preproc.wisp stdenv.wisp tostring.wisp
Added Files:
records.wisp
Log Message:
Made macros ordinary first-class objects.
Index: Makefile.am
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/Makefile.am,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- Makefile.am 31 Aug 2002 14:39:45 -0000 1.37
+++ Makefile.am 4 Sep 2002 14:29:47 -0000 1.38
@@ -11,6 +11,6 @@
case.wisp codegen.wisp cut.wisp cxr.wisp dictbase.wisp ewisp.wisp \
filing.wisp frer.wisp init.wisp lambda-parser.wisp lists.wisp \
locals.wisp macrobase.wisp modular.wisp pack.wisp parser.wisp \
- preproc.wisp objects.wisp rec.wisp semideque.wisp serial.wisp \
- stdenv.wisp strings.wisp symbols.wisp sys.wisp sysconst.wisp \
- sysenv.wisp tostring.wisp unix.wisp vectors.wisp
+ preproc.wisp objects.wisp rec.wisp records.wisp semideque.wisp \
+ serial.wisp stdenv.wisp strings.wisp symbols.wisp sys.wisp \
+ sysconst.wisp sysenv.wisp tostring.wisp unix.wisp vectors.wisp
Index: ORDER
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/ORDER,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -d -r1.46 -r1.47
--- ORDER 31 Aug 2002 14:39:45 -0000 1.46
+++ ORDER 4 Sep 2002 14:29:47 -0000 1.47
@@ -7,6 +7,7 @@
# @(#) $Id$
dictbase.wisp # all global variables depend on it
+records.wisp # macrobase.wisp depends on it
macrobase.wisp # macro definition depends on it
assert.wisp
builtin.wisp
Index: builtin.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/builtin.wisp,v
retrieving revision 1.208
retrieving revision 1.209
diff -u -d -r1.208 -r1.209
--- builtin.wisp 26 Aug 2002 16:20:07 -0000 1.208
+++ builtin.wisp 4 Sep 2002 14:29:47 -0000 1.209
@@ -40,24 +40,12 @@
;; that's OK as long as you remember to compile this file TWICE at
;; each modification.
-;; Another performance hint: it's allowed for macros to shadow
-;; functions. In that case, (foo ...) is interpreted as a macro
-;; call to foo , all other references to foo treat it like a
-;; function (or rather a variable since there's no difference
-;; between functions and variables). Thus, it's highly
-;; recommended to create both macro and function variants for
-;; little but frequently used things such as the cadaddamadarr
-;; things.
-;;
;; Beware that the (foo ...) forms within declaration of the
;; foo macro translate to calls to the function foo. If you
;; want a recursive macro, create one that returns a structure
;; that contains such forms. (defmacro (foo) '(foo)) (foo)
;; makes the compiler think it's a hamster in a wheel.
;; As a matter of fact, so does (metacode (let (loop) (loop))).
-;;
-;; If you explicitly want to invoke a function, not a macro,
-;; use (apply ...).
;;;; Numerical comparison
@@ -327,24 +315,10 @@
;;;; Environment manipulation
-;; An environment is just a dictionary which contains another dictionary
-;; called *macros*. Usually, only environments are used as home
-;; dictionaries for procedures (but this is not enforced in any way).
-
-(define (make-empty-env)
- (my d (make-dict)
- (dict-set! d '*macros* (make-dict))
- d))
-
-(define (env-copy source)
- (my d (dict-copy source)
- (dict-set! d '*macros* (dict-copy (dict-ref source '*macros*)))
- d))
-
(defmacro (current-globals)
`',*source-dictionary*)
-;;;; Formerly "String manipulations"
+;;;; Formerly "String manipulation"
(define (integer->string i (radix 10))
(%integer->string i radix))
@@ -352,7 +326,7 @@
(define (string->integer s (radix 10))
(%string->integer s radix))
-;;;; The standard cond
+;;;; The standard |cond|
(defmacro (cond clause . rest)
(cond
@@ -646,25 +620,5 @@
(vector? (list->vector (loop (vector->list s))))
(dict? (alist->dict (loop (dict->alist s))))
(else s))))
-
-(define (make-record-type slot-count . hooks)
- (my data ((asm NN_pr_make_record_type) slot-count)
- (my record-type (car data)
- (let ((ref-hook #f)
- (ref-hook? #f))
- (while (not (null? hooks))
- (my (hook-name hook-generator . rest-hooks) hooks
- (set! hooks rest-hooks)
- (case hook-name
- ((ref) (if ref-hook?
- (raise 'duplicate-ref-hook hook-generator)
- (begin
- (set! ref-hook? #t)
- (set! ref-hook (apply hook-generator data)))))
- (else (raise 'record-hook-name? hook-name)))))
- (if ref-hook?
- (set! ((asm NN_pr_record_type_ref_slot) record-type)
- ref-hook))))
- data))
; vim: lispwords+=,local
Index: macrobase.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/macrobase.wisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- macrobase.wisp 26 Aug 2002 16:18:24 -0000 1.16
+++ macrobase.wisp 4 Sep 2002 14:29:47 -0000 1.17
@@ -6,17 +6,32 @@
;;
;;;; @(#) $Id$
-(define *macros* (make-dict))
+(my (%<macro> %make-macro %macro-expander) (make-record-type 1)
+
+ (define <macro> %<macro>)
+
+ (define (procedure->macro p)
+ (if (not (or (evmfunc? p)
+ (native? p)))
+ (raise 'procedure? p))
+ (%make-macro p))
+
+ (define (macro->procedure m)
+ (%macro-expander m))
+
+ (define macro? (record-type-discriminator <macro>)))
(defmacro (defmacro template . body)
(cond
((cons? template)
- `(set! (dict-ref *macros* ',(car template))
- (lambda (*source-dictionary* . ,(cdr template)) . ,body)))
+ `(define ,(car template)
+ (procedure->macro
+ (lambda (*source-dictionary* . ,(cdr template)) . ,body))))
((and (symbol? template) (cons? body) (null? (cdr body)))
- `(set! (dict-ref *macros* ',template)
- (lambda (*source-dictionary* . .l)
- (apply (hide .l ,(car body)) .l))))
+ `(define ,template
+ (procedure->macro
+ (lambda (*source-dictionary* . .l)
+ (apply (hide .l ,(car body)) .l)))))
(else
(raise 'syntax-error `(defmacro ,template . ,body)))))
Index: modular.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/modular.wisp,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -d -r1.60 -r1.61
--- modular.wisp 26 Aug 2002 16:18:24 -0000 1.60
+++ modular.wisp 4 Sep 2002 14:29:47 -0000 1.61
@@ -19,7 +19,6 @@
(define (module-load f)
(let ((exports '())
- (mexports '())
(home-dict (regular-env)))
((if (port? f) read-all=> for-each)
(lambda (s)
@@ -27,23 +26,16 @@
((cons? s)
(case (car s)
((export) (cons! exports (cdr s)))
- ((export-macro) (cons! mexports (cdr s)))
((module)) ; ignore (module ...)
(else (eval s home-dict))))
(else (eval s home-dict))))
f)
(set! exports (flatten exports))
- (set! mexports (flatten mexports))
(for-each (lambda (name)
(if (not (fit-for-variable-name? name))
- (raise 'invalid-export (list 'export name))))
+ (raise 'invalid-export name)))
exports)
- (for-each (lambda (name)
- (if (not (fit-for-variable-name? name))
- (raise 'invalid-export (list 'export-macro name))))
- mexports)
- (cons (pick-dict-items home-dict exports)
- (pick-dict-items (dict-ref home-dict '*macros*) mexports))))
+ (pick-dict-items home-dict exports)))
(define modules (make-box '()))
@@ -76,7 +68,7 @@
exportion))))))))
(define (module-ref module-name (item-name #f))
- (my mod (car (%get-module module-name))
+ (my mod (%get-module module-name)
(if item-name
(my c (assq item-name mod)
(if c
@@ -84,24 +76,9 @@
(raise 'unknown item-name)))
(alist-copy mod))))
-(define (module-macro-ref module-name (macro-name #f))
- (my mod (cdr (%get-module module-name))
- (if macro-name
- (my c (assq macro-name mod)
- (if c
- (cdr c)
- (raise 'unknown macro-name)))
- (alist-copy mod))))
-
(define (real-use module-name target)
(my exportion (%get-module module-name)
- (alist->dict (car exportion) target)
- (my m (dict-ref target '*macros* #f)
- (if (not m)
- (begin
- (set! m (make-dict))
- (set! (dict-ref target '*macros*) m)))
- (alist->dict (cdr exportion) m)))
+ (alist->dict exportion target))
(begin))
(defmacro (use . names)
Index: preproc.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/preproc.wisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- preproc.wisp 26 Aug 2002 16:20:08 -0000 1.5
+++ preproc.wisp 4 Sep 2002 14:29:47 -0000 1.6
@@ -23,19 +23,6 @@
(else
(cons (car vars) (loop (cdr vars)))))))
-(define (cache-dict d . rest)
- (hache
- (cond
- ((null? rest)
- (lambda (x)
- (dict-ref d x)))
- ((null? (cdr rest))
- (my def (car rest)
- (lambda (x)
- (dict-ref d x def))))
- (else
- (raise 'argcount (cons d rest))))))
-
(define (drop-var index legacy)
(let (loop (l legacy))
(let ((item (car l))
@@ -54,7 +41,7 @@
;; - no (hide ...)
;; - no unquoted literals
;; - no entanglement outside literals
-;; - no unexpandeed macro references
+;; - no unexpanded macro references
;; - bodies of (lambda ...), (my ...), (return ...), (while ...) and
;; (WITHIN ...) always consist of a single item
;; - (DEFINE ...), (set! ...) and (while ...) only appear in void context
@@ -72,289 +59,285 @@
;; generator can't be passed to users directly.
(define (preprocess item env)
- (my fetch-macro (cache-dict (my macros (try (dict-ref env '*macros*)
- (except (unknown) '#f))
- (if (dict? macros)
- macros
- (make-dict)))
- '#f)
- (my gen-var (my var-counter (make-counter)
- (lambda #f
- (string->symbol ".v$(var-counter)")))
- (letrec (((expression x legacy)
- (cond
- ((symbol? x)
- (cond
- ((assq x legacy) => cdr)
- ((keyword? x) `',x)
- ((or (eq? x '$) (eq? x '$?)) x)
- ((fit-for-variable-name? x) (list 'GLOBAL x))
- (else (raise 'preprocessing-error x))))
- ((or (number? x) (boolean? x) (char? x) (string? x))
- `',x)
- ((cons? x)
- (my verb (car x)
- (my args (let (loop (l (cdr x)))
- (cond
- ((cons? l)
- (cons (car l) (loop (cdr l))))
- ((null? l)
- '())
- (else (raise 'form? x))))
- (if (symbol? verb)
- (case verb
- ; special forms
- ((asm)
- ;; Bare link is a special case
- (if (and (eq? verb 'asm) (cons? args) (null? (cdr args)))
- (if (or (symbol? (car args)) (string? (car args)))
- (cons 'asm args)
- (raise 'preprocessing-error x))
- (if (not (null? args))
- (cons verb
- (cons (let (loop (l (car args)))
- (cond
- ((null? l) '())
- ((cons? l)
- (cons (expression (car l) legacy)
- (loop (cdr l))))
- ((and (symbol? l) (assq l legacy)) => cdr)
- (else (raise 'preprocessing-error x))))
- (map (lambda (ins)
- (cond
- ((cons? ins)
- (cons (car ins)
- (cdr ins)))
- (else ins)))
- (cdr args))))
- (raise 'preprocessing-error x))))
- ((begin)
- (begin-form args legacy))
- ((CALL)
+ (my gen-var (my var-counter (make-counter)
+ (lambda #f
+ (string->symbol ".v$(var-counter)")))
+ (letrec (((expression x legacy)
+ (cond
+ ((symbol? x)
+ (cond
+ ((assq x legacy) => cdr)
+ ((keyword? x) `',x)
+ ((or (eq? x '$) (eq? x '$?)) x)
+ ((fit-for-variable-name? x) (list 'GLOBAL x))
+ (else (raise 'preprocessing-error x))))
+ ((or (number? x) (boolean? x) (char? x) (string? x))
+ `',x)
+ ((cons? x)
+ (my verb (car x)
+ (my args (let (loop (l (cdr x)))
+ (cond
+ ((cons? l)
+ (cons (car l) (loop (cdr l))))
+ ((null? l)
+ '())
+ (else (raise 'form? x))))
+ (if (symbol? verb)
+ (case verb
+ ; special forms
+ ((asm)
+ ;; Bare link is a special case
+ (if (and (eq? verb 'asm) (cons? args) (null? (cdr args)))
+ (if (or (symbol? (car args)) (string? (car args)))
+ (cons 'asm args)
+ (raise 'preprocessing-error x))
(if (not (null? args))
- (procedure-call (car args) (cdr args) legacy)
- (raise 'preprocessing-error x)))
- ((DEFINE)
- (if (= (length args) 2)
- (let ((target (car args))
- (expr (cadr args)))
- (if (fit-for-variable-name? target)
- (if (assq target legacy)
- (raise 'invalid-definition x)
+ (cons verb
+ (cons (let (loop (l (car args)))
+ (cond
+ ((null? l) '())
+ ((cons? l)
+ (cons (expression (car l) legacy)
+ (loop (cdr l))))
+ ((and (symbol? l) (assq l legacy)) => cdr)
+ (else (raise 'preprocessing-error x))))
+ (map (lambda (ins)
+ (cond
+ ((cons? ins)
+ (cons (car ins)
+ (cdr ins)))
+ (else ins)))
+ (cdr args))))
+ (raise 'preprocessing-error x))))
+ ((begin)
+ (begin-form args legacy))
+ ((CALL)
+ (if (not (null? args))
+ (procedure-call (car args) (cdr args) legacy)
+ (raise 'preprocessing-error x)))
+ ((DEFINE)
+ (if (= (length args) 2)
+ (let ((target (car args))
+ (expr (cadr args)))
+ (if (fit-for-variable-name? target)
+ (if (assq target legacy)
+ (raise 'invalid-definition x)
+ (list 'begin
+ (list 'DEFINE
+ target
+ (expression expr legacy))
+ (list 'quote (begin))))
+ (raise 'preprocessing-error x)))
+ (raise 'preprocessing-error x)))
+ ((GLOBAL)
+ (if (and (= (length args) 1)
+ (symbol? (car args)))
+ (cons 'GLOBAL args)
+ (raise 'preprocessing-error x)))
+ ((hide)
+ (if (not (null? args))
+ (my hiddee (expression (car args) legacy)
+ (if (symbol? hiddee)
+ (begin-form (cdr args) (drop-var hiddee legacy))
+ (raise 'preprocessing-error x)))
+ (raise 'preprocessing-error x)))
+ ((hold)
+ (if (not (null? (length args)))
+ (my v (gen-var)
+ (list 'my v (expression (car args) legacy)
(list 'begin
- (list 'DEFINE
- target
- (expression expr legacy))
- (list 'quote (begin))))
- (raise 'preprocessing-error x)))
- (raise 'preprocessing-error x)))
- ((GLOBAL)
- (if (and (= (length args) 1)
- (symbol? (car args)))
- (cons 'GLOBAL args)
- (raise 'preprocessing-error x)))
- ((hide)
- (if (not (null? args))
- (my hiddee (expression (car args) legacy)
- (if (symbol? hiddee)
- (begin-form (cdr args) (drop-var hiddee legacy))
- (raise 'preprocessing-error x)))
- (raise 'preprocessing-error x)))
- ((hold)
- (if (not (null? (length args)))
- (my v (gen-var)
- (list 'my v (expression (car args) legacy)
- (list 'begin
- (begin-form (cdr args) legacy)
- v)))))
- ((if)
- (case (length args)
- ((2 3)
- (cons 'if (expression-list args legacy)))
- (else
- (raise 'preprocessing-error x))))
- ((lambda)
- (if (>= (length args) 2)
- (my (() cc pl (() n:=?)) (parse-lambda-list (car args))
- (my v:=? (gen-var)
- (acons! legacy n:=? v:=?)
- (cond
- ((eqv? cc #\G)
- (set! cc #f))
- ((symbol? cc)
- (my v (gen-var)
- (acons! legacy cc v)
- (set! cc v))))
- ; traverse the lambda-list and rename non-optional
- ; variables
- (for-each (lambda (pli)
- (if pli
- (case (car pli)
- ((! *)
- (my v (gen-var)
- (acons! legacy (second pli) v)
- (set! (second pli) v)))
- ((?)))))
- pl)
- ; traverse the lambda-list and process optional variables
- (for-each (lambda (pli)
- (if (and pli (eq? (car pli) '?))
- (begin
- (set! (third pli)
- (expression (third pli) legacy))
+ (begin-form (cdr args) legacy)
+ v)))))
+ ((if)
+ (case (length args)
+ ((2 3)
+ (cons 'if (expression-list args legacy)))
+ (else
+ (raise 'preprocessing-error x))))
+ ((lambda)
+ (if (>= (length args) 2)
+ (my (() cc pl (() n:=?)) (parse-lambda-list (car args))
+ (my v:=? (gen-var)
+ (acons! legacy n:=? v:=?)
+ (cond
+ ((eqv? cc #\G)
+ (set! cc #f))
+ ((symbol? cc)
+ (my v (gen-var)
+ (acons! legacy cc v)
+ (set! cc v))))
+ ; traverse the lambda-list and rename non-optional
+ ; variables
+ (for-each (lambda (pli)
+ (if pli
+ (case (car pli)
+ ((! *)
(my v (gen-var)
(acons! legacy (second pli) v)
- (set! (second pli) v)))))
- pl)
- (list 'lambda
- (cons
- (list '() #f v:=?)
- (let (loop (pl pl))
- (cond
- ((null? pl)
- (if (symbol? cc)
- (list (list ':= cc))
- '()))
- ((not (car pl)) ; must be the last entry
- '#f)
- ((and (null? (cdr pl)) (eqv? cc #\S))
- (set! cc #f)
- (cons ':= (loop pl)))
- ((eq? (caar pl) '!)
- (cons (cadar pl)
- (loop (cdr pl))))
- ((eq? (caar pl) '*)
- (cons (cadar pl)
- (cons '...
- (loop (cdr pl)))))
- ((eq? (caar pl) '?)
- (cons (cdar pl)
- (loop (cdr pl))))
- (else
- (raise 'internal-trouble pl)))))
- (begin-form (cdr args) legacy))))
- (raise 'preprocessing-error x)))
- ((my)
- (if (>= (length args) 2)
- (let ((targets (car args))
- (expr (cadr args))
- (body (cddr args))
- (old-legacy legacy))
- (my vars '()
- (my new-targets (let (loop (tar targets))
- (cond
- ((null? tar) '())
- ((fit-for-variable-name? tar)
- (if (memq tar vars)
- (raise 'invalid-my-target targets))
- (my repl (gen-var)
- (my rc (cons tar repl)
- (cons! vars tar)
- (cons! legacy rc))
- repl))
- ((cons? tar)
- (my l (loop (car tar)) ; for ordering
- (cons l (loop (cdr tar)))))
- (else
- (raise 'invalid-my-target tar))))
- (list 'my new-targets (expression expr old-legacy)
- (begin-form body legacy)))))
- (raise 'preprocessing-error x)))
- ((OR)
- (if (= (length args) 2)
- (cons 'OR (expression-list args legacy))
- (raise 'preprocessing-error x)))
- ((quote)
- (if (= (length args) 1)
- (cons 'quote args)
- (raise 'preprocessing-error x)))
- ((set!)
- (if (= (length args) 2)
- (list 'begin
- (cons 'set! (expression-list args legacy))
- (list 'quote (begin)))
- (raise 'preprocessing-error x)))
- ((splicing)
- (if (= (length args) 1)
- (list 'splicing (expression (car args) legacy))
- (raise 'preprocessing-error x)))
- ((while)
- (if (not (null? args))
- (list 'begin
- (list 'while (expression (car args) legacy)
- (begin-form (cdr args) legacy))
- (list 'quote (begin)))
- (raise 'preprocessing-error x)))
- ((WITHIN)
- (if (>= (length args) 2)
- (my (class expr . body) args
- (if (symbol? class)
- (set! class (dict-ref env class)))
- (if (not (class? class))
- (raise 'class? class))
- (my old-legacy legacy
- ; FIXME: slot hidding doesn't work with this
- (my slots (map car (vector->list (class->vector class)))
- (for-each
- (lambda (slot)
- (if (string=?
- (symbol->string slot)[0 ... 2]
- ".v")
- (raise 'invalid-slot-name slot))
- (acons! legacy slot slot))
- slots))
- (list 'WITHIN class (expression expr old-legacy)
- (begin-form body legacy))))
- (raise 'preprocessing-error x)))
- (else
- (cond
- ((assq verb legacy) ; local procedure call
- (procedure-call verb args legacy))
- ((my mx (fetch-macro verb)
- (and (procedure? mx) mx)) ; macro
- => (lambda (mx)
- (expression (apply mx env args) legacy)))
- (else
- (procedure-call verb args legacy)))))
- (procedure-call verb args legacy)))))
- (else
- (raise 'preprocessing-error x))))
- ((procedure-call verb args legacy)
- (simple-procedure-call (expression verb legacy)
- (expression-list args legacy) legacy))
- ((simple-procedure-call verb args legacy)
- (cons
- (if (find (lambda (x)
- (and (cons? x)
- (eq? (car x) 'splicing)))
- args)
- 'VCALL 'CALL)
- (cons verb args)))
- ((expression-list items legacy)
- (map (cut expression <> legacy) items))
- ((begin-form items legacy)
- (set! items (map (lambda (item)
- (expression item legacy)) items))
- (set! items
- (unsure-collect
- (lambda (store approve)
- (store `',(begin))
- (letrec (((process item)
- (store item)
- (cond
- ((symbol? item)) ; no approval
- ((cons? item)
- (case (car item)
- ((GLOBAL lambda quote)) ; no approval
- ((begin) (for-each process (cdr item)))
- (else (approve))))
- (else (approve)))))
- (for-each process items))
- (approve))))
- (if (null? (cdr items))
- (car items)
- (cons 'begin items))))
- (expression item '())))))
+ (set! (second pli) v)))
+ ((?)))))
+ pl)
+ ; traverse the lambda-list and process optional variables
+ (for-each (lambda (pli)
+ (if (and pli (eq? (car pli) '?))
+ (begin
+ (set! (third pli)
+ (expression (third pli) legacy))
+ (my v (gen-var)
+ (acons! legacy (second pli) v)
+ (set! (second pli) v)))))
+ pl)
+ (list 'lambda
+ (cons
+ (list '() #f v:=?)
+ (let (loop (pl pl))
+ (cond
+ ((null? pl)
+ (if (symbol? cc)
+ (list (list ':= cc))
+ '()))
+ ((not (car pl)) ; must be the last entry
+ '#f)
+ ((and (null? (cdr pl)) (eqv? cc #\S))
+ (set! cc #f)
+ (cons ':= (loop pl)))
+ ((eq? (caar pl) '!)
+ (cons (cadar pl)
+ (loop (cdr pl))))
+ ((eq? (caar pl) '*)
+ (cons (cadar pl)
+ (cons '...
+ (loop (cdr pl)))))
+ ((eq? (caar pl) '?)
+ (cons (cdar pl)
+ (loop (cdr pl))))
+ (else
+ (raise 'internal-trouble pl)))))
+ (begin-form (cdr args) legacy))))
+ (raise 'preprocessing-error x)))
+ ((my)
+ (if (>= (length args) 2)
+ (let ((targets (car args))
+ (expr (cadr args))
+ (body (cddr args))
+ (old-legacy legacy))
+ (my vars '()
+ (my new-targets (let (loop (tar targets))
+ (cond
+ ((null? tar) '())
+ ((fit-for-variable-name? tar)
+ (if (memq tar vars)
+ (raise 'invalid-my-target targets))
+ (my repl (gen-var)
+ (my rc (cons tar repl)
+ (cons! vars tar)
+ (cons! legacy rc))
+ repl))
+ ((cons? tar)
+ (my l (loop (car tar)) ; for ordering
+ (cons l (loop (cdr tar)))))
+ (else
+ (raise 'invalid-my-target tar))))
+ (list 'my new-targets (expression expr old-legacy)
+ (begin-form body legacy)))))
+ (raise 'preprocessing-error x)))
+ ((OR)
+ (if (= (length args) 2)
+ (cons 'OR (expression-list args legacy))
+ (raise 'preprocessing-error x)))
+ ((quote)
+ (if (= (length args) 1)
+ (cons 'quote args)
+ (raise 'preprocessing-error x)))
+ ((set!)
+ (if (= (length args) 2)
+ (list 'begin
+ (cons 'set! (expression-list args legacy))
+ (list 'quote (begin)))
+ (raise 'preprocessing-error x)))
+ ((splicing)
+ (if (= (length args) 1)
+ (list 'splicing (expression (car args) legacy))
+ (raise 'preprocessing-error x)))
+ ((while)
+ (if (not (null? args))
+ (list 'begin
+ (list 'while (expression (car args) legacy)
+ (begin-form (cdr args) legacy))
+ (list 'quote (begin)))
+ (raise 'preprocessing-error x)))
+ ((WITHIN)
+ (if (>= (length args) 2)
+ (my (class expr . body) args
+ (if (symbol? class)
+ (set! class (dict-ref env class)))
+ (if (not (class? class))
+ (raise 'class? class))
+ (my old-legacy legacy
+ ; FIXME: slot hidding doesn't work with this
+ (my slots (map car (vector->list (class->vector class)))
+ (for-each
+ (lambda (slot)
+ (if (string=?
+ (symbol->string slot)[0 ... 2]
+ ".v")
+ (raise 'invalid-slot-name slot))
+ (acons! legacy slot slot))
+ slots))
+ (list 'WITHIN class (expression expr old-legacy)
+ (begin-form body legacy))))
+ (raise 'preprocessing-error x)))
+ (else
+ (cond
+ ((assq verb legacy) ; local procedure call
+ (procedure-call verb args legacy))
+ ((my mx (and (dict-ref env verb #f) -> mac
+ (macro? mac)
+ (macro->procedure mac))
+ (and (procedure? mx) mx)) ; macro
+ => (lambda (mx)
+ (expression (apply mx env args) legacy)))
+ (else
+ (procedure-call verb args legacy)))))
+ (procedure-call verb args legacy)))))
+ (else
+ (raise 'preprocessing-error x))))
+ ((procedure-call verb args legacy)
+ (simple-procedure-call (expression verb legacy)
+ (expression-list args legacy) legacy))
+ ((simple-procedure-call verb args legacy)
+ (cons
+ (if (find (lambda (x)
+ (and (cons? x)
+ (eq? (car x) 'splicing)))
+ args)
+ 'VCALL 'CALL)
+ (cons verb args)))
+ ((expression-list items legacy)
+ (map (cut expression <> legacy) items))
+ ((begin-form items legacy)
+ (set! items (map (lambda (item)
+ (expression item legacy)) items))
+ (set! items
+ (unsure-collect
+ (lambda (store approve)
+ (store `',(begin))
+ (letrec (((process item)
+ (store item)
+ (cond
+ ((symbol? item)) ; no approval
+ ((cons? item)
+ (case (car item)
+ ((GLOBAL lambda quote)) ; no approval
+ ((begin) (for-each process (cdr item)))
+ (else (approve))))
+ (else (approve)))))
+ (for-each process items))
+ (approve))))
+ (if (null? (cdr items))
+ (car items)
+ (cons 'begin items))))
+ (expression item '()))))
(define (optimize-source item home-dict)
(my gen-var (my var-counter (make-counter)
Index: stdenv.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/stdenv.wisp,v
retrieving revision 1.355
retrieving revision 1.356
diff -u -d -r1.355 -r1.356
--- stdenv.wisp 4 Sep 2002 14:28:37 -0000 1.355
+++ stdenv.wisp 4 Sep 2002 14:29:47 -0000 1.356
@@ -50,22 +50,23 @@
(cons 'list
(map (lambda (x) `(cons ',x ,x))
'(* *stderr* *stdin* *stdout* + - / /= < << <= <box>
- <c16string> <class> <file> <port> <record-type> = > >= >>
- abs address-of alist->dict alist-copy analyse append
- append-reverse apply assert-object-type assoc assq assv
- atom? big-integer? bit? bitstring-ref boolean? box-empty!
- box-empty? box-ref box? broketed? c16string? c8string?
- caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr
- cadar caddar cadddr caddr cadr call-with-in/out-files
- call-with-input-file call-with-output-file car car*
- cardinal? catch cdaaar cdaadr cdaar cdadar cdaddr cdadr
- cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr cdr*
- ceiling cfmakeraw char->control-char char->integer
- char-and char-bit-clear char-bit-set char-bit-toggle
- char-bit? char-decimal? char-digit? char-downcase
- char-hexadecimal? char-letter-modifier? char-letter?
- char-lower-case? char-mirrored? char-number-letter?
- char-octal? char-or char-order char-punctuation-close?
+ <c16string> <class> <file> <macro> <port> <record-type> =
+ > >= >> abs acons! address-of alist->dict alist-copy
+ analyse and append append-reverse apply assert
+ assert-object-type assoc assq assv atom? big-integer? bind
+ bit? bitstring-ref boolean? box-empty! box-empty? box-ref
+ box? broketed? c16string? c8string? caaaar caaadr caaar
+ caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr
+ caddr cadr call-with-in/out-files call-with-input-file
+ call-with-output-file car car! car* cardinal? case catch
+ cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr
+ cddar cdddar cddddr cdddr cddr cdr cdr! cdr* ceiling
+ cfmakeraw char->control-char char->integer char-and
+ char-bit-clear char-bit-set char-bit-toggle char-bit?
+ char-decimal? char-digit? char-downcase char-hexadecimal?
+ char-letter-modifier? char-letter? char-lower-case?
+ char-mirrored? char-number-letter? char-octal? char-or
+ char-order char-punctuation-close?
char-punctuation-connector? char-punctuation-dash?
char-punctuation-final-quote?
char-punctuation-initial-quote? char-punctuation-open?
@@ -78,53 +79,58 @@
char8? char<=? char<? char=? char>=? char>? char?
circular-list class->vector class-discriminator class-of
class-slots class? close-input-port close-output-port
- close-port collect collect-string compile concatenate cons
- cons-copy cons? construct-filename denominator desv desv+r
- dict->alist dict-bind! dict-copy dict-defined? dict-drop!
- dict-fetch dict-ref dict? drop duplicate-dict-item!
- dwim-stringify eighth env-copy env-ref eof-object? eq?
- equal? eqv? eval even? evmfunc? exit fifth file-ctime
- file-descriptor file-mtime file-stat file-type file?
- filter find find-tail first fit-for-symbol?
- fit-for-variable-name? fixnum? flatten floor
- for-all-env-vars for-dir-entries for-each fourth fraction?
- freeze-class frer->structure hache init-port input-port?
- instance? integer->char integer->string integer?
- intermingle keyword? last-cons length list list->semideque
+ close-port collect collect-string compile concatenate cond
+ cons cons! cons-copy cons? construct-filename
+ current-globals cut cute decr! define define-class
+ defmacro denominator desv desv+r dict->alist dict-bind!
+ dict-copy dict-defined? dict-drop! dict-fetch dict-ref
+ dict? dis do drop duplicate-dict-item! dwim-stringify
+ eighth env-ref eof-object? eq? equal? eqv? eval even?
+ evmfunc? exit fifth file-ctime file-descriptor file-mtime
+ file-stat file-type file? filter find find-tail first
+ fit-for-symbol? fit-for-variable-name? fixnum? flatten
+ floor for-all-env-vars for-dir-entries for-each fourth
+ fraction? freeze-class frer->structure gimme hache hide*
+ incr! init-port input-port? instance? integer->char
+ integer->string integer? intermingle keyword? lambda-pack
+ last-cons length let let* letrec list list->semideque
list->vector list-copy list-ref list? load lookup-slot
- make-box make-c16string make-c8string make-class
- make-counter make-dict make-empty-env make-instance
- make-record-type make-string make-vector map meaning
- member memq memv modify-bit module-macro-ref module-ref
- modulo native? negative? newline ninth not null-list?
- null? number->string number? numerator nybble? nyp? odd?
- open-input-file open-output-file order->dict output-port?
- pack-be-integer pack-le-integer parse-character-body
- parse-lambda-list peek-char peek-string pick-dict-items
- port? portio-debugging positive? preprocess print
- procedure? provide-semiraw-files provide-syscalls quotient
- raise rassoc rassq rassv rational->cons rational? read
- read-all=> read-char read-char-sequence
- read-character-body read-directory read-line read-string
- read-whole-file real? record-type-discriminator
- record-type-referrer record-type-slot-count record-type?
- reduce-index ref remainder reverse round run-ewisp-file
- sbyte? second seek semideque semideque->list
- semideque-bottom semideque-insert! semideque-pop!
- semideque-push! semideque-top seventh signal sixth slice
+ macro->procedure macro? make-box make-c16string
+ make-c8string make-class make-counter make-dict
+ make-instance make-record-type make-string make-vector map
+ meaning member memq memv metacode modify-bit module
+ module-ref modulo my-port native? negative? newline ninth
+ not null-list? null? number->string number? numerator
+ nybble? nyp? odd? open-input-file open-output-file opt or
+ order->dict output-port? pack-be-integer pack-le-integer
+ parse-character-body parse-lambda-list peek-char
+ peek-string pick-dict-items port? portio-debugging
+ positive? prep preprocess print procedure->macro
+ procedure? provide-semiraw-files provide-syscalls
+ quasiquote quotient raise rassoc rassq rassv
+ rational->cons rational? read read-all=> read-char
+ read-char-sequence read-character-body read-directory
+ read-line read-string read-whole-file real? rec
+ record-type-discriminator record-type-referrer
+ record-type-slot-count record-type? reduce-index ref
+ remainder reverse round run-ewisp-file sbyte? second seek
+ semideque semideque->list semideque-bottom
+ semideque-insert! semideque-pop! semideque-push!
+ semideque-top serial seventh signal sixth slice
split-by-char string string->c16string string->c8string
string->integer string->list string->number string->symbol
string-append string-concatenate string-copy
string-downcase string-downcase! string-fill! string-join
string-length string-move! string-null? string-ref
string-upcase string-upcase! string<=? string<? string=?
- string>=? string>? string? structure->string subclass?
- substring superclass swyde? symbol->string symbol-length
- symbol-ref symbol<=? symbol<? symbol>=? symbol>? symbol?
- system-constant tcchangeattr tcgetattr tcgetattr-raw
- tcsetattr-raw tenth third toposplit translate tree-copy
- truncate tty? type-of ubyte? unix-time unpack-be-integer
- unpack-le-integer unsure-collect utf-8->c16string
+ string>=? string>? string? structure->string sub subclass?
+ substring superclass swap! swyde? symbol->string
+ symbol-length symbol-ref symbol<=? symbol<? symbol>=?
+ symbol>? symbol? system-constant tcchangeattr tcgetattr
+ tcgetattr-raw tcsetattr-raw tenth third toposplit
+ translate tree-copy truncate try tty? type type-of ubyte?
+ unix-time unpack-be-integer unpack-le-integer
+ unsure-collect use utf-8->c16string
utf-8-first-byte->length uwyde? vector vector->list
vector-append vector-copy vector-fill! vector-length
vector-move! vector-ref vector? void? wisp-string-hash
@@ -141,7 +147,7 @@
; scan module export lists
((let (loop (modules (box-ref modules)))
(and (cons? modules)
- (my (module-name . (objexl)) (car modules)
+ (my (module-name . objexl) (car modules)
(or (and (rassq obj objexl) -> mec
(list (car mec)
'use module-name))
@@ -156,7 +162,6 @@
(set! (dict-ref e 'wisp-version) (string-copy wisp-version))
(set! (dict-ref e 'wisp-build) (string-copy wisp-build))
(set! (dict-ref e 'wisp-builder) (string-copy wisp-builder))
- (set! (dict-ref e '*macros*) (dict-copy *macros*))
e)))
(define origin *origin)
(define regular-env *regular-env))
Index: tostring.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/tostring.wisp,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -d -r1.73 -r1.74
--- tostring.wisp 31 Aug 2002 14:30:24 -0000 1.73
+++ tostring.wisp 4 Sep 2002 14:29:47 -0000 1.74
@@ -63,6 +63,19 @@
(list copy seen-twice unrecognized)
copy))))
+; works on both procedures and macros
+(define (procedure-remark s)
+ (cond
+ ((and (procedure? s) (meaning s)) ; macros do not have meaning
+ => (lambda (m)
+ (if (cons? m)
+ "$,[m]"
+ "($,[m])")))
+ ((origin s)
+ => (lambda (o)
+ "$(car o) of $(cdr o)"))
+ (else #f)))
+
(define (structure->string s)
(my (copy dupl) (topocopy s #t)
(for-each (lambda (c)
@@ -188,14 +201,17 @@
((procedure? s)
(emit "#<")
(emit (if (native? s) "native" "procedure"))
- (my m (meaning s)
- (if m
- (begin
+ (and (procedure-remark s) -> r
+ (begin
(emit #\space)
- (loop
- (if (cons? m)
- m
- (list m))))))
+ (emit r)))
+ (emit #\>))
+ ((macro? s)
+ (emit "#<macro")
+ (and (procedure-remark s) -> r
+ (begin
+ (emit #\space)
+ (emit r)))
(emit #\>))
((void? s) (emit "#<void>"))
((class? s)
|
