mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
death to tabs
This commit is contained in:
Alex Shinn
parent
113560aeb7
commit
d593a5cb0a
13 changed files with 316 additions and 305 deletions
|
|
@ -123,30 +123,30 @@
|
|||
(test "\"\\uD801\\uDC37\"" (json->string "𐐷"))
|
||||
(test "\"\\uD83D\\uDE10\"" (json->string "😐"))
|
||||
(test "{\"menu\":{\"id\":\"file\",\"value\":\"File\",\"popup\":{\"menuitem\":[{\"value\":\"New\",\"onclick\":\"CreateNewDoc()\"},{\"value\":\"Open\",\"onclick\":\"OpenDoc()\"},{\"value\":\"Close\",\"onclick\":\"CloseDoc()\"}]}}}"
|
||||
(json->string '((menu
|
||||
(id . "file")
|
||||
(value . "File")
|
||||
(popup
|
||||
(menuitem
|
||||
. #(((value . "New") (onclick . "CreateNewDoc()"))
|
||||
((value . "Open") (onclick . "OpenDoc()"))
|
||||
((value . "Close") (onclick . "CloseDoc()")))))))))
|
||||
(json->string '((menu
|
||||
(id . "file")
|
||||
(value . "File")
|
||||
(popup
|
||||
(menuitem
|
||||
. #(((value . "New") (onclick . "CreateNewDoc()"))
|
||||
((value . "Open") (onclick . "OpenDoc()"))
|
||||
((value . "Close") (onclick . "CloseDoc()")))))))))
|
||||
(test "{\"glossary\":{\"title\":\"example glossary\",\"GlossDiv\":{\"title\":\"S\",\"GlossList\":{\"GlossEntry\":{\"ID\":\"SGML\",\"SortAs\":\"SGML\",\"GlossTerm\":\"Standard Generalized Markup Language\",\"Acronym\":\"SGML\",\"Abbrev\":\"ISO 8879:1986\",\"GlossDef\":{\"para\":\"A meta-markup language, used to create markup languages such as DocBook.\",\"GlossSeeAlso\":[\"GML\",\"XML\"]},\"GlossSee\":\"markup\"}}}}}"
|
||||
(json->string '((glossary
|
||||
(title . "example glossary")
|
||||
(GlossDiv
|
||||
(title . "S")
|
||||
(GlossList
|
||||
(GlossEntry
|
||||
(ID . "SGML")
|
||||
(SortAs . "SGML")
|
||||
(GlossTerm . "Standard Generalized Markup Language")
|
||||
(Acronym . "SGML")
|
||||
(Abbrev . "ISO 8879:1986")
|
||||
(GlossDef
|
||||
(para . "A meta-markup language, used to create markup languages such as DocBook.")
|
||||
(GlossSeeAlso . #("GML" "XML")))
|
||||
(GlossSee . "markup"))))))))
|
||||
(json->string '((glossary
|
||||
(title . "example glossary")
|
||||
(GlossDiv
|
||||
(title . "S")
|
||||
(GlossList
|
||||
(GlossEntry
|
||||
(ID . "SGML")
|
||||
(SortAs . "SGML")
|
||||
(GlossTerm . "Standard Generalized Markup Language")
|
||||
(Acronym . "SGML")
|
||||
(Abbrev . "ISO 8879:1986")
|
||||
(GlossDef
|
||||
(para . "A meta-markup language, used to create markup languages such as DocBook.")
|
||||
(GlossSeeAlso . #("GML" "XML")))
|
||||
(GlossSee . "markup"))))))))
|
||||
(test-end)
|
||||
(test-end)
|
||||
)))
|
||||
|
|
|
|||
|
|
@ -1312,13 +1312,13 @@
|
|||
|
||||
(define (get-chicken-repo-path)
|
||||
(let ((release (string-trim (process->string '(csi -release))
|
||||
char-whitespace?)))
|
||||
char-whitespace?)))
|
||||
(string-trim
|
||||
(if (string-prefix? "4." release)
|
||||
(process->string '(csi -p "(repository-path)"))
|
||||
(process->string
|
||||
'(csi -R chicken.platform -p "(car (repository-path))")))
|
||||
char-whitespace?)))
|
||||
(if (string-prefix? "4." release)
|
||||
(process->string '(csi -p "(repository-path)"))
|
||||
(process->string
|
||||
'(csi -R chicken.platform -p "(car (repository-path))")))
|
||||
char-whitespace?)))
|
||||
|
||||
(define (get-install-dirs impl cfg)
|
||||
(define (guile-eval expr)
|
||||
|
|
|
|||
|
|
@ -13,9 +13,9 @@
|
|||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((id (cadr expr))
|
||||
(binding (cddr expr)))
|
||||
(binding (cddr expr)))
|
||||
(let ((mac (cdr (env-cell (current-usage-environment) id))))
|
||||
(macro-aux-set! mac binding))
|
||||
(macro-aux-set! mac binding))
|
||||
`(,(rename 'begin))))))
|
||||
|
||||
(define (make-pattern-variable pvar)
|
||||
|
|
@ -34,9 +34,9 @@
|
|||
|
||||
(define (ellipsis-identifier? id)
|
||||
(let* ((cell (env-cell (current-usage-environment) current-ellipsis-id))
|
||||
(ellipsis (if cell
|
||||
(macro-aux (cdr cell))
|
||||
(rename '...))))
|
||||
(ellipsis (if cell
|
||||
(macro-aux (cdr cell))
|
||||
(rename '...))))
|
||||
(free-identifier=? id ellipsis)))
|
||||
|
||||
(define bound-identifier=?
|
||||
|
|
@ -47,7 +47,7 @@
|
|||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let*-values (((out envs)
|
||||
(gen-template (cadr expr) '() ellipsis-identifier? level)))
|
||||
(gen-template (cadr expr) '() ellipsis-identifier? level)))
|
||||
out))))
|
||||
|
||||
(define (syntax->datum stx)
|
||||
|
|
@ -63,68 +63,68 @@
|
|||
((pair? tmpl)
|
||||
(cond
|
||||
((and (identifier? (car tmpl))
|
||||
(free-identifier=? (car tmpl) (rename 'unsyntax)))
|
||||
(free-identifier=? (car tmpl) (rename 'unsyntax)))
|
||||
(if (and level (zero? level))
|
||||
(values (cadr tmpl) envs)
|
||||
(let*-values (((out envs) (gen-template (cadr tmpl) envs ell? (and level (- level 1)))))
|
||||
(values `(,(rename 'list) ,(gen-data (car tmpl)) ,out) envs))))
|
||||
(values (cadr tmpl) envs)
|
||||
(let*-values (((out envs) (gen-template (cadr tmpl) envs ell? (and level (- level 1)))))
|
||||
(values `(,(rename 'list) ,(gen-data (car tmpl)) ,out) envs))))
|
||||
((and (identifier? (car tmpl))
|
||||
(free-identifier=? (car tmpl) (rename 'quasisyntax)))
|
||||
(free-identifier=? (car tmpl) (rename 'quasisyntax)))
|
||||
(let*-values (((out envs) (gen-template (cadr tmpl) envs ell? (and level (+ level 1)))))
|
||||
(values `(,(rename 'list) ,(gen-data (car tmpl)) ,out) envs)))
|
||||
(values `(,(rename 'list) ,(gen-data (car tmpl)) ,out) envs)))
|
||||
((and (pair? (car tmpl))
|
||||
(free-identifier=? (caar tmpl) (rename 'unsyntax)))
|
||||
(free-identifier=? (caar tmpl) (rename 'unsyntax)))
|
||||
(if (and level (zero? level))
|
||||
(let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'cons*) ,@(cdar tmpl) ,out) envs))
|
||||
(let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1))))
|
||||
((out2 envs) (gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1)
|
||||
,out2) envs))))
|
||||
(let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'cons*) ,@(cdar tmpl) ,out) envs))
|
||||
(let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1))))
|
||||
((out2 envs) (gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1)
|
||||
,out2) envs))))
|
||||
((and (pair? (car tmpl))
|
||||
(free-identifier=? (caar tmpl) (rename 'unsyntax-splicing)))
|
||||
(free-identifier=? (caar tmpl) (rename 'unsyntax-splicing)))
|
||||
(if (and level (zero? level))
|
||||
(let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'append) ,@(cdar tmpl) ,out) envs))
|
||||
(let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1))))
|
||||
((out2 envs) (gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1)
|
||||
,out2) envs))))
|
||||
(let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'append) ,@(cdar tmpl) ,out) envs))
|
||||
(let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1))))
|
||||
((out2 envs) (gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1)
|
||||
,out2) envs))))
|
||||
((and (identifier? (car tmpl))
|
||||
(ell? (car tmpl)))
|
||||
(ell? (car tmpl)))
|
||||
(gen-template (cadr tmpl) envs (lambda (id) #f) level))
|
||||
((and (pair? (cdr tmpl))
|
||||
(identifier? (cadr tmpl))
|
||||
(ell? (cadr tmpl)))
|
||||
(identifier? (cadr tmpl))
|
||||
(ell? (cadr tmpl)))
|
||||
(let*-values (((out* envs)
|
||||
(gen-template (cddr tmpl) envs ell? level))
|
||||
((out envs)
|
||||
(gen-template (car tmpl) (cons '() envs) ell? level)))
|
||||
(if (null? (car envs))
|
||||
(error "too many ellipses following syntax template" (car tmpl)))
|
||||
(values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx))
|
||||
(,(rename 'cons) ,out ,(rename 'stx)))
|
||||
,out* ,@(car envs))
|
||||
(cdr envs))))
|
||||
(gen-template (cddr tmpl) envs ell? level))
|
||||
((out envs)
|
||||
(gen-template (car tmpl) (cons '() envs) ell? level)))
|
||||
(if (null? (car envs))
|
||||
(error "too many ellipses following syntax template" (car tmpl)))
|
||||
(values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx))
|
||||
(,(rename 'cons) ,out ,(rename 'stx)))
|
||||
,out* ,@(car envs))
|
||||
(cdr envs))))
|
||||
(else
|
||||
(let*-values (((out1 envs)
|
||||
(gen-template (car tmpl) envs ell? level))
|
||||
((out2 envs)
|
||||
(gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'cons) ,out1 ,out2) envs)))))
|
||||
(gen-template (car tmpl) envs ell? level))
|
||||
((out2 envs)
|
||||
(gen-template (cdr tmpl) envs ell? level)))
|
||||
(values `(,(rename 'cons) ,out1 ,out2) envs)))))
|
||||
((vector? tmpl)
|
||||
(let*-values (((out envs)
|
||||
(gen-template (vector->list tmpl) envs ell? level)))
|
||||
(gen-template (vector->list tmpl) envs ell? level)))
|
||||
(values `(,(rename 'list->vector) ,out) envs)))
|
||||
((identifier? tmpl)
|
||||
(cond ((ell? tmpl)
|
||||
(error "misplaced ellipsis in syntax template" tmpl))
|
||||
((pattern-variable tmpl) =>
|
||||
(lambda (binding)
|
||||
(values (car binding)
|
||||
(update-envs tmpl (car binding) (cadr binding) envs))))
|
||||
(else
|
||||
(values (gen-data tmpl) envs))))
|
||||
(error "misplaced ellipsis in syntax template" tmpl))
|
||||
((pattern-variable tmpl) =>
|
||||
(lambda (binding)
|
||||
(values (car binding)
|
||||
(update-envs tmpl (car binding) (cadr binding) envs))))
|
||||
(else
|
||||
(values (gen-data tmpl) envs))))
|
||||
(else
|
||||
(values `(,(rename 'quote) ,tmpl) envs))))
|
||||
|
||||
|
|
@ -135,35 +135,35 @@
|
|||
(define (update-envs id x level envs)
|
||||
(let loop ((level level) (envs envs))
|
||||
(cond ((zero? level)
|
||||
envs)
|
||||
((null? envs)
|
||||
(error "too few ellipses following syntax template" id))
|
||||
(else
|
||||
(let ((outer-envs (loop (- level 1) (cdr envs))))
|
||||
(cond ((member x (car envs) bound-identifier=?)
|
||||
envs)
|
||||
(else
|
||||
(cons (cons x (car envs))
|
||||
outer-envs))))))))
|
||||
envs)
|
||||
((null? envs)
|
||||
(error "too few ellipses following syntax template" id))
|
||||
(else
|
||||
(let ((outer-envs (loop (- level 1) (cdr envs))))
|
||||
(cond ((member x (car envs) bound-identifier=?)
|
||||
envs)
|
||||
(else
|
||||
(cons (cons x (car envs))
|
||||
outer-envs))))))))
|
||||
|
||||
(define-syntax syntax-case
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((expr (cadr expr))
|
||||
(lit* (car (cddr expr)))
|
||||
(clause* (reverse (cdr (cddr expr))))
|
||||
(error #'(error "syntax error" e)))
|
||||
(lit* (car (cddr expr)))
|
||||
(clause* (reverse (cdr (cddr expr))))
|
||||
(error #'(error "syntax error" e)))
|
||||
#`(let ((e #,expr))
|
||||
#,(if (null? clause*)
|
||||
error
|
||||
#`(let ((fail (lambda () #,error)))
|
||||
#,(let loop ((clause (car clause*))
|
||||
(clause* (cdr clause*)))
|
||||
(if (null? clause*)
|
||||
(gen-clause lit* clause)
|
||||
#`(let ((fail (lambda ()
|
||||
#,(gen-clause lit* clause))))
|
||||
#,(loop (car clause*) (cdr clause*))))))))))))
|
||||
#,(if (null? clause*)
|
||||
error
|
||||
#`(let ((fail (lambda () #,error)))
|
||||
#,(let loop ((clause (car clause*))
|
||||
(clause* (cdr clause*)))
|
||||
(if (null? clause*)
|
||||
(gen-clause lit* clause)
|
||||
#`(let ((fail (lambda ()
|
||||
#,(gen-clause lit* clause))))
|
||||
#,(loop (car clause*) (cdr clause*))))))))))))
|
||||
|
||||
(define (gen-clause lit* clause)
|
||||
(if (= 3 (length clause))
|
||||
|
|
@ -172,121 +172,128 @@
|
|||
|
||||
(define (gen-output lit* pattern fender output-expr)
|
||||
(let*-values (((matcher vars)
|
||||
(gen-matcher #'e lit* pattern '())))
|
||||
(matcher (lambda ()
|
||||
#`(let-syntax #,(map (lambda (var)
|
||||
#`(#,(car var)
|
||||
(make-pattern-variable (syntax-quote #,(car var)))))
|
||||
vars)
|
||||
#,@(map (lambda (var)
|
||||
#`(define-pattern-variable . #,var))
|
||||
vars)
|
||||
(if #,fender
|
||||
#,output-expr
|
||||
(fail)))))))
|
||||
(gen-matcher #'e lit* pattern '())))
|
||||
(matcher
|
||||
(lambda ()
|
||||
#`(let-syntax
|
||||
#,(map (lambda (var)
|
||||
#`(#,(car var)
|
||||
(make-pattern-variable (syntax-quote #,(car var)))))
|
||||
vars)
|
||||
#,@(map (lambda (var)
|
||||
#`(define-pattern-variable . #,var))
|
||||
vars)
|
||||
(if #,fender
|
||||
#,output-expr
|
||||
(fail)))))))
|
||||
|
||||
(define (gen-matcher e lit* pattern vars)
|
||||
(cond ((pair? pattern)
|
||||
(cond
|
||||
((and (pair? (cdr pattern))
|
||||
(identifier? (cadr pattern))
|
||||
(ellipsis-identifier? (cadr pattern)))
|
||||
(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)))
|
||||
(values (lambda (k)
|
||||
#`(let ((n (length+ #,e)))
|
||||
(if (and n (>= n #,l))
|
||||
(let*-values (((#,h #,t) (split-at #,e (- n #,l))))
|
||||
#,(head-matcher (lambda ()
|
||||
(tail-matcher k))))
|
||||
(fail))))
|
||||
vars))))
|
||||
(else
|
||||
(let ((e1 (car (generate-temporaries '(#f))))
|
||||
(e2 (car (generate-temporaries '(#f)))))
|
||||
(let*-values (((car-matcher vars)
|
||||
(gen-matcher e1 lit* (car pattern) vars))
|
||||
((cdr-matcher vars)
|
||||
(gen-matcher e2 lit* (cdr pattern) vars)))
|
||||
(values (lambda (k)
|
||||
#`(if (pair? #,e)
|
||||
(let ((#,e1 (car #,e))
|
||||
(#,e2 (cdr #,e)))
|
||||
#,(car-matcher (lambda ()
|
||||
(cdr-matcher k))))
|
||||
(fail)))
|
||||
vars))))))
|
||||
((identifier? pattern)
|
||||
(cond ((member pattern lit* free-identifier=?)
|
||||
(values (lambda (k)
|
||||
#`(if (free-identifier=? #'#,pattern #,e)
|
||||
#,(k)
|
||||
(fail)))
|
||||
vars))
|
||||
((ellipsis-identifier? pattern)
|
||||
(error "misplaced ellipsis" pattern))
|
||||
((free-identifier=? pattern #'_)
|
||||
(values (lambda (k)
|
||||
(k))
|
||||
vars))
|
||||
(else
|
||||
(values (lambda (k)
|
||||
(k))
|
||||
(alist-cons pattern (list e 0) vars)))))
|
||||
(else
|
||||
(values (lambda (k)
|
||||
#`(if (equal? (syntax->datum #,e) '#,pattern)
|
||||
#,(k)
|
||||
(fail)))
|
||||
vars))))
|
||||
(cond
|
||||
((pair? pattern)
|
||||
(cond
|
||||
((and (pair? (cdr pattern))
|
||||
(identifier? (cadr pattern))
|
||||
(ellipsis-identifier? (cadr pattern)))
|
||||
(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)))
|
||||
(values (lambda (k)
|
||||
#`(let ((n (length+ #,e)))
|
||||
(if (and n (>= n #,l))
|
||||
(let*-values (((#,h #,t) (split-at #,e (- n #,l))))
|
||||
#,(head-matcher (lambda ()
|
||||
(tail-matcher k))))
|
||||
(fail))))
|
||||
vars))))
|
||||
(else
|
||||
(let ((e1 (car (generate-temporaries '(#f))))
|
||||
(e2 (car (generate-temporaries '(#f)))))
|
||||
(let*-values (((car-matcher vars)
|
||||
(gen-matcher e1 lit* (car pattern) vars))
|
||||
((cdr-matcher vars)
|
||||
(gen-matcher e2 lit* (cdr pattern) vars)))
|
||||
(values (lambda (k)
|
||||
#`(if (pair? #,e)
|
||||
(let ((#,e1 (car #,e))
|
||||
(#,e2 (cdr #,e)))
|
||||
#,(car-matcher (lambda ()
|
||||
(cdr-matcher k))))
|
||||
(fail)))
|
||||
vars))))))
|
||||
((identifier? pattern)
|
||||
(cond ((member pattern lit* free-identifier=?)
|
||||
(values (lambda (k)
|
||||
#`(if (free-identifier=? #'#,pattern #,e)
|
||||
#,(k)
|
||||
(fail)))
|
||||
vars))
|
||||
((ellipsis-identifier? pattern)
|
||||
(error "misplaced ellipsis" pattern))
|
||||
((free-identifier=? pattern #'_)
|
||||
(values (lambda (k)
|
||||
(k))
|
||||
vars))
|
||||
(else
|
||||
(values (lambda (k)
|
||||
(k))
|
||||
(alist-cons pattern (list e 0) vars)))))
|
||||
(else
|
||||
(values (lambda (k)
|
||||
#`(if (equal? (syntax->datum #,e) '#,pattern)
|
||||
#,(k)
|
||||
(fail)))
|
||||
vars))))
|
||||
|
||||
(define (gen-map h lit* pattern vars)
|
||||
(let*-values (((matcher inner-vars) (gen-matcher #'g lit* pattern '())))
|
||||
(let ((loop (car (generate-temporaries '(#f))))
|
||||
(g* (generate-temporaries inner-vars)))
|
||||
(values (lambda (k)
|
||||
#`(let #,loop ((#,h (reverse #,h))
|
||||
#,@(map (lambda (g)
|
||||
#`(#,g '()))
|
||||
g*))
|
||||
(if (null? #,h)
|
||||
#,(k)
|
||||
(let ((g (car #,h)))
|
||||
#,(matcher (lambda ()
|
||||
#`(#,loop (cdr #,h)
|
||||
#,@(map (lambda (var g)
|
||||
#`(cons #,(cadr var) #,g))
|
||||
inner-vars g*))))))))
|
||||
(fold (lambda (g var vars)
|
||||
(alist-cons (car var) (list g (+ (cadr (cdr var)) 1)) vars))
|
||||
vars g* inner-vars)))))
|
||||
(g* (generate-temporaries inner-vars)))
|
||||
(values
|
||||
(lambda (k)
|
||||
#`(let #,loop ((#,h (reverse #,h))
|
||||
#,@(map (lambda (g)
|
||||
#`(#,g '()))
|
||||
g*))
|
||||
(if (null? #,h)
|
||||
#,(k)
|
||||
(let ((g (car #,h)))
|
||||
#,(matcher
|
||||
(lambda ()
|
||||
#`(#,loop (cdr #,h)
|
||||
#,@(map (lambda (var g)
|
||||
#`(cons #,(cadr var) #,g))
|
||||
inner-vars g*))))))))
|
||||
(fold (lambda (g var vars)
|
||||
(alist-cons (car var) (list g (+ (cadr (cdr var)) 1)) vars))
|
||||
vars g* inner-vars)))))
|
||||
|
||||
(define (gen-matcher* e lit* pattern* vars)
|
||||
(let loop ((e e) (pattern* pattern*) (vars vars))
|
||||
(cond ((null? pattern*)
|
||||
(values (lambda (k)
|
||||
#`(if (null? #,e)
|
||||
#,(k)
|
||||
(fail)))
|
||||
vars))
|
||||
((pair? pattern*)
|
||||
(let ((e1 (car (generate-temporaries '(#f))))
|
||||
(e2 (car (generate-temporaries '(#f)))))
|
||||
(let*-values (((car-matcher vars)
|
||||
(gen-matcher e1 lit* (car pattern*) vars))
|
||||
((cdr-matcher vars)
|
||||
(loop e2 (cdr pattern*) vars)))
|
||||
(values (lambda (k)
|
||||
#`(let ((#,e1 (car #,e))
|
||||
(#,e2 (cdr #,e)))
|
||||
#,(car-matcher (lambda ()
|
||||
(cdr-matcher k)))))
|
||||
vars))))
|
||||
(else
|
||||
(gen-matcher e lit* pattern* vars)))))
|
||||
(values (lambda (k)
|
||||
#`(if (null? #,e)
|
||||
#,(k)
|
||||
(fail)))
|
||||
vars))
|
||||
((pair? pattern*)
|
||||
(let ((e1 (car (generate-temporaries '(#f))))
|
||||
(e2 (car (generate-temporaries '(#f)))))
|
||||
(let*-values (((car-matcher vars)
|
||||
(gen-matcher e1 lit* (car pattern*) vars))
|
||||
((cdr-matcher vars)
|
||||
(loop e2 (cdr pattern*) vars)))
|
||||
(values (lambda (k)
|
||||
#`(let ((#,e1 (car #,e))
|
||||
(#,e2 (cdr #,e)))
|
||||
#,(car-matcher (lambda ()
|
||||
(cdr-matcher k)))))
|
||||
vars))))
|
||||
(else
|
||||
(gen-matcher e lit* pattern* vars)))))
|
||||
|
||||
(define (make-synthetic-identifier id)
|
||||
(close-syntax id (environment)))
|
||||
|
|
@ -299,7 +306,7 @@
|
|||
(syntax-case x ()
|
||||
((_ ((p e0) ...) e1 e2 ...)
|
||||
#'(syntax-case (list e0 ...) ()
|
||||
((p ...) (let () e1 e2 ...)))))))
|
||||
((p ...) (let () e1 e2 ...)))))))
|
||||
|
||||
(define (syntax-violation who message . form*)
|
||||
(apply error message form*))
|
||||
|
|
@ -309,7 +316,7 @@
|
|||
(syntax-case stx ()
|
||||
((_ ellipsis)
|
||||
(let ((mac (cdr (env-cell (current-usage-environment) current-ellipsis-id))))
|
||||
(macro-aux-set! mac #'ellipsis))
|
||||
(macro-aux-set! mac #'ellipsis))
|
||||
#'(begin)))))
|
||||
|
||||
(define-syntax with-ellipsis
|
||||
|
|
@ -317,6 +324,6 @@
|
|||
(syntax-case stx ()
|
||||
((_ ellipsis . body)
|
||||
(with-syntax ((current-ellipsis current-ellipsis-id))
|
||||
#'(let-syntax ((current-ellipsis (syntax-rules ())))
|
||||
(define-current-ellipsis ellipsis)
|
||||
. body))))))
|
||||
#'(let-syntax ((current-ellipsis (syntax-rules ())))
|
||||
(define-current-ellipsis ellipsis)
|
||||
. body))))))
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
(define-library (chibi syntax-case)
|
||||
(export ... _ free-identifier=? bound-identifier=? identifier?
|
||||
syntax-case syntax quasisyntax unsyntax unsyntax-splicing
|
||||
datum->syntax syntax->datum
|
||||
generate-temporaries with-syntax syntax-violation
|
||||
with-ellipsis ellipsis-identifier?)
|
||||
syntax-case syntax quasisyntax unsyntax unsyntax-splicing
|
||||
datum->syntax syntax->datum
|
||||
generate-temporaries with-syntax syntax-violation
|
||||
with-ellipsis ellipsis-identifier?)
|
||||
(import (chibi)
|
||||
(chibi ast)
|
||||
(meta)
|
||||
(srfi 1)
|
||||
(srfi 11))
|
||||
(chibi ast)
|
||||
(meta)
|
||||
(srfi 1)
|
||||
(srfi 11))
|
||||
(include "syntax-case.scm"))
|
||||
|
|
|
|||
|
|
@ -19,9 +19,9 @@
|
|||
(body
|
||||
(define (user-information user)
|
||||
(car (if (string? user)
|
||||
(getpwnam_r user (make-string 1024))
|
||||
(getpwuid_r user (make-string 1024)))))
|
||||
(getpwnam_r user (make-string 1024))
|
||||
(getpwuid_r user (make-string 1024)))))
|
||||
(define (group-information group)
|
||||
(car (if (string? group)
|
||||
(getgrnam_r group (make-string 1024))
|
||||
(getgrgid_r group (make-string 1024)))))))))
|
||||
(getgrnam_r group (make-string 1024))
|
||||
(getgrgid_r group (make-string 1024)))))))))
|
||||
|
|
|
|||
|
|
@ -113,17 +113,17 @@
|
|||
(define rename
|
||||
((lambda (renames)
|
||||
(lambda (identifier)
|
||||
((lambda (cell)
|
||||
(if cell
|
||||
(cdr cell)
|
||||
((lambda (name)
|
||||
(set! renames (cons (cons identifier name) renames))
|
||||
name)
|
||||
((lambda (cell)
|
||||
(if cell
|
||||
(cdr cell)
|
||||
((lambda (name)
|
||||
(set! renames (cons (cons identifier name) renames))
|
||||
name)
|
||||
((lambda (id)
|
||||
(syntactic-closure-set-rename! id rename)
|
||||
id)
|
||||
(close-syntax identifier mac-env)))))
|
||||
(assq identifier renames))))
|
||||
(close-syntax identifier mac-env)))))
|
||||
(assq identifier renames))))
|
||||
'()))
|
||||
rename))
|
||||
|
||||
|
|
@ -131,15 +131,15 @@
|
|||
(lambda (transformer)
|
||||
(lambda (expr use-env mac-env)
|
||||
((lambda (old-use-env old-mac-env old-renamer)
|
||||
(current-usage-environment use-env)
|
||||
(current-transformer-environment mac-env)
|
||||
(current-renamer (make-renamer mac-env))
|
||||
((lambda (result)
|
||||
(current-usage-environment old-use-env)
|
||||
(current-transformer-environment old-mac-env)
|
||||
(current-renamer old-renamer)
|
||||
result)
|
||||
(transformer expr)))
|
||||
(current-usage-environment use-env)
|
||||
(current-transformer-environment mac-env)
|
||||
(current-renamer (make-renamer mac-env))
|
||||
((lambda (result)
|
||||
(current-usage-environment old-use-env)
|
||||
(current-transformer-environment old-mac-env)
|
||||
(current-renamer old-renamer)
|
||||
result)
|
||||
(transformer expr)))
|
||||
(current-usage-environment)
|
||||
(current-transformer-environment)
|
||||
(current-renamer)))))
|
||||
|
|
@ -147,15 +147,15 @@
|
|||
(%define-syntax define-syntax
|
||||
(lambda (expr use-env mac-env)
|
||||
(list (close-syntax '%define-syntax mac-env)
|
||||
(cadr expr)
|
||||
(list (close-syntax 'make-transformer mac-env)
|
||||
(car (cddr expr))))))
|
||||
(cadr expr)
|
||||
(list (close-syntax 'make-transformer mac-env)
|
||||
(car (cddr expr))))))
|
||||
|
||||
(define free-identifier=?
|
||||
(lambda (x y)
|
||||
((lambda (use-env cur-env)
|
||||
(identifier=? (if use-env use-env cur-env) x
|
||||
(if use-env use-env cur-env) y))
|
||||
(if use-env use-env cur-env) y))
|
||||
(current-usage-environment)
|
||||
(current-environment))))
|
||||
|
||||
|
|
@ -163,7 +163,7 @@
|
|||
(lambda (f)
|
||||
(lambda (expr)
|
||||
(close-syntax (f expr (current-usage-environment))
|
||||
(current-transformer-environment)))))
|
||||
(current-transformer-environment)))))
|
||||
|
||||
(define rsc-macro-transformer
|
||||
(lambda (f)
|
||||
|
|
@ -800,11 +800,11 @@
|
|||
(define (%point-out point) (vector-ref point 2))
|
||||
(define (%point-parent point) (vector-ref point 3))
|
||||
|
||||
(define root-point ; Shared among all state spaces
|
||||
(define root-point ; Shared among all state spaces
|
||||
(%make-point 0
|
||||
(lambda () (error "winding in to root!"))
|
||||
(lambda () (error "winding out of root!"))
|
||||
#f))
|
||||
(lambda () (error "winding in to root!"))
|
||||
(lambda () (error "winding out of root!"))
|
||||
#f))
|
||||
|
||||
(cond-expand
|
||||
(threads)
|
||||
|
|
@ -1129,7 +1129,7 @@
|
|||
symbol)
|
||||
((syntactic-closure-rename id)
|
||||
=> (lambda (renamer)
|
||||
(renamer symbol)))
|
||||
(renamer symbol)))
|
||||
(else
|
||||
symbol)))
|
||||
|
||||
|
|
@ -1137,17 +1137,17 @@
|
|||
(define (datum->syntax id datum)
|
||||
(let loop ((datum datum))
|
||||
(cond ((pair? datum)
|
||||
(cons (loop (car datum))
|
||||
(loop (cdr datum))))
|
||||
((vector? datum)
|
||||
(do ((res (make-vector (vector-length datum)))
|
||||
(i 0 (+ i 1)))
|
||||
((= i (vector-length datum)) res)
|
||||
(vector-set! res i (loop (vector-ref datum i)))))
|
||||
((symbol? datum)
|
||||
(symbol->identifier id datum))
|
||||
(else
|
||||
datum))))
|
||||
(cons (loop (car datum))
|
||||
(loop (cdr datum))))
|
||||
((vector? datum)
|
||||
(do ((res (make-vector (vector-length datum)))
|
||||
(i 0 (+ i 1)))
|
||||
((= i (vector-length datum)) res)
|
||||
(vector-set! res i (loop (vector-ref datum i)))))
|
||||
((symbol? datum)
|
||||
(symbol->identifier id datum))
|
||||
(else
|
||||
datum))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; additional syntax
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
(define-syntax let-values
|
||||
(syntax-rules ()
|
||||
((let-values () . body)
|
||||
(let () . body))
|
||||
(let () . body))
|
||||
((let-values ("step") (binds ...) bind expr maps () () . body)
|
||||
(let*-values (binds ... (bind expr)) (let maps . body)))
|
||||
((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body)
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@
|
|||
(comparator-min-in-list comp args))
|
||||
|
||||
#;
|
||||
(define default-comparator ;Defined in comparators.scm
|
||||
(define default-comparator ;Defined in comparators.scm
|
||||
(make-default-comparator))
|
||||
|
||||
(define boolean-comparator
|
||||
|
|
|
|||
|
|
@ -274,22 +274,22 @@
|
|||
) ; end comparators/bound-salt
|
||||
|
||||
|
||||
(test-group "comparators/min-max"
|
||||
(test 5 (comparator-max real-comparator 1 5 3 2 -2))
|
||||
(test -2 (comparator-min real-comparator 1 5 3 2 -2))
|
||||
(test 5 (comparator-max-in-list real-comparator '(1 5 3 2 -2)))
|
||||
(test -2 (comparator-min-in-list real-comparator '(1 5 3 2 -2)))
|
||||
) ; end comparators/min-max
|
||||
(test-group "comparators/min-max"
|
||||
(test 5 (comparator-max real-comparator 1 5 3 2 -2))
|
||||
(test -2 (comparator-min real-comparator 1 5 3 2 -2))
|
||||
(test 5 (comparator-max-in-list real-comparator '(1 5 3 2 -2)))
|
||||
(test -2 (comparator-min-in-list real-comparator '(1 5 3 2 -2)))
|
||||
) ; end comparators/min-max
|
||||
|
||||
(test-group "comparators/variables"
|
||||
;; Most of the variables have been tested above.
|
||||
(test-assert (=? char-comparator #\C #\C))
|
||||
(test-assert (=? char-ci-comparator #\c #\C))
|
||||
(test-assert (=? string-comparator "ABC" "ABC"))
|
||||
(test-assert (=? string-ci-comparator "abc" "ABC"))
|
||||
(test-assert (=? eq-comparator 32 32))
|
||||
(test-assert (=? eqv-comparator 32 32))
|
||||
(test-assert (=? equal-comparator "ABC" "ABC"))
|
||||
) ; end comparators/variables
|
||||
(test-group "comparators/variables"
|
||||
;; Most of the variables have been tested above.
|
||||
(test-assert (=? char-comparator #\C #\C))
|
||||
(test-assert (=? char-ci-comparator #\c #\C))
|
||||
(test-assert (=? string-comparator "ABC" "ABC"))
|
||||
(test-assert (=? string-ci-comparator "abc" "ABC"))
|
||||
(test-assert (=? eq-comparator 32 32))
|
||||
(test-assert (=? eqv-comparator 32 32))
|
||||
(test-assert (=? equal-comparator "ABC" "ABC"))
|
||||
) ; end comparators/variables
|
||||
|
||||
)))) ; end comparators
|
||||
|
|
|
|||
|
|
@ -169,11 +169,11 @@
|
|||
(test #b0 (bit-field-rotate #b0 128 0 256))
|
||||
(test #b1 (bit-field-rotate #b1 128 1 256))
|
||||
(test #x100000000000000000000000000000000
|
||||
(bit-field-rotate #x100000000000000000000000000000000 128 0 64))
|
||||
(bit-field-rotate #x100000000000000000000000000000000 128 0 64))
|
||||
(test #x100000000000000000000000000000008
|
||||
(bit-field-rotate #x100000000000000000000000000000001 3 0 64))
|
||||
(bit-field-rotate #x100000000000000000000000000000001 3 0 64))
|
||||
(test #x100000000000000002000000000000000
|
||||
(bit-field-rotate #x100000000000000000000000000000001 -3 0 64))
|
||||
(bit-field-rotate #x100000000000000000000000000000001 -3 0 64))
|
||||
(test #b110 (bit-field-rotate #b110 0 0 10))
|
||||
(test #b110 (bit-field-rotate #b110 0 0 256))
|
||||
(test 1 (bit-field-rotate #x100000000000000000000000000000000 1 0 129))
|
||||
|
|
|
|||
|
|
@ -418,16 +418,16 @@
|
|||
;; generator->list
|
||||
(define generator->list
|
||||
(case-lambda ((gen n)
|
||||
(generator->list (gtake gen n)))
|
||||
(generator->list (gtake gen n)))
|
||||
((gen)
|
||||
(reverse (generator->reverse-list gen)))))
|
||||
(reverse (generator->reverse-list gen)))))
|
||||
|
||||
;; generator->reverse-list
|
||||
(define generator->reverse-list
|
||||
(case-lambda ((gen n)
|
||||
(generator->reverse-list (gtake gen n)))
|
||||
(generator->reverse-list (gtake gen n)))
|
||||
((gen)
|
||||
(generator-fold cons '() gen))))
|
||||
(generator-fold cons '() gen))))
|
||||
|
||||
;; generator->vector
|
||||
(define generator->vector
|
||||
|
|
|
|||
|
|
@ -9,15 +9,19 @@
|
|||
(name-str (id->string name))
|
||||
(procs (cddr expr))
|
||||
(make (car procs))
|
||||
(make-name (if (eq? make #t)
|
||||
(datum->syntax name
|
||||
(string->symbol (string-append "make-" name-str)))
|
||||
(if (pair? make) (car make) make)))
|
||||
(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
|
||||
(string->symbol (string-append name-str "?")))
|
||||
pred))
|
||||
(pred-name
|
||||
(if (eq? pred #t)
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol (string-append name-str "?")))
|
||||
pred))
|
||||
(fields (cddr procs))
|
||||
(field-names (map (lambda (x) (if (pair? x) (car x) x)) fields))
|
||||
(make-fields (if (pair? make) (cdr make) (and (not parent) field-names)))
|
||||
|
|
|
|||
|
|
@ -112,16 +112,16 @@
|
|||
|
||||
;;; See issue #494.
|
||||
(test-assert
|
||||
(let-syntax
|
||||
((foo
|
||||
(syntax-rules ()
|
||||
((foo)
|
||||
(let ()
|
||||
(define-record-type record
|
||||
#t
|
||||
#t)
|
||||
(record? (make-record)))))))
|
||||
(foo)))
|
||||
(let-syntax
|
||||
((foo
|
||||
(syntax-rules ()
|
||||
((foo)
|
||||
(let ()
|
||||
(define-record-type record
|
||||
#t
|
||||
#t)
|
||||
(record? (make-record)))))))
|
||||
(foo)))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(let ()
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue