From e40d9d4f6c020c5e0c1b0da8965ee6109e1188b1 Mon Sep 17 00:00:00 2001 From: Peter Bex 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