Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Implement syntax-case

Browse source
This commit is contained in:
Marc Nieper-Wisskirchen 2018-11-30 14:04:07 +01:00 • committed by Marc Nieper-Wißkirchen
parent 3c4d839c71
commit 152b20f244
18 changed files with 547 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
eval.c
View file

@ -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) {

10
include/chibi/sexp.h
View file

@ -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,

3
lib/chibi/ast.c
View file

@ -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);

2
lib/chibi/ast.scm
View file

@ -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}

2
lib/chibi/ast.sld
View file

@ -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

50
lib/chibi/syntax-case-test.sld Normal file
View file

@ -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))))

323
lib/chibi/syntax-case.scm Normal file
View file

@ -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.

11
lib/chibi/syntax-case.sld Normal file
View file

@ -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"))

89
lib/init-7.scm
View file

@ -98,20 +98,15 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax
(define sc-macro-transformer
(lambda (f)
(lambda (expr use-env mac-env)
(make-syntactic-closure mac-env '() (f expr use-env)))))
(current-renamer (lambda (x) x))
(define rsc-macro-transformer
(lambda (f)
(lambda (expr use-env mac-env)
(f expr mac-env))))
(define close-syntax
(lambda (form env)
(make-syntactic-closure env '() form)))
(define er-macro-transformer
(lambda (f)
(lambda (expr use-env mac-env)
((lambda (rename compare) (f expr rename compare))
(define make-renamer
(lambda (mac-env)
(define rename
((lambda (renames)
(lambda (identifier)
((lambda (cell)
@ -120,10 +115,61 @@
((lambda (name)
(set! renames (cons (cons identifier name) renames))
name)
(make-syntactic-closure mac-env '() identifier))))
((lambda (id)
(syntactic-closure-set-rename! id rename)
id)
(close-syntax identifier mac-env)))))
(assq identifier renames))))
'())
(lambda (x y) (identifier=? use-env x use-env y))))))
'()))
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)
(close-syntax (f expr (current-usage-environment))
(current-transformer-environment)))))
(define rsc-macro-transformer
(lambda (f)
(lambda (expr)
(f expr (current-transformer-environment)))))
(define er-macro-transformer
(lambda (f)
(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

4
lib/meta-7.scm
View file

@ -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

6
lib/srfi/139.scm
View file

@ -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)

5
lib/srfi/38.scm
View file

@ -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))))

6
lib/srfi/99/records/syntactic.scm
View file

@ -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))

2
lib/srfi/99/records/syntactic.sld
View file

@ -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"))

12
lib/srfi/99/test.sld
View file

@ -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 ()

5
opcodes.c
View file

@ -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),

32
sexp.c
View file

@ -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);

2
tests/lib-tests.scm
View file

@ -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)