;;; also documented in the R4RS and draft R5RS.
;;;
;;; bound-identifier=?
-;;; datum->syntax-object
+;;; datum->syntax
;;; define-syntax
;;; fluid-let-syntax
;;; free-identifier=?
;;; letrec-syntax
;;; syntax
;;; syntax-case
-;;; syntax-object->datum
+;;; syntax->datum
;;; syntax-rules
;;; with-syntax
;;;
;;; conditionally evaluates expr ... at compile-time or run-time
;;; depending upon situations (see the Chez Scheme System Manual,
;;; Revision 3, for a complete description)
-;;; (syntax-error object message)
+;;; (syntax-violation who message form [subform])
;;; used to report errors found during expansion
-;;; (install-global-transformer symbol value)
-;;; used by expanded code to install top-level syntactic abstractions
-;;; (syntax-dispatch e p)
+;;; ($sc-dispatch e p)
;;; used by expanded code to handle syntax-case matching
;;; The following nonstandard procedures must be provided by the
;;; Objects with no standard print syntax, including objects containing
;;; cycles and syntax object, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax-object.
+;;; are contained within a syntax form or produced by datum->syntax.
;;; Such objects are never copied.
;;; All identifiers that don't have macro definitions and are not bound
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
(let ()
(define-syntax define-structure
(lambda (x)
(define construct-name
(lambda (template-identifier . args)
- (datum->syntax-object
+ (datum->syntax
template-identifier
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x)
x
- (symbol->string (syntax-object->datum x))))
+ (symbol->string (syntax->datum x))))
args))))))
(syntax-case x ()
((_ (name id1 ...))
(define top-level-eval-hook
(lambda (x mod)
- (eval `(,noexpand ,x) (if mod (resolve-module mod)
- (interaction-environment)))))
+ (primitive-eval `(,noexpand ,x))))
(define local-eval-hook
(lambda (x mod)
- (eval `(,noexpand ,x) (if mod (resolve-module mod)
- (interaction-environment)))))
+ (primitive-eval `(,noexpand ,x))))
(define error-hook
(lambda (who why what)
((_) (gensym))))
(define put-global-definition-hook
- (lambda (symbol binding modname)
- (let* ((module (if modname
- (resolve-module modname)
- (current-module)))
- (v (or (module-variable module symbol)
- (let ((v (make-variable 'sc-macro)))
- (module-add! module symbol v)
- v))))
- (if (not (variable-bound? v))
- (variable-set! v (gensym)))
- ;; Properties are tied to variable objects
- (set-object-property! v '*sc-expander* binding))))
-
-(define remove-global-definition-hook
- (lambda (symbol modname)
- (let* ((module (if modname
- (resolve-module modname)
- (current-module)))
- (v (module-local-variable module symbol)))
- (if v
- (let ((p (assq '*sc-expander* (object-properties v))))
- (set-object-properties! v (delq p (object-properties v))))))))
+ (lambda (symbol type val)
+ (let ((existing (let ((v (module-variable (current-module) symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val)
+ (not (syncase-macro-type val))
+ val))))))
+ (module-define! (current-module)
+ symbol
+ (if existing
+ (make-extended-syncase-macro existing type val)
+ (make-syncase-macro type val))))))
(define get-global-definition-hook
(lambda (symbol module)
- (let* ((module (if module
- (resolve-module module)
- (warn "wha" symbol (current-module))))
- (v (module-variable module symbol)))
- (and v
- (or (object-property v '*sc-expander*)
- (and (variable-bound? v)
- (macro? (variable-ref v))
- (macro-transformer (variable-ref v)) ;non-primitive
- guile-macro))))))
+ (if (and (not module) (current-module))
+ (warn "module system is booted, we should have a module" symbol))
+ (let ((v (module-variable (if module
+ (resolve-module (cdr module))
+ (current-module))
+ symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val) (syncase-macro-type val)
+ (cons (syncase-macro-type val)
+ (syncase-macro-binding val))))))))
+
)
(define-syntax build-global-reference
(syntax-rules ()
((_ source var mod)
- (build-annotated source
- (make-module-ref mod var #f)))))
+ (build-annotated
+ source
+ (if mod
+ (make-module-ref (cdr mod) var (car mod))
+ (make-module-ref mod var 'bare))))))
(define-syntax build-global-assignment
(syntax-rules ()
((_ source var exp mod)
(build-annotated source
- `(set! ,(make-module-ref mod var #f) ,exp)))))
+ `(set! ,(if mod
+ (make-module-ref (cdr mod) var (car mod))
+ (make-module-ref mod var 'bare))
+ ,exp)))))
(define-syntax build-global-definition
(syntax-rules ()
(define-syntax build-lambda
(syntax-rules ()
+ ((_ src vars docstring exp)
+ (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
+ ,exp)))
((_ src vars exp)
(build-annotated src `(lambda ,vars ,exp)))))
(define global-extend
(lambda (type sym val)
- (put-global-definition-hook sym (make-binding type val)
- (module-name (current-module)))))
+ (put-global-definition-hook sym type val)))
;;; Conceptually, identifiers are always syntax objects. Internally,
(define chi-install-global
(lambda (name e)
(build-application no-source
- (build-primref no-source 'install-global-transformer)
- (list (build-data no-source name) e))))
+ (build-primref no-source 'define)
+ (list
+ name
+ ;; FIXME: seems nasty to call current-module here
+ (if (let ((v (module-variable (current-module) name)))
+ ;; FIXME use primitive-macro?
+ (and v (variable-bound? v) (macro? (variable-ref v))
+ (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
+ (build-application no-source
+ (build-primref no-source 'make-extended-syncase-macro)
+ (list (build-application no-source
+ (build-primref no-source 'module-ref)
+ (list (build-application no-source 'current-module '())
+ (build-data no-source name)))
+ (build-data no-source 'macro)
+ e))
+ (build-application no-source
+ (build-primref no-source 'make-syncase-macro)
+ (list (build-data no-source 'macro) e)))))))
(define chi-when-list
(lambda (e when-list w)
((free-id=? x (syntax compile)) 'compile)
((free-id=? x (syntax load)) 'load)
((free-id=? x (syntax eval)) 'eval)
- (else (syntax-error (wrap x w #f)
- "invalid eval-when situation"))))
+ (else (syntax-violation 'eval-when
+ "invalid situation"
+ e (wrap x w #f)))))
situations))))))
;;; syntax-type returns six values: type, value, e, w, s, and mod. The
(let* ((n (id-var-name value w))
(type (binding-type (lookup n r mod))))
(case type
- ((global)
+ ((global core macro module-ref)
(eval-if-c&e m
(build-global-definition s n (chi e r w mod) mod)
mod))
((displaced-lexical)
- (syntax-error (wrap value w mod) "identifier out of context"))
- ((core macro module-ref)
- (remove-global-definition-hook n mod)
- (eval-if-c&e m
- (build-global-definition s n (chi e r w mod) mod)
- mod))
+ (syntax-violation #f "identifier out of context"
+ e (wrap value w mod)))
(else
- (syntax-error (wrap value w mod)
- "cannot define keyword at top level")))))
+ (syntax-violation #f "cannot define keyword at top level"
+ e (wrap value w mod))))))
(else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
(define chi
(chi-sequence (syntax (e1 e2 ...)) r w s mod)
(chi-void))))))
((define-form define-syntax-form)
- (syntax-error (wrap value w mod) "invalid context for definition of"))
+ (syntax-violation #f "definition in expression context"
+ e (wrap value w mod)))
((syntax)
- (syntax-error (source-wrap e w s mod)
- "reference to pattern variable outside syntax form"))
+ (syntax-violation #f "reference to pattern variable outside syntax form"
+ (source-wrap e w s mod)))
((displaced-lexical)
- (syntax-error (source-wrap e w s mod)
- "reference to identifier outside its scope"))
- (else (syntax-error (source-wrap e w s mod))))))
+ (syntax-violation #f "reference to identifier outside its scope"
+ (source-wrap e w s mod)))
+ (else (syntax-violation #f "unexpected syntax"
+ (source-wrap e w s mod))))))
(define chi-application
(lambda (x e r w s mod)
(if rib
(cons rib (cons 'shift s))
(cons 'shift s)))
- (module-name (procedure-module p))))))) ;; hither the hygiene
+ (let ((pmod (procedure-module p)))
+ (if pmod
+ ;; hither the hygiene
+ (cons 'hygiene (module-name pmod))
+ ;; but it's possible for the proc to have
+ ;; no mod, if it was made before modules
+ ;; were booted
+ '(hygiene guile))))))))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
(do ((i 0 (fx+ i 1)))
(vector-set! v i
(rebuild-macro-output (vector-ref x i) m)))))
((symbol? x)
- (syntax-error x "encountered raw symbol in macro output"))
+ (syntax-violation #f "encountered raw symbol in macro output"
+ (source-wrap e w s mod) x))
(else x))))
(rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
(let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
(ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
(if (null? body)
- (syntax-error outer-form "no expressions in body")
+ (syntax-violation #f "no expressions in body" outer-form)
(let ((e (cdar body)) (er (caar body)))
(call-with-values
(lambda () (syntax-type e er empty-wrap no-source ribcage mod))
(cdr body))))
(begin
(if (not (valid-bound-ids? ids))
- (syntax-error outer-form
- "invalid or duplicate identifier in definition"))
+ (syntax-violation
+ #f "invalid or duplicate identifier in definition"
+ outer-form))
(let loop ((bs bindings) (er-cache #f) (r-cache #f))
(if (not (null? bs))
(let* ((b (car bs)))
(cdr body)))))))))))))))))
(define chi-lambda-clause
- (lambda (e c r w mod k)
+ (lambda (e docstring c r w mod k)
(syntax-case c ()
+ ((args doc e1 e2 ...)
+ (and (string? (syntax->datum (syntax doc))) (not docstring))
+ (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
(((id ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "invalid parameter list in")
+ (syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(k new-vars
+ docstring
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
((ids e1 e2 ...)
(let ((old-ids (lambda-var-list (syntax ids))))
(if (not (valid-bound-ids? old-ids))
- (syntax-error e "invalid parameter list in")
+ (syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels old-ids))
(new-vars (map gen-var old-ids)))
(k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
(if (null? ls1)
ls2
(f (cdr ls1) (cons (car ls1) ls2))))
+ docstring
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
(make-binding-wrap old-ids labels w)
mod))))))
- (_ (syntax-error e)))))
+ (_ (syntax-violation 'lambda "bad lambda" e)))))
(define chi-local-syntax
(lambda (rec? e r w s mod k)
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound keyword in")
+ (syntax-violation #f "duplicate bound keyword" e)
(let ((labels (gen-labels ids)))
(let ((new-w (make-binding-wrap ids labels w)))
(k (syntax (e1 e2 ...))
new-w
s
mod))))))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation #f "bad local syntax definition"
+ (source-wrap e w s mod))))))
(define eval-local-transformer
(lambda (expanded mod)
(let ((p (local-eval-hook expanded mod)))
(if (procedure? p)
p
- (syntax-error p "nonprocedure transformer")))))
+ (syntax-violation #f "nonprocedure transformer" p)))))
(define chi-void
(lambda ()
(lambda (id n)
(case (binding-type (lookup n r mod))
((displaced-lexical)
- (syntax-error (source-wrap id w s mod)
- "identifier out of context"))))
+ (syntax-violation 'fluid-let-syntax
+ "identifier out of context"
+ e
+ (source-wrap id w s mod)))))
(syntax (var ...))
names)
(chi-body
r)
w
mod)))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation 'fluid-let-syntax "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'quote
(lambda (e r w s mod)
(syntax-case e ()
((_ e) (build-data s (strip (syntax e) w)))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation 'quote "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'syntax
(let ()
(gen-ref src (car var.lev) (cdr var.lev) maps)))
(lambda (var maps) (values `(ref ,var) maps)))
(if (ellipsis? e)
- (syntax-error src "misplaced ellipsis in syntax form")
+ (syntax-violation 'syntax "misplaced ellipsis" src)
(values `(quote ,e) maps)))))
(syntax-case e ()
((dots e)
(cons '() maps) ellipsis? mod))
(lambda (x maps)
(if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
+ (syntax-violation 'syntax "extra ellipsis"
+ src)
(values (gen-map x (car maps))
(cdr maps))))))))
(syntax-case y ()
(lambda () (k (cons '() maps)))
(lambda (x maps)
(if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
+ (syntax-violation 'syntax "extra ellipsis" src)
(values (gen-mappend x (car maps))
(cdr maps))))))))
(_ (call-with-values
(if (fx= level 0)
(values var maps)
(if (null? maps)
- (syntax-error src "missing ellipsis in syntax form")
+ (syntax-violation 'syntax "missing ellipsis" src)
(call-with-values
(lambda () (gen-ref src var (fx- level 1) (cdr maps)))
(lambda (outer-var outer-maps)
(call-with-values
(lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
(lambda (e maps) (regen e))))
- (_ (syntax-error e)))))))
+ (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
(global-extend 'core 'lambda
(lambda (e r w s mod)
(syntax-case e ()
((_ . c)
- (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod
- (lambda (vars body) (build-lambda s vars body)))))))
+ (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
+ (lambda (vars docstring body) (build-lambda s vars docstring body)))))))
(global-extend 'core 'let
(let ()
(define (chi-let e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound variable in")
+ (syntax-violation 'let "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((nw (make-binding-wrap ids labels w))
(syntax (f id ...))
(syntax (val ...))
(syntax (e1 e2 ...))))
- (_ (syntax-error (source-wrap e w s mod)))))))
+ (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
(global-extend 'core 'letrec
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound variable in")
+ (syntax-violation 'letrec "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((w (make-binding-wrap ids labels w))
(map (lambda (x) (chi x r w mod)) (syntax (val ...)))
(chi-body (syntax (e1 e2 ...))
(source-wrap e w s mod) r w mod)))))))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
(global-extend 'core 'set!
(build-lexical-assignment s (binding-value b) val))
((global) (build-global-assignment s n val mod))
((displaced-lexical)
- (syntax-error (wrap (syntax id) w mod)
- "identifier out of context"))
- (else (syntax-error (source-wrap e w s mod)))))))
+ (syntax-violation 'set! "identifier out of context"
+ (wrap (syntax id) w mod)))
+ (else (syntax-violation 'set! "bad set!"
+ (source-wrap e w s mod)))))))
((_ (head tail ...) val)
(call-with-values
(lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod))
(lambda (type value ee ww ss modmod)
(case type
((module-ref)
- (call-with-values (lambda () (value (syntax (head tail ...))))
- (lambda (id mod)
- (build-global-assignment s id (syntax val) mod))))
+ (let ((val (chi (syntax val) r w mod)))
+ (call-with-values (lambda () (value (syntax (head tail ...))))
+ (lambda (id mod)
+ (build-global-assignment s id val mod)))))
(else
(build-application s
(chi (syntax (setter head)) r w mod)
(map (lambda (e) (chi e r w mod))
(syntax (tail ... val)))))))))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@
(lambda (e)
- (syntax-case e (%module-public-interface)
+ (syntax-case e ()
((_ (mod ...) id)
(and (andmap id? (syntax (mod ...))) (id? (syntax id)))
- (values (syntax-object->datum (syntax id))
- (syntax-object->datum
- (syntax (mod ... %module-public-interface))))))))
+ (values (syntax->datum (syntax id))
+ (syntax->datum
+ (syntax (public mod ...))))))))
(global-extend 'module-ref '@@
(lambda (e)
(syntax-case e ()
((_ (mod ...) id)
(and (andmap id? (syntax (mod ...))) (id? (syntax id)))
- (values (syntax-object->datum (syntax id))
- (syntax-object->datum
- (syntax (mod ...))))))))
+ (values (syntax->datum (syntax id))
+ (syntax->datum
+ (syntax (private mod ...))))))))
(global-extend 'begin 'begin '())
(let ()
(define convert-pattern
; accepts pattern & keys
- ; returns syntax-dispatch pattern & ids
+ ; returns $sc-dispatch pattern & ids
(lambda (pattern keys)
(let cvt ((p pattern) (n 0) (ids '()))
(if (id? p)
(lambda (p pvars)
(cond
((not (distinct-bound-ids? (map car pvars)))
- (syntax-error pat
- "duplicate pattern variable in syntax-case pattern"))
+ (syntax-violation 'syntax-case "duplicate pattern variable" pat))
((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
- (syntax-error pat
- "misplaced ellipsis in syntax-case pattern"))
+ (syntax-violation 'syntax-case "misplaced ellipsis" pat))
(else
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-primref no-source 'list)
(list x))
(build-application no-source
- (build-primref no-source 'syntax-dispatch)
+ (build-primref no-source '$sc-dispatch)
(list x (build-data no-source p)))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
(build-application no-source
- (build-primref no-source 'syntax-error)
- (list x))
+ (build-primref no-source 'syntax-violation)
+ (list #f "source expression failed to match any pattern" x))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? (syntax pat))
((pat fender exp)
(gen-clause x keys (cdr clauses) r
(syntax pat) (syntax fender) (syntax exp) mod))
- (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
+ (_ (syntax-violation 'syntax-case "invalid clause"
+ (car clauses)))))))
(lambda (e r w s mod)
(let ((e (source-wrap e w s mod)))
r
mod))
(list (chi (syntax val) r empty-wrap mod))))
- (syntax-error e "invalid literals list in"))))))))
+ (syntax-violation 'syntax-case "invalid literals list" e))))))))
;;; The portable sc-expand seeds chi-top's mode m with 'e (for
;;; evaluating) and esew (which stands for "eval syntax expanders
(if (and (pair? x) (equal? (car x) noexpand))
(cadr x)
(chi-top x null-env top-wrap m esew
- (module-name (current-module)))))))
+ (cons 'hygiene (module-name (current-module))))))))
(set! sc-expand3
(let ((m 'e) (esew '(eval)))
(if (or (null? rest) (null? (cdr rest)))
esew
(cadr rest))
- (module-name (current-module)))))))
+ (cons 'hygiene (module-name (current-module))))))))
(set! identifier?
(lambda (x)
(nonsymbol-id? x)))
-(set! datum->syntax-object
+(set! datum->syntax
(lambda (id datum)
(make-syntax-object datum (syntax-object-wrap id) #f)))
-(set! syntax-object->datum
+(set! syntax->datum
; accepts any object, since syntax objects may consist partially
; or entirely of unwrapped, nonsymbolic data
(lambda (x)
(arg-check nonsymbol-id? y 'bound-identifier=?)
(bound-id=? x y)))
-(set! syntax-error
- (lambda (object . messages)
- (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
- (let ((message (if (null? messages)
- "invalid syntax"
- (apply string-append messages))))
- (error-hook #f message (strip object empty-wrap)))))
-
-(set! install-global-transformer
- (lambda (sym v)
- (arg-check symbol? sym 'define-syntax)
- (arg-check procedure? v 'define-syntax)
- (global-extend 'macro sym v)))
-
-;;; syntax-dispatch expects an expression and a pattern. If the expression
+(set! syntax-violation
+ (lambda (who message form . subform)
+ (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+ who 'syntax-violation)
+ (arg-check string? message 'syntax-violation)
+ (scm-error 'syntax-error 'sc-expand
+ (string-append
+ (if who "~a: " "")
+ "~a "
+ (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
+ (let ((tail (cons message
+ (map (lambda (x) (strip x empty-wrap))
+ (append subform (list form))))))
+ (if who (cons who tail) tail))
+ #f)))
+
+;;; $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
(syntax-object-module e)))
(else (match* (unannotate e) p w r mod)))))
-(set! syntax-dispatch
+(set! $sc-dispatch
(lambda (e p)
(cond
((eq? p 'any) (list e))
p (syntax-object-wrap e) '() (syntax-object-module e)))
(else (match* (unannotate e) p empty-wrap '() #f)))))
-(set! sc-chi chi)
))
)
(syntax-case s ()
(() v)
((e) (syntax e))
- (_ (syntax-error orig-x))))
+ (_ (syntax-violation
+ 'do "bad step expression"
+ orig-x s))))
(syntax (var ...))
(syntax (step ...)))))
(syntax-case (syntax (e1 ...)) ()
(let f ((x (read p)))
(if (eof-object? x)
(begin (close-input-port p) '())
- (cons (datum->syntax-object k x)
+ (cons (datum->syntax k x)
(f (read p))))))))
(syntax-case x ()
((k filename)
- (let ((fn (syntax-object->datum (syntax filename))))
+ (let ((fn (syntax->datum (syntax filename))))
(with-syntax (((exp ...) (read-file fn (syntax k))))
(syntax (begin exp ...))))))))
((_ e)
(error 'unquote
"expression ,~s not valid outside of quasiquote"
- (syntax-object->datum (syntax e)))))))
+ (syntax->datum (syntax e)))))))
(define-syntax unquote-splicing
(lambda (x)
((_ e)
(error 'unquote-splicing
"expression ,@~s not valid outside of quasiquote"
- (syntax-object->datum (syntax e)))))))
+ (syntax->datum (syntax e)))))))
(define-syntax case
(lambda (x)
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
(((k ...) e1 e2 ...)
(syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
- (_ (syntax-error x)))
+ (_ (syntax-violation 'case "bad clause" x clause)))
(with-syntax ((rest (f (car clauses) (cdr clauses))))
(syntax-case clause (else)
(((k ...) e1 e2 ...)
(syntax (if (memv t '(k ...))
(begin e1 e2 ...)
rest)))
- (_ (syntax-error x))))))))
+ (_ (syntax-violation 'case "bad clause" x
+ clause))))))))
(syntax (let ((t e)) body)))))))
(define-syntax identifier-syntax
HCoop / bpt / guile.git / blobdiff