summaryrefslogtreecommitdiff
path: root/module/ice-9/psyntax.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/psyntax.scm')
-rw-r--r--module/ice-9/psyntax.scm227
1 files changed, 111 insertions, 116 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index d2c10fd06..2911e96ea 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2588,6 +2588,14 @@
(global-extend 'eval-when 'eval-when '())
(global-extend 'core 'syntax-case expand-syntax-case)
+ (define-syntax define/override
+ (syntax-rules ()
+ ((_ (id . args) . body) (define/override id (lambda args . body)))
+ ((_ id exp) (set! id exp))))
+ (define-syntax define*/override
+ (syntax-rules ()
+ ((_ (id . args) . body) (define/override id (lambda* args . body)))))
+
;; The portable macroexpand seeds expand-top's mode m with 'e (for
;; evaluating) and esew (which stands for "eval syntax expanders
;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
@@ -2597,89 +2605,81 @@
;; syntactic definitions are evaluated immediately after they are
;; expanded, and the expanded definitions are also residualized into
;; the object file if we are compiling a file.
- (set! macroexpand
- (lambda* (x #:optional (m 'e) (esew '(eval)))
- (define (unstrip x)
- (define (annotate result)
- (let ((props (source-properties x)))
- (if (pair? props)
- (datum->syntax #f result #:source props)
- result)))
- (cond
- ((pair? x)
- (annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
- ((vector? x)
- (let ((v (make-vector (vector-length x))))
- (annotate (list->vector (map unstrip (vector->list x))))))
- ((syntax? x) x)
- (else (annotate x))))
- (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew
- (cons 'hygiene (module-name (current-module))))))
-
- (set! identifier?
- (lambda (x)
- (nonsymbol-id? x)))
-
- (set! datum->syntax
- (lambda* (id datum #:key source)
- (define (props->sourcev alist)
- (and (pair? alist)
- (vector (assq-ref alist 'filename)
- (assq-ref alist 'line)
- (assq-ref alist 'column))))
- (make-syntax datum
- (if id
- (syntax-wrap id)
- empty-wrap)
- (if id
- (syntax-module id)
- #f)
- (cond
- ((not source)
- (props->sourcev (source-properties datum)))
- ((and (list? source) (and-map pair? source))
- (props->sourcev source))
- ((and (vector? source) (= 3 (vector-length source)))
- source)
- (else (syntax-sourcev source))))))
-
- (set! syntax->datum
- ;; accepts any object, since syntax objects may consist partially
- ;; or entirely of unwrapped, nonsymbolic data
- (lambda (x)
- (strip x)))
-
- (set! generate-temporaries
- (lambda (ls)
- (arg-check list? ls 'generate-temporaries)
- (let ((mod (cons 'hygiene (module-name (current-module)))))
- (map (lambda (x)
- (wrap (gen-var 't) top-wrap mod))
- ls))))
-
- (set! free-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'free-identifier=?)
- (arg-check nonsymbol-id? y 'free-identifier=?)
- (free-id=? x y)))
-
- (set! bound-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'bound-identifier=?)
- (arg-check nonsymbol-id? y 'bound-identifier=?)
- (bound-id=? x y)))
-
- (set! syntax-violation
- (lambda* (who message form #:optional subform)
- (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
- who 'syntax-violation)
- (arg-check string? message 'syntax-violation)
- (throw 'syntax-error who message
- (sourcev->alist
- (or (source-annotation subform)
- (source-annotation form)))
- (strip form)
- (strip subform))))
+ (define*/override (macroexpand x #:optional (m 'e) (esew '(eval)))
+ (define (unstrip x)
+ (define (annotate result)
+ (let ((props (source-properties x)))
+ (if (pair? props)
+ (datum->syntax #f result #:source props)
+ result)))
+ (cond
+ ((pair? x)
+ (annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
+ ((vector? x)
+ (let ((v (make-vector (vector-length x))))
+ (annotate (list->vector (map unstrip (vector->list x))))))
+ ((syntax? x) x)
+ (else (annotate x))))
+ (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew
+ (cons 'hygiene (module-name (current-module)))))
+
+ (define/override (identifier? x)
+ (nonsymbol-id? x))
+
+ (define*/override (datum->syntax id datum #:key source)
+ (define (props->sourcev alist)
+ (and (pair? alist)
+ (vector (assq-ref alist 'filename)
+ (assq-ref alist 'line)
+ (assq-ref alist 'column))))
+ (make-syntax datum
+ (if id
+ (syntax-wrap id)
+ empty-wrap)
+ (if id
+ (syntax-module id)
+ #f)
+ (cond
+ ((not source)
+ (props->sourcev (source-properties datum)))
+ ((and (list? source) (and-map pair? source))
+ (props->sourcev source))
+ ((and (vector? source) (= 3 (vector-length source)))
+ source)
+ (else (syntax-sourcev source)))))
+
+ (define/override (syntax->datum x)
+ ;; accepts any object, since syntax objects may consist partially
+ ;; or entirely of unwrapped, nonsymbolic data
+ (strip x))
+
+ (define/override (generate-temporaries ls)
+ (arg-check list? ls 'generate-temporaries)
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ (map (lambda (x)
+ (wrap (gen-var 't) top-wrap mod))
+ ls)))
+
+ (define/override (free-identifier=? x y)
+ (arg-check nonsymbol-id? x 'free-identifier=?)
+ (arg-check nonsymbol-id? y 'free-identifier=?)
+ (free-id=? x y))
+
+ (define/override (bound-identifier=? x y)
+ (arg-check nonsymbol-id? x 'bound-identifier=?)
+ (arg-check nonsymbol-id? y 'bound-identifier=?)
+ (bound-id=? x y))
+
+ (define*/override (syntax-violation who message form #:optional subform)
+ (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+ who 'syntax-violation)
+ (arg-check string? message 'syntax-violation)
+ (throw 'syntax-error who message
+ (sourcev->alist
+ (or (source-annotation subform)
+ (source-annotation form)))
+ (strip form)
+ (strip subform)))
(let ()
(define (%syntax-module id)
@@ -2737,30 +2737,27 @@
(define! 'syntax-local-binding syntax-local-binding)
(define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers))
- ;; $sc-dispatch expects an expression and a pattern. If the expression
- ;; matches the pattern a list of the matching expressions for each
- ;; "any" is returned. Otherwise, #f is returned. (This use of #f will
- ;; not work on r4rs implementations that violate the ieee requirement
- ;; that #f and () be distinct.)
-
- ;; The expression is matched with the pattern as follows:
-
- ;; pattern: matches:
- ;; () empty list
- ;; any anything
- ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
- ;; each-any (any*)
- ;; #(free-id <key>) <key> with free-identifier=?
- ;; #(each <pattern>) (<pattern>*)
- ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
- ;; #(vector <pattern>) (list->vector <pattern>)
- ;; #(atom <object>) <object> with "equal?"
-
- ;; Vector cops out to pair under assumption that vectors are rare. If
- ;; not, should convert to:
- ;; #(vector <pattern>*) #(<pattern>*)
-
- (let ()
+ (define/override ($sc-dispatch e p)
+ ;; $sc-dispatch expects an expression and a pattern. If the expression
+ ;; matches the pattern a list of the matching expressions for each
+ ;; "any" is returned. Otherwise, #f is returned.
+
+ ;; The expression is matched with the pattern as follows:
+
+ ;; pattern: matches:
+ ;; () empty list
+ ;; any anything
+ ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
+ ;; each-any (any*)
+ ;; #(free-id <key>) <key> with free-identifier=?
+ ;; #(each <pattern>) (<pattern>*)
+ ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
+ ;; #(vector <pattern>) (list->vector <pattern>)
+ ;; #(atom <object>) <object> with "equal?"
+
+ ;; Vector cops out to pair under assumption that vectors are rare. If
+ ;; not, should convert to:
+ ;; #(vector <pattern>*) #(<pattern>*)
(define (match-each e p w mod)
(cond
@@ -2884,15 +2881,13 @@
(or (syntax-module e) mod)))
(else (match* e p w r mod))))
- (set! $sc-dispatch
- (lambda (e p)
- (cond
- ((eq? p 'any) (list e))
- ((eq? p '_) '())
- ((syntax? e)
- (match* (syntax-expression e)
- p (syntax-wrap e) '() (syntax-module e)))
- (else (match* e p empty-wrap '() #f)))))))
+ (cond
+ ((eq? p 'any) (list e))
+ ((eq? p '_) '())
+ ((syntax? e)
+ (match* (syntax-expression e)
+ p (syntax-wrap e) '() (syntax-module e)))
+ (else (match* e p empty-wrap '() #f)))))
(define-syntax with-syntax