~ chicken-core (chicken-5) b4d9df49e9750bfbcf032d251df5d2b995ecaa8f
commit b4d9df49e9750bfbcf032d251df5d2b995ecaa8f
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Wed Jul 8 22:58:06 2015 +1200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed Jul 8 22:58:06 2015 +1200
Use module-namespaced expand procedures
Removes `##sys#expand` and `##sys#strip-syntax`, updating all files to
use the module-namespaced versions instead. For modules,
"chicken.expand" is imported and its identifiers are used directly; for
other files, the fully-qualified names are used.
Also removes some square brackets from surrounding code.
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index f0b4dbf1..6963aca8 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -180,7 +180,7 @@
"bad argument type - not a string or symbol"
code))))
(##core#the ,(chicken.compiler.support#foreign-type->scrutiny-type
- (##sys#strip-syntax (caddr form))
+ (chicken.expand#strip-syntax (caddr form))
'result)
#f ,tmp) ) ) ) ) )
@@ -219,8 +219,8 @@
(lambda (form r c)
(##sys#check-syntax 'foreign-primitive form '(_ _ . _))
(let* ((hasrtype (and (pair? (cddr form)) (not (string? (caddr form)))))
- (rtype (and hasrtype (##sys#strip-syntax (cadr form))))
- (args (##sys#strip-syntax (if hasrtype (caddr form) (cadr form))))
+ (rtype (and hasrtype (chicken.expand#strip-syntax (cadr form))))
+ (args (chicken.expand#strip-syntax (if hasrtype (caddr form) (cadr form))))
(argtypes (map car args)))
`(##core#the (procedure
,(map (cut chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
@@ -239,9 +239,9 @@
(##sys#check-syntax 'foreign-lambda form '(_ _ _ . _))
`(##core#the
(procedure ,(map (cut chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
- (##sys#strip-syntax (cdddr form)))
+ (chicken.expand#strip-syntax (cdddr form)))
,(chicken.compiler.support#foreign-type->scrutiny-type
- (##sys#strip-syntax (cadr form)) 'result))
+ (chicken.expand#strip-syntax (cadr form)) 'result))
#f
(##core#foreign-lambda ,@(cdr form))))))
@@ -256,9 +256,9 @@
(chicken.compiler.support#foreign-type->scrutiny-type
(car a)
'arg))
- (##sys#strip-syntax (caddr form)))
+ (chicken.expand#strip-syntax (caddr form)))
,(chicken.compiler.support#foreign-type->scrutiny-type
- (##sys#strip-syntax (cadr form)) 'result))
+ (chicken.expand#strip-syntax (cadr form)) 'result))
#f
(##core#foreign-lambda* ,@(cdr form))))))
@@ -270,9 +270,9 @@
(##sys#check-syntax 'foreign-safe-lambda form '(_ _ _ . _))
`(##core#the
(procedure ,(map (cut chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
- (##sys#strip-syntax (cdddr form)))
+ (chicken.expand#strip-syntax (cdddr form)))
,(chicken.compiler.support#foreign-type->scrutiny-type
- (##sys#strip-syntax (cadr form)) 'result))
+ (chicken.expand#strip-syntax (cadr form)) 'result))
#f
(##core#foreign-safe-lambda ,@(cdr form))))))
@@ -285,9 +285,9 @@
`(##core#the
(procedure ,(map (lambda (a)
(chicken.compiler.support#foreign-type->scrutiny-type (car a) 'arg))
- (##sys#strip-syntax (caddr form)))
+ (chicken.expand#strip-syntax (caddr form)))
,(chicken.compiler.support#foreign-type->scrutiny-type
- (##sys#strip-syntax (cadr form)) 'result))
+ (chicken.expand#strip-syntax (cadr form)) 'result))
#f
(##core#foreign-safe-lambda* ,@(cdr form))))))
@@ -297,7 +297,7 @@
(##sys#er-transformer
(lambda (form r c)
(##sys#check-syntax 'foreign-type-size form '(_ _))
- (let* ((t (##sys#strip-syntax (cadr form)))
+ (let* ((t (chicken.expand#strip-syntax (cadr form)))
(tmp (gensym "code_"))
(decl
(if (string? t)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 2063d8cc..5d998406 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -190,7 +190,7 @@
,msg
,@(if (pair? msg-and-args)
(cdr msg-and-args)
- `((##core#quote ,(##sys#strip-syntax exp))))))))))))
+ `((##core#quote ,(chicken.expand#strip-syntax exp))))))))))))
(##sys#extend-macro-environment
'ensure
@@ -514,7 +514,7 @@
(else?
(##sys#notice
"non-`else' clause following `else' clause in `select'"
- (##sys#strip-syntax clause))
+ (chicken.expand#strip-syntax clause))
(expand rclauses #t)
'(##core#begin))
(else
@@ -1112,7 +1112,7 @@
(##sys#er-transformer
(lambda (x r c)
(##sys#check-syntax 'define-interface x '(_ variable _))
- (let ((name (##sys#strip-syntax (cadr x)))
+ (let ((name (chicken.expand#strip-syntax (cadr x)))
(%quote (r 'quote)))
(when (eq? '* name)
(syntax-error-hook
@@ -1122,7 +1122,7 @@
(,%quote ,name)
(,%quote ##core#interface)
(,%quote
- ,(let ((exps (##sys#strip-syntax (caddr x))))
+ ,(let ((exps (chicken.expand#strip-syntax (caddr x))))
(cond ((eq? '* exps) '*)
((symbol? exps) `(#:interface ,exps))
((list? exps)
@@ -1139,7 +1139,7 @@
(##sys#er-transformer
(lambda (x r c)
(##sys#check-syntax 'functor x '(_ (symbol . #((_ _) 0)) _ . _))
- (let* ((x (##sys#strip-syntax x))
+ (let* ((x (chicken.expand#strip-syntax x))
(head (cadr x))
(name (car head))
(args (cdr head))
@@ -1177,14 +1177,14 @@
(##sys#check-syntax ': x '(_ symbol _ . _))
(if (not (memq #:compiling ##sys#features))
'(##core#undefined)
- (let* ((type1 (##sys#strip-syntax (caddr x)))
+ (let* ((type1 (chicken.expand#strip-syntax (caddr x)))
(name1 (cadr x)))
;; we need pred/pure info, so not using
;; "chicken.compiler.scrutinizer#check-and-validate-type"
(let-values (((type pred pure)
(chicken.compiler.scrutinizer#validate-type
type1
- (##sys#strip-syntax name1))))
+ (chicken.expand#strip-syntax name1))))
(cond ((not type)
(chicken.expand#syntax-error ': "invalid type syntax" name1 type1))
(else
@@ -1223,7 +1223,7 @@
(args (cdr head))
(alias (gensym name))
(galias (##sys#globalize alias '())) ;XXX and this?
- (rtypes (and (pair? (cdddr x)) (##sys#strip-syntax (caddr x))))
+ (rtypes (and (pair? (cdddr x)) (chicken.expand#strip-syntax (caddr x))))
(%define (r 'define))
(body (if rtypes (cadddr x) (caddr x))))
(let loop ((args args) (anames '()) (atypes '()))
@@ -1290,7 +1290,7 @@
,ln
,var ; must be variable (see: CPS transform)
,@(map (lambda (clause)
- (let ((hd (##sys#strip-syntax (car clause))))
+ (let ((hd (chicken.expand#strip-syntax (car clause))))
(list
(if (eq? hd 'else)
'else
@@ -1309,9 +1309,9 @@
(##sys#check-syntax 'define-type x '(_ variable _))
(cond ((not (memq #:compiling ##sys#features)) '(##core#undefined))
(else
- (let ((name (##sys#strip-syntax (cadr x)))
+ (let ((name (chicken.expand#strip-syntax (cadr x)))
(%quote (r 'quote))
- (t0 (##sys#strip-syntax (caddr x))))
+ (t0 (chicken.expand#strip-syntax (caddr x))))
`(##core#elaborationtimeonly
(##sys#put/restore!
(,%quote ,name)
diff --git a/core.scm b/core.scm
index 92e150c9..32005bfa 100644
--- a/core.scm
+++ b/core.scm
@@ -318,6 +318,7 @@
chicken.compiler.support
chicken.data-structures
chicken.eval
+ chicken.expand
chicken.extras
chicken.foreign)
@@ -590,7 +591,7 @@
(set! ##sys#syntax-error-culprit x)
(let* ((name0 (lookup (car x) se))
(name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
- (xexpanded (##sys#expand x se compiler-syntax-enabled)))
+ (xexpanded (expand x se compiler-syntax-enabled)))
(when ln (update-line-number-database! xexpanded ln))
(cond ((not (eq? x xexpanded))
(walk xexpanded e se dest ldest h ln))
@@ -611,7 +612,7 @@
(walk (cadddr x) e se #f #f h ln) ) ) )
((##core#syntax ##core#quote)
- `(quote ,(##sys#strip-syntax (cadr x))))
+ `(quote ,(strip-syntax (cadr x))))
((##core#check)
(if unsafe
@@ -620,7 +621,7 @@
((##core#the)
`(##core#the
- ,(##sys#strip-syntax (cadr x))
+ ,(strip-syntax (cadr x))
,(caddr x)
,(walk (cadddr x) e se dest ldest h ln)))
@@ -629,7 +630,7 @@
,(or ln (cadr x))
,(walk (caddr x) e se #f #f h ln)
,@(map (lambda (cl)
- (list (##sys#strip-syntax (car cl))
+ (list (strip-syntax (car cl))
(walk (cadr cl) e se dest ldest h ln)))
(cdddr x))))
@@ -647,11 +648,11 @@
((##core#inline_ref)
`(##core#inline_ref
- (,(caadr x) ,(##sys#strip-syntax (cadadr x)))))
+ (,(caadr x) ,(strip-syntax (cadadr x)))))
((##core#inline_loc_ref)
`(##core#inline_loc_ref
- ,(##sys#strip-syntax (cadr x))
+ ,(strip-syntax (cadr x))
,(walk (caddr x) e se dest ldest h ln)))
((##core#require-for-syntax)
@@ -666,7 +667,7 @@
((##core#require-extension)
(let ((imp? (caddr x)))
(walk
- (let loop ([ids (##sys#strip-syntax (cadr x))])
+ (let loop ([ids (strip-syntax (cadr x))])
(if (null? ids)
'(##core#undefined)
(let ((id (car ids)))
@@ -788,7 +789,7 @@
se
(##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- (##sys#strip-syntax (car b)))))
+ (strip-syntax (car b)))))
(cadr x) )
se) ) )
(walk
@@ -803,7 +804,7 @@
#f
(##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- (##sys#strip-syntax (car b)))))
+ (strip-syntax (car b)))))
(cadr x) ) )
(se2 (append ms se)) )
(for-each
@@ -855,7 +856,7 @@
(##sys#cons
(##sys#ensure-transformer
(##sys#eval/meta body)
- (##sys#strip-syntax var))
+ (strip-syntax var))
(##sys#current-environment))))
(walk
(if ##sys#enable-runtime-macros
@@ -882,7 +883,7 @@
(and (pair? (cdr b))
(cons (##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- (##sys#strip-syntax (car b)))
+ (strip-syntax (car b)))
se))
(##sys#get name '##compiler#compiler-syntax) ) ) )
(cadr x))))
@@ -916,13 +917,13 @@
(##sys#with-module-aliases
(map (lambda (b)
(##sys#check-syntax 'functor b '(symbol symbol))
- (##sys#strip-syntax b))
+ (strip-syntax b))
(cadr x))
(lambda ()
(walk `(##core#begin ,@(cddr x)) e se dest ldest h ln))))
((##core#module)
- (let* ((name (##sys#strip-syntax (cadr x)))
+ (let* ((name (strip-syntax (cadr x)))
(exports
(or (eq? #t (caddr x))
(map (lambda (exp)
@@ -937,7 +938,7 @@
(##sys#syntax-error-hook
'module
"invalid export syntax" exp name))))
- (##sys#strip-syntax (caddr x)))))
+ (strip-syntax (caddr x)))))
(csyntax compiler-syntax))
(when (##sys#current-module)
(##sys#syntax-error-hook
@@ -1126,11 +1127,11 @@
(walk (expand-foreign-primitive x) e se dest ldest h ln) )
((##core#define-foreign-variable)
- (let* ([var (##sys#strip-syntax (second x))]
- [type (##sys#strip-syntax (third x))]
- [name (if (pair? (cdddr x))
+ (let* ((var (strip-syntax (second x)))
+ (type (strip-syntax (third x)))
+ (name (if (pair? (cdddr x))
(fourth x)
- (symbol->string var) ) ] )
+ (symbol->string var))))
(set! foreign-variables
(cons (list var type
(if (string? name)
@@ -1140,9 +1141,9 @@
'(##core#undefined) ) )
((##core#define-foreign-type)
- (let ([name (second x)]
- [type (##sys#strip-syntax (third x))]
- [conv (cdddr x)] )
+ (let ((name (second x))
+ (type (strip-syntax (third x)))
+ (conv (cdddr x)))
(cond [(pair? conv)
(let ([arg (gensym)]
[ret (gensym)] )
@@ -1177,11 +1178,11 @@
'(##core#undefined) ) )
((##core#let-location)
- (let* ([var (second x)]
- [type (##sys#strip-syntax (third x))]
- [alias (gensym)]
- [store (gensym)]
- [init (and (pair? (cddddr x)) (fourth x))] )
+ (let* ((var (second x))
+ (type (strip-syntax (third x)))
+ (alias (gensym))
+ (store (gensym))
+ (init (and (pair? (cddddr x)) (fourth x))))
(set-real-name! alias var)
(set! location-pointer-map
(cons (list alias store type) location-pointer-map) )
@@ -1403,9 +1404,7 @@
(syntax-error "invalid declaration" spec) ) ) )
(define (stripa x) ; global aliasing
(##sys#globalize x se))
- (define (strip x) ; raw symbol
- (##sys#strip-syntax x))
- (define stripu ##sys#strip-syntax)
+ (define stripu strip-syntax)
(define (globalize-all syms)
(filter-map
(lambda (var)
@@ -1421,8 +1420,7 @@
(lambda (return)
(unless (pair? spec)
(syntax-error "invalid declaration specification" spec) )
- ;(pp `(DECLARE: ,(strip spec)))
- (case (##sys#strip-syntax (car spec)) ; no global aliasing
+ (case (strip-syntax (car spec)) ; no global aliasing
((uses)
(let ((us (stripu (cdr spec))))
(apply register-feature! us)
@@ -1458,7 +1456,7 @@
(set! extended-bindings (lset-intersection/eq? syms default-extended-bindings)))]))
((number-type)
(check-decl spec 1 1)
- (set! number-type (strip (cadr spec))))
+ (set! number-type (strip-syntax (cadr spec))))
((fixnum fixnum-arithmetic) (set! number-type 'fixnum))
((generic) (set! number-type 'generic))
((unsafe) (set! unsafe #t))
@@ -1500,7 +1498,7 @@
(globalize-all (cdr spec))))
((not)
(check-decl spec 1)
- (case (##sys#strip-syntax (second spec)) ; strip all
+ (case (strip-syntax (second spec)) ; strip all
[(standard-bindings)
(if (null? (cddr spec))
(set! standard-bindings '())
@@ -1535,7 +1533,7 @@
(globalize-all (cddr spec)))))
[else
(check-decl spec 1 1)
- (let ((id (strip (cadr spec))))
+ (let ((id (strip-syntax (cadr spec))))
(case id
[(interrupts-enabled) (set! insert-timer-checks #f)]
[(safe) (set! unsafe #t)]
@@ -1588,7 +1586,7 @@
(else
(warning
"invalid import-library specification" il))))
- (strip (cdr spec))))))
+ (strip-syntax (cdr spec))))))
((profile)
(set! emit-profile #t)
(cond ((null? (cdr spec))
@@ -1618,9 +1616,9 @@
(if (not (and (list? spec)
(>= (length spec) 2)
(symbol? (car spec))))
- (warning "illegal type declaration" (##sys#strip-syntax spec))
+ (warning "illegal type declaration" (strip-syntax spec))
(let ((name (##sys#globalize (car spec) se))
- (type (##sys#strip-syntax (cadr spec))))
+ (type (strip-syntax (cadr spec))))
(if (local? (car spec))
(note-local (car spec))
(let-values (((type pred pure) (validate-type type name)))
@@ -1642,18 +1640,18 @@
(when (pair? (cddr spec))
(install-specializations
name
- (##sys#strip-syntax (cddr spec)))))
+ (strip-syntax (cddr spec)))))
(else
(warning
"illegal `type' declaration"
- (##sys#strip-syntax spec)))))))))
+ (strip-syntax spec)))))))))
(cdr spec)))
((predicate)
(for-each
(lambda (spec)
(cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
(let ((name (##sys#globalize (car spec) se))
- (type (##sys#strip-syntax (cadr spec))))
+ (type (strip-syntax (cadr spec))))
(if (local? (car spec))
(note-local (car spec))
(let-values (((type pred pure) (validate-type type name)))
@@ -1699,14 +1697,14 @@
(else (loop (car type)))))
((or (symbol? type) (string? type)) type)
(else 'a))))
- (let* ((rtype (##sys#strip-syntax rtype))
- (argtypes (##sys#strip-syntax argtypes))
- [params (if argnames
+ (let* ((rtype (strip-syntax rtype))
+ (argtypes (strip-syntax argtypes))
+ (params (if argnames
(map gensym argnames)
- (map (o gensym type->symbol) argtypes))]
- [f-id (gensym 'stub)]
- [bufvar (gensym)]
- [rsize (estimate-foreign-result-size rtype)] )
+ (map (o gensym type->symbol) argtypes)))
+ (f-id (gensym 'stub))
+ (bufvar (gensym))
+ (rsize (estimate-foreign-result-size rtype)))
(when sname (set-real-name! f-id (string->symbol sname)))
(set! foreign-lambda-stubs
(cons (make-foreign-stub f-id rtype sname argtypes argnames body cps callback)
@@ -1730,7 +1728,7 @@
(define (expand-foreign-lambda exp callback?)
(let* ((name (third exp))
- (sname (cond ((symbol? name) (symbol->string (##sys#strip-syntax name)))
+ (sname (cond ((symbol? name) (symbol->string (strip-syntax name)))
((string? name) name)
(else (quit-compiling
"name `~s' of foreign procedure has wrong type"
@@ -1740,23 +1738,23 @@
(create-foreign-stub rtype sname argtypes #f #f callback? callback?) ) )
(define (expand-foreign-lambda* exp callback?)
- (let* ([rtype (second exp)]
- [args (third exp)]
- [body (apply string-append (cdddr exp))]
- [argtypes (map (lambda (x) (car x)) args)]
+ (let* ((rtype (second exp))
+ (args (third exp))
+ (body (apply string-append (cdddr exp)))
+ (argtypes (map (lambda (x) (car x)) args))
;; C identifiers aren't hygienically renamed inside body strings
- [argnames (map cadr (##sys#strip-syntax args))] )
+ (argnames (map cadr (strip-syntax args))))
(create-foreign-stub rtype #f argtypes argnames body callback? callback?) ) )
;; TODO: Try to fold this procedure into expand-foreign-lambda*
(define (expand-foreign-primitive exp)
- (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp))))]
- [rtype (if hasrtype (second exp) 'void)]
- [args (##sys#strip-syntax (if hasrtype (third exp) (second exp)))]
- [body (apply string-append (if hasrtype (cdddr exp) (cddr exp)))]
- [argtypes (map (lambda (x) (car x)) args)]
+ (let* ((hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp)))))
+ (rtype (if hasrtype (second exp) 'void))
+ (args (strip-syntax (if hasrtype (third exp) (second exp))))
+ (body (apply string-append (if hasrtype (cdddr exp) (cddr exp))))
+ (argtypes (map (lambda (x) (car x)) args))
;; C identifiers aren't hygienically renamed inside body strings
- [argnames (map cadr (##sys#strip-syntax args))] )
+ (argnames (map cadr (strip-syntax args))))
(create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
diff --git a/csi.scm b/csi.scm
index 024550e7..5b983be5 100644
--- a/csi.scm
+++ b/csi.scm
@@ -316,7 +316,7 @@ EOF
(case cmd
((x)
(let ([x (read)])
- (pretty-print (##sys#strip-syntax (expand x)))
+ (pretty-print (strip-syntax (expand x)))
(##sys#void) ) )
((p)
(let* ([x (read)]
diff --git a/eval.scm b/eval.scm
index 9d03d75c..0d752b8f 100644
--- a/eval.scm
+++ b/eval.scm
@@ -58,7 +58,10 @@
;; Exclude values defined within this module.
(import (except scheme eval load interaction-environment null-environment scheme-report-environment))
-(import chicken chicken.foreign)
+(import chicken)
+
+(import chicken.expand
+ chicken.foreign)
(include "common-declarations.scm")
(include "mini-srfi-1.scm")
@@ -320,7 +323,7 @@
(##sys#syntax-error/context "illegal non-atomic object" x)]
[(symbol? (##sys#slot x 0))
(emit-syntax-trace-info tf x cntr)
- (let ((x2 (##sys#expand x se #f)))
+ (let ((x2 (expand x se)))
(d `(EVAL/EXPANDED: ,x2))
(if (not (eq? x2 x))
(compile x2 e h tf cntr se)
@@ -330,7 +333,7 @@
(case head
[(##core#quote)
- (let* ((c (##sys#strip-syntax (cadr x))))
+ (let* ((c (strip-syntax (cadr x))))
(case c
[(-1) (lambda v -1)]
[(0) (lambda v 0)]
@@ -582,7 +585,7 @@
se
(##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- (##sys#strip-syntax (car b)))))
+ (strip-syntax (car b)))))
(cadr x) )
se) ) )
(compile
@@ -596,7 +599,7 @@
#f
(##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- (##sys#strip-syntax (car b)))))
+ (strip-syntax (car b)))))
(cadr x) ) )
(se2 (append ms se)) )
(for-each
@@ -640,13 +643,13 @@
(##sys#with-module-aliases
(map (lambda (b)
(##sys#check-syntax 'functor b '(symbol symbol))
- (##sys#strip-syntax b))
+ (strip-syntax b))
(cadr x))
(lambda ()
(compile `(##core#begin ,@(cddr x)) e #f tf cntr se))))
((##core#module)
- (let* ((x (##sys#strip-syntax x))
+ (let* ((x (strip-syntax x))
(name (cadr x))
(exports
(or (eq? #t (caddr x))
@@ -713,7 +716,7 @@
[(##core#require-extension)
(let ((imp? (caddr x)))
(compile
- (let loop ([ids (##sys#strip-syntax (cadr x))])
+ (let loop ((ids (strip-syntax (cadr x))))
(if (null? ids)
'(##core#undefined)
(let-values (((exp f real-id)
@@ -753,7 +756,7 @@
((##core#typecase)
;; drops exp and requires "else" clause
- (cond ((assq 'else (##sys#strip-syntax (cdddr x))) =>
+ (cond ((assq 'else (strip-syntax (cdddr x))) =>
(lambda (cl)
(compile (cadr cl) e h tf cntr se)))
(else
diff --git a/expand.scm b/expand.scm
index 3eda4d89..b9618dd3 100644
--- a/expand.scm
+++ b/expand.scm
@@ -130,8 +130,6 @@
(##sys#setslot vec i (walk (##sys#slot x i))))))
(else x)))))
-(define ##sys#strip-syntax strip-syntax)
-
(define (##sys#extend-se se vars #!optional (aliases (map gensym vars)))
(for-each
(lambda (alias sym)
@@ -318,8 +316,6 @@
(loop exp2)
exp2) ) ) )
-(define ##sys#expand expand)
-
;;; Extended (DSSSL-style) lambda lists
;
@@ -367,7 +363,7 @@
,(map (lambda (k)
(let ([s (car k)])
`(,s (##sys#get-keyword
- (##core#quote ,(->keyword (##sys#strip-syntax s))) ,(or hasrest rvar)
+ (##core#quote ,(->keyword (strip-syntax s))) ,(or hasrest rvar)
,@(if (pair? (cdr k))
`((,%lambda () ,@(cdr k)))
'())))))
@@ -642,14 +638,14 @@
(define (syntax-error . args)
(apply ##sys#signal-hook #:syntax-error
- (##sys#strip-syntax args)))
+ (strip-syntax args)))
(define ##sys#syntax-error-hook syntax-error)
(define ##sys#syntax-error/context
(lambda (msg arg)
(define (syntax-imports sym)
- (let loop ((defs (or (##sys#get (##sys#strip-syntax sym) '##core#db) '())))
+ (let loop ((defs (or (##sys#get (strip-syntax sym) '##core#db) '())))
(cond ((null? defs) '())
((eq? 'syntax (caar defs))
(cons (cadar defs) (loop (cdr defs))))
@@ -665,10 +661,10 @@
(outstr ": ")
(##sys#print arg #t out)
(outstr "\ninside expression `(")
- (##sys#print (##sys#strip-syntax (car ##sys#syntax-context)) #t out)
+ (##sys#print (strip-syntax (car ##sys#syntax-context)) #t out)
(outstr " ...)'"))
(else
- (let* ((sym (##sys#strip-syntax (car cx)))
+ (let* ((sym (strip-syntax (car cx)))
(us (syntax-imports sym)))
(cond ((pair? us)
(outstr msg)
@@ -888,7 +884,7 @@
((vector? sym)
(list->vector (mirror-rename (vector->list sym))))
((not (symbol? sym)) sym)
- (else ; Code stolen from ##sys#strip-syntax
+ (else ; Code stolen from strip-syntax
(let ((renamed (lookup sym se) ) )
(cond ((assq-reverse sym renv) =>
(lambda (a)
@@ -1164,7 +1160,7 @@
(cond (else?
(##sys#warn
(sprintf "clause following `~S' clause in `cond'" else?)
- (##sys#strip-syntax clause))
+ (chicken.expand#strip-syntax clause))
(expand rclauses else?)
'(##core#begin))
((or (c %else (car clause))
@@ -1232,7 +1228,7 @@
(cond (else?
(##sys#warn
"clause following `else' clause in `case'"
- (##sys#strip-syntax clause))
+ (chicken.expand#strip-syntax clause))
(expand rclauses #t)
'(##core#begin))
((c %else (car clause))
@@ -1378,7 +1374,7 @@
x
(cons 'cond-expand clauses)) )
(define (test fx)
- (cond ((symbol? fx) (##sys#feature? (##sys#strip-syntax fx)))
+ (cond ((symbol? fx) (##sys#feature? (chicken.expand#strip-syntax fx)))
((not (pair? fx)) (err fx))
(else
(let ((head (car fx))
@@ -1448,7 +1444,7 @@
(let ((len (length x)))
(##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
(cond ((and (fx>= len 4) (c (r '=) (caddr x)))
- (let* ((x (##sys#strip-syntax x))
+ (let* ((x (chicken.expand#strip-syntax x))
(name (cadr x))
(app (cadddr x)))
(cond ((symbol? app)
@@ -1488,7 +1484,7 @@
;;XXX use module name in "loc" argument?
(let ((exports
(##sys#validate-exports
- (##sys#strip-syntax (caddr x)) 'module)))
+ (chicken.expand#strip-syntax (caddr x)) 'module)))
`(##core#module
,(cadr x)
,(if (eq? '* exports)
@@ -1517,7 +1513,7 @@
(lambda (x r c)
(let ((exps
(##sys#validate-exports
- (##sys#strip-syntax (cdr x))
+ (chicken.expand#strip-syntax (cdr x))
'export))
(mod (##sys#current-module)))
(when mod
diff --git a/modules.scm b/modules.scm
index d6989c27..04513ac2 100644
--- a/modules.scm
+++ b/modules.scm
@@ -305,9 +305,9 @@
(ifs (module-import-forms mod))
(sexports (module-sexports mod))
(mifs (module-meta-import-forms mod)))
- `(,@(if (pair? ifs) `((chicken.eval#eval '(import ,@(##sys#strip-syntax ifs)))) '())
- ,@(if (pair? mifs) `((import ,@(##sys#strip-syntax mifs))) '())
- ,@(##sys#fast-reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
+ `(,@(if (pair? ifs) `((chicken.eval#eval '(import ,@(chicken.expand#strip-syntax ifs)))) '())
+ ,@(if (pair? mifs) `((import ,@(chicken.expand#strip-syntax mifs))) '())
+ ,@(##sys#fast-reverse (map chicken.expand#strip-syntax (module-meta-expressions mod)))
(##sys#register-compiled-module
',(module-name mod)
(list
@@ -322,7 +322,7 @@
(let* ((name (car sexport))
(a (assq name dlist)))
(cond ((pair? a)
- `(cons ',(car sexport) ,(##sys#strip-syntax (cdr a))))
+ `(cons ',(car sexport) ,(chicken.expand#strip-syntax (cdr a))))
(else
(dm "re-exported syntax" name mname)
`',name))))
@@ -335,7 +335,7 @@
((assq (caar sd) sexports) (loop (cdr sd)))
(else
(let ((name (caar sd)))
- (cons `(cons ',(caar sd) ,(##sys#strip-syntax (cdar sd)))
+ (cons `(cons ',(caar sd) ,(chicken.expand#strip-syntax (cdar sd)))
(loop (cdr sd)))))))))))))
(define (##sys#register-compiled-module name iexports vexports sexports #!optional
@@ -588,7 +588,7 @@
((number? x) (number->string x))
(else (##sys#syntax-error-hook loc "invalid prefix" ))))
(define (import-name spec)
- (let* ((mod (##sys#find-module/import-library (##sys#strip-syntax spec) 'import))
+ (let* ((mod (##sys#find-module/import-library (chicken.expand#strip-syntax spec) 'import))
(vexp (module-vexports mod))
(sexp (module-sexports mod))
(iexp (module-iexports mod)))
diff --git a/rules.make b/rules.make
index 613e981d..f66eaf29 100644
--- a/rules.make
+++ b/rules.make
@@ -545,6 +545,7 @@ core.c: core.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm \
chicken.data-structures.import.scm \
chicken.eval.import.scm \
+ chicken.expand.import.scm \
chicken.extras.import.scm
optimizer.c: optimizer.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm \
@@ -554,6 +555,7 @@ optimizer.c: optimizer.scm mini-srfi-1.scm \
scrutinizer.c: scrutinizer.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm \
chicken.data-structures.import.scm \
+ chicken.expand.import.scm \
chicken.extras.import.scm \
chicken.files.import.scm \
chicken.ports.import.scm
@@ -567,6 +569,7 @@ chicken-ffi-syntax.c: chicken-ffi-syntax.scm \
chicken.data-structures.import.scm
support.c: support.scm mini-srfi-1.scm \
chicken.data-structures.import.scm \
+ chicken.expand.import.scm \
chicken.extras.import.scm \
chicken.files.import.scm \
chicken.foreign.import.scm \
@@ -651,6 +654,7 @@ data-structures.c: data-structures.scm \
extras.c: extras.scm \
chicken.data-structures.import.scm
eval.c: eval.scm \
+ chicken.expand.import.scm \
chicken.foreign.import.scm
files.c: files.scm \
chicken.data-structures.import.scm \
diff --git a/scrutinizer.scm b/scrutinizer.scm
index d1c6fb6a..234b9e48 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -35,6 +35,7 @@
(import chicken scheme
chicken.compiler.support
chicken.data-structures
+ chicken.expand
chicken.extras
chicken.files
chicken.ports)
@@ -281,7 +282,7 @@
(define (fragment x)
(let ((x (build-expression-tree x)))
(let walk ((x x) (d 0))
- (cond ((atom? x) (##sys#strip-syntax x))
+ (cond ((atom? x) (strip-syntax x))
((>= d +fragment-max-depth+) '...)
((list? x)
(let* ((len (length x))
@@ -289,7 +290,7 @@
(append (take x +fragment-max-length+) '(...))
x)))
(map (cute walk <> (add1 d)) xs)))
- (else (##sys#strip-syntax x))))))
+ (else (strip-syntax x))))))
(define (pp-fragment x)
(string-chomp
@@ -2104,7 +2105,7 @@
(else (values #f #f #f)))))
(define (check-and-validate-type type loc #!optional name)
- (let-values (((t pred pure) (validate-type (##sys#strip-syntax type) name)))
+ (let-values (((t pred pure) (validate-type (strip-syntax type) name)))
(or t
(error loc "invalid type specifier" type))))
diff --git a/srfi-4.scm b/srfi-4.scm
index acedc20b..c0034b23 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -463,7 +463,7 @@ EOF
(define-syntax list->NNNvector
(er-macro-transformer
(lambda (x r c)
- (let* ((tag (##sys#strip-syntax (cadr x)))
+ (let* ((tag (strip-syntax (cadr x)))
(tagstr (symbol->string tag))
(name (string->symbol (string-append "list->" tagstr)))
(make (string->symbol (string-append "make-" tagstr)))
@@ -531,7 +531,7 @@ EOF
(define-syntax NNNvector->list
(er-macro-transformer
(lambda (x r c)
- (let* ((tag (symbol->string (##sys#strip-syntax (cadr x))))
+ (let* ((tag (symbol->string (strip-syntax (cadr x))))
(alloc (and (pair? (cddr x)) (caddr x)))
(name (string->symbol (string-append tag "->list"))))
`(define (,name v)
diff --git a/support.scm b/support.scm
index dcb66f30..fcff0e19 100644
--- a/support.scm
+++ b/support.scm
@@ -77,6 +77,7 @@
(import chicken scheme
chicken.data-structures
+ chicken.expand
chicken.extras
chicken.files
chicken.foreign
@@ -1192,7 +1193,7 @@
;;; Convert result value, if a string:
(define (finish-foreign-result type body) ; Used only in compiler.scm
- (let ((type (##sys#strip-syntax type)))
+ (let ((type (strip-syntax type)))
(case type
[(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
[(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
Trap