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

death to tabs

Browse source
This commit is contained in:
Alex Shinn 2020-07-28 15:26:42 +09:00
parent 113560aeb7
commit d593a5cb0a
13 changed files with 316 additions and 305 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
lib/chibi/syntax-case.scm
View file

@ -173,8 +173,10 @@
(define (gen-output lit* pattern fender output-expr)
(let*-values (((matcher vars)
(gen-matcher #'e lit* pattern '())))
(matcher (lambda ()
#`(let-syntax #,(map (lambda (var)
(matcher
(lambda ()
#`(let-syntax
#,(map (lambda (var)
#`(#,(car var)
(make-pattern-variable (syntax-quote #,(car var)))))
vars)
@ -186,7 +188,8 @@
(fail)))))))
(define (gen-matcher e lit* pattern vars)
(cond ((pair? pattern)
(cond
((pair? pattern)
(cond
((and (pair? (cdr pattern))
(identifier? (cadr pattern))
@ -194,8 +197,10 @@
(let* ((l (length+ (cddr pattern)))
(h (car (generate-temporaries '(#f))))
(t (car (generate-temporaries '(#f)))))
(let*-values (((head-matcher vars) (gen-map h lit* (car pattern) vars))
((tail-matcher vars) (gen-matcher* t lit* (cddr pattern) vars)))
(let*-values (((head-matcher vars)
(gen-map h lit* (car pattern) vars))
((tail-matcher vars)
(gen-matcher* t lit* (cddr pattern) vars)))
(values (lambda (k)
#`(let ((n (length+ #,e)))
(if (and n (>= n #,l))
@ -247,7 +252,8 @@
(let*-values (((matcher inner-vars) (gen-matcher #'g lit* pattern '())))
(let ((loop (car (generate-temporaries '(#f))))
(g* (generate-temporaries inner-vars)))
(values (lambda (k)
(values
(lambda (k)
#`(let #,loop ((#,h (reverse #,h))
#,@(map (lambda (g)
#`(#,g '()))
@ -255,7 +261,8 @@
(if (null? #,h)
#,(k)
(let ((g (car #,h)))
#,(matcher (lambda ()
#,(matcher
(lambda ()
#`(#,loop (cdr #,h)
#,@(map (lambda (var g)
#`(cons #,(cadr var) #,g))

12
lib/srfi/99/records/syntactic.scm
View file

@ -9,13 +9,17 @@
(name-str (id->string name))
(procs (cddr expr))
(make (car procs))
(make-name (if (eq? make #t)
(datum->syntax name
(make-name
(if (eq? make #t)
(datum->syntax
name
(string->symbol (string-append "make-" name-str)))
(if (pair? make) (car make) make)))
(pred (cadr procs))
(pred-name (if (eq? pred #t)
(datum->syntax name
(pred-name
(if (eq? pred #t)
(datum->syntax
name
(string->symbol (string-append name-str "?")))
pred))
(fields (cddr procs))