From 4981c4771f13f0761965df01868eef78dbc8d7ef Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Sat, 2 Nov 2024 11:01:54 +0100 Subject: [PATCH] Add `(rnrs syntax-case)` --- lib/chibi/syntax-case.scm | 41 +++++++++++++--- lib/chibi/syntax-case.sld | 4 +- lib/rnrs/base.sld | 36 +++++++++++++- lib/rnrs/conditions.sld | 101 ++++++++++++++++++++++++++++++++++++++ lib/rnrs/syntax-case.sld | 17 +++++++ 5 files changed, 188 insertions(+), 11 deletions(-) create mode 100644 lib/rnrs/conditions.sld create mode 100644 lib/rnrs/syntax-case.sld diff --git a/lib/chibi/syntax-case.scm b/lib/chibi/syntax-case.scm index f0b80d21..3c06f2bd 100644 --- a/lib/chibi/syntax-case.scm +++ b/lib/chibi/syntax-case.scm @@ -61,6 +61,16 @@ ((letrec-syntax ((keyword transformer) ...) . body) (%letrec-syntax ((keyword (make-transformer transformer)) ...) . body)))) +(define-syntax splicing-let-syntax + (syntax-rules () + ((splicing-let-syntax ((keyword transformer) ...) . body) + (%splicing-let-syntax ((keyword (make-transformer transformer)) ...) . body)))) + +(define-syntax splicing-letrec-syntax + (syntax-rules () + ((splicing-letrec-syntax ((keyword transformer) ...) . body) + (%splicing-letrec-syntax ((keyword (make-transformer transformer)) ...) . body)))) + (define-record-type Pattern-Cell (make-pattern-cell val) pattern-cell? (val pattern-cell-value)) @@ -77,7 +87,7 @@ (define (make-pattern-variable pvar) (lambda (expr) - (error "reference to pattern variable outside syntax" pvar))) + (syntax-violation #f "reference to pattern variable outside syntax" pvar))) (define (pattern-variable x) (and-let* @@ -163,7 +173,9 @@ ((out envs) (gen-template (car tmpl) (cons '() envs) ell? level))) (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)) (,(rename 'cons) ,out ,(rename 'stx))) ,out* ,@(car envs)) @@ -180,7 +192,9 @@ (values `(,(rename 'list->vector) ,out) envs))) ((identifier? tmpl) (cond ((ell? tmpl) - (error "misplaced ellipsis in syntax template" tmpl)) + (syntax-violation 'syntax + "misplaced ellipsis in syntax template" + tmpl)) ((pattern-variable tmpl) => (lambda (binding) (values (car binding) @@ -199,7 +213,7 @@ (cond ((zero? level) envs) ((null? envs) - (error "too few ellipses following syntax template" id)) + (syntax-violation #f "too few ellipses following syntax template" id)) (else (let ((outer-envs (loop (- level 1) (cdr envs)))) (cond ((member x (car envs) bound-identifier=?) @@ -214,7 +228,7 @@ (let ((expr (cadr expr)) (lit* (car (cddr expr))) (clause* (reverse (cdr (cddr expr)))) - (error #'(error "syntax error" e))) + (error #`(syntax-violation #f "syntax error" e))) #`(let ((e #,expr)) #,(if (null? clause*) error @@ -294,7 +308,7 @@ (fail))) vars)) ((ellipsis-identifier? pattern) - (error "misplaced ellipsis" pattern)) + (syntax-violation #f "misplaced ellipsis" pattern)) ((free-identifier=? pattern #'_) (values (lambda (k) (k)) @@ -370,8 +384,19 @@ #'(syntax-case (list e0 ...) () ((p ...) (let () e1 e2 ...))))))) -(define (syntax-violation who message . form*) - (apply error message form*)) +(define (syntax-violation who message form . maybe-subform) + (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 (lambda (stx) diff --git a/lib/chibi/syntax-case.sld b/lib/chibi/syntax-case.sld index a12a7316..93670beb 100644 --- a/lib/chibi/syntax-case.sld +++ b/lib/chibi/syntax-case.sld @@ -14,10 +14,12 @@ procedure-arity procedure-variadic? procedure-variable-transformer? make-variable-transformer) + (rnrs conditions) (only (meta) environment) (srfi 1) (srfi 2) (srfi 9) (srfi 11) - (srfi 39)) + (srfi 39) + (prefix (srfi 188) %)) (include "syntax-case.scm")) diff --git a/lib/rnrs/base.sld b/lib/rnrs/base.sld index d8347f83..3e995688 100644 --- a/lib/rnrs/base.sld +++ b/lib/rnrs/base.sld @@ -190,8 +190,11 @@ vector-set! vector? zero?) - (import (rename (scheme base) - (error r7rs:error)) + (import (except (scheme base) + define-syntax + let-syntax + letrec-syntax + syntax-rules) (scheme cxr) (scheme inexact) (scheme complex) @@ -203,9 +206,38 @@ (balanced-quotient div0) (balanced-remainder mod0) (balanced/ div0-and-mod0)) + (rename (chibi syntax-case) + (splicing-let-syntax let-syntax) + (splicing-letrec-syntax letrec-syntax)) (except (chibi ast) error) (chibi show)) + (define-syntax syntax-rules + (lambda (x) + (syntax-case x () + ((_ (lit ...) ((k . p) t) ...) + #;(for-all 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 (syntax-rules () ((_ expr) diff --git a/lib/rnrs/conditions.sld b/lib/rnrs/conditions.sld new file mode 100644 index 00000000..4d34ecfb --- /dev/null +++ b/lib/rnrs/conditions.sld @@ -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?)) diff --git a/lib/rnrs/syntax-case.sld b/lib/rnrs/syntax-case.sld new file mode 100644 index 00000000..adfe2ed8 --- /dev/null +++ b/lib/rnrs/syntax-case.sld @@ -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)))