;;;; -*-scheme-*-
;;;;
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
-;;;; 2012 Free Software Foundation, Inc.
+;;;; 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;; revision control logs corresponding to this file: 2009, 2010.
+;;; This code is based on "Syntax Abstraction in Scheme"
+;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman.
+;;; Lisp and Symbolic Computation 5:4, 295-326, 1992.
+;;; <http://www.cs.indiana.edu/~dyb/pubs/LaSC-5-4-pp295-326.pdf>
+
+
;;; This file defines the syntax-case expander, macroexpand, and a set
;;; of associated syntactic forms and procedures. Of these, the
;;; following are documented in The Scheme Programming Language,
(lambda (symbol module)
(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) (macro-type val)
- (cons (macro-type val)
- (macro-binding val)))))))))
+ (and (not (equal? module '(primitive)))
+ (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) (macro-type val)
+ (cons (macro-type val)
+ (macro-binding val))))))))))
(define (decorate-source e s)
(lambda (source test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp)))
- (define build-dynlet
- (lambda (source fluids vals body)
- (make-dynlet source fluids vals body)))
-
(define build-lexical-reference
(lambda (type source name var)
(make-lexical-ref source name var)))
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
(bare-cont var)))
+ ((primitive)
+ (syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod))))))
(define build-global-reference
;; syntax object wraps
- ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
- ;; <subst> ::= <shift> | <subs>
- ;; <subs> ::= #(<old name> <label> (<mark> ...))
- ;; <shift> ::= positive fixnum
+ ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+ ;; <subst> ::= shift | <subs>
+ ;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
+ ;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
(define-syntax make-wrap (identifier-syntax cons))
(define-syntax wrap-marks (identifier-syntax car))
(define-syntax wrap-subst (identifier-syntax cdr))
- (define-syntax subst-rename? (identifier-syntax vector?))
- (define-syntax-rule (rename-old x) (vector-ref x 0))
- (define-syntax-rule (rename-new x) (vector-ref x 1))
- (define-syntax-rule (rename-marks x) (vector-ref x 2))
- (define-syntax-rule (make-rename old new marks)
- (vector old new marks))
-
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define (gen-label)
;; displaced-lexical none displaced lexical identifier
;; lexical-call name call to lexical variable
;; global-call name call to global variable
+ ;; primitive-call name call to primitive
;; call none any other call
;; begin-form none begin expression
;; define-form id variable definition
((lexical)
(values 'lexical-call fval e e w s mod))
((global)
- ;; If we got here via an (@@ ...) expansion, we need to
- ;; make sure the fmod information is propagated back
- ;; correctly -- hence this consing.
- (values 'global-call (make-syntax-object fval w fmod)
- e e w s mod))
+ (if (equal? fmod '(primitive))
+ (values 'primitive-call fval e e w s mod)
+ ;; If we got here via an (@@ ...) expansion, we
+ ;; need to make sure the fmod information is
+ ;; propagated back correctly -- hence this
+ ;; consing.
+ (values 'global-call (make-syntax-object fval w fmod)
+ e e w s mod)))
((macro)
(syntax-type (expand-macro fval e r w s rib mod)
r empty-wrap s rib mod for-car?))
((module-ref)
- (call-with-values (lambda () (fval e r w))
+ (call-with-values (lambda () (fval e r w mod))
(lambda (e r w s mod)
(syntax-type e r w s rib mod for-car?))))
((core)
;; apply transformer
(value e r w s mod))
((module-ref)
- (call-with-values (lambda () (value e r w))
+ (call-with-values (lambda () (value e r w mod))
(lambda (e r w s mod)
(expand e r w mod))))
((lexical-call)
(syntax-object-module value)
mod))
e r w s mod))
+ ((primitive-call)
+ (syntax-case e ()
+ ((_ e ...)
+ (build-primcall s
+ value
+ (map (lambda (e) (expand e r w mod))
+ #'(e ...))))))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod))
((call) (expand-call (expand (car e) r w mod) e r w s mod))
(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 (source-annotation er) ribcage mod #f))
+ (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod #f))
(lambda (type value form e w s mod)
(case type
((define-form)
(cons id var-ids)
(cons var vars) (cons (cons er (wrap e w mod)) vals)
(cons (make-binding 'lexical var) bindings)))))
- ((define-syntax-form define-syntax-parameter-form)
- (let ((id (wrap value w mod)) (label (gen-label)))
+ ((define-syntax-form)
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
(extend-ribcage! ribcage id label)
- (parse (cdr body)
- (cons id ids) (cons label labels)
- var-ids vars vals
- (cons (make-binding
- (if (eq? type 'define-syntax-parameter-form)
- 'syntax-parameter
- 'macro)
- (cons er (wrap e w mod)))
- bindings))))
+ ;; As required by R6RS, evaluate the right-hand-sides of internal
+ ;; syntax definition forms and add their transformers to the
+ ;; compile-time environment immediately, so that the newly-defined
+ ;; keywords may be used in definition context within the same
+ ;; lexical contour.
+ (set-cdr! r (extend-env
+ (list label)
+ (list (make-binding
+ 'macro
+ (eval-local-transformer
+ (expand e trans-r w mod)
+ mod)))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
+ ((define-syntax-parameter-form)
+ ;; Same as define-syntax-form, but different format of the binding.
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
+ (extend-ribcage! ribcage id label)
+ (set-cdr! r (extend-env
+ (list label)
+ (list (make-binding
+ 'syntax-parameter
+ (list (eval-local-transformer
+ (expand e trans-r w mod)
+ mod))))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
((begin-form)
(syntax-case e ()
((_ e1 ...)
(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)))
- (if (memq (car b) '(macro syntax-parameter))
- (let* ((er (cadr b))
- (r-cache
- (if (eq? er er-cache)
- r-cache
- (macros-only-env er))))
- (set-cdr! b
- (eval-local-transformer
- (expand (cddr b) r-cache empty-wrap mod)
- mod))
- (if (eq? (car b) 'syntax-parameter)
- (set-cdr! b (list (cdr b))))
- (loop (cdr bs) er r-cache))
- (loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
(build-letrec no-source #t
(reverse (map syntax->datum var-ids))
(global-extend 'core 'case-lambda
(lambda (e r w s mod)
+ (define (build-it meta clauses)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case e r w s mod
+ lambda-formals
+ clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))
(syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
- (call-with-values
- (lambda ()
- (expand-lambda-case e r w s mod
- lambda-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
- (lambda (meta lcase)
- (build-case-lambda s meta lcase))))
+ ((_ (args e1 e2 ...) ...)
+ (build-it '() #'((args e1 e2 ...) ...)))
+ ((_ docstring (args e1 e2 ...) ...)
+ (string? (syntax->datum #'docstring))
+ (build-it `((documentation
+ . ,(syntax->datum #'docstring)))
+ #'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
(global-extend 'core 'case-lambda*
(lambda (e r w s mod)
+ (define (build-it meta clauses)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case e r w s mod
+ lambda*-formals
+ clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))
(syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
- (call-with-values
- (lambda ()
- (expand-lambda-case e r w s mod
- lambda*-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
- (lambda (meta lcase)
- (build-case-lambda s meta lcase))))
+ ((_ (args e1 e2 ...) ...)
+ (build-it '() #'((args e1 e2 ...) ...)))
+ ((_ docstring (args e1 e2 ...) ...)
+ (string? (syntax->datum #'docstring))
+ (build-it `((documentation
+ . ,(syntax->datum #'docstring)))
+ #'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
(global-extend 'core 'let
(case type
((module-ref)
(let ((val (expand #'val r w mod)))
- (call-with-values (lambda () (value #'(head tail ...) r w))
+ (call-with-values (lambda () (value #'(head tail ...) r w mod))
(lambda (e r w s* mod)
(syntax-case e ()
(e (id? #'e)
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@
- (lambda (e r w)
+ (lambda (e r w mod)
(syntax-case e ()
((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id))
- (values (syntax->datum #'id) r w #f
+ ;; Strip the wrap from the identifier and return top-wrap
+ ;; so that the identifier will not be captured by lexicals.
+ (values (syntax->datum #'id) r top-wrap #f
(syntax->datum
#'(public mod ...)))))))
(global-extend 'module-ref '@@
- (lambda (e r w)
+ (lambda (e r w mod)
(define remodulate
(lambda (x mod)
(cond ((pair? x)
((fx= i n) v)
(vector-set! v i (remodulate (vector-ref x i) mod)))))
(else x))))
- (syntax-case e ()
- ((_ (mod ...) exp)
+ (syntax-case e (@@ primitive)
+ ((_ primitive id)
+ (and (id? #'id)
+ (equal? (cdr (if (syntax-object? #'id)
+ (syntax-object-module #'id)
+ mod))
+ '(guile)))
+ ;; Strip the wrap from the identifier and return top-wrap
+ ;; so that the identifier will not be captured by lexicals.
+ (values (syntax->datum #'id) r top-wrap #f '(primitive)))
+ ((_ (mod ...) id)
+ (and (and-map id? #'(mod ...)) (id? #'id))
+ ;; Strip the wrap from the identifier and return top-wrap
+ ;; so that the identifier will not be captured by lexicals.
+ (values (syntax->datum #'id) r top-wrap #f
+ (syntax->datum
+ #'(private mod ...))))
+ ((_ @@ (mod ...) exp)
(and-map id? #'(mod ...))
+ ;; This is a special syntax used to support R6RS library forms.
+ ;; Unlike the syntax above, the last item is not restricted to
+ ;; be a single identifier, and the syntax objects are kept
+ ;; intact, with only their module changed.
(let ((mod (syntax->datum #'(private mod ...))))
(values (remodulate #'exp mod)
r w (source-annotation #'exp)
(expand #'then r w mod)
(expand #'else r w mod))))))
- (global-extend 'core 'with-fluids
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((fluid val) ...) b b* ...)
- (build-dynlet
- s
- (map (lambda (x) (expand x r w mod)) #'(fluid ...))
- (map (lambda (x) (expand x r w mod)) #'(val ...))
- (expand-body #'(b b* ...)
- (source-wrap e w s mod) r w mod))))))
-
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
(lambda (pattern keys)
(define cvt*
(lambda (p* n ids)
- (if (not (pair? p*))
- (cvt p* n ids)
- (call-with-values
- (lambda () (cvt* (cdr p*) n ids))
+ (syntax-case p* ()
+ ((x . y)
+ (call-with-values
+ (lambda () (cvt* #'y n ids))
(lambda (y ids)
(call-with-values
- (lambda () (cvt (car p*) n ids))
+ (lambda () (cvt #'x n ids))
(lambda (x ids)
- (values (cons x y) ids))))))))
+ (values (cons x y) ids))))))
+ (_ (cvt p* n ids)))))
(define (v-reverse x)
(let loop ((r '()) (x x))
(lambda () (convert-pattern pat keys))
(lambda (p pvars)
(cond
- ((not (distinct-bound-ids? (map car pvars)))
- (syntax-violation 'syntax-case "duplicate pattern variable" pat))
((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
+ ((not (distinct-bound-ids? (map car pvars)))
+ (syntax-violation 'syntax-case "duplicate pattern variable" pat))
(else
(let ((y (gen-var 'tmp)))
;; fat finger binding and references to temp variable y
(if (and (id? #'pat)
(and-map (lambda (x) (not (free-id=? #'pat x)))
(cons #'(... ...) keys)))
- (if (free-id=? #'pad #'_)
+ (if (free-id=? #'pat #'_)
(expand #'exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var #'pat)))
(let ()
(define (syntax-module id)
(arg-check nonsymbol-id? id 'syntax-module)
- (cdr (syntax-object-module id)))
+ (let ((mod (syntax-object-module id)))
+ (and (not (equal? mod '(primitive)))
+ (cdr mod))))
- (define (syntax-local-binding id)
+ (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
(arg-check nonsymbol-id? id 'syntax-local-binding)
(with-transformer-environment
(lambda (e r w s rib mod)
(strip-anti-mark (syntax-object-wrap id))
r
(syntax-object-module id)
- ;; FIXME: come up with a better policy for
- ;; resolve-syntax-parameters
- #t))
+ resolve-syntax-parameters?))
(lambda (type value mod)
(case type
((lexical) (values 'lexical value))
((macro) (values 'macro value))
+ ((syntax-parameter) (values 'syntax-parameter (car value)))
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
- ((global) (values 'global (cons value (cdr mod))))
+ ((global)
+ (if (equal? mod '(primitive))
+ (values 'primitive value)
+ (values 'global (cons value (cdr mod)))))
(else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id)
((out ...) (let () e1 e2 ...)))))))
(define-syntax syntax-rules
- (lambda (x)
- (syntax-case x ()
+ (lambda (xx)
+ (syntax-case xx ()
((_ (k ...) ((keyword . pattern) template) ...)
#'(lambda (x)
;; embed patterns as procedure metadata
(binding (car bindings)))
#'(let (binding) body))))))))
-(define-syntax do
- (lambda (orig-x)
- (syntax-case orig-x ()
- ((_ ((var init . step) ...) (e0 e1 ...) c ...)
- (with-syntax (((step ...)
- (map (lambda (v s)
- (syntax-case s ()
- (() v)
- ((e) #'e)
- (_ (syntax-violation
- 'do "bad step expression"
- orig-x s))))
- #'(var ...)
- #'(step ...))))
- (syntax-case #'(e1 ...) ()
- (() #'(let doloop ((var init) ...)
- (if (not e0)
- (begin c ... (doloop step ...)))))
- ((e1 e2 ...)
- #'(let doloop ((var init) ...)
- (if e0
- (begin e1 e2 ...)
- (begin c ... (doloop step ...)))))))))))
-
(define-syntax quasiquote
(let ()
(define (quasi p lev)
(define-syntax include
(lambda (x)
(define read-file
- (lambda (fn k)
- (let ((p (open-input-file fn)))
+ (lambda (fn dir k)
+ (let* ((p (open-input-file
+ (cond ((absolute-file-name? fn)
+ fn)
+ (dir
+ (in-vicinity dir fn))
+ (else
+ (syntax-violation
+ 'include
+ "relative file name only allowed when the include form is in a file"
+ x)))))
+ (enc (file-encoding p)))
+
+ ;; Choose the input encoding deterministically.
+ (set-port-encoding! p (or enc "UTF-8"))
+
(let f ((x (read p))
(result '()))
(if (eof-object? x)
(reverse result))
(f (read p)
(cons (datum->syntax k x) result)))))))
- (syntax-case x ()
- ((k filename)
- (let ((fn (syntax->datum #'filename)))
- (with-syntax (((exp ...) (read-file fn #'filename)))
- #'(begin exp ...)))))))
+ (let* ((src (syntax-source x))
+ (file (and src (assq-ref src 'filename)))
+ (dir (and (string? file) (dirname file))))
+ (syntax-case x ()
+ ((k filename)
+ (let ((fn (syntax->datum #'filename)))
+ (with-syntax (((exp ...) (read-file fn dir #'filename)))
+ #'(begin exp ...))))))))
(define-syntax include-from-path
(lambda (x)
"expression not valid outside of quasiquote"
x)))
-(define-syntax case
- (lambda (x)
- (syntax-case x ()
- ((_ e m1 m2 ...)
- (with-syntax
- ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
- (if (null? clauses)
- (syntax-case clause (else)
- ((else e1 e2 ...) #'(begin e1 e2 ...))
- (((k ...) e1 e2 ...)
- #'(if (memv t '(k ...)) (begin e1 e2 ...)))
- (_ (syntax-violation 'case "bad clause" x clause)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else)
- (((k ...) e1 e2 ...)
- #'(if (memv t '(k ...))
- (begin e1 e2 ...)
- rest))
- (_ (syntax-violation 'case "bad clause" x
- clause))))))))
- #'(let ((t e)) body))))))
-
(define (make-variable-transformer proc)
(if (procedure? proc)
(let ((trans (lambda (x)
(error "variable transformer not a procedure" proc)))
(define-syntax identifier-syntax
- (lambda (x)
- (syntax-case x (set!)
+ (lambda (xx)
+ (syntax-case xx (set!)
((_ e)
#'(lambda (x)
#((macro-type . identifier-syntax))
(syntax-case x ()
((_ (id . args) b0 b1 ...)
#'(define id (lambda* args b0 b1 ...)))
- ((_ id val) (identifier? #'x)
+ ((_ id val) (identifier? #'id)
#'(define id val)))))
HCoop / bpt / guile.git / blobdiff