Import psyntax from Guile-1.8: R7RS with-ellipsis.
* GNUmakefile (psyntax-import): New target. * module/mes/psyntax.ss: Import. * module/mes/psyntax-pp.mes: Import. * NEWS: Mention it.
This commit is contained in:
Jan Nieuwenhuizen
parent
40a6f2df34
commit
f8bc344dfc
|
|
@ -110,6 +110,11 @@ guile-mescc: mescc.cat
|
|||
paren: all
|
||||
scripts/paren.mes
|
||||
|
||||
GUILE_GIT:=$(HOME)/src/guile
|
||||
psyntax-import:
|
||||
git --git-dir=$(GUILE_GIT)/.git --work-tree=$(GUILE_GIT) show ba8a709:ice-9/psyntax.ss > module/mes/psyntax.ss
|
||||
git --git-dir=$(GUILE_GIT)/.git --work-tree=$(GUILE_GIT) show ba8a709:ice-9/psyntax.pp > module/mes/psyntax-pp.mes
|
||||
|
||||
help: help-top
|
||||
|
||||
install: all
|
||||
|
|
|
|||
1
NEWS
1
NEWS
|
|
@ -22,6 +22,7 @@ block-comments are all handled by the Scheme reader later.
|
|||
*** Lambda* and define* are now supported.
|
||||
*** #;-comment is now supported.
|
||||
*** Non-nested #| |#-comment is now supported.
|
||||
*** R7RS syntax-rules with custom ellipsis, with-ellipsis are now supported.
|
||||
** Noteworthy bug fixes
|
||||
*** Closure is not a pair.
|
||||
* Changes in 0.3 since 0.2
|
||||
|
|
|
|||
|
|
@ -28,8 +28,3 @@
|
|||
(define datum->syntax datum->syntax-object)
|
||||
(define syntax->datum syntax-object->datum)
|
||||
(set! expand-macro sc-expand)
|
||||
|
||||
(define-macro (define-syntax-rule id-pattern . template)
|
||||
`(define-syntax ,(car id-pattern)
|
||||
(syntax-rules ()
|
||||
((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -1,7 +1,32 @@
|
|||
;;;; -*-scheme-*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001, 2003, 2006 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
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 2.1 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This library is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;;; Lesser General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;;; License along with this library; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
;;;;
|
||||
|
||||
|
||||
;;; Portable implementation of syntax-case
|
||||
;;; Extracted from Chez Scheme Version 5.9f
|
||||
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
|
||||
|
||||
;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
|
||||
;;; to the ChangeLog distributed in the same directory as this file:
|
||||
;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
|
||||
;;; 2000-09-12, 2001-03-08
|
||||
|
||||
;;; Copyright (c) 1992-1997 Cadence Research Systems
|
||||
;;; Permission to copy this software, in whole or in part, to use this
|
||||
;;; software for any lawful purpose, and to redistribute this software
|
||||
|
|
@ -102,6 +127,13 @@
|
|||
;;; evaluator/expander that no expansion is necessary, since expr has
|
||||
;;; already been fully expanded to core forms.
|
||||
;;;
|
||||
;;; eval will not be invoked during the loading of psyntax.pp. After
|
||||
;;; psyntax.pp has been loaded, the expansion of any macro definition,
|
||||
;;; whether local or global, will result in a call to eval. If, however,
|
||||
;;; sc-expand has already been registered as the expander to be used
|
||||
;;; by eval, and eval accepts one argument, nothing special must be done
|
||||
;;; to support the "noexpand" flag, since it is handled by sc-expand.
|
||||
;;;
|
||||
;;; (error who format-string why what)
|
||||
;;; where who is either a symbol or #f, format-string is always "~a ~s",
|
||||
;;; why is always a string, and what may be any object. error should
|
||||
|
|
@ -127,6 +159,12 @@
|
|||
;;; the code below, but to avoid bootstrapping problems, do so only
|
||||
;;; after you have a working version of the expander.
|
||||
|
||||
;;; Chez Scheme allows the syntactic form (syntax <template>) to be
|
||||
;;; abbreviated to #'<template>, just as (quote <datum>) may be
|
||||
;;; abbreviated to '<datum>. The #' syntax makes programs written
|
||||
;;; using syntax-case shorter and more readable and draws out the
|
||||
;;; intuitive connection between syntax and quote.
|
||||
|
||||
;;; If you find that this code loads or runs slowly, consider
|
||||
;;; switching to faster hardware or a faster implementation of
|
||||
;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
|
||||
|
|
@ -284,11 +322,11 @@
|
|||
|
||||
(define top-level-eval-hook
|
||||
(lambda (x)
|
||||
(eval `(,noexpand ,x))))
|
||||
(eval `(,noexpand ,x) (interaction-environment))))
|
||||
|
||||
(define local-eval-hook
|
||||
(lambda (x)
|
||||
(eval `(,noexpand ,x))))
|
||||
(eval `(,noexpand ,x) (interaction-environment))))
|
||||
|
||||
(define error-hook
|
||||
(lambda (who why what)
|
||||
|
|
@ -355,9 +393,11 @@
|
|||
((_ src name) name)
|
||||
((_ src level name) name)))
|
||||
|
||||
(define-syntax build-data
|
||||
(syntax-rules ()
|
||||
((_ src exp) `',exp)))
|
||||
(define (build-data src exp)
|
||||
(if (and (self-evaluating? exp)
|
||||
(not (vector? exp)))
|
||||
exp
|
||||
(list 'quote exp)))
|
||||
|
||||
(define build-sequence
|
||||
(lambda (src exps)
|
||||
|
|
@ -365,6 +405,18 @@
|
|||
(car exps)
|
||||
`(begin ,@exps))))
|
||||
|
||||
(define build-let
|
||||
(lambda (src vars val-exps body-exp)
|
||||
(if (null? vars)
|
||||
body-exp
|
||||
`(let ,(map list vars val-exps) ,body-exp))))
|
||||
|
||||
(define build-named-let
|
||||
(lambda (src vars val-exps body-exp)
|
||||
(if (null? vars)
|
||||
body-exp
|
||||
`(let ,(car vars) ,(map list (cdr vars) val-exps) ,body-exp))))
|
||||
|
||||
(define build-letrec
|
||||
(lambda (src vars val-exps body-exp)
|
||||
(if (null? vars)
|
||||
|
|
@ -373,13 +425,7 @@
|
|||
|
||||
(define-syntax build-lexical-var
|
||||
(syntax-rules ()
|
||||
((_ src id) (gensym))))
|
||||
|
||||
(define-syntax self-evaluating?
|
||||
(syntax-rules ()
|
||||
((_ e)
|
||||
(let ((x e))
|
||||
(or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
|
||||
((_ src id) (gensym (symbol->string id)))))
|
||||
)
|
||||
|
||||
(define-structure (syntax-object expression wrap))
|
||||
|
|
@ -429,6 +475,7 @@
|
|||
|
||||
;;; <binding> ::= (macro . <procedure>) macros
|
||||
;;; (core . <procedure>) core forms
|
||||
;;; (external-macro . <procedure>) external-macro
|
||||
;;; (begin) begin
|
||||
;;; (define) define
|
||||
;;; (define-syntax) define-syntax
|
||||
|
|
@ -495,7 +542,7 @@
|
|||
(if (null? r)
|
||||
'()
|
||||
(let ((a (car r)))
|
||||
(if (eq? (cadr a) 'macro)
|
||||
(if (memq (cadr a) '(macro ellipsis))
|
||||
(cons a (macros-only-env (cdr r)))
|
||||
(macros-only-env (cdr r)))))))
|
||||
|
||||
|
|
@ -843,6 +890,7 @@
|
|||
;;; type value explanation
|
||||
;;; -------------------------------------------------------------------
|
||||
;;; core procedure core form (including singleton)
|
||||
;;; external-macro procedure external macro
|
||||
;;; lexical name lexical variable reference
|
||||
;;; global name global variable reference
|
||||
;;; begin none begin keyword
|
||||
|
|
@ -896,7 +944,7 @@
|
|||
((macro)
|
||||
(syntax-type (chi-macro (binding-value b) e r w rib)
|
||||
r empty-wrap s rib))
|
||||
((core) (values type (binding-value b) e w s))
|
||||
((core external-macro) (values type (binding-value b) e w s))
|
||||
((local-syntax)
|
||||
(values 'local-syntax-form (binding-value b) e w s))
|
||||
((begin) (values 'begin-form #f e w s))
|
||||
|
|
@ -924,6 +972,10 @@
|
|||
(id? (syntax name))
|
||||
(values 'define-syntax-form (syntax name)
|
||||
(syntax val) w s))))
|
||||
((ellipsis)
|
||||
(values 'ellipsis
|
||||
(make-syntax-object (syntax-object-expression value)
|
||||
(anti-mark (syntax-object-wrap value)))))
|
||||
(else (values 'call #f e w s))))
|
||||
(values 'call #f e w s))))
|
||||
((syntax-object? e)
|
||||
|
|
@ -1002,15 +1054,20 @@
|
|||
(chi-install-global n (chi e r w))))
|
||||
(chi-void)))))
|
||||
((define-form)
|
||||
(let ((n (id-var-name value w)))
|
||||
(case (binding-type (lookup n r))
|
||||
(let* ((n (id-var-name value w))
|
||||
(type (binding-type (lookup n r))))
|
||||
(case type
|
||||
((global)
|
||||
(eval-if-c&e m
|
||||
(build-global-definition s n (chi e r w))))
|
||||
((displaced-lexical)
|
||||
(syntax-error (wrap value w) "identifier out of context"))
|
||||
(else (syntax-error (wrap value w)
|
||||
"cannot define keyword at top level")))))
|
||||
(else
|
||||
(if (eq? type 'external-macro)
|
||||
(eval-if-c&e m
|
||||
(build-global-definition s n (chi e r w)))
|
||||
(syntax-error (wrap value w)
|
||||
"cannot define keyword at top level"))))))
|
||||
(else (eval-if-c&e m (chi-expr type value e r w s))))))))
|
||||
|
||||
(define chi
|
||||
|
|
@ -1025,7 +1082,7 @@
|
|||
(case type
|
||||
((lexical)
|
||||
(build-lexical-reference 'value s value))
|
||||
((core) (value e r w s))
|
||||
((core external-macro) (value e r w s))
|
||||
((lexical-call)
|
||||
(chi-application
|
||||
(build-lexical-reference 'fun (source-annotation (car e)) value)
|
||||
|
|
@ -1276,16 +1333,28 @@
|
|||
(let ((p (local-eval-hook expanded)))
|
||||
(if (procedure? p)
|
||||
p
|
||||
(syntax-error p "nonprocedure transfomer")))))
|
||||
(syntax-error p "nonprocedure transformer")))))
|
||||
|
||||
(define chi-void
|
||||
(lambda ()
|
||||
(build-application no-source (build-primref no-source 'void) '())))
|
||||
|
||||
(define ellipsis?
|
||||
(lambda (x)
|
||||
(and (nonsymbol-id? x)
|
||||
(free-id=? x (syntax (... ...))))))
|
||||
(lambda (e r)
|
||||
(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=?'.
|
||||
(let* ((id (make-syntax-object '$sc-ellipsis
|
||||
(syntax-object-wrap e)))
|
||||
(n (id-var-name id empty-wrap))
|
||||
(b (lookup n r)))
|
||||
(if (eq? (binding-type b) 'ellipsis)
|
||||
(bound-id=? e (binding-value b))
|
||||
(free-id=? e (syntax (... ...))))))))
|
||||
|
||||
;;; data
|
||||
|
||||
|
|
@ -1418,17 +1487,17 @@
|
|||
(let ((var.lev (binding-value b)))
|
||||
(gen-ref src (car var.lev) (cdr var.lev) maps)))
|
||||
(lambda (var maps) (values `(ref ,var) maps)))
|
||||
(if (ellipsis? e)
|
||||
(if (ellipsis? e r)
|
||||
(syntax-error src "misplaced ellipsis in syntax form")
|
||||
(values `(quote ,e) maps)))))
|
||||
(syntax-case e ()
|
||||
((dots e)
|
||||
(ellipsis? (syntax dots))
|
||||
(gen-syntax src (syntax e) r maps (lambda (x) #f)))
|
||||
(ellipsis? (syntax dots) r)
|
||||
(gen-syntax src (syntax e) r maps (lambda (e r) #f)))
|
||||
((x dots . y)
|
||||
; this could be about a dozen lines of code, except that we
|
||||
; choose to handle (syntax (x ... ...)) forms
|
||||
(ellipsis? (syntax dots))
|
||||
(ellipsis? (syntax dots) r)
|
||||
(let f ((y (syntax y))
|
||||
(k (lambda (maps)
|
||||
(call-with-values
|
||||
|
|
@ -1443,7 +1512,7 @@
|
|||
(cdr maps))))))))
|
||||
(syntax-case y ()
|
||||
((dots . y)
|
||||
(ellipsis? (syntax dots))
|
||||
(ellipsis? (syntax dots) r)
|
||||
(f (syntax y)
|
||||
(lambda (maps)
|
||||
(call-with-values
|
||||
|
|
@ -1579,6 +1648,56 @@
|
|||
(lambda (vars body) (build-lambda s vars body)))))))
|
||||
|
||||
|
||||
(global-extend 'core 'with-ellipsis
|
||||
(lambda (e r w s)
|
||||
(let* ((tmp e) (tmp (syntax-dispatch tmp '(_ any any . each-any))))
|
||||
(if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp))
|
||||
(apply (lambda (dots e1 e2)
|
||||
(let ((id (if (symbol? dots)
|
||||
'$sc-ellipsis
|
||||
(make-syntax-object
|
||||
'$sc-ellipsis
|
||||
(syntax-object-wrap dots)))))
|
||||
(let ((ids (list id))
|
||||
(labels (list (gen-label)))
|
||||
(bindings (list (cons 'ellipsis (source-wrap dots w s)))))
|
||||
(let ((nw (make-binding-wrap ids labels w))
|
||||
(nr (extend-env labels bindings r)))
|
||||
(chi-body (cons e1 e2) (source-wrap e nw s) nr nw)))))
|
||||
tmp)
|
||||
(syntax-error 'with-ellipsis "bad syntax")))))
|
||||
|
||||
(global-extend 'core 'let
|
||||
(let ()
|
||||
(define (chi-let e r w s constructor ids vals exps)
|
||||
(if (not (valid-bound-ids? ids))
|
||||
(syntax-error e "duplicate bound variable in")
|
||||
(let ((labels (gen-labels ids))
|
||||
(new-vars (map gen-var ids)))
|
||||
(let ((nw (make-binding-wrap ids labels w))
|
||||
(nr (extend-var-env labels new-vars r)))
|
||||
(constructor s
|
||||
new-vars
|
||||
(map (lambda (x) (chi x r w)) vals)
|
||||
(chi-body exps (source-wrap e nw s) nr nw))))))
|
||||
(lambda (e r w s)
|
||||
(syntax-case e ()
|
||||
((_ ((id val) ...) e1 e2 ...)
|
||||
(chi-let e r w s
|
||||
build-let
|
||||
(syntax (id ...))
|
||||
(syntax (val ...))
|
||||
(syntax (e1 e2 ...))))
|
||||
((_ f ((id val) ...) e1 e2 ...)
|
||||
(id? (syntax f))
|
||||
(chi-let e r w s
|
||||
build-named-let
|
||||
(syntax (f id ...))
|
||||
(syntax (val ...))
|
||||
(syntax (e1 e2 ...))))
|
||||
(_ (syntax-error (source-wrap e w s)))))))
|
||||
|
||||
|
||||
(global-extend 'core 'letrec
|
||||
(lambda (e r w s)
|
||||
(syntax-case e ()
|
||||
|
|
@ -1596,21 +1715,6 @@
|
|||
(chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
|
||||
(_ (syntax-error (source-wrap e w s))))))
|
||||
|
||||
(global-extend 'core 'if
|
||||
(lambda (e r w s)
|
||||
(syntax-case e ()
|
||||
((_ test then)
|
||||
(build-conditional s
|
||||
(chi (syntax test) r w)
|
||||
(chi (syntax then) r w)
|
||||
(chi-void)))
|
||||
((_ test then else)
|
||||
(build-conditional s
|
||||
(chi (syntax test) r w)
|
||||
(chi (syntax then) r w)
|
||||
(chi (syntax else) r w)))
|
||||
(_ (syntax-error (source-wrap e w s))))))
|
||||
|
||||
|
||||
(global-extend 'core 'set!
|
||||
(lambda (e r w s)
|
||||
|
|
@ -1628,6 +1732,11 @@
|
|||
(syntax-error (wrap (syntax id) w)
|
||||
"identifier out of context"))
|
||||
(else (syntax-error (source-wrap e w s)))))))
|
||||
((_ (getter arg ...) val)
|
||||
(build-application s
|
||||
(chi (syntax (setter getter)) r w)
|
||||
(map (lambda (e) (chi e r w))
|
||||
(syntax (arg ... val)))))
|
||||
(_ (syntax-error (source-wrap e w s))))))
|
||||
|
||||
(global-extend 'begin 'begin '())
|
||||
|
|
@ -1643,7 +1752,7 @@
|
|||
(define convert-pattern
|
||||
; accepts pattern & keys
|
||||
; returns syntax-dispatch pattern & ids
|
||||
(lambda (pattern keys)
|
||||
(lambda (pattern keys ellipsis?)
|
||||
(let cvt ((p pattern) (n 0) (ids '()))
|
||||
(if (id? p)
|
||||
(if (bound-id-member? p keys)
|
||||
|
|
@ -1693,13 +1802,13 @@
|
|||
(define gen-clause
|
||||
(lambda (x keys clauses r pat fender exp)
|
||||
(call-with-values
|
||||
(lambda () (convert-pattern pat keys))
|
||||
(lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r))))
|
||||
(lambda (p pvars)
|
||||
(cond
|
||||
((not (distinct-bound-ids? (map car pvars)))
|
||||
(syntax-error pat
|
||||
"duplicate pattern variable in syntax-case pattern"))
|
||||
((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
|
||||
((not (andmap (lambda (x) (not (ellipsis? (car x) r))) pvars))
|
||||
(syntax-error pat
|
||||
"misplaced ellipsis in syntax-case pattern"))
|
||||
(else
|
||||
|
|
@ -1758,7 +1867,7 @@
|
|||
(let ((e (source-wrap e w s)))
|
||||
(syntax-case e ()
|
||||
((_ val (key ...) m ...)
|
||||
(if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
|
||||
(if (andmap (lambda (x) (and (id? x) (not (ellipsis? x r))))
|
||||
(syntax (key ...)))
|
||||
(let ((x (gen-var 'tmp)))
|
||||
; fat finger binding and references to temp variable x
|
||||
|
|
@ -1786,13 +1895,25 @@
|
|||
(cadr x)
|
||||
(chi-top x null-env top-wrap m esew)))))
|
||||
|
||||
(set! sc-expand3
|
||||
(let ((m 'e) (esew '(eval)))
|
||||
(lambda (x . rest)
|
||||
(if (and (pair? x) (equal? (car x) noexpand))
|
||||
(cadr x)
|
||||
(chi-top x
|
||||
null-env
|
||||
top-wrap
|
||||
(if (null? rest) m (car rest))
|
||||
(if (or (null? rest) (null? (cdr rest)))
|
||||
esew
|
||||
(cadr rest)))))))
|
||||
|
||||
(set! identifier?
|
||||
(lambda (x)
|
||||
(nonsymbol-id? x)))
|
||||
|
||||
(set! datum->syntax-object
|
||||
(lambda (id datum)
|
||||
(arg-check nonsymbol-id? id 'datum->syntax-object)
|
||||
(make-syntax-object datum (syntax-object-wrap id))))
|
||||
|
||||
(set! syntax-object->datum
|
||||
|
|
@ -1891,6 +2012,7 @@
|
|||
(lambda (p r)
|
||||
(cond
|
||||
((null? p) r)
|
||||
((eq? p '_) r)
|
||||
((eq? p 'any) (cons '() r))
|
||||
((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
|
||||
((eq? p 'each-any) (cons '() r))
|
||||
|
|
@ -1930,6 +2052,7 @@
|
|||
(lambda (e p w r)
|
||||
(cond
|
||||
((not r) #f)
|
||||
((eq? p '_) r)
|
||||
((eq? p 'any) (cons (wrap e w) r))
|
||||
((syntax-object? e)
|
||||
(match*
|
||||
|
|
@ -1943,10 +2066,13 @@
|
|||
(lambda (e p)
|
||||
(cond
|
||||
((eq? p 'any) (list e))
|
||||
((eq? p '_) '())
|
||||
((syntax-object? e)
|
||||
(match* (unannotate (syntax-object-expression e))
|
||||
p (syntax-object-wrap e) '()))
|
||||
(else (match* (unannotate e) p empty-wrap '())))))
|
||||
|
||||
(set! sc-chi chi)
|
||||
))
|
||||
)
|
||||
|
||||
|
|
@ -1954,47 +2080,58 @@
|
|||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ () e1 e2 ...)
|
||||
(syntax (begin e1 e2 ...)))
|
||||
(syntax (let () e1 e2 ...)))
|
||||
((_ ((out in)) e1 e2 ...)
|
||||
(syntax (syntax-case in () (out (begin e1 e2 ...)))))
|
||||
(syntax (syntax-case in () (out (let () e1 e2 ...)))))
|
||||
((_ ((out in) ...) e1 e2 ...)
|
||||
(syntax (syntax-case (list in ...) ()
|
||||
((out ...) (begin e1 e2 ...))))))))
|
||||
((out ...) (let () e1 e2 ...))))))))
|
||||
|
||||
(define-syntax syntax-rules
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ (k ...) ((keyword . pattern) template) ...)
|
||||
(syntax (lambda (x)
|
||||
(lambda (xx)
|
||||
(define (expand-syntax-rules dots keys docstrings clauses)
|
||||
(with-syntax
|
||||
(((k ...) keys)
|
||||
((docstring ...) docstrings)
|
||||
((((keyword . pattern) template) ...) clauses))
|
||||
(with-syntax
|
||||
((form (syntax (lambda (x)
|
||||
docstring ... ; optional docstring
|
||||
;; #((macro-type . syntax-rules)
|
||||
;; (patterns pattern ...)) ; embed patterns as procedure metadata
|
||||
(syntax-case x (k ...)
|
||||
((dummy . pattern) (syntax template))
|
||||
...)))))))
|
||||
...)))))
|
||||
(if dots
|
||||
(with-syntax ((dots dots))
|
||||
(syntax (with-ellipsis dots form)))
|
||||
(syntax form)))))
|
||||
(syntax-case xx ()
|
||||
((_ (k ...) ((keyword . pattern) template) ...)
|
||||
(expand-syntax-rules #f (syntax (k ...)) (syntax ()) (syntax (((keyword . pattern) template) ...))))
|
||||
((_ (k ...) docstring ((keyword . pattern) template) ...)
|
||||
(string? (syntax-object->datum (syntax docstring)))
|
||||
(expand-syntax-rules #f (syntax (k ...)) (syntax (docstring)) (syntax (((keyword . pattern) template) ...))))
|
||||
((_ dots (k ...) ((keyword . pattern) template) ...)
|
||||
(identifier? (syntax dots))
|
||||
(expand-syntax-rules (syntax dots) (syntax (k ...)) (syntax ()) (syntax (((keyword . pattern) template) ...))))
|
||||
((_ dots (k ...) docstring ((keyword . pattern) template) ...)
|
||||
(and (identifier? (syntax dots)) (string? (syntax-object->datum (syntax docstring))))
|
||||
(expand-syntax-rules (syntax dots) (syntax (k ...)) (syntax (docstring)) (syntax (((keyword . pattern) template) ...)))))))
|
||||
|
||||
(define-syntax or
|
||||
(define-syntax define-syntax-rule
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_) (syntax #f))
|
||||
((_ e) (syntax e))
|
||||
((_ e1 e2 e3 ...)
|
||||
(syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
|
||||
|
||||
(define-syntax and
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
|
||||
((_ e) (syntax e))
|
||||
((_) (syntax #t)))))
|
||||
|
||||
(define-syntax let
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ ((x v) ...) e1 e2 ...)
|
||||
(andmap identifier? (syntax (x ...)))
|
||||
(syntax ((lambda (x ...) e1 e2 ...) v ...)))
|
||||
((_ f ((x v) ...) e1 e2 ...)
|
||||
(andmap identifier? (syntax (f x ...)))
|
||||
(syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
|
||||
v ...))))))
|
||||
((_ (name . pattern) template)
|
||||
(syntax (define-syntax name
|
||||
(syntax-rules ()
|
||||
((_ . pattern) template)))))
|
||||
((_ (name . pattern) docstring template)
|
||||
(string? (syntax-object->datum (syntax docstring)))
|
||||
(syntax (define-syntax name
|
||||
(syntax-rules ()
|
||||
docstring
|
||||
((_ . pattern) template))))))))
|
||||
|
||||
(define-syntax let*
|
||||
(lambda (x)
|
||||
|
|
@ -2008,25 +2145,6 @@
|
|||
(binding (car bindings)))
|
||||
(syntax (let (binding) body)))))))))
|
||||
|
||||
(define-syntax cond
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ m1 m2 ...)
|
||||
(let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
|
||||
(if (null? clauses)
|
||||
(syntax-case clause (else =>)
|
||||
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
|
||||
((e0) (syntax (let ((t e0)) (if t t))))
|
||||
((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
|
||||
((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
|
||||
(_ (syntax-error x)))
|
||||
(with-syntax ((rest (f (car clauses) (cdr clauses))))
|
||||
(syntax-case clause (else =>)
|
||||
((e0) (syntax (let ((t e0)) (if t t rest))))
|
||||
((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
|
||||
((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
|
||||
(_ (syntax-error x))))))))))
|
||||
|
||||
(define-syntax do
|
||||
(lambda (orig-x)
|
||||
(syntax-case orig-x ()
|
||||
|
|
@ -2080,19 +2198,19 @@
|
|||
(lambda (p lev)
|
||||
(syntax-case p (unquote unquote-splicing quasiquote)
|
||||
((unquote p)
|
||||
(if (fx= lev 0)
|
||||
(if (= lev 0)
|
||||
(syntax p)
|
||||
(quasicons (syntax (quote unquote))
|
||||
(quasi (syntax (p)) (fx- lev 1)))))
|
||||
(quasi (syntax (p)) (- lev 1)))))
|
||||
(((unquote-splicing p) . q)
|
||||
(if (fx= lev 0)
|
||||
(if (= lev 0)
|
||||
(quasiappend (syntax p) (quasi (syntax q) lev))
|
||||
(quasicons (quasicons (syntax (quote unquote-splicing))
|
||||
(quasi (syntax (p)) (fx- lev 1)))
|
||||
(quasi (syntax (p)) (- lev 1)))
|
||||
(quasi (syntax q) lev))))
|
||||
((quasiquote p)
|
||||
(quasicons (syntax (quote quasiquote))
|
||||
(quasi (syntax (p)) (fx+ lev 1))))
|
||||
(quasi (syntax (p)) (+ lev 1))))
|
||||
((p . q)
|
||||
(quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
|
||||
(#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
|
||||
|
|
@ -2166,4 +2284,3 @@
|
|||
(syntax e))
|
||||
((_ x (... ...))
|
||||
(syntax (e x (... ...)))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -168,4 +168,40 @@ exit $?
|
|||
body ...)))))
|
||||
(string-let foo (list foo foo)))))
|
||||
|
||||
;; (pass-if-equal "custom ellipsis within normal ellipsis"
|
||||
;; '((((a x) (a y) (a …))
|
||||
;; ((b x) (b y) (b …))
|
||||
;; ((c x) (c y) (c …)))
|
||||
;; (((a x) (b x) (c x))
|
||||
;; ((a y) (b y) (c y))
|
||||
;; ((a …) (b …) (c …))))
|
||||
;; (let ()
|
||||
;; (define-syntax foo
|
||||
;; (syntax-rules ()
|
||||
;; ((_ y ...)
|
||||
;; (syntax-rules … ()
|
||||
;; ((_ x …)
|
||||
;; '((((x y) ...) …)
|
||||
;; (((x y) …) ...)))))))
|
||||
;; (define-syntax bar (foo x y …))
|
||||
;; (bar a b c)))
|
||||
|
||||
(let ()
|
||||
(define-syntax define-quotation-macros
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ (macro-name head-symbol) ...)
|
||||
#'(begin (define-syntax macro-name
|
||||
(lambda (x)
|
||||
(with-ellipsis :::
|
||||
(syntax-case x ()
|
||||
((_ x :::)
|
||||
#'(quote (head-symbol x :::)))))))
|
||||
...)))))
|
||||
(define-quotation-macros (quote-a a) (quote-b b) (quote-c c))
|
||||
|
||||
(pass-if-equal "with-ellipsis"
|
||||
'(a 1 2 3)
|
||||
(quote-a 1 2 3)))
|
||||
|
||||
(result 'report)
|
||||
|
|
|
|||
Loading…
Reference in a new issue