~ chicken-core (chicken-5) c338315a211eef734b3413cb68bb17fde54c7947
commit c338315a211eef734b3413cb68bb17fde54c7947
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Thu Jun 8 21:02:18 2017 +0200
Commit: Kooda <kooda@upyum.com>
CommitDate: Wed Jun 14 12:29:53 2017 +0200
Make syntax-rules fully self-contained
All expansion time support code for the generated expanders is moved
into a (chicken internal syntax-rules) module, which is not emitted,
so it's not available to users, but expansions can use the things
defined by the module through explicit reference to the fully
qualified name.
Signed-off-by: Kooda <kooda@upyum.com>
diff --git a/expand.scm b/expand.scm
index 3c04a4f7..ab60f3dc 100644
--- a/expand.scm
+++ b/expand.scm
@@ -250,7 +250,8 @@
(let ((exp2
(if cs
;; compiler-syntax may "fall through"
- (fluid-let ((##sys#syntax-rules-mismatch (lambda (input) exp))) ; a bit of a hack
+ (fluid-let ((chicken.internal.syntax-rules#syntax-rules-mismatch
+ (lambda (input) exp))) ; a bit of a hack
(handler exp se dse))
(handler exp se dse))) )
(when (and (not cs) (eq? exp exp2))
@@ -736,9 +737,6 @@
(else (loop (cdr cx))))))))
(##sys#syntax-error-hook (get-output-string out))))))
-(define (##sys#syntax-rules-mismatch input)
- (##sys#syntax-error-hook "no rule matches form" input))
-
(define (get-line-number sexp)
(and ##sys#line-number-database
(pair? sexp)
diff --git a/library.scm b/library.scm
index 3c55eb23..9da4ef93 100644
--- a/library.scm
+++ b/library.scm
@@ -5737,27 +5737,6 @@ EOF
z
(f (##sys#slot lst 0) (loop (##sys#slot lst 1))))))
-;; contributed by Peter Bex
-(define (##sys#drop-right input temp)
- ;;XXX use unsafe accessors
- (let loop ((len (length input))
- (input input))
- (cond
- ((> len temp)
- (cons (car input)
- (loop (- len 1) (cdr input))))
- (else '()))))
-
-(define (##sys#take-right input temp)
- ;;XXX use unsafe accessors
- (let loop ((len (length input))
- (input input))
- (cond
- ((> len temp)
- (loop (- len 1) (cdr input)))
- (else input))))
-
-
;;; Platform configuration inquiry:
(module chicken.platform
diff --git a/rules.make b/rules.make
index a1638563..954fde45 100644
--- a/rules.make
+++ b/rules.make
@@ -784,7 +784,9 @@ read-syntax.c: $(SRCDIR)read-syntax.scm $(SRCDIR)common-declarations.scm
repl.c: $(SRCDIR)repl.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) -emit-import-library chicken.repl
expand.c: $(SRCDIR)expand.scm $(SRCDIR)synrules.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib) -emit-import-library chicken.expand
+ $(bootstrap-lib) \
+ -no-module-registration \
+ -emit-import-library chicken.expand
modules.c: $(SRCDIR)modules.scm $(SRCDIR)common-declarations.scm $(SRCDIR)mini-srfi-1.scm
$(bootstrap-lib)
extras.c: $(SRCDIR)extras.scm $(SRCDIR)common-declarations.scm
diff --git a/synrules.scm b/synrules.scm
index cf8912ec..7fdf7fa9 100644
--- a/synrules.scm
+++ b/synrules.scm
@@ -40,7 +40,6 @@
; ((or e1 e ...) (let ((temp e1))
; (if temp temp (or e ...))))))
-
(##sys#extend-macro-environment
'syntax-rules
'()
@@ -55,10 +54,44 @@
(set! ellipsis subkeywords)
(set! subkeywords (car rules))
(set! rules (cdr rules)))
- (##sys#process-syntax-rules ellipsis rules subkeywords r c)))))
+ (chicken.internal.syntax-rules#process-syntax-rules
+ ellipsis rules subkeywords r c)))))
+
+
+;; Runtime internal support module exclusively for syntax-rules
+(module chicken.internal.syntax-rules
+ (drop-right take-right syntax-rules-mismatch)
+
+(import scheme)
+(define (syntax-rules-mismatch input)
+ (##sys#syntax-error-hook "no rule matches form" input))
-(define (##sys#process-syntax-rules ellipsis rules subkeywords r c)
+(define (drop-right input temp)
+ ;;XXX use unsafe accessors
+ (let loop ((len (length input))
+ (input input))
+ (cond
+ ((> len temp)
+ (cons (car input)
+ (loop (- len 1) (cdr input))))
+ (else '()))))
+
+(define (take-right input temp)
+ ;;XXX use unsafe accessors
+ (let loop ((len (length input))
+ (input input))
+ (cond
+ ((> len temp)
+ (loop (- len 1) (cdr input)))
+ (else input))))
+
+;; OBSOLETE
+;; These two can be removed after the next snapshot
+(define ##sys#drop-right drop-right)
+(define ##sys#take-right take-right)
+
+(define (process-syntax-rules ellipsis rules subkeywords r c)
(define %append '##sys#append)
(define %apply '##sys#apply)
@@ -99,6 +132,10 @@
(define %temp (r 'temp))
(define %syntax-error '##sys#syntax-error-hook)
(define %ellipsis (r ellipsis))
+ (define %take-right (r 'chicken.internal.syntax-rules#take-right))
+ (define %drop-right (r 'chicken.internal.syntax-rules#drop-right))
+ (define %syntax-rules-mismatch
+ (r 'chicken.internal.syntax-rules#syntax-rules-mismatch))
(define (ellipsis? x)
(c x %ellipsis))
@@ -106,10 +143,9 @@
(define (make-transformer rules)
`(##sys#er-transformer
(,%lambda (,%input ,%rename ,%compare)
- (,%let ((,%tail (,%cdr ,%input)))
- (,%cond ,@(map process-rule rules)
- (,%else
- (##sys#syntax-rules-mismatch ,%input)))))))
+ (,%let ((,%tail (,%cdr ,%input)))
+ (,%cond ,@(map process-rule rules)
+ (,%else (,%syntax-rules-mismatch ,%input)))))))
(define (process-rule rule)
(if (and (pair? rule)
@@ -176,7 +212,7 @@
(let* ((tail-length (length (cddr pattern)))
(%match (if (zero? tail-length) ; Simple segment?
path ; No list traversing overhead at runtime!
- `(##sys#drop-right ,path ,tail-length))))
+ `(,%drop-right ,path ,tail-length))))
(append
(process-pattern (car pattern)
%temp
@@ -187,7 +223,7 @@
`(,%map1 (,%lambda (,%temp) ,x) ,%match))))
#f)
(process-pattern (cddr pattern)
- `(##sys#take-right ,path ,tail-length) mapit #t))))
+ `(,%take-right ,path ,tail-length) mapit #t))))
((pair? pattern)
(append (process-pattern (car pattern) `(,%car ,path) mapit #f)
(process-pattern (cdr pattern) `(,%cdr ,path) mapit #f)))
@@ -312,3 +348,5 @@
pattern)))
(make-transformer rules))
+
+) ; chicken.internal.syntax-rules
Trap