artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Import psyntax from Guile-1.8: R7RS with-ellipsis.

Browse source 
* 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 2016-12-19 19:41:43 +01:00
parent 40a6f2df34
commit f8bc344dfc
6 changed files with 9877 additions and 10017 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
GNUmakefile
View file

@ -110,6 +110,11 @@ guile-mescc: mescc.cat
paren: all paren: all
scripts/paren.mes 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 help: help-top
install: all install: all

1
NEWS
View file

@ -22,6 +22,7 @@ block-comments are all handled by the Scheme reader later.
*** Lambda* and define* are now supported. *** Lambda* and define* are now supported.
*** #;-comment is now supported. *** #;-comment is now supported.
*** Non-nested #| |#-comment is now supported. *** Non-nested #| |#-comment is now supported.
*** R7RS syntax-rules with custom ellipsis, with-ellipsis are now supported.
** Noteworthy bug fixes ** Noteworthy bug fixes
*** Closure is not a pair. *** Closure is not a pair.
* Changes in 0.3 since 0.2 * Changes in 0.3 since 0.2

5
module/mes/psyntax-1.mes
View file

@ -28,8 +28,3 @@
(define datum->syntax datum->syntax-object) (define datum->syntax datum->syntax-object)
(define syntax->datum syntax-object->datum) (define syntax->datum syntax-object->datum)
(set! expand-macro sc-expand) (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))))

10634
module/mes/psyntax-pp.mes
View file

File diff suppressed because it is too large Load diff

325
module/mes/psyntax.ss
View file

@ -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 ;;; Portable implementation of syntax-case
;;; Extracted from Chez Scheme Version 5.9f ;;; Extracted from Chez Scheme Version 5.9f
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman ;;; 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 ;;; Copyright (c) 1992-1997 Cadence Research Systems
;;; Permission to copy this software, in whole or in part, to use this ;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software ;;; software for any lawful purpose, and to redistribute this software
@ -102,6 +127,13 @@
;;; evaluator/expander that no expansion is necessary, since expr has ;;; evaluator/expander that no expansion is necessary, since expr has
;;; already been fully expanded to core forms. ;;; 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) ;;; (error who format-string why what)
;;; where who is either a symbol or #f, format-string is always "~a ~s", ;;; 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 ;;; 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 ;;; the code below, but to avoid bootstrapping problems, do so only
;;; after you have a working version of the expander. ;;; 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 ;;; If you find that this code loads or runs slowly, consider
;;; switching to faster hardware or a faster implementation of ;;; switching to faster hardware or a faster implementation of
;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding, ;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
@ -284,11 +322,11 @@
(define top-level-eval-hook (define top-level-eval-hook
(lambda (x) (lambda (x)
(eval `(,noexpand ,x)))) (eval `(,noexpand ,x) (interaction-environment))))
(define local-eval-hook (define local-eval-hook
(lambda (x) (lambda (x)
(eval `(,noexpand ,x)))) (eval `(,noexpand ,x) (interaction-environment))))
(define error-hook (define error-hook
(lambda (who why what) (lambda (who why what)
@ -355,9 +393,11 @@
((_ src name) name) ((_ src name) name)
((_ src level name) name))) ((_ src level name) name)))
(define-syntax build-data (define (build-data src exp)
(syntax-rules () (if (and (self-evaluating? exp)
((_ src exp) `',exp))) (not (vector? exp)))
exp
(list 'quote exp)))
(define build-sequence (define build-sequence
(lambda (src exps) (lambda (src exps)
@ -365,6 +405,18 @@
(car exps) (car exps)
`(begin ,@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 (define build-letrec
(lambda (src vars val-exps body-exp) (lambda (src vars val-exps body-exp)
(if (null? vars) (if (null? vars)
@ -373,13 +425,7 @@
(define-syntax build-lexical-var (define-syntax build-lexical-var
(syntax-rules () (syntax-rules ()
((_ src id) (gensym)))) ((_ src id) (gensym (symbol->string id)))))
(define-syntax self-evaluating?
(syntax-rules ()
((_ e)
(let ((x e))
(or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
) )
(define-structure (syntax-object expression wrap)) (define-structure (syntax-object expression wrap))
@ -429,6 +475,7 @@
;;; <binding> ::= (macro . <procedure>) macros ;;; <binding> ::= (macro . <procedure>) macros
;;; (core . <procedure>) core forms ;;; (core . <procedure>) core forms
;;; (external-macro . <procedure>) external-macro
;;; (begin) begin ;;; (begin) begin
;;; (define) define ;;; (define) define
;;; (define-syntax) define-syntax ;;; (define-syntax) define-syntax
@ -495,7 +542,7 @@
(if (null? r) (if (null? r)
'() '()
(let ((a (car r))) (let ((a (car r)))
(if (eq? (cadr a) 'macro) (if (memq (cadr a) '(macro ellipsis))
(cons a (macros-only-env (cdr r))) (cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r))))))) (macros-only-env (cdr r)))))))
@ -843,6 +890,7 @@
;;; type value explanation ;;; type value explanation
;;; ------------------------------------------------------------------- ;;; -------------------------------------------------------------------
;;; core procedure core form (including singleton) ;;; core procedure core form (including singleton)
;;; external-macro procedure external macro
;;; lexical name lexical variable reference ;;; lexical name lexical variable reference
;;; global name global variable reference ;;; global name global variable reference
;;; begin none begin keyword ;;; begin none begin keyword
@ -896,7 +944,7 @@
((macro) ((macro)
(syntax-type (chi-macro (binding-value b) e r w rib) (syntax-type (chi-macro (binding-value b) e r w rib)
r empty-wrap s 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) ((local-syntax)
(values 'local-syntax-form (binding-value b) e w s)) (values 'local-syntax-form (binding-value b) e w s))
((begin) (values 'begin-form #f e w s)) ((begin) (values 'begin-form #f e w s))
@ -924,6 +972,10 @@
(id? (syntax name)) (id? (syntax name))
(values 'define-syntax-form (syntax name) (values 'define-syntax-form (syntax name)
(syntax val) w s)))) (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)))) (else (values 'call #f e w s))))
(values 'call #f e w s)))) (values 'call #f e w s))))
((syntax-object? e) ((syntax-object? e)
@ -1002,15 +1054,20 @@
(chi-install-global n (chi e r w)))) (chi-install-global n (chi e r w))))
(chi-void))))) (chi-void)))))
((define-form) ((define-form)
(let ((n (id-var-name value w))) (let* ((n (id-var-name value w))
(case (binding-type (lookup n r)) (type (binding-type (lookup n r))))
(case type
((global) ((global)
(eval-if-c&e m (eval-if-c&e m
(build-global-definition s n (chi e r w)))) (build-global-definition s n (chi e r w))))
((displaced-lexical) ((displaced-lexical)
(syntax-error (wrap value w) "identifier out of context")) (syntax-error (wrap value w) "identifier out of context"))
(else (syntax-error (wrap value w) (else
"cannot define keyword at top level"))))) (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)))))))) (else (eval-if-c&e m (chi-expr type value e r w s))))))))
(define chi (define chi
@ -1025,7 +1082,7 @@
(case type (case type
((lexical) ((lexical)
(build-lexical-reference 'value s value)) (build-lexical-reference 'value s value))
((core) (value e r w s)) ((core external-macro) (value e r w s))
((lexical-call) ((lexical-call)
(chi-application (chi-application
(build-lexical-reference 'fun (source-annotation (car e)) value) (build-lexical-reference 'fun (source-annotation (car e)) value)
@ -1276,16 +1333,28 @@
(let ((p (local-eval-hook expanded))) (let ((p (local-eval-hook expanded)))
(if (procedure? p) (if (procedure? p)
p p
(syntax-error p "nonprocedure transfomer"))))) (syntax-error p "nonprocedure transformer")))))
(define chi-void (define chi-void
(lambda () (lambda ()
(build-application no-source (build-primref no-source 'void) '()))) (build-application no-source (build-primref no-source 'void) '())))
(define ellipsis? (define ellipsis?
(lambda (x) (lambda (e r)
(and (nonsymbol-id? x) (and (nonsymbol-id? e)
(free-id=? x (syntax (... ...)))))) ;; 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 ;;; data
@ -1418,17 +1487,17 @@
(let ((var.lev (binding-value b))) (let ((var.lev (binding-value b)))
(gen-ref src (car var.lev) (cdr var.lev) maps))) (gen-ref src (car var.lev) (cdr var.lev) maps)))
(lambda (var maps) (values `(ref ,var) maps))) (lambda (var maps) (values `(ref ,var) maps)))
(if (ellipsis? e) (if (ellipsis? e r)
(syntax-error src "misplaced ellipsis in syntax form") (syntax-error src "misplaced ellipsis in syntax form")
(values `(quote ,e) maps))))) (values `(quote ,e) maps)))))
(syntax-case e () (syntax-case e ()
((dots e) ((dots e)
(ellipsis? (syntax dots)) (ellipsis? (syntax dots) r)
(gen-syntax src (syntax e) r maps (lambda (x) #f))) (gen-syntax src (syntax e) r maps (lambda (e r) #f)))
((x dots . y) ((x dots . y)
; this could be about a dozen lines of code, except that we ; this could be about a dozen lines of code, except that we
; choose to handle (syntax (x ... ...)) forms ; choose to handle (syntax (x ... ...)) forms
(ellipsis? (syntax dots)) (ellipsis? (syntax dots) r)
(let f ((y (syntax y)) (let f ((y (syntax y))
(k (lambda (maps) (k (lambda (maps)
(call-with-values (call-with-values
@ -1443,7 +1512,7 @@
(cdr maps)))))))) (cdr maps))))))))
(syntax-case y () (syntax-case y ()
((dots . y) ((dots . y)
(ellipsis? (syntax dots)) (ellipsis? (syntax dots) r)
(f (syntax y) (f (syntax y)
(lambda (maps) (lambda (maps)
(call-with-values (call-with-values
@ -1579,6 +1648,56 @@
(lambda (vars body) (build-lambda s vars body))))))) (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 (global-extend 'core 'letrec
(lambda (e r w s) (lambda (e r w s)
(syntax-case e () (syntax-case e ()
@ -1596,21 +1715,6 @@
(chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w))))))) (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
(_ (syntax-error (source-wrap e w s)))))) (_ (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! (global-extend 'core 'set!
(lambda (e r w s) (lambda (e r w s)
@ -1628,6 +1732,11 @@
(syntax-error (wrap (syntax id) w) (syntax-error (wrap (syntax id) w)
"identifier out of context")) "identifier out of context"))
(else (syntax-error (source-wrap e w s))))))) (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)))))) (_ (syntax-error (source-wrap e w s))))))
(global-extend 'begin 'begin '()) (global-extend 'begin 'begin '())
@ -1643,7 +1752,7 @@
(define convert-pattern (define convert-pattern
; accepts pattern & keys ; accepts pattern & keys
; returns syntax-dispatch pattern & ids ; returns syntax-dispatch pattern & ids
(lambda (pattern keys) (lambda (pattern keys ellipsis?)
(let cvt ((p pattern) (n 0) (ids '())) (let cvt ((p pattern) (n 0) (ids '()))
(if (id? p) (if (id? p)
(if (bound-id-member? p keys) (if (bound-id-member? p keys)
@ -1693,13 +1802,13 @@
(define gen-clause (define gen-clause
(lambda (x keys clauses r pat fender exp) (lambda (x keys clauses r pat fender exp)
(call-with-values (call-with-values
(lambda () (convert-pattern pat keys)) (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r))))
(lambda (p pvars) (lambda (p pvars)
(cond (cond
((not (distinct-bound-ids? (map car pvars))) ((not (distinct-bound-ids? (map car pvars)))
(syntax-error pat (syntax-error pat
"duplicate pattern variable in syntax-case pattern")) "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 (syntax-error pat
"misplaced ellipsis in syntax-case pattern")) "misplaced ellipsis in syntax-case pattern"))
(else (else
@ -1758,7 +1867,7 @@
(let ((e (source-wrap e w s))) (let ((e (source-wrap e w s)))
(syntax-case e () (syntax-case e ()
((_ val (key ...) m ...) ((_ 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 ...))) (syntax (key ...)))
(let ((x (gen-var 'tmp))) (let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x ; fat finger binding and references to temp variable x
@ -1786,13 +1895,25 @@
(cadr x) (cadr x)
(chi-top x null-env top-wrap m esew))))) (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? (set! identifier?
(lambda (x) (lambda (x)
(nonsymbol-id? x))) (nonsymbol-id? x)))
(set! datum->syntax-object (set! datum->syntax-object
(lambda (id datum) (lambda (id datum)
(arg-check nonsymbol-id? id 'datum->syntax-object)
(make-syntax-object datum (syntax-object-wrap id)))) (make-syntax-object datum (syntax-object-wrap id))))
(set! syntax-object->datum (set! syntax-object->datum
@ -1891,6 +2012,7 @@
(lambda (p r) (lambda (p r)
(cond (cond
((null? p) r) ((null? p) r)
((eq? p '_) r)
((eq? p 'any) (cons '() r)) ((eq? p 'any) (cons '() r))
((pair? p) (match-empty (car p) (match-empty (cdr p) r))) ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
((eq? p 'each-any) (cons '() r)) ((eq? p 'each-any) (cons '() r))
@ -1930,6 +2052,7 @@
(lambda (e p w r) (lambda (e p w r)
(cond (cond
((not r) #f) ((not r) #f)
((eq? p '_) r)
((eq? p 'any) (cons (wrap e w) r)) ((eq? p 'any) (cons (wrap e w) r))
((syntax-object? e) ((syntax-object? e)
(match* (match*
@ -1943,10 +2066,13 @@
(lambda (e p) (lambda (e p)
(cond (cond
((eq? p 'any) (list e)) ((eq? p 'any) (list e))
((eq? p '_) '())
((syntax-object? e) ((syntax-object? e)
(match* (unannotate (syntax-object-expression e)) (match* (unannotate (syntax-object-expression e))
p (syntax-object-wrap e) '())) p (syntax-object-wrap e) '()))
(else (match* (unannotate e) p empty-wrap '()))))) (else (match* (unannotate e) p empty-wrap '())))))
(set! sc-chi chi)
)) ))
) )
@ -1954,47 +2080,58 @@
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ () e1 e2 ...) ((_ () e1 e2 ...)
(syntax (begin e1 e2 ...))) (syntax (let () e1 e2 ...)))
((_ ((out in)) 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 ...) ((_ ((out in) ...) e1 e2 ...)
(syntax (syntax-case (list in ...) () (syntax (syntax-case (list in ...) ()
((out ...) (begin e1 e2 ...)))))))) ((out ...) (let () e1 e2 ...))))))))
(define-syntax syntax-rules (define-syntax syntax-rules
(lambda (x) (lambda (xx)
(syntax-case x () (define (expand-syntax-rules dots keys docstrings clauses)
((_ (k ...) ((keyword . pattern) template) ...) (with-syntax
(syntax (lambda (x) (((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 ...) (syntax-case x (k ...)
((dummy . pattern) (syntax template)) ((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) (lambda (x)
(syntax-case x () (syntax-case x ()
((_) (syntax #f)) ((_ (name . pattern) template)
((_ e) (syntax e)) (syntax (define-syntax name
((_ e1 e2 e3 ...) (syntax-rules ()
(syntax (let ((t e1)) (if t t (or e2 e3 ...)))))))) ((_ . pattern) template)))))
((_ (name . pattern) docstring template)
(define-syntax and (string? (syntax-object->datum (syntax docstring)))
(lambda (x) (syntax (define-syntax name
(syntax-case x () (syntax-rules ()
((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f))) docstring
((_ e) (syntax e)) ((_ . pattern) template))))))))
((_) (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 ...))))))
(define-syntax let* (define-syntax let*
(lambda (x) (lambda (x)
@ -2008,25 +2145,6 @@
(binding (car bindings))) (binding (car bindings)))
(syntax (let (binding) body))))))))) (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 (define-syntax do
(lambda (orig-x) (lambda (orig-x)
(syntax-case orig-x () (syntax-case orig-x ()
@ -2080,19 +2198,19 @@
(lambda (p lev) (lambda (p lev)
(syntax-case p (unquote unquote-splicing quasiquote) (syntax-case p (unquote unquote-splicing quasiquote)
((unquote p) ((unquote p)
(if (fx= lev 0) (if (= lev 0)
(syntax p) (syntax p)
(quasicons (syntax (quote unquote)) (quasicons (syntax (quote unquote))
(quasi (syntax (p)) (fx- lev 1))))) (quasi (syntax (p)) (- lev 1)))))
(((unquote-splicing p) . q) (((unquote-splicing p) . q)
(if (fx= lev 0) (if (= lev 0)
(quasiappend (syntax p) (quasi (syntax q) lev)) (quasiappend (syntax p) (quasi (syntax q) lev))
(quasicons (quasicons (syntax (quote unquote-splicing)) (quasicons (quasicons (syntax (quote unquote-splicing))
(quasi (syntax (p)) (fx- lev 1))) (quasi (syntax (p)) (- lev 1)))
(quasi (syntax q) lev)))) (quasi (syntax q) lev))))
((quasiquote p) ((quasiquote p)
(quasicons (syntax (quote quasiquote)) (quasicons (syntax (quote quasiquote))
(quasi (syntax (p)) (fx+ lev 1)))) (quasi (syntax (p)) (+ lev 1))))
((p . q) ((p . q)
(quasicons (quasi (syntax p) lev) (quasi (syntax q) lev))) (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
(#(x ...) (quasivector (quasi (syntax (x ...)) lev))) (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
@ -2166,4 +2284,3 @@
(syntax e)) (syntax e))
((_ x (... ...)) ((_ x (... ...))
(syntax (e x (... ...))))))))))) (syntax (e x (... ...)))))))))))

36
tests/psyntax.test
View file

@ -168,4 +168,40 @@ exit $?
body ...))))) body ...)))))
(string-let foo (list foo foo))))) (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) (result 'report)