On Thu, Jun 08, 2017 at 09:19:24PM +0200, Peter Bex wrote: > 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.
Well, not simple enough I guess ;). I decided at the last minute to rename "chicken.syntax-rules.internal" to "chicken.internal.syntax-rules" which is more consistent with our other naming conventions, but forgot to rename the reference in expand.scm as well. This new version of the patch fixes that problem. Cheers, Peter
From 83e2487703ded3ac52c0ce75e10933e8ac3ca1f9 Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> 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..ab60f3d 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 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 [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
