Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Implement ellipsis escaping, as per R7RS #711

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Implement ellipsis escaping, as per R7RS #711

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
b3389a3
Implement ellipsis escaping, as per R7RS
jpellegrini Jan 29, 2025
9965604
Make let-yntax code similar to that of define-syntax
jpellegrini Jan 29, 2025
d5f9dd5
Fix test for let-syntax with ellipsis escaping
jpellegrini Jan 29, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
195 changes: 168 additions & 27 deletions lib/mbe.stk
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -168,6 +168,8 @@ doc>
(define mbe:ellipsis-sub-envs #f)
(define mbe:contained-in? #f)

(define ellipsis-marker (gensym "ELLIPSIS-"))

;=============================================================================

;; reverse assq:
Expand Down Expand Up @@ -645,6 +647,85 @@ doc>
(and (pair? x) (pair? (cdr x)) (eq? (cadr x) ellipsis))))


;;; tests if x is an ellipsis escape pattern, i.e., of the form
;;; (... <template>)
;;;
;;; (mbe:ellipsis-escape? 'a '...) => #f
;;; (mbe:ellipsis-escape? '(a b) '...) => #f
;;; (mbe:ellipsis-escape? '(... b) '...) => #t
;;; (mbe:ellipsis-escape? '(... ...) '...) => #t
;;; (mbe:ellipsis-escape? '(... b c) '...) => error
(define mbe:ellipsis-escape?
(lambda (expr ell)
(and (pair? expr)
(eq? ell (car expr))
(pair? (cdr expr)))))


;; Simple substitituon x -> y in a nested list.
;;
;; (replace
;; '(a b (c d e) (f (d e) g) h e)
;; 'e
;; 'EH) => (a b (c d EH) (f (d EH) g) h EH)
;;
;; The test used is eq? so no substitution is done
;; in the following case, for example:
;;
;; (replace
;; '(a b (c d (e e e)) (f (d e) g) h (e e e))
;; '(e e e)
;; 'EH) => '(a b (c d (e e e)) (f (d e) g) h (e e e))
;;
(define (replace lst x y)
(cond ((eq? lst x) y)
((pair? lst)
(cons (replace (car lst) x y)
(replace (cdr lst) x y)))
(else lst)))

;; mbe:subst-ellipsis will replace the ellipsis symbol inside
;; a template that is marked as an "ellipsis escape":
;;
;; (mbe:subst-ellipsis
;; '(... x)
;; '... 'ELL) => 'x
;;
;; (mbe:subst-ellipsis
;; '(... ...)
;; '... 'ELL) => 'ELL
;;
;; (mbe:subst-ellipsis
;; '(a (b ... x) c)
;; '... 'ELL) => '(a (b ... x) c)
;;
;; (mbe:subst-ellipsis
;; '(a (... x) c)
;; '... 'ELL) => '(a x c)
;;
;; (mbe:subst-ellipsis
;; 'a
;; '... 'ELL) => 'a
;;
;; (mbe:subst-ellipsis
;; '(a (b (... (x y z)) c) d)
;; '... 'ELL) => '(a (b (x y z) c) d)
;;
;; (mbe:subst-ellipsis
;; '(a (b (... (x (... u) y z)) c) d)
;; '... 'ELL) => (a (b (x (ELL u) y z) c) d)
;;
;; (mbe:subst-ellipsis
;; '(a (b (... c d)))
;; '... 'ELL) => error
(define (mbe:subst-ellipsis lst ell new-ell)
(cond ((mbe:ellipsis-escape? lst ell)
(cadr (replace lst ell new-ell)))
((pair? lst)
(map* (lambda (x) (mbe:subst-ellipsis x ell new-ell)) lst))
(else lst)))


#|

Original DEFINE-SYNTAX
Expand Down Expand Up @@ -706,21 +787,72 @@ doc>
(let ((in-pattern (caar l))
(out-pattern (cadar l)))
(if (mbe:matches-pattern? in-pattern macro-form keywords ellipsis)
(let ((tmp (hyg:tag out-pattern
;; We call mbe:subst-ellipsis on the out-pattern before anything else, so the
;; escaped ellipsis patterns have their ellispses truned into the gensymed
;; symbol "ellipsis-marker".
;; Then, after doing the tag/untag/get-bindings, we call replace to put
;; the ellipsis symbols back into their places.
(let ((tmp (hyg:tag (mbe:subst-ellipsis out-pattern ellipsis ellipsis-marker)
(append! (hyg:flatten in-pattern) keywords)
'()
ellipsis)))
(hyg:untag (mbe:expand-pattern (car tmp)
(mbe:get-bindings in-pattern
macro-form
keywords
ellipsis)
keywords
ellipsis)
(cdr tmp)
'()))
(replace (hyg:untag (mbe:expand-pattern (car tmp)
(mbe:get-bindings in-pattern
macro-form
keywords
ellipsis)
keywords
ellipsis)
(cdr tmp)
'())
ellipsis-marker ellipsis))
(Loop (cdr l))))))))

;; This utility checks for ellipsis escaping patterns written wrongly, like
;; (... a b) --> the "b" cannot be there
(define (check-wrong-ellipsis-escape-single expr ell)
(when (and (pair? expr)
(eq? ell (car expr))
(list? (cdr expr))) ;; length of cdr may be 0 (bad) 1 (good) or more (bad).
(when (null? (cdr expr)) ;; length of expr = 1, only (...)
(error 'syntax-rules "Misplaced ellipsis"))
(unless (null? (cddr expr)) ;; length of expr > 2, we have (... a more)
(error 'syntax-rules
"In (<ellipsis> <pattern>), <pattern> should be a single element: ~s" expr))))


;; for-each, but goes into sublists. used by the ellipsis escaping chack in syntax-rules
(define (deep-for-each f lst)
(cond
((null? lst)
(void))
((pair? lst)
(f lst)
(for-each* (lambda (x) (deep-for-each f x)) lst)
(void))
(else (void))))

;; Check for wrong ellipsis escaping patterns
(define (check-wrong-ellipsis-escape clauses ell)
;; clauses is like
;;
;; (((arg1 arg2 ...)
;; template))
;;
;; then each clause is
;;
;; ((arg1 arg2 ...)
;; template)
;;
;; so we do for-each in the clauses list, and in each one we run
;; deep-for-each on (cadr clause)
(for-each
(lambda (clause)
(deep-for-each
(lambda (x)
(check-wrong-ellipsis-escape-single x ell))
(cadr clause)))
clauses))

;;
;; A very simple implementation of let-syntax.
Expand All @@ -746,26 +878,35 @@ doc>
,(map (lambda (x)
(let ((macro-name (car x))
(syn-rules (cadr x)))
(let ((alt-ellipsis? (not (list? (cadr syn-rules)))))
(let ((ellipsis (if alt-ellipsis?
(cadr syn-rules)
'...))
(keywords (if alt-ellipsis?
(cons macro-name (caddr syn-rules))
(cons macro-name (cadr syn-rules))))
(clauses (if alt-ellipsis?
(cdddr syn-rules)
(cddr syn-rules))))
`(,macro-name (lambda args
((%%symbol-value 'find-clause 'MBE)
',macro-name
args
',keywords
',clauses
',ellipsis)))))))
;; SRFI-46:
;; Let the user pick the ellipsis symbol. Since STklos does not recognize
;; symbols starting with ":", we test for symbol and keyword here.
;; If we find that the user included a symbol or keyword instead of a list
;; after "SYNTAX-RULES", then it's the ellipsis marker to be used,
;; (SYNTAX-RULES ::: () ((_ (f x :::)) (do-something x :::)))
(let ((ellipsis '...))
(when (or (symbol? (cadr syn-rules))
(keyword? (cadr syn-rules)))
(set! ellipsis (cadr syn-rules))
(set! syn-rules (cdr syn-rules)))


(let ((keywords (cons macro-name (cadr syn-rules)))
(clauses (cddr syn-rules)))

(check-wrong-ellipsis-escape clauses ellipsis)
`(,macro-name (lambda args
((%%symbol-value 'find-clause 'MBE)
',macro-name
args
',keywords
',clauses
',ellipsis)))))))
bindings)
,@body))



;; NOTE:
;; define-syntax is defined in the file lib/runtime-macros.stk
;;
Expand Down
4 changes: 4 additions & 0 deletions lib/runtime-macros.stk
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -100,6 +100,10 @@

(let ((keywords (cons macro-name (cadr syn-rules)))
(clauses (cddr syn-rules)))

;; Should we export this symbol from MBE? It will only be used here.
((in-module MBE check-wrong-ellipsis-escape) clauses ellipsis)

`(define-macro (,macro-name . args)
((%%symbol-value 'find-clause 'MBE) ',macro-name
args
Expand Down
74 changes: 74 additions & 0 deletions tests/test-macros.stk
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -273,6 +273,80 @@
(g ((quote ...) 2 3 4 5 6)))))



;;; ellipsis escaping (example in R7RS)
(define-syntax be-like-begin
(syntax-rules ()
((be-like-begin name)
(define-syntax name
(syntax-rules ()
((name expr (... ...))
(begin expr (... ...))))))))

(be-like-begin sequence)

(test "ellipsis escaping (example in R7RS)"
4
(sequence 1 2 3 4))

(let-syntax ((with-alternate-begin
(syntax-rules ()
((_ name body ...)
(let-syntax ((name
(syntax-rules ()
((name expr (... ...))
(begin expr (... ...))))))
body ...)))))
(with-alternate-begin sequence
(test "ellipsis escaping (example in R7RS), adapted"
30
(sequence 10 20 30))))



(define-syntax test-macro:nested-ellipsis-escape
(syntax-rules ()
((_ a b c d e)
(a (b (... (c d e ...)) c)))))

(test "ellipsis escaping (nested)"
'(1 (2 (3 4 5 ...) 3))
(macro-expand '(test-macro:nested-ellipsis-escape 1 2 3 4 5)))

(let-syntax ((test-macro:nested-ellipsis-escape
(syntax-rules ()
((_ a b c d e)
(a (b (... (c d e ...)) c))))))
(test "ellipsis escaping (nested) - let-syntax"
'(1 (2 (3 4 5 ...) 3))
(macro-expand '(test-macro:nested-ellipsis-escape 1 2 3 4 5))))

(test/compile-error "ellipsis escape with too many elements in template.1"
(define-syntax %f
(syntax-rules ()
((%f) (... 1 2))))) ;; wrong, will signal an error!

(test/compile-error "ellipsis escape with too many elements in template.2"
(let-syntax ((%f (syntax-rules ()
((%f) (... 1 2)))))
(macro-expand '(%f)))) ; should never get here

(test/compile-error "ellipsis escape with too many elements in template.3"
(let-syntax ((%f (syntax-rules ()
((%f) (begin (... 1 2))))))
(macro-expand '(%f)))) ; should never get here

(test/compile-error "ellipsis escape with not enough elements in template.4"
(let-syntax ((%f (syntax-rules ()
((%f) (a (...))))))
(macro-expand* '(%f)))) ; should never get here

(let-syntax ((%f (syntax-rules ()
((%f) (format (... "2"))))))
(test "ellipsis escaping"
'"2"
(%f)))

;;FIXME: Add more tests !!!!!!!!!


Expand Down