Update of /cvsroot/scsh/scsh-0.6/scheme/bcomp
In directory usw-pr-cvs1:/tmp/cvs-serv24517/scheme/bcomp
Modified Files:
name.scm package-undef.scm package.scm rules.scm syntax.scm
transform.scm usual.scm
Log Message:
Merged in macro expander changes from Scheme 48 0.56.
Index: name.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/bcomp/name.scm,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -r1.1.1.1 -r1.2
*** name.scm 1999/09/14 12:44:55 1.1.1.1
--- name.scm 2001/07/09 14:15:05 1.2
***************
*** 20,26 ****
(define-record-type generated :generated
! (make-generated symbol token env parent-name)
generated?
! (symbol generated-symbol)
(token generated-token)
(env generated-env)
--- 20,26 ----
(define-record-type generated :generated
! (make-generated name token env parent-name)
generated?
! (name generated-name)
(token generated-token)
(env generated-env)
***************
*** 29,36 ****
(define-record-discloser :generated
(lambda (name)
! (list 'generated (generated-symbol name) (generated-uid name))))
! (define (generate-name symbol env parent-name) ;for opt/inline.scm
! (make-generated symbol (cons #f #f) env parent-name)) ;foo
(define (generated-uid generated-name)
--- 29,36 ----
(define-record-discloser :generated
(lambda (name)
! (list 'generated (generated-name name) (generated-uid name))))
! (define (generate-name name env parent-name) ;for opt/inline.scm
! (make-generated name (cons #f #f) env parent-name))
(define (generated-uid generated-name)
***************
*** 47,51 ****
(if (symbol? name)
name
! (string->symbol (string-append (symbol->string (generated-symbol name))
"##"
(number->string (generated-uid name))))))
--- 47,52 ----
(if (symbol? name)
name
! (string->symbol (string-append (symbol->string
! (name->symbol (generated-name name)))
"##"
(number->string (generated-uid name))))))
***************
*** 55,63 ****
(string-hash (symbol->string name)))
((generated? name)
! (name-hash (generated-symbol name)))
(else
(error "invalid name" name))))
! (define make-name-table (make-table-maker eq? name-hash))
; Used by QUOTE to turn generated names back into symbols
--- 56,65 ----
(string-hash (symbol->string name)))
((generated? name)
! (name-hash (generated-name name)))
(else
(error "invalid name" name))))
! (define make-name-table
! (make-table-maker eq? name-hash))
; Used by QUOTE to turn generated names back into symbols
***************
*** 70,74 ****
(make-immutable! thing))
((generated? thing)
! (desyntaxify (generated-symbol thing)))
((pair? thing)
(make-immutable!
--- 72,76 ----
(make-immutable! thing))
((generated? thing)
! (desyntaxify (generated-name thing)))
((pair? thing)
(make-immutable!
***************
*** 98,102 ****
; A qualified name is a generated name that has been translated into a path.
; For example, if syntax A introduces a reference to procedure B, then the
! ; reference to B, as a qualified name, will be #(>> A B). If B has refers
; C and is substituted in-line, then the reference to C is #(>> #(>> A B) C).
; The binding for C can be located by going to the structure which supplies A,
--- 100,104 ----
; A qualified name is a generated name that has been translated into a path.
; For example, if syntax A introduces a reference to procedure B, then the
! ; reference to B, as a qualified name, will be #(>> A B). If B refers to
; C and is substituted in-line, then the reference to C is #(>> #(>> A B) C).
; The binding for C can be located by going to the structure which supplies A,
***************
*** 115,118 ****
--- 117,121 ----
(define (qualified-parent-name q) (vector-ref q 1))
(define (qualified-symbol q) (vector-ref q 2))
+ (define (qualified-uid q) (vector-ref q 3))
; Convert an alias (generated name) to S-expression form ("qualified name").
***************
*** 122,132 ****
name)
((let ((d0 (lookup env name))
! (d1 (lookup env (generated-symbol name))))
(and d0 d1 (same-denotation? d0 d1)))
! (generated-symbol name)) ;+++
(else
(make-qualified (qualify-parent (generated-parent-name name)
env)
! (generated-symbol name)
(generated-uid name)))))
--- 125,135 ----
name)
((let ((d0 (lookup env name))
! (d1 (lookup env (generated-name name))))
(and d0 d1 (same-denotation? d0 d1)))
! (generated-name name)) ;+++
(else
(make-qualified (qualify-parent (generated-parent-name name)
env)
! (generated-name name)
(generated-uid name)))))
***************
*** 138,141 ****
--- 141,147 ----
; is replaced with
; #(>> define-record-type record-ref)
+ ;
+ ; I think that this is buggy. The RECUR calls are using the wrong
environment.
+ ; ENV is not the environment in which the names will be looked up.
(define (qualify-parent name env)
***************
*** 158,162 ****
(recur parent) ;+++
(make-qualified (recur parent)
! (generated-symbol name)
(generated-uid name))))
name)))
--- 164,168 ----
(recur parent) ;+++
(make-qualified (recur parent)
! (generated-name name)
(generated-uid name))))
name)))
Index: package-undef.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/bcomp/package-undef.scm,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -r1.1.1.1 -r1.2
*** package-undef.scm 1999/09/14 12:44:55 1.1.1.1
--- package-undef.scm 2001/07/09 14:15:05 1.2
***************
*** 93,97 ****
(if (generated? name)
(note-caching! (generated-env name)
! (generated-symbol name)
place)
(let ((package (cenv->package cenv)))
--- 93,97 ----
(if (generated? name)
(note-caching! (generated-env name)
! (generated-name name)
place)
(let ((package (cenv->package cenv)))
***************
*** 104,108 ****
(if (generated? name)
(get-location-for-unassignable (generated-env name)
! (generated-symbol name))
(let ((package (cenv->package cenv)))
(warn "invalid assignment" name)
--- 104,108 ----
(if (generated? name)
(get-location-for-unassignable (generated-env name)
! (generated-name name))
(let ((package (cenv->package cenv)))
(warn "invalid assignment" name)
***************
*** 116,120 ****
(if (generated? name)
(get-location-for-undefined (generated-env name)
! (generated-symbol name))
(let ((package (cenv->package cenv)))
((or (fluid $note-undefined)
--- 116,120 ----
(if (generated? name)
(get-location-for-undefined (generated-env name)
! (generated-name name))
(let ((package (cenv->package cenv)))
((or (fluid $note-undefined)
***************
*** 172,176 ****
(if (generated? name)
(add-name (generated-env name)
! (generated-symbol name))
(add-name env name)))
(lambda ()
--- 172,176 ----
(if (generated? name)
(add-name (generated-env name)
! (generated-name name))
(add-name env name)))
(lambda ()
***************
*** 201,205 ****
(write (map (lambda (name)
(if (generated? name)
! (generated-symbol name)
name))
(reverse names))
--- 201,205 ----
(write (map (lambda (name)
(if (generated? name)
! (generated-name name)
name))
(reverse names))
Index: package.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/bcomp/package.scm,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -r1.1.1.1 -r1.2
*** package.scm 1999/09/14 12:44:55 1.1.1.1
--- package.scm 2001/07/09 14:15:05 1.2
***************
*** 315,319 ****
; Access path is (generated-parent-name name)
(generic-lookup (generated-env name)
! (generated-symbol name)))
(else
(search-opens (package-opens-really package) name integrate?)))))
--- 315,319 ----
; Access path is (generated-parent-name name)
(generic-lookup (generated-env name)
! (generated-name name)))
(else
(search-opens (package-opens-really package) name integrate?)))))
Index: rules.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/bcomp/rules.scm,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -r1.1.1.1 -r1.2
*** rules.scm 1999/09/14 12:44:55 1.1.1.1
--- rules.scm 2001/07/09 14:15:05 1.2
***************
*** 18,31 ****
(rules (cddr exp)))
(if (and (list? subkeywords)
! (every name? subkeywords))
;; Pair of the procedure and list of auxiliary names
! `(,(r 'cons) ;should be 'transformer
! ,(process-rules rules subkeywords r c)
! (,(r 'quote)
! ,(find-free-names-in-syntax-rules subkeywords rules)))
! exp))
exp))
'(append and car cdr cond cons else eq? equal? lambda let let* map
! pair? quote values))
--- 18,31 ----
(rules (cddr exp)))
(if (and (list? subkeywords)
! (every name? subkeywords))
;; Pair of the procedure and list of auxiliary names
! `(,(r 'cons) ;should be 'transformer
! ,(process-rules rules subkeywords r c)
! (,(r 'quote)
! ,(find-free-names-in-syntax-rules subkeywords rules)))
! exp))
exp))
'(append and car cdr cond cons else eq? equal? lambda let let* map
! pair? quote code-quote values))
***************
*** 50,53 ****
--- 50,54 ----
(define %pair? (r 'pair?))
(define %quote (r 'quote))
+ (define %code-quote (r 'code-quote))
(define %rename (r 'rename))
(define %tail (r 'tail))
***************
*** 80,84 ****
(cond ((name? pattern)
(if (member pattern subkeywords)
! `((,%compare ,input (,%rename ',pattern)))
`()))
((segment-pattern? pattern)
--- 81,85 ----
(cond ((name? pattern)
(if (member pattern subkeywords)
! `((,%compare ,input (,%rename (,%code-quote ,pattern))))
`()))
((segment-pattern? pattern)
***************
*** 135,139 ****
(syntax-error "template dimension error (too few ...'s?)"
template))
! `(,%rename ',template))))
((segment-template? template)
(let* ((depth (segment-depth template))
--- 136,140 ----
(syntax-error "template dimension error (too few ...'s?)"
template))
! `(,%rename (,%code-quote ,template)))))
((segment-template? template)
(let* ((depth (segment-depth template))
***************
*** 161,165 ****
`(,%cons ,(process-template (car template) dim env)
,(process-template (cdr template) dim env)))
! (else `(,%quote ,template))))
; Return an association list of (var . dim)
--- 162,167 ----
`(,%cons ,(process-template (car template) dim env)
,(process-template (cdr template) dim env)))
! (else
! `(,%quote ,template))))
; Return an association list of (var . dim)
Index: syntax.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/bcomp/syntax.scm,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -r1.1.1.1 -r1.2
*** syntax.scm 1999/09/14 12:44:55 1.1.1.1
--- syntax.scm 2001/07/09 14:15:05 1.2
***************
*** 179,183 ****
; This returns a single node, either a LETREC, if there are internal
definitions,
! ; or a BEGIN if there aren't any.
(define (expand-body body env)
--- 179,185 ----
; This returns a single node, either a LETREC, if there are internal
definitions,
! ; or a BEGIN if there aren't any. If there are no expressions we turn the
last
! ; definition back into an expression, thus causing the correct warning to be
! ; printed by the compiler.
(define (expand-body body env)
***************
*** 190,197 ****
(if (null? defs)
(make-node operator/begin (cons 'begin (expand-list exps env)))
! (expand-letrec (map car (reverse defs))
! (map cdr (reverse defs))
! exps
! env))))))
; Walk through FORMS looking for definitions. ENV is the current environment,
--- 192,207 ----
(if (null? defs)
(make-node operator/begin (cons 'begin (expand-list exps env)))
! (call-with-values
! (lambda ()
! (if (null? exps)
! (values (reverse (cdr defs))
! `((,operator/define ,(caar defs) ,(cdar defs))))
! (values (reverse defs)
! exps)))
! (lambda (defs exps)
! (expand-letrec (map car defs)
! (map cdr defs)
! exps
! env))))))))
; Walk through FORMS looking for definitions. ENV is the current environment,
Index: transform.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/bcomp/transform.scm,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -r1.1.1.1 -r1.2
*** transform.scm 1999/09/14 12:44:55 1.1.1.1
--- transform.scm 2001/07/09 14:15:05 1.2
***************
*** 66,70 ****
(define (name->source-name name)
(if (generated? name)
! (generated-symbol name)
name))
--- 66,70 ----
(define (name->source-name name)
(if (generated? name)
! (name->source-name (generated-name name))
name))
***************
*** 80,84 ****
(eq? (generated-token name)
token))
! (lookup env-of-definition (generated-symbol name))
(lookup env-of-use name)))
env-of-use)))
--- 80,84 ----
(eq? (generated-token name)
token))
! (lookup env-of-definition (generated-name name))
(lookup env-of-use name)))
env-of-use)))
***************
*** 90,104 ****
(define (make-name-generator env token parent-name)
(let ((alist '())) ;list of (symbol . generated)
! (lambda (symbol)
! (if (symbol? symbol)
! (let ((probe (assq symbol alist)))
(if probe
(cdr probe)
! (let ((new-name (make-generated symbol token env parent-name)))
! (set! alist (cons (cons symbol new-name)
alist))
new-name)))
! (error "non-symbol argument to rename procedure"
! symbol parent-name)))))
;----------------
--- 90,104 ----
(define (make-name-generator env token parent-name)
(let ((alist '())) ;list of (symbol . generated)
! (lambda (name)
! (if (name? name)
! (let ((probe (assq name alist)))
(if probe
(cdr probe)
! (let ((new-name (make-generated name token env parent-name)))
! (set! alist (cons (cons name new-name)
alist))
new-name)))
! (error "non-name argument to rename procedure"
! name parent-name)))))
;----------------
***************
*** 106,108 ****
(define (lookup cenv name)
! (cenv name))
\ No newline at end of file
--- 106,108 ----
(define (lookup cenv name)
! (cenv name))
Index: usual.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/bcomp/usual.scm,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -r1.1.1.1 -r1.2
*** usual.scm 1999/09/14 12:44:55 1.1.1.1
--- usual.scm 2001/07/09 14:15:05 1.2
***************
*** 264,268 ****
(descend-quasiquote (cdr x) level
(lambda (cdr-mode cdr-arg)
! (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
(return 'quote x))
((eq? car-mode 'unquote-splicing)
--- 264,269 ----
(descend-quasiquote (cdr x) level
(lambda (cdr-mode cdr-arg)
! (cond ((and (eq? car-mode 'quote)
! (eq? cdr-mode 'quote))
(return 'quote x))
((eq? car-mode 'unquote-splicing)
***************
*** 289,293 ****
(define (interesting-to-quasiquote? x marker)
! (and (pair? x) (c (car x) marker)))
(if (and (pair? (cdr exp))
--- 290,295 ----
(define (interesting-to-quasiquote? x marker)
! (and (pair? x)
! (c (car x) marker)))
(if (and (pair? (cdr exp))
|