Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-25 13:05:07 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Revert "Implement identifier-syntax in init-7.scm"

Browse source 
This reverts commit d55d6c619c.
This commit is contained in:
Daphne Preston-Kendal 2022-03-15 09:07:11 +01:00
parent abda243d21
commit 70455ed3f8
1 changed files with 12 additions and 62 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

74
lib/init-7.scm
View file

@ -849,12 +849,12 @@
(lambda () (current-output-port old-out))))) (lambda () (current-output-port old-out)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax-rules and identifier-syntax ;; syntax-rules
(define (syntax-template-transformer rename compare id-syntax? ellipsis ellipsis-specified? lits forms) (define (syntax-rules-transformer expr rename compare)
(let ((count 0) (let ((ellipsis-specified? (identifier? (cadr expr)))
(count 0)
(_er-macro-transformer (rename 'er-macro-transformer)) (_er-macro-transformer (rename 'er-macro-transformer))
(_er-macro-transformer* (rename 'er-macro-transformer*))
(_lambda (rename 'lambda)) (_let (rename 'let)) (_lambda (rename 'lambda)) (_let (rename 'let))
(_begin (rename 'begin)) (_if (rename 'if)) (_begin (rename 'begin)) (_if (rename 'if))
(_and (rename 'and)) (_or (rename 'or)) (_and (rename 'and)) (_or (rename 'or))
@ -874,12 +874,15 @@
(_list->vector (rename 'list->vector)) (_list->vector (rename 'list->vector))
(_cons3 (rename 'cons-source)) (_cons3 (rename 'cons-source))
(_underscore (rename '_))) (_underscore (rename '_)))
(define ellipsis (if ellipsis-specified? (cadr expr) (rename '...)))
(define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
(define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
(define (next-symbol s) (define (next-symbol s)
(set! count (+ count 1)) (set! count (+ count 1))
(rename (string->symbol (string-append s (%number->string count))))) (rename (string->symbol (string-append s (%number->string count)))))
(define (expand-pattern pat tmpl) (define (expand-pattern pat tmpl)
(let lp ((p (if id-syntax? pat (cdr pat))) (let lp ((p (cdr pat))
(x (if id-syntax? _expr (list _cdr _expr))) (x (list _cdr _expr))
(dim 0) (dim 0)
(vars '()) (vars '())
(k (lambda (vars) (k (lambda (vars)
@ -1069,7 +1072,7 @@
((null? t) (list _quote '())) ((null? t) (list _quote '()))
(else t)))) (else t))))
(list (list
(if id-syntax? _er-macro-transformer* _er-macro-transformer) _er-macro-transformer
(list _lambda (list _expr _rename _compare) (list _lambda (list _expr _rename _compare)
(list (list
_car _car
@ -1080,7 +1083,7 @@
(lambda (clause) (lambda (clause)
(if (and (list? clause) (= (length clause) 2)) (if (and (list? clause) (= (length clause) 2))
(expand-pattern (car clause) (cadr clause)) (expand-pattern (car clause) (cadr clause))
(error "invalid syntax rule, which must be of the form (pattern template) (note fenders are not supported)" (error "invalid syntax-rules clause, which must be of the form (pattern template) (note fenders are not supported)"
clause))) clause)))
forms) forms)
(list (list
@ -1092,60 +1095,7 @@
(define-syntax syntax-rules (define-syntax syntax-rules
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let ((ellipsis-specified? (identifier? (cadr expr)))) (syntax-rules-transformer expr rename compare))))
(let ((ellipsis (if ellipsis-specified? (cadr expr) (rename '...)))
(lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
(forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr))))
(syntax-template-transformer rename compare
#f ; not id-syntax?
ellipsis ellipsis-specified?
lits forms))))))
(define-syntax identifier-syntax
(er-macro-transformer
(lambda (expr rename compare)
(let ((template (cadr expr))
(_er-macro-transformer* (rename 'er-macro-transformer*))
(_lambda (rename 'lambda)) (_expr (rename 'expr))
(_rename (rename 'rename)) (_compare (rename 'compare))
(_if (rename 'if)) (_pair? (rename 'pair?))
(_cons (rename 'cons)) (_cdr (rename 'cdr))
(_quote (rename 'syntax-quote))
(_make-variable-transformer (rename 'make-variable-transformer))
(_set! (rename 'set!)) (_o (rename 'o)))
(cond ((= (length expr) 2)
(list
_er-macro-transformer*
(list _lambda (list _expr _rename _compare)
(list _if (list _pair? _expr)
(list _cons
(list _quote template)
(list _cdr _expr))
(list _quote template)))))
(else
(let* ((ellipsis-specified? (identifier? (cadr expr)))
(ellipsis (if ellipsis-specified? (cadr expr) (rename '...)))
(forms (if ellipsis-specified? (cddr expr) (cdr expr))))
(if (not (and (= (length forms) 2)
(identifier? (caar forms))
(compare (caar (cadr forms)) _set!)
(identifier? (car (cdar (cadr forms))))))
(error "invalid identifier-syntax clauses" forms)
(list
_make-variable-transformer
(syntax-template-transformer
rename compare
#t ; id-syntax?
ellipsis ellipsis-specified?
(list ; lits, i.e. (set!)
(caar (cadr forms)))
(list ; forms
(cadr forms) ; set! form
(list ; application form
(cons (caar forms) _o)
(cons (cadr (car forms)) _o))
(car forms)) ; bare identifier form
))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; let(rec)-syntax and datum->syntax ;; let(rec)-syntax and datum->syntax