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

Add (rnrs syntax-case)

Browse source
This commit is contained in:
Daphne Preston-Kendal 2024-11-02 11:01:54 +01:00
parent 910c32182f
commit 31a3316bf2
5 changed files with 177 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
lib/chibi/syntax-case.scm
View file

@ -77,7 +77,7 @@
(define (make-pattern-variable pvar) (define (make-pattern-variable pvar)
(lambda (expr) (lambda (expr)
(error "reference to pattern variable outside syntax" pvar))) (syntax-violation #f "reference to pattern variable outside syntax" pvar)))
(define (pattern-variable x) (define (pattern-variable x)
(and-let* (and-let*
@ -163,7 +163,9 @@
((out envs) ((out envs)
(gen-template (car tmpl) (cons '() envs) ell? level))) (gen-template (car tmpl) (cons '() envs) ell? level)))
(if (null? (car envs)) (if (null? (car envs))
(error "too many ellipses following syntax template" (car tmpl))) (syntax-violation 'syntax
"too many ellipses following syntax template"
(car tmpl)))
(values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx)) (values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx))
(,(rename 'cons) ,out ,(rename 'stx))) (,(rename 'cons) ,out ,(rename 'stx)))
,out* ,@(car envs)) ,out* ,@(car envs))
@ -180,7 +182,9 @@
(values `(,(rename 'list->vector) ,out) envs))) (values `(,(rename 'list->vector) ,out) envs)))
((identifier? tmpl) ((identifier? tmpl)
(cond ((ell? tmpl) (cond ((ell? tmpl)
(error "misplaced ellipsis in syntax template" tmpl)) (syntax-violation 'syntax
"misplaced ellipsis in syntax template"
tmpl))
((pattern-variable tmpl) => ((pattern-variable tmpl) =>
(lambda (binding) (lambda (binding)
(values (car binding) (values (car binding)
@ -199,7 +203,7 @@
(cond ((zero? level) (cond ((zero? level)
envs) envs)
((null? envs) ((null? envs)
(error "too few ellipses following syntax template" id)) (syntax-violation #f "too few ellipses following syntax template" id))
(else (else
(let ((outer-envs (loop (- level 1) (cdr envs)))) (let ((outer-envs (loop (- level 1) (cdr envs))))
(cond ((member x (car envs) bound-identifier=?) (cond ((member x (car envs) bound-identifier=?)
@ -214,7 +218,7 @@
(let ((expr (cadr expr)) (let ((expr (cadr expr))
(lit* (car (cddr expr))) (lit* (car (cddr expr)))
(clause* (reverse (cdr (cddr expr)))) (clause* (reverse (cdr (cddr expr))))
(error #'(error "syntax error" e))) (error #`(syntax-violation #f "syntax error" e)))
#`(let ((e #,expr)) #`(let ((e #,expr))
#,(if (null? clause*) #,(if (null? clause*)
error error
@ -294,7 +298,7 @@
(fail))) (fail)))
vars)) vars))
((ellipsis-identifier? pattern) ((ellipsis-identifier? pattern)
(error "misplaced ellipsis" pattern)) (syntax-violation #f "misplaced ellipsis" pattern))
((free-identifier=? pattern #'_) ((free-identifier=? pattern #'_)
(values (lambda (k) (values (lambda (k)
(k)) (k))
@ -370,8 +374,19 @@
#'(syntax-case (list e0 ...) () #'(syntax-case (list e0 ...) ()
((p ...) (let () e1 e2 ...))))))) ((p ...) (let () e1 e2 ...)))))))
(define (syntax-violation who message . form*) (define (syntax-violation who message form . maybe-subform)
(apply error message form*)) (raise (condition (make-syntax-violation form
(if (null? maybe-subform)
#f
(car maybe-subform)))
(cond (who => make-who-condition)
((identifier? form)
(make-who-condition (syntax->datum form)))
((and (pair? form)
(identifier? (car form)))
(make-who-condition (syntax->datum (car form))))
(else (condition)))
(make-message-condition message))))
(define-syntax define-current-ellipsis (define-syntax define-current-ellipsis
(lambda (stx) (lambda (stx)

1
lib/chibi/syntax-case.sld
View file

@ -14,6 +14,7 @@
procedure-arity procedure-variadic? procedure-arity procedure-variadic?
procedure-variable-transformer? procedure-variable-transformer?
make-variable-transformer) make-variable-transformer)
(rnrs conditions)
(only (meta) environment) (only (meta) environment)
(srfi 1) (srfi 1)
(srfi 2) (srfi 2)

37
lib/rnrs/base.sld
View file

@ -190,12 +190,16 @@
vector-set! vector-set!
vector? vector?
zero?) zero?)
(import (rename (scheme base) (import (except (scheme base)
(error r7rs:error)) define-syntax
let-syntax
letrec-syntax
syntax-rules)
(scheme cxr) (scheme cxr)
(scheme inexact) (scheme inexact)
(scheme complex) (scheme complex)
(rnrs conditions) (rnrs conditions)
(only (srfi 1) every)
(rename (srfi 141) (rename (srfi 141)
(euclidean-quotient div) (euclidean-quotient div)
(euclidean-remainder mod) (euclidean-remainder mod)
@ -203,9 +207,38 @@
(balanced-quotient div0) (balanced-quotient div0)
(balanced-remainder mod0) (balanced-remainder mod0)
(balanced/ div0-and-mod0)) (balanced/ div0-and-mod0))
(rename (chibi syntax-case)
(splicing-let-syntax let-syntax)
(splicing-letrec-syntax letrec-syntax))
(except (chibi ast) error) (except (chibi ast) error)
(chibi show)) (chibi show))
(define-syntax syntax-rules
(lambda (x)
(syntax-case x ()
((_ (lit ...) ((k . p) t) ...)
(every identifier? #'(lit ... k ...))
#'(lambda (x)
(syntax-case x (lit ...)
((_ . p) #'t) ...))))))
(define-syntax identifier-syntax
(lambda (x)
(syntax-case x (set!)
((_ e)
#'(lambda (x)
(syntax-case x ()
(id (identifier? #'id) #'e)
((_ x (... ...)) #'(e x (... ...))))))
((_ (id exp1) ((set! var val) exp2))
(and (identifier? #'id) (identifier? #'var))
#'(make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! var val) #'exp2)
((id x (... ...)) #'(exp1 x (... ...)))
(id (identifier? #'id) #'exp1))))))))
(define-syntax assert (define-syntax assert
(syntax-rules () (syntax-rules ()
((_ expr) ((_ expr)

101
lib/rnrs/conditions.sld Normal file
View file

@ -0,0 +1,101 @@
(library (rnrs conditions)
(export &condition
(rename make-compound-condition condition)
simple-conditions
condition-predicate
condition-accessor
(rename define-condition-type/constructor define-condition-type)
;; 7.3 Standard condition types
&message
make-message-condition
message-condition?
condition-message
&warning
make-warning
warning?
&serious
make-serious-condition
serious-condition?
&error
make-error
error?
&violation
make-violation
violation?
&assertion
make-assertion-violation
assertion-violation?
&irritants
make-irritants-condition
irritants-condition?
condition-irritants
&who
make-who-condition
who-condition?
condition-who
&non-continuable
make-non-continuable-violation
non-continuable-violation?
&implementation-restriction
make-implementation-restriction-violation
implementation-restriction-violation?
&lexical
make-lexical-violation
lexical-violation?
&syntax
make-syntax-violation
syntax-violation?
syntax-violation-form
syntax-violation-subform
&undefined
make-undefined-violation
undefined-violation?)
(import (srfi 35 internal))
(define-condition-type/constructor &warning &condition
make-warning warning?)
(define-condition-type/constructor &violation &serious
make-violation violation?)
(define-condition-type/constructor &assertion &violation
make-assertion-violation assertion-violation?)
(define-condition-type/constructor &irritants &condition
make-irritants-condition irritants-condition?
(irritants condition-irritants))
(define-condition-type/constructor &who &condition
make-who-condition who-condition?
(who condition-who))
(define-condition-type/constructor &non-continuable &violation
make-non-continuable-violation non-continuable-violation?)
(define-condition-type/constructor &implementation-restriction &violation
make-implementation-restriction-violation
implementation-restriction-violation?)
(define-condition-type/constructor &lexical &violation
make-lexical-violation lexical-violation?)
(define-condition-type/constructor &syntax &violation
make-syntax-violation syntax-violation?
(form syntax-violation-form)
(subform syntax-violation-subform))
(define-condition-type/constructor &undefined &violation
make-undefined-violation undefined-violation?))

17
lib/rnrs/syntax-case.sld Normal file
View file

@ -0,0 +1,17 @@
(library (rnrs syntax-case)
(export make-variable-transformer
syntax-case
syntax
identifier?
bound-identifier=?
free-identifier=?
syntax->datum
datum->syntax
generate-temporaries
with-syntax
quasisyntax
unsyntax
unsyntax-splicing
syntax-violation)
(import (chibi ast)
(chibi syntax-case)))