From 152b20f24452788053d141e8a598b97ad013cad5 Mon Sep 17 00:00:00 2001 From: Marc Nieper-Wisskirchen Date: Fri, 30 Nov 2018 14:04:07 +0100 Subject: [PATCH 1/3] Implement syntax-case --- eval.c | 9 +- include/chibi/sexp.h | 10 +- lib/chibi/ast.c | 3 +- lib/chibi/ast.scm | 2 + lib/chibi/ast.sld | 2 +- lib/chibi/syntax-case-test.sld | 50 +++++ lib/chibi/syntax-case.scm | 323 ++++++++++++++++++++++++++++++ lib/chibi/syntax-case.sld | 11 + lib/init-7.scm | 95 +++++++-- lib/meta-7.scm | 4 +- lib/srfi/139.scm | 6 +- lib/srfi/38.scm | 5 + lib/srfi/99/records/syntactic.scm | 6 +- lib/srfi/99/records/syntactic.sld | 2 +- lib/srfi/99/test.sld | 16 +- opcodes.c | 5 + sexp.c | 32 ++- tests/lib-tests.scm | 2 + 18 files changed, 547 insertions(+), 36 deletions(-) create mode 100644 lib/chibi/syntax-case-test.sld create mode 100644 lib/chibi/syntax-case.scm create mode 100644 lib/chibi/syntax-case.sld diff --git a/eval.c b/eval.c index 3d694914..ab4cc682 100644 --- a/eval.c +++ b/eval.c @@ -384,6 +384,7 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO); sexp_macro_env(mac) = e; sexp_macro_proc(mac) = p; + sexp_macro_aux(mac) = SEXP_FALSE; return mac; } @@ -397,10 +398,12 @@ sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp_synclo_env(res) = sexp_synclo_env(expr); sexp_synclo_free_vars(res) = sexp_synclo_free_vars(expr); sexp_synclo_expr(res) = sexp_synclo_expr(expr); + sexp_synclo_rename(res) = sexp_synclo_rename(expr); } else { sexp_synclo_env(res) = env; sexp_synclo_free_vars(res) = fv; sexp_synclo_expr(res) = expr; + sexp_synclo_rename(res) = SEXP_FALSE; } return res; } @@ -2162,9 +2165,9 @@ static struct sexp_core_form_struct core_forms[] = { {SEXP_CORE_BEGIN, (sexp)"begin"}, {SEXP_CORE_QUOTE, (sexp)"quote"}, {SEXP_CORE_SYNTAX_QUOTE, (sexp)"syntax-quote"}, - {SEXP_CORE_DEFINE_SYNTAX, (sexp)"define-syntax"}, - {SEXP_CORE_LET_SYNTAX, (sexp)"let-syntax"}, - {SEXP_CORE_LETREC_SYNTAX, (sexp)"letrec-syntax"}, + {SEXP_CORE_DEFINE_SYNTAX, (sexp)"%define-syntax"}, + {SEXP_CORE_LET_SYNTAX, (sexp)"%let-syntax"}, + {SEXP_CORE_LETREC_SYNTAX, (sexp)"%letrec-syntax"}, }; sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) { diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 151427f1..1de4d95a 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -494,10 +494,10 @@ struct sexp_struct { sexp bc, vars; } procedure; struct { - sexp proc, env, source; + sexp proc, env, source, aux; } macro; struct { - sexp env, free_vars, expr; + sexp env, free_vars, expr, rename; } synclo; struct { sexp file; @@ -1133,10 +1133,12 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_macro_proc(x) (sexp_field(x, macro, SEXP_MACRO, proc)) #define sexp_macro_env(x) (sexp_field(x, macro, SEXP_MACRO, env)) #define sexp_macro_source(x) (sexp_field(x, macro, SEXP_MACRO, source)) +#define sexp_macro_aux(x) (sexp_field(x, macro, SEXP_MACRO, aux)) #define sexp_synclo_env(x) (sexp_field(x, synclo, SEXP_SYNCLO, env)) #define sexp_synclo_free_vars(x) (sexp_field(x, synclo, SEXP_SYNCLO, free_vars)) #define sexp_synclo_expr(x) (sexp_field(x, synclo, SEXP_SYNCLO, expr)) +#define sexp_synclo_rename(x) (sexp_field(x, synclo, SEXP_SYNCLO, rename)) #define sexp_core_code(x) (sexp_field(x, core, SEXP_CORE, code)) #define sexp_core_name(x) (sexp_field(x, core, SEXP_CORE, name)) @@ -1388,6 +1390,10 @@ enum sexp_context_globals { SEXP_G_QUASIQUOTE_SYMBOL, SEXP_G_UNQUOTE_SYMBOL, SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_SYNTAX_SYMBOL, + SEXP_G_QUASISYNTAX_SYMBOL, + SEXP_G_UNSYNTAX_SYMBOL, + SEXP_G_UNSYNTAX_SPLICING_SYMBOL, SEXP_G_EMPTY_VECTOR, SEXP_G_CUR_IN_SYMBOL, SEXP_G_CUR_OUT_SYMBOL, diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 54bc124b..0fb4ad9b 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -72,7 +72,7 @@ sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, s id = sexp_synclo_expr(id); } cell = sexp_env_cell(ctx, env, id, 0); - if (!cell && createp) + if (!cell && sexp_truep(createp)) cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL); } return cell ? cell : SEXP_FALSE; @@ -669,6 +669,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_accessors(ctx, env, SEXP_MACRO, 0, "macro-procedure", NULL); sexp_define_accessors(ctx, env, SEXP_MACRO, 1, "macro-env", NULL); sexp_define_accessors(ctx, env, SEXP_MACRO, 2, "macro-source", NULL); + sexp_define_accessors(ctx, env, SEXP_MACRO, 3, "macro-aux", "macro-aux-set!"); sexp_define_foreign(ctx, env, "procedure-code", 1, sexp_get_procedure_code); sexp_define_foreign(ctx, env, "procedure-vars", 1, sexp_get_procedure_vars); sexp_define_foreign(ctx, env, "procedure-arity", 1, sexp_get_procedure_arity); diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm index 81c62bf9..f44938ec 100644 --- a/lib/chibi/ast.scm +++ b/lib/chibi/ast.scm @@ -222,6 +222,8 @@ ;;> \item{\scheme{(macro-procedure f)} - the macro procedure} ;;> \item{\scheme{(macro-env f)} - the environment the macro was defined in} ;;> \item{\scheme{(macro-source f)} - the source location the macro was defined in} +;;> \item{\scheme{(macro-aux f)} - custom auxiliary data stored with the macro} +;;> \item{\scheme{(macro-aux-set! f x)}} ;;> ] ;;> \subsection{Bytecode Objects} diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld index 19b31f27..6e8ccb6f 100644 --- a/lib/chibi/ast.sld +++ b/lib/chibi/ast.sld @@ -26,7 +26,7 @@ exception-kind exception-message exception-irritants exception-source opcode-name opcode-num-params opcode-return-type opcode-param-type opcode-class opcode-code opcode-data opcode-variadic? - macro-procedure macro-env macro-source + macro-procedure macro-env macro-source macro-aux macro-aux-set! procedure-code procedure-vars procedure-name procedure-name-set! procedure-arity procedure-variadic? procedure-flags bytecode-name bytecode-literals bytecode-source diff --git a/lib/chibi/syntax-case-test.sld b/lib/chibi/syntax-case-test.sld new file mode 100644 index 00000000..57b27a3d --- /dev/null +++ b/lib/chibi/syntax-case-test.sld @@ -0,0 +1,50 @@ +(define-library (chibi syntax-case-test) + (export run-tests) + (import (chibi) + (chibi syntax-case) + (chibi test)) + (begin + (define (run-tests) + (test-begin "Syntax Case") + + (test "syntax constant list" + '(+ 1 2) + #'(+ 1 2)) + + (test "pattern variable" + 'foo + (syntax-case 'foo () + (x #'x))) + + (test "syntax-case pair" + '(a b) + (syntax-case '(a . b) () + ((x . y) #'(x y)))) + + (test "syntax-case var" + 'a + (syntax-case '(a . b) (b) + ((b . y) #f) + ((x . b) #'x))) + + (test "syntax-case simple ellipsis" + '(a b c) + (syntax-case '(a b c) () + ((a ...) #'(a ...)))) + + (test "syntax-case ellipsis with tail" + '(a b x c) + (syntax-case '(a b c) () + ((a ... b) #'(a ... x b)))) + + (test "syntax-case ellipsis with dotted tail" + '(a b x c y d) + (syntax-case '(a b c . d) () + ((a ... b . c) #'(a ... x b y c)))) + + (test "syntax-case nested ellipsis" + '((a b) (d e) c f) + (syntax-case '((a b c) (d e f)) () + (((x ... y) ...) #'((x ...) ... y ...)))) + + (test-end)))) diff --git a/lib/chibi/syntax-case.scm b/lib/chibi/syntax-case.scm new file mode 100644 index 00000000..bee7ccf1 --- /dev/null +++ b/lib/chibi/syntax-case.scm @@ -0,0 +1,323 @@ +;; Written by Marc Nieper-Wißkirchen + +;; TODO: make-variable-transformer and identifier-syntax. + +;; TODO: make-synthetic-identifier should return a truly unique (that +;; is not free-identifier=? to any other) identifier. + +;; TODO: Consecutive ellipses in syntax templates. + +;; TODO: Write many more tests. + +(define-syntax define-pattern-variable + (er-macro-transformer + (lambda (expr rename compare) + (let ((id (cadr expr)) + (binding (cddr expr))) + (let ((mac (cdr (env-cell (current-usage-environment) id)))) + (macro-aux-set! mac binding)) + `(,(rename 'begin)))))) + +(define (make-pattern-variable pvar) + (lambda (expr) + (error "reference to pattern variable outside syntax" pvar))) + +(define (pattern-variable x) + (let ((cell (env-cell (current-usage-environment) x))) + (and cell (macro? (cdr cell)) (macro-aux (cdr cell))))) + +(define (rename id) + ((current-renamer) id)) + +(define (ellipsis? id) + (free-identifier=? id (rename '...))) + +(define bound-identifier=? + (lambda (x y) + (eq? x y))) + +(define (syntax-transformer level) + (er-macro-transformer + (lambda (expr rename compare) + (let*-values (((out envs) + (gen-template (cadr expr) '() ellipsis? level))) + out)))) + +(define (syntax->datum stx) + (strip-syntactic-closures stx)) + +(define (symbol->identifier id symbol) + (if (symbol? id) + symbol + ((syntactic-closure-rename id) + symbol))) + +;; TODO: Handle cycles in datum. +(define (datum->syntax id datum) + (let loop ((datum datum)) + (cond ((pair? datum) + (cons (loop (car datum)) + (loop (cdr datum)))) + ((vector? datum) + (do ((res (make-vector (vector-length datum))) + (i 0 (+ i 1))) + ((= i (vector-length datum)) res) + (vector-set! res i (loop (vector-ref datum i))))) + ((symbol? datum) + (symbol->identifier id datum)) + (else + datum)))) + +(define-syntax syntax (syntax-transformer #f)) +(define-syntax quasisyntax (syntax-transformer 0)) +(define-auxiliary-syntax unsyntax) +(define-auxiliary-syntax unsyntax-splicing) + +(define (gen-template tmpl envs ell? level) + (cond + ((pair? tmpl) + (cond + ((and (identifier? (car tmpl)) + (free-identifier=? (car tmpl) (rename 'unsyntax))) + (if (and level (zero? level)) + (values (cadr tmpl) envs) + (let*-values (((out envs) (gen-template (cadr tmpl) envs ell? (and level (- level 1))))) + (values `(,(rename 'list) ,(gen-data (car tmpl)) ,out) envs)))) + ((and (identifier? (car tmpl)) + (free-identifier=? (car tmpl) (rename 'quasisyntax))) + (let*-values (((out envs) (gen-template (cadr tmpl) envs ell? (and level (+ level 1))))) + (values `(,(rename 'list) ,(gen-data (car tmpl)) ,out) envs))) + ((and (pair? (car tmpl)) + (free-identifier=? (caar tmpl) (rename 'unsyntax))) + (if (and level (zero? level)) + (let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level))) + (values `(,(rename 'cons*) ,@(cdar tmpl) ,out) envs)) + (let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1)))) + ((out2 envs) (gen-template (cdr tmpl) envs ell? level))) + (values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1) + ,out2) envs)))) + ((and (pair? (car tmpl)) + (free-identifier=? (caar tmpl) (rename 'unsyntax-splicing))) + (if (and level (zero? level)) + (let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level))) + (values `(,(rename 'append) ,@(cdar tmpl) ,out) envs)) + (let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1)))) + ((out2 envs) (gen-template (cdr tmpl) envs ell? level))) + (values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1) + ,out2) envs)))) + ((and (identifier? (car tmpl)) + (ell? (car tmpl))) + (gen-template (cadr tmpl) envs (lambda (id) #f) level)) + ((and (pair? (cdr tmpl)) + (identifier? (cadr tmpl)) + (ell? (cadr tmpl))) + (let*-values (((out* envs) + (gen-template (cddr tmpl) envs ell? level)) + ((out envs) + (gen-template (car tmpl) (cons '() envs) ell? level))) + (if (null? (car envs)) + (error "too many ellipses following syntax template" (car tmpl))) + (values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx)) + (,(rename 'cons) ,out ,(rename 'stx))) + ,out* ,@(car envs)) + (cdr envs)))) + (else + (let*-values (((out1 envs) + (gen-template (car tmpl) envs ell? level)) + ((out2 envs) + (gen-template (cdr tmpl) envs ell? level))) + (values `(,(rename 'cons) ,out1 ,out2) envs))))) + ((vector? tmpl) + (let*-values (((out envs) + (gen-template (vector->list tmpl) envs ell? level))) + (values `(,(rename 'list->vector) ,out) envs))) + ((identifier? tmpl) + (cond ((ell? tmpl) + (error "misplaced ellipsis in syntax template" tmpl)) + ((pattern-variable tmpl) => + (lambda (binding) + (values (car binding) + (update-envs tmpl (car binding) (cadr binding) envs)))) + (else + (values (gen-data tmpl) envs)))) + (else + (values `(,(rename 'quote) ,tmpl) envs)))) + +(define (gen-data id) + `((,(rename 'current-renamer)) + (,(rename 'syntax-quote) ,id))) + +(define (update-envs id x level envs) + (let loop ((level level) (envs envs)) + (cond ((zero? level) + envs) + ((null? envs) + (error "too few ellipses following syntax template" id)) + (else + (let ((outer-envs (loop (- level 1) (cdr envs)))) + (cond ((member x (car envs) bound-identifier=?) + envs) + (else + (cons (cons x (car envs)) + outer-envs)))))))) + +(define-syntax syntax-case + (er-macro-transformer + (lambda (expr rename compare) + (let ((expr (cadr expr)) + (lit* (car (cddr expr))) + (clause* (reverse (cdr (cddr expr)))) + (error #'(error "syntax error" e))) + #`(let ((e #,expr)) + #,(if (null? clause*) + error + #`(let ((fail (lambda () #,error))) + #,(let loop ((clause (car clause*)) + (clause* (cdr clause*))) + (if (null? clause*) + (gen-clause lit* clause) + #`(let ((fail (lambda () + #,(gen-clause lit* clause)))) + #,(loop (car clause*) (cdr clause*)))))))))))) + +(define (gen-clause lit* clause) + (if (= 3 (length clause)) + (gen-output lit* (car clause) (cadr clause) (car (cddr clause))) + (gen-output lit* (car clause) #t (cadr clause)))) + +(define (gen-output lit* pattern fender output-expr) + (let*-values (((matcher vars) + (gen-matcher #'e lit* pattern '()))) + (matcher (lambda () + #`(let-syntax #,(map (lambda (var) + #`(#,(car var) + (make-pattern-variable (syntax-quote #,(car var))))) + vars) + #,@(map (lambda (var) + #`(define-pattern-variable . #,var)) + vars) + (if #,fender + #,output-expr + (fail))))))) + +(define (gen-matcher e lit* pattern vars) + (cond ((pair? pattern) + (cond + ((and (pair? (cdr pattern)) + (identifier? (cadr pattern)) + (ellipsis? (cadr pattern))) + (let* ((l (length+ (cddr pattern))) + (h (car (generate-temporaries '(#f)))) + (t (car (generate-temporaries '(#f))))) + (let*-values (((head-matcher vars) (gen-map h lit* (car pattern) vars)) + ((tail-matcher vars) (gen-matcher* t lit* (cddr pattern) vars))) + (values (lambda (k) + #`(let ((n (length+ #,e))) + (if (and n (>= n #,l)) + (let*-values (((#,h #,t) (split-at #,e (- n #,l)))) + #,(head-matcher (lambda () + (tail-matcher k)))) + (fail)))) + vars)))) + (else + (let ((e1 (car (generate-temporaries '(#f)))) + (e2 (car (generate-temporaries '(#f))))) + (let*-values (((car-matcher vars) + (gen-matcher e1 lit* (car pattern) vars)) + ((cdr-matcher vars) + (gen-matcher e2 lit* (cdr pattern) vars))) + (values (lambda (k) + #`(if (pair? #,e) + (let ((#,e1 (car #,e)) + (#,e2 (cdr #,e))) + #,(car-matcher (lambda () + (cdr-matcher k)))) + (fail))) + vars)))))) + ((identifier? pattern) + (cond ((member pattern lit* free-identifier=?) + (values (lambda (k) + #`(if (free-identifier=? #'#,pattern #,e) + #,(k) + (fail))) + vars)) + ((ellipsis? pattern) + (error "misplaced ellipsis" pattern)) + ((free-identifier=? pattern #'_) + (values (lambda (k) + (k)) + vars)) + (else + (values (lambda (k) + (k)) + (alist-cons pattern (list e 0) vars))))) + (else + (values (lambda (k) + #`(if (equal? (syntax->datum #,e) '#,pattern) + #,(k) + (fail))) + vars)))) + +(define (gen-map h lit* pattern vars) + (let*-values (((matcher inner-vars) (gen-matcher #'g lit* pattern '()))) + (let ((loop (car (generate-temporaries '(#f)))) + (g* (generate-temporaries inner-vars))) + (values (lambda (k) + #`(let #,loop ((#,h (reverse #,h)) + #,@(map (lambda (g) + #`(#,g '())) + g*)) + (if (null? #,h) + #,(k) + (let ((g (car #,h))) + #,(matcher (lambda () + #`(#,loop (cdr #,h) + #,@(map (lambda (var g) + #`(cons #,(cadr var) #,g)) + inner-vars g*)))))))) + (fold (lambda (g var vars) + (alist-cons (car var) (list g (+ (cadr (cdr var)) 1)) vars)) + vars g* inner-vars))))) + +(define (gen-matcher* e lit* pattern* vars) + (let loop ((e e) (pattern* pattern*) (vars vars)) + (cond ((null? pattern*) + (values (lambda (k) + #`(if (null? #,e) + #,(k) + (fail))) + vars)) + ((pair? pattern*) + (let ((e1 (car (generate-temporaries '(#f)))) + (e2 (car (generate-temporaries '(#f))))) + (let*-values (((car-matcher vars) + (gen-matcher e1 lit* (car pattern*) vars)) + ((cdr-matcher vars) + (loop e2 (cdr pattern*) vars))) + (values (lambda (k) + #`(let ((#,e1 (car #,e)) + (#,e2 (cdr #,e))) + #,(car-matcher (lambda () + (cdr-matcher k))))) + vars)))) + (else + (gen-matcher e lit* pattern* vars))))) + +(define (make-synthetic-identifier id) + (close-syntax id (environment))) + +(define (generate-temporaries l) + (map (lambda (x) (make-synthetic-identifier 't)) l)) + +(define-syntax with-syntax + (lambda (x) + (syntax-case x () + ((_ ((p e0) ...) e1 e2 ...) + #'(syntax-case (list e0 ...) () + ((p ...) (let () e1 e2 ...))))))) + +(define (syntax-violation who message . form*) + (apply error message form*)) + + +;; TODO: Move datum->syntax from init-7 here. diff --git a/lib/chibi/syntax-case.sld b/lib/chibi/syntax-case.sld new file mode 100644 index 00000000..7b139daa --- /dev/null +++ b/lib/chibi/syntax-case.sld @@ -0,0 +1,11 @@ +(define-library (chibi syntax-case) + (export ... _ free-identifier=? bound-identifier=? identifier? + syntax-case syntax quasisyntax unsyntax unsyntax-splicing + datum->syntax syntax->datum + generate-temporaries with-syntax syntax-violation) + (import (chibi) + (chibi ast) + (meta) + (srfi 1) + (srfi 11)) + (include "syntax-case.scm")) diff --git a/lib/init-7.scm b/lib/init-7.scm index 87857fd6..f243cb0a 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -98,32 +98,78 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; syntax +(current-renamer (lambda (x) x)) + +(define close-syntax + (lambda (form env) + (make-syntactic-closure env '() form))) + +(define make-renamer + (lambda (mac-env) + (define rename + ((lambda (renames) + (lambda (identifier) + ((lambda (cell) + (if cell + (cdr cell) + ((lambda (name) + (set! renames (cons (cons identifier name) renames)) + name) + ((lambda (id) + (syntactic-closure-set-rename! id rename) + id) + (close-syntax identifier mac-env))))) + (assq identifier renames)))) + '())) + rename)) + +(define make-transformer + (lambda (transformer) + (lambda (expr use-env mac-env) + ((lambda (old-use-env old-mac-env old-renamer) + (current-usage-environment use-env) + (current-transformer-environment mac-env) + (current-renamer (make-renamer mac-env)) + ((lambda (result) + (current-usage-environment old-use-env) + (current-transformer-environment old-mac-env) + (current-renamer old-renamer) + result) + (transformer expr))) + (current-usage-environment) + (current-transformer-environment) + (current-renamer))))) + +(%define-syntax define-syntax + (lambda (expr use-env mac-env) + (list (close-syntax '%define-syntax mac-env) + (cadr expr) + (list (close-syntax 'make-transformer mac-env) + (car (cddr expr)))))) + +(define free-identifier=? + (lambda (x y) + ((lambda (use-env cur-env) + (identifier=? (if use-env use-env cur-env) x + (if use-env use-env cur-env) y)) + (current-usage-environment) + (current-environment)))) + (define sc-macro-transformer (lambda (f) - (lambda (expr use-env mac-env) - (make-syntactic-closure mac-env '() (f expr use-env))))) + (lambda (expr) + (close-syntax (f expr (current-usage-environment)) + (current-transformer-environment))))) (define rsc-macro-transformer (lambda (f) - (lambda (expr use-env mac-env) - (f expr mac-env)))) + (lambda (expr) + (f expr (current-transformer-environment))))) (define er-macro-transformer (lambda (f) - (lambda (expr use-env mac-env) - ((lambda (rename compare) (f expr rename compare)) - ((lambda (renames) - (lambda (identifier) - ((lambda (cell) - (if cell - (cdr cell) - ((lambda (name) - (set! renames (cons (cons identifier name) renames)) - name) - (make-syntactic-closure mac-env '() identifier)))) - (assq identifier renames)))) - '()) - (lambda (x y) (identifier=? use-env x use-env y)))))) + (lambda (expr) + (f expr (current-renamer) free-identifier=?)))) (define-syntax cond (er-macro-transformer @@ -929,6 +975,19 @@ (lambda (expr rename compare) (syntax-rules-transformer expr rename compare)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; let(rec)-syntax + +(define-syntax let-syntax + (syntax-rules () + ((let-syntax ((keyword transformer) ...) . body) + (%let-syntax ((keyword (make-transformer transformer)) ...) . body)))) + +(define-syntax letrec-syntax + (syntax-rules () + ((letrec-syntax ((keyword transformer) ...) . body) + (%letrec-syntax ((keyword (make-transformer transformer)) ...) . body)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; additional syntax diff --git a/lib/meta-7.scm b/lib/meta-7.scm index ad8f9d76..9050861e 100644 --- a/lib/meta-7.scm +++ b/lib/meta-7.scm @@ -223,8 +223,8 @@ (module-env-set! mod (eval-module name mod))) mod)) -(define-syntax meta-begin begin) -(define-syntax meta-define define) +(%define-syntax meta-begin begin) +(%define-syntax meta-define define) (define define-library-transformer (er-macro-transformer diff --git a/lib/srfi/139.scm b/lib/srfi/139.scm index 4198dfba..f744c105 100644 --- a/lib/srfi/139.scm +++ b/lib/srfi/139.scm @@ -4,7 +4,7 @@ (for-each set-cdr! (car (cddr expr)) (cadr (cddr expr))) (car (cdr expr))))) -(define-syntax syntax-parameterize +(%define-syntax syntax-parameterize (lambda (expr use-env mac-env) (let* ((_let (make-syntactic-closure mac-env '() 'let)) (_set! (make-syntactic-closure mac-env '() 'set!)) @@ -21,7 +21,9 @@ (old (map cdr cells)) (new (map (lambda (transformer) (make-macro - (eval (make-syntactic-closure use-env '() transformer)) + (make-transformer + (eval + (make-syntactic-closure use-env '() transformer))) use-env)) transformers))) (for-each set-cdr! cells new) diff --git a/lib/srfi/38.scm b/lib/srfi/38.scm index 78a98921..0b3c28b8 100644 --- a/lib/srfi/38.scm +++ b/lib/srfi/38.scm @@ -370,6 +370,11 @@ ((#\() (list->vector (read-one in))) ((#\') (read-char in) (list 'syntax (read-one in))) ((#\`) (read-char in) (list 'quasisyntax (read-one in))) + ((#\,) (read-char in) + (let ((sym (if (eqv? #\@ (peek-char in)) + (begin (read-char in) 'unsyntax-splicing) + 'unsyntax))) + (list sym (read-one in)))) ((#\t) (let ((s (read-name #f in))) (or (string-ci=? s "t") (string-ci=? s "true") (read-error "bad # syntax" s)))) diff --git a/lib/srfi/99/records/syntactic.scm b/lib/srfi/99/records/syntactic.scm index 1f8ae70c..e3166128 100644 --- a/lib/srfi/99/records/syntactic.scm +++ b/lib/srfi/99/records/syntactic.scm @@ -10,11 +10,13 @@ (procs (cddr expr)) (make (car procs)) (make-name (if (eq? make #t) - (string->symbol (string-append "make-" name-str)) + (datum->syntax (car expr) + (string->symbol (string-append "make-" name-str))) (if (pair? make) (car make) make))) (pred (cadr procs)) (pred-name (if (eq? pred #t) - (string->symbol (string-append name-str "?")) + (datum->syntax (car expr) + (string->symbol (string-append name-str "?"))) pred)) (fields (cddr procs)) (field-names (map (lambda (x) (if (pair? x) (car x) x)) fields)) diff --git a/lib/srfi/99/records/syntactic.sld b/lib/srfi/99/records/syntactic.sld index 6a62db99..5ddc00c6 100644 --- a/lib/srfi/99/records/syntactic.sld +++ b/lib/srfi/99/records/syntactic.sld @@ -1,5 +1,5 @@ (define-library (srfi 99 records syntactic) (export define-record-type) - (import (chibi) (srfi 99 records inspection)) + (import (chibi) (chibi syntax-case) (srfi 99 records inspection)) (include "syntactic.scm")) diff --git a/lib/srfi/99/test.sld b/lib/srfi/99/test.sld index d3a8702a..a012c0b9 100644 --- a/lib/srfi/99/test.sld +++ b/lib/srfi/99/test.sld @@ -110,6 +110,18 @@ (test 'mixed (breed-of felix)) (test '(and black white) (color-of felix)) + ;;; See issue #494. + (test-assert + (let-syntax + ((foo + (syntax-rules () + ((foo) + (let () + (define-record-type record + #t + #t) + (record? (make-record))))))) + (foo))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let () @@ -178,9 +190,9 @@ (define make-point (rtd-constructor point #(x y))) (define point-x (rtd-accessor point 'x)) (test 'point (rtd-name point)) - (test 3 (point-x (make-point 3 2)))) + (test 3 (point-x (make-point 3 2)))) - ;; Name conflicts - make sure we rename + ;; Name conflicts - make sure we rename (let () (define-record-type example make-example #t example) diff --git a/opcodes.c b/opcodes.c index dfc78684..4f7f259a 100644 --- a/opcodes.c +++ b/opcodes.c @@ -38,6 +38,9 @@ _PARAM("current-output-port", _I(SEXP_OPORT)), _PARAM("current-error-port", _I(SEXP_OPORT)), _PARAM("current-exception-handler", _I(SEXP_PROCEDURE)), _PARAM("interaction-environment", _I(SEXP_ENV)), +_PARAM("current-usage-environment", _I(SEXP_ENV)), +_PARAM("current-transformer-environment", _I(SEXP_ENV)), +_PARAM("current-renamer", _I(SEXP_PROCEDURE)), _PARAM("command-line", SEXP_NULL), _OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL), _OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL), @@ -45,6 +48,8 @@ _OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FAL _OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-cdr!", 0, NULL), _GETTER("pair-source", SEXP_PAIR, 2), _SETTER("pair-source-set!", SEXP_PAIR, 2), +_GETTER("syntactic-closure-rename", SEXP_SYNCLO, 3), +_SETTER("syntactic-closure-set-rename!", SEXP_SYNCLO, 3), _OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_OBJECT), _I(SEXP_VECTOR), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "vector-ref", 0, NULL), _OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, SEXP_VOID, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0, "vector-set!", 0, NULL), _OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_VECTOR), SEXP_FALSE, SEXP_FALSE, 0, "vector-length", 0, NULL), diff --git a/sexp.c b/sexp.c index d6e9d72d..dded7238 100644 --- a/sexp.c +++ b/sexp.c @@ -217,8 +217,8 @@ static struct sexp_type_struct _sexp_type_specs[] = { {SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_FILENON, SEXP_FINALIZE_FILENO}, {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 5, 5, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, - {SEXP_MACRO, sexp_offsetof(macro, proc), 3, 3, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, - {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sc", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_MACRO, sexp_offsetof(macro, proc), 4, 4, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_SYNCLO, sexp_offsetof(synclo, env), 4, 4, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sc", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, {SEXP_ENV, sexp_offsetof(env, parent), 3+SEXP_USE_RENAME_BINDINGS, 3+SEXP_USE_RENAME_BINDINGS, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Environment", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, {SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Bytecode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, {SEXP_CORE, sexp_offsetof(core, name), 1, 1, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Core-Form", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, @@ -465,6 +465,10 @@ void sexp_init_context_globals (sexp ctx) { sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote", -1); sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote", -1); sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing", -1); + sexp_global(ctx, SEXP_G_SYNTAX_SYMBOL) = sexp_intern(ctx, "syntax", -1); + sexp_global(ctx, SEXP_G_QUASISYNTAX_SYMBOL) = sexp_intern(ctx, "quasisyntax", -1); + sexp_global(ctx, SEXP_G_UNSYNTAX_SYMBOL) = sexp_intern(ctx, "unsyntax", -1); + sexp_global(ctx, SEXP_G_UNSYNTAX_SPLICING_SYMBOL) = sexp_intern(ctx, "unsyntax-splicing", -1); sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "current-input-port", -1); sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "current-output-port", -1); sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "current-error-port", -1); @@ -2093,6 +2097,8 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { sexp_write(ctx, sexp_make_fixnum(obj), out); sexp_write_char(ctx, ' ', out); sexp_write(ctx, sexp_synclo_expr(obj), out); + sexp_write_char(ctx, ' ', out); + sexp_write(ctx, sexp_synclo_rename(obj), out); sexp_write_char(ctx, '>', out); break; default: @@ -3166,6 +3172,28 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) { res = sexp_list_to_vector(ctx, res); } break; + case '\'': + res = sexp_read_one(ctx, in, shares); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_SYNTAX_SYMBOL), res); + break; + case '`': + res = sexp_read_one(ctx, in, shares); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASISYNTAX_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read_one(ctx, in, shares); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNSYNTAX_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read_one(ctx, in, shares); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNSYNTAX_SYMBOL), res); + } + break; default: res = sexp_read_error(ctx, "invalid char following '#'", c1 == EOF ? SEXP_EOF : sexp_make_character(c1), in); diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index 25f47020..2e9f68b2 100644 --- a/tests/lib-tests.scm +++ b/tests/lib-tests.scm @@ -52,6 +52,7 @@ (rename (chibi show-test) (run-tests run-show-tests)) (rename (chibi show c-test) (run-tests run-show-c-tests)) (rename (chibi string-test) (run-tests run-string-tests)) + (rename (chibi syntax-case-test) (run-tests run-syntax-case-tests)) (rename (chibi system-test) (run-tests run-system-tests)) (rename (chibi tar-test) (run-tests run-tar-tests)) ;;(rename (chibi term ansi-test) (run-tests run-term-ansi-tests)) @@ -107,6 +108,7 @@ (run-rsa-tests) (run-scribble-tests) (run-string-tests) +(run-syntax-case-tests) (run-sha2-tests) (run-show-tests) (run-show-c-tests) From 081a2a7b3f87c8764017bf411f8ab7b41c19761e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= Date: Wed, 5 Dec 2018 12:15:17 +0100 Subject: [PATCH 2/3] Construct constructor/predicate names in the syntactic context of the record name, not the context of the invokation of define-record-type --- lib/srfi/99/records/syntactic.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/srfi/99/records/syntactic.scm b/lib/srfi/99/records/syntactic.scm index e3166128..e43a8a79 100644 --- a/lib/srfi/99/records/syntactic.scm +++ b/lib/srfi/99/records/syntactic.scm @@ -10,12 +10,12 @@ (procs (cddr expr)) (make (car procs)) (make-name (if (eq? make #t) - (datum->syntax (car expr) + (datum->syntax name (string->symbol (string-append "make-" name-str))) (if (pair? make) (car make) make))) (pred (cadr procs)) (pred-name (if (eq? pred #t) - (datum->syntax (car expr) + (datum->syntax name (string->symbol (string-append name-str "?"))) pred)) (fields (cddr procs)) From 5c963df96fe46f11e0c27000b3f789de8801b371 Mon Sep 17 00:00:00 2001 From: Marc Nieper-Wisskirchen Date: Wed, 5 Dec 2018 15:59:39 +0100 Subject: [PATCH 3/3] Move datum->syntax back to init-7.scm. Don't crash when renamer not present in syntactic closure. --- lib/chibi/syntax-case.scm | 22 ---------------------- lib/init-7.scm | 28 +++++++++++++++++++++++++++- 2 files changed, 27 insertions(+), 23 deletions(-) diff --git a/lib/chibi/syntax-case.scm b/lib/chibi/syntax-case.scm index bee7ccf1..92c3b74d 100644 --- a/lib/chibi/syntax-case.scm +++ b/lib/chibi/syntax-case.scm @@ -46,28 +46,6 @@ (define (syntax->datum stx) (strip-syntactic-closures stx)) -(define (symbol->identifier id symbol) - (if (symbol? id) - symbol - ((syntactic-closure-rename id) - symbol))) - -;; TODO: Handle cycles in datum. -(define (datum->syntax id datum) - (let loop ((datum datum)) - (cond ((pair? datum) - (cons (loop (car datum)) - (loop (cdr datum)))) - ((vector? datum) - (do ((res (make-vector (vector-length datum))) - (i 0 (+ i 1))) - ((= i (vector-length datum)) res) - (vector-set! res i (loop (vector-ref datum i))))) - ((symbol? datum) - (symbol->identifier id datum)) - (else - datum)))) - (define-syntax syntax (syntax-transformer #f)) (define-syntax quasisyntax (syntax-transformer 0)) (define-auxiliary-syntax unsyntax) diff --git a/lib/init-7.scm b/lib/init-7.scm index f243cb0a..a3bc89b9 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -976,7 +976,7 @@ (syntax-rules-transformer expr rename compare)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; let(rec)-syntax +;; let(rec)-syntax and datum->syntax (define-syntax let-syntax (syntax-rules () @@ -988,6 +988,32 @@ ((letrec-syntax ((keyword transformer) ...) . body) (%letrec-syntax ((keyword (make-transformer transformer)) ...) . body)))) +(define (symbol->identifier id symbol) + (cond + ((symbol? id) + symbol) + ((syntactic-closure-rename id) + => (lambda (renamer) + (renamer symbol))) + (else + symbol))) + +;; TODO: Handle cycles in datum. +(define (datum->syntax id datum) + (let loop ((datum datum)) + (cond ((pair? datum) + (cons (loop (car datum)) + (loop (cdr datum)))) + ((vector? datum) + (do ((res (make-vector (vector-length datum))) + (i 0 (+ i 1))) + ((= i (vector-length datum)) res) + (vector-set! res i (loop (vector-ref datum i))))) + ((symbol? datum) + (symbol->identifier id datum)) + (else + datum)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; additional syntax