;;;; -*-scheme-*-
;;;;
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
-;;;; 2012, 2013 Free Software Foundation, Inc.
+;;;; 2012, 2013, 2015 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
;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
;;; revision control logs corresponding to this file: 2009, 2010.
+;;; Modified by Mark H Weaver <mhw@netris.org> according to the Git
+;;; revision control logs corresponding to this file: 2012, 2013.
+
+
+;;; 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
;; (syntax . (<var> . <level>)) pattern variables
;; (global) assumed global variable
;; (lexical . <var>) lexical variables
+ ;; (ellipsis . <identifier>) custom ellipsis
;; (displaced-lexical) displaced lexicals
;; <level> ::= <nonnegative integer>
;; <var> ::= variable returned by build-lexical-var
;; a lexical variable is a lambda- or letrec-bound variable.
+ ;; an ellipsis binding is introduced by the 'with-ellipsis' special
+ ;; form.
+
;; a displaced-lexical identifier is a lexical identifier removed from
;; it's scope by the return of a syntax object containing the identifier.
;; a displaced lexical can also appear when a letrec-syntax-bound
(if (null? r)
'()
(let ((a (car r)))
- (if (memq (cadr a) '(macro syntax-parameter))
+ (if (memq (cadr a) '(macro syntax-parameter ellipsis))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
(let ((n (id-var-name id w mod)))
(cond
((syntax-object? n)
- ;; Recursing allows syntax-parameterize to override
- ;; macro-introduced syntax parameters.
- (resolve-identifier n w r mod resolve-syntax-parameters?))
+ (cond
+ ((not (eq? n id))
+ ;; This identifier aliased another; recurse to allow
+ ;; syntax-parameterize to override macro-introduced syntax
+ ;; parameters.
+ (resolve-identifier n w r mod resolve-syntax-parameters?))
+ (else
+ ;; Resolved to a free variable that was introduced by this
+ ;; macro; continue to resolve this global by name.
+ (resolve-identifier (syntax-object-expression n)
+ (syntax-object-wrap n)
+ r
+ (syntax-object-module n)
+ resolve-syntax-parameters?))))
((symbol? n)
(resolve-global n (if (syntax-object? id)
(syntax-object-module id)
(let ((x (build-global-definition s var (expand e r w mod))))
(top-level-eval-hook x mod)
(lambda () x))
- (lambda ()
- (build-global-definition s var (expand e r w mod)))))))
+ (call-with-values
+ (lambda () (resolve-identifier id empty-wrap r mod #t))
+ (lambda (type* value* mod*)
+ ;; If the identifier to be bound is currently bound to a
+ ;; macro, then immediately discard that binding.
+ (if (eq? type* 'macro)
+ (top-level-eval-hook (build-global-definition
+ s var (build-void s))
+ mod))
+ (lambda ()
+ (build-global-definition s var (expand e r w mod)))))))))
((define-syntax-form define-syntax-parameter-form)
(let* ((id (wrap value w mod))
(label (gen-label))
(parse #'(e1 ...) r w s m esew mod))))
((local-syntax-form)
(expand-local-syntax value e r w s mod
- (lambda (forms r w s mod)
- (parse forms r w s m esew mod))))
+ (lambda (forms r w s mod)
+ (parse forms r w s m esew mod))))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(build-void no-source)))
(define ellipsis?
- (lambda (x)
- (and (nonsymbol-id? x)
- (free-id=? x #'(... ...)))))
+ (lambda (e r mod)
+ (and (nonsymbol-id? e)
+ ;; If there is a binding for the special identifier
+ ;; #{ $sc-ellipsis }# in the lexical environment of E,
+ ;; and if the associated binding type is 'ellipsis',
+ ;; then the binding's value specifies the custom ellipsis
+ ;; identifier within that lexical environment, and the
+ ;; comparison is done using 'bound-id=?'.
+ (call-with-values
+ (lambda () (resolve-identifier
+ (make-syntax-object '#{ $sc-ellipsis }#
+ (syntax-object-wrap e)
+ (syntax-object-module e))
+ empty-wrap r mod #f))
+ (lambda (type value mod)
+ (if (eq? type 'ellipsis)
+ (bound-id=? e value)
+ (free-id=? e #'(... ...))))))))
(define lambda-formals
(lambda (orig-args)
(lambda (var maps)
(values `(ref ,var) maps))))
(else
- (if (ellipsis? e)
+ (if (ellipsis? e r mod)
(syntax-violation 'syntax "misplaced ellipsis" src)
(values `(quote ,e) maps))))))
(syntax-case e ()
((dots e)
- (ellipsis? #'dots)
- (gen-syntax src #'e r maps (lambda (x) #f) mod))
+ (ellipsis? #'dots r mod)
+ (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
((x dots . y)
;; this could be about a dozen lines of code, except that we
;; choose to handle #'(x ... ...) forms
- (ellipsis? #'dots)
+ (ellipsis? #'dots r mod)
(let f ((y #'y)
(k (lambda (maps)
(call-with-values
(cdr maps))))))))
(syntax-case y ()
((dots . y)
- (ellipsis? #'dots)
+ (ellipsis? #'dots r mod)
(f #'y
(lambda (maps)
(call-with-values
#'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
+ (global-extend 'core 'with-ellipsis
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ dots e1 e2 ...)
+ (id? #'dots)
+ (let ((id (if (symbol? #'dots)
+ '#{ $sc-ellipsis }#
+ (make-syntax-object '#{ $sc-ellipsis }#
+ (syntax-object-wrap #'dots)
+ (syntax-object-module #'dots)))))
+ (let ((ids (list id))
+ (labels (list (gen-label)))
+ (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod)))))
+ (let ((nw (make-binding-wrap ids labels w))
+ (nr (extend-env labels bindings r)))
+ (expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod)))))
+ (_ (syntax-violation 'with-ellipsis "bad syntax"
+ (source-wrap e w s mod))))))
+
(global-extend 'core 'let
(let ()
(define (expand-let e r w s mod constructor ids vals exps)
(define convert-pattern
;; accepts pattern & keys
;; returns $sc-dispatch pattern & ids
- (lambda (pattern keys)
+ (lambda (pattern keys ellipsis?)
(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))
(define gen-clause
(lambda (x keys clauses r pat fender exp mod)
(call-with-values
- (lambda () (convert-pattern pat keys))
+ (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
(lambda (p pvars)
(cond
+ ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars))
+ (syntax-violation 'syntax-case "misplaced ellipsis" pat))
((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))
(else
(let ((y (gen-var 'tmp)))
;; fat finger binding and references to temp variable y
(let ((e (source-wrap e w s mod)))
(syntax-case e ()
((_ val (key ...) m ...)
- (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod))))
#'(key ...))
(let ((x (gen-var 'tmp)))
;; fat finger binding and references to temp variable x
(if (equal? mod '(primitive))
(values 'primitive value)
(values 'global (cons value (cdr mod)))))
+ ((ellipsis)
+ (values 'ellipsis
+ (make-syntax-object (syntax-object-expression value)
+ (anti-mark (syntax-object-wrap value))
+ (syntax-object-module value))))
(else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id)
#'(syntax-case (list in ...) ()
((out ...) (let () e1 e2 ...)))))))
+(define-syntax syntax-error
+ (lambda (x)
+ (syntax-case x ()
+ ;; Extended internal syntax which provides the original form
+ ;; as the first operand, for improved error reporting.
+ ((_ (keyword . operands) message arg ...)
+ (string? (syntax->datum #'message))
+ (syntax-violation (syntax->datum #'keyword)
+ (string-join (cons (syntax->datum #'message)
+ (map (lambda (x)
+ (object->string
+ (syntax->datum x)))
+ #'(arg ...))))
+ (and (syntax->datum #'keyword)
+ #'(keyword . operands))))
+ ;; Standard R7RS syntax
+ ((_ message arg ...)
+ (string? (syntax->datum #'message))
+ #'(syntax-error (#f) message arg ...)))))
+
(define-syntax syntax-rules
(lambda (xx)
+ (define (expand-clause clause)
+ ;; Convert a 'syntax-rules' clause into a 'syntax-case' clause.
+ (syntax-case clause (syntax-error)
+ ;; If the template is a 'syntax-error' form, use the extended
+ ;; internal syntax, which adds the original form as the first
+ ;; operand for improved error reporting.
+ (((keyword . pattern) (syntax-error message arg ...))
+ (string? (syntax->datum #'message))
+ #'((dummy . pattern) #'(syntax-error (dummy . pattern) message arg ...)))
+ ;; Normal case
+ (((keyword . pattern) template)
+ #'((dummy . pattern) #'template))))
+ (define (expand-syntax-rules dots keys docstrings clauses)
+ (with-syntax
+ (((k ...) keys)
+ ((docstring ...) docstrings)
+ ((((keyword . pattern) template) ...) clauses)
+ ((clause ...) (map expand-clause clauses)))
+ (with-syntax
+ ((form #'(lambda (x)
+ docstring ... ; optional docstring
+ #((macro-type . syntax-rules)
+ (patterns pattern ...)) ; embed patterns as procedure metadata
+ (syntax-case x (k ...)
+ clause ...))))
+ (if dots
+ (with-syntax ((dots dots))
+ #'(with-ellipsis dots form))
+ #'form))))
(syntax-case xx ()
((_ (k ...) ((keyword . pattern) template) ...)
- #'(lambda (x)
- ;; embed patterns as procedure metadata
- #((macro-type . syntax-rules)
- (patterns pattern ...))
- (syntax-case x (k ...)
- ((_ . pattern) #'template)
- ...)))
+ (expand-syntax-rules #f #'(k ...) #'() #'(((keyword . pattern) template) ...)))
((_ (k ...) docstring ((keyword . pattern) template) ...)
(string? (syntax->datum #'docstring))
- #'(lambda (x)
- ;; the same, but allow a docstring
- docstring
- #((macro-type . syntax-rules)
- (patterns pattern ...))
- (syntax-case x (k ...)
- ((_ . pattern) #'template)
- ...))))))
+ (expand-syntax-rules #f #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...)))
+ ((_ dots (k ...) ((keyword . pattern) template) ...)
+ (identifier? #'dots)
+ (expand-syntax-rules #'dots #'(k ...) #'() #'(((keyword . pattern) template) ...)))
+ ((_ dots (k ...) docstring ((keyword . pattern) template) ...)
+ (and (identifier? #'dots) (string? (syntax->datum #'docstring)))
+ (expand-syntax-rules #'dots #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...))))))
(define-syntax define-syntax-rule
(lambda (x)
(define read-file
(lambda (fn dir k)
(let* ((p (open-input-file
- (if (absolute-file-name? fn)
- fn
- (in-vicinity dir fn))))
+ (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.
HCoop / bpt / guile.git / blobdiff