Hi all, Here's a reasonably simple patch that moves the expansion-time support helpers for ye olde syntax-rules into an internal module in synrules.scm. process-syntax-rules is also stripped from its ##sys# prefix, since that's no longer required with the new support for fully qualified symbols.
This shouldn't offend anyone because the expansion of syntax-rules itself is a macro that requires er-macro-transformer. Given that you need to link expand.scm into a program that uses er-macro-transformer, these helpers will also be available and do not have to be in library.scm. Of course it's not 100% self-contained because the expansion still refers to other identifiers from library.scm, but those are all standard Scheme. Cheers, Peter
From e40d9d4f6c020c5e0c1b0da8965ee6109e1188b1 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Thu, 8 Jun 2017 21:02:18 +0200
Subject: [PATCH] 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.
---
expand.scm | 6 ++----
library.scm | 21 ---------------------
rules.make | 4 +++-
synrules.scm | 56 +++++++++++++++++++++++++++++++++++++++++++++++---------
4 files changed, 52 insertions(+), 35 deletions(-)
diff --git a/expand.scm b/expand.scm
index 3c04a4f..8525755 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.syntax-rules.internal#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 3c55eb2..9da4ef9 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 a163856..954fde4 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 cf8912e..7fdf7fa 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
--
2.1.4
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
