Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +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) (define (gen-output lit* pattern fender output-expr)
(let*-values (((matcher vars) (let*-values (((matcher vars)
(gen-matcher #'e lit* pattern '()))) (gen-matcher #'e lit* pattern '())))
(matcher (lambda () (matcher
#`(let-syntax #,(map (lambda (var) (lambda ()
#`(let-syntax
#,(map (lambda (var)
#`(#,(car var) #`(#,(car var)
(make-pattern-variable (syntax-quote #,(car var))))) (make-pattern-variable (syntax-quote #,(car var)))))
vars) vars)
@ -186,7 +188,8 @@
(fail))))))) (fail)))))))
(define (gen-matcher e lit* pattern vars) (define (gen-matcher e lit* pattern vars)
(cond ((pair? pattern) (cond
((pair? pattern)
(cond (cond
((and (pair? (cdr pattern)) ((and (pair? (cdr pattern))
(identifier? (cadr pattern)) (identifier? (cadr pattern))
@ -194,8 +197,10 @@
(let* ((l (length+ (cddr pattern))) (let* ((l (length+ (cddr pattern)))
(h (car (generate-temporaries '(#f)))) (h (car (generate-temporaries '(#f))))
(t (car (generate-temporaries '(#f))))) (t (car (generate-temporaries '(#f)))))
(let*-values (((head-matcher vars) (gen-map h lit* (car pattern) vars)) (let*-values (((head-matcher vars)
((tail-matcher vars) (gen-matcher* t lit* (cddr pattern) vars))) (gen-map h lit* (car pattern) vars))
((tail-matcher vars)
(gen-matcher* t lit* (cddr pattern) vars)))
(values (lambda (k) (values (lambda (k)
#`(let ((n (length+ #,e))) #`(let ((n (length+ #,e)))
(if (and n (>= n #,l)) (if (and n (>= n #,l))
@ -247,7 +252,8 @@
(let*-values (((matcher inner-vars) (gen-matcher #'g lit* pattern '()))) (let*-values (((matcher inner-vars) (gen-matcher #'g lit* pattern '())))
(let ((loop (car (generate-temporaries '(#f)))) (let ((loop (car (generate-temporaries '(#f))))
(g* (generate-temporaries inner-vars))) (g* (generate-temporaries inner-vars)))
(values (lambda (k) (values
(lambda (k)
#`(let #,loop ((#,h (reverse #,h)) #`(let #,loop ((#,h (reverse #,h))
#,@(map (lambda (g) #,@(map (lambda (g)
#`(#,g '())) #`(#,g '()))
@ -255,7 +261,8 @@
(if (null? #,h) (if (null? #,h)
#,(k) #,(k)
(let ((g (car #,h))) (let ((g (car #,h)))
#,(matcher (lambda () #,(matcher
(lambda ()
#`(#,loop (cdr #,h) #`(#,loop (cdr #,h)
#,@(map (lambda (var g) #,@(map (lambda (var g)
#`(cons #,(cadr var) #,g)) #`(cons #,(cadr var) #,g))

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

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