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

46
lib/chibi/json-test.sld
View file

@ -123,30 +123,30 @@
(test "\"\\uD801\\uDC37\"" (json->string "𐐷")) (test "\"\\uD801\\uDC37\"" (json->string "𐐷"))
(test "\"\\uD83D\\uDE10\"" (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()\"}]}}}" (test "{\"menu\":{\"id\":\"file\",\"value\":\"File\",\"popup\":{\"menuitem\":[{\"value\":\"New\",\"onclick\":\"CreateNewDoc()\"},{\"value\":\"Open\",\"onclick\":\"OpenDoc()\"},{\"value\":\"Close\",\"onclick\":\"CloseDoc()\"}]}}}"
(json->string '((menu (json->string '((menu
(id . "file") (id . "file")
(value . "File") (value . "File")
(popup (popup
(menuitem (menuitem
. #(((value . "New") (onclick . "CreateNewDoc()")) . #(((value . "New") (onclick . "CreateNewDoc()"))
((value . "Open") (onclick . "OpenDoc()")) ((value . "Open") (onclick . "OpenDoc()"))
((value . "Close") (onclick . "CloseDoc()"))))))))) ((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\"}}}}}" (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 (json->string '((glossary
(title . "example glossary") (title . "example glossary")
(GlossDiv (GlossDiv
(title . "S") (title . "S")
(GlossList (GlossList
(GlossEntry (GlossEntry
(ID . "SGML") (ID . "SGML")
(SortAs . "SGML") (SortAs . "SGML")
(GlossTerm . "Standard Generalized Markup Language") (GlossTerm . "Standard Generalized Markup Language")
(Acronym . "SGML") (Acronym . "SGML")
(Abbrev . "ISO 8879:1986") (Abbrev . "ISO 8879:1986")
(GlossDef (GlossDef
(para . "A meta-markup language, used to create markup languages such as DocBook.") (para . "A meta-markup language, used to create markup languages such as DocBook.")
(GlossSeeAlso . #("GML" "XML"))) (GlossSeeAlso . #("GML" "XML")))
(GlossSee . "markup")))))))) (GlossSee . "markup"))))))))
(test-end) (test-end)
(test-end) (test-end)
))) )))

12
lib/chibi/snow/commands.scm
View file

@ -1312,13 +1312,13 @@
(define (get-chicken-repo-path) (define (get-chicken-repo-path)
(let ((release (string-trim (process->string '(csi -release)) (let ((release (string-trim (process->string '(csi -release))
char-whitespace?))) char-whitespace?)))
(string-trim (string-trim
(if (string-prefix? "4." release) (if (string-prefix? "4." release)
(process->string '(csi -p "(repository-path)")) (process->string '(csi -p "(repository-path)"))
(process->string (process->string
'(csi -R chicken.platform -p "(car (repository-path))"))) '(csi -R chicken.platform -p "(car (repository-path))")))
char-whitespace?))) char-whitespace?)))
(define (get-install-dirs impl cfg) (define (get-install-dirs impl cfg)
(define (guile-eval expr) (define (guile-eval expr)

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

@ -13,9 +13,9 @@
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let ((id (cadr expr)) (let ((id (cadr expr))
(binding (cddr expr))) (binding (cddr expr)))
(let ((mac (cdr (env-cell (current-usage-environment) id)))) (let ((mac (cdr (env-cell (current-usage-environment) id))))
(macro-aux-set! mac binding)) (macro-aux-set! mac binding))
`(,(rename 'begin)))))) `(,(rename 'begin))))))
(define (make-pattern-variable pvar) (define (make-pattern-variable pvar)
@ -34,9 +34,9 @@
(define (ellipsis-identifier? id) (define (ellipsis-identifier? id)
(let* ((cell (env-cell (current-usage-environment) current-ellipsis-id)) (let* ((cell (env-cell (current-usage-environment) current-ellipsis-id))
(ellipsis (if cell (ellipsis (if cell
(macro-aux (cdr cell)) (macro-aux (cdr cell))
(rename '...)))) (rename '...))))
(free-identifier=? id ellipsis))) (free-identifier=? id ellipsis)))
(define bound-identifier=? (define bound-identifier=?
@ -47,7 +47,7 @@
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let*-values (((out envs) (let*-values (((out envs)
(gen-template (cadr expr) '() ellipsis-identifier? level))) (gen-template (cadr expr) '() ellipsis-identifier? level)))
out)))) out))))
(define (syntax->datum stx) (define (syntax->datum stx)
@ -63,68 +63,68 @@
((pair? tmpl) ((pair? tmpl)
(cond (cond
((and (identifier? (car tmpl)) ((and (identifier? (car tmpl))
(free-identifier=? (car tmpl) (rename 'unsyntax))) (free-identifier=? (car tmpl) (rename 'unsyntax)))
(if (and level (zero? level)) (if (and level (zero? level))
(values (cadr tmpl) envs) (values (cadr tmpl) envs)
(let*-values (((out envs) (gen-template (cadr tmpl) envs ell? (and level (- level 1))))) (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 (identifier? (car tmpl)) ((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))))) (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)) ((and (pair? (car tmpl))
(free-identifier=? (caar tmpl) (rename 'unsyntax))) (free-identifier=? (caar tmpl) (rename 'unsyntax)))
(if (and level (zero? level)) (if (and level (zero? level))
(let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level))) (let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level)))
(values `(,(rename 'cons*) ,@(cdar tmpl) ,out) envs)) (values `(,(rename 'cons*) ,@(cdar tmpl) ,out) envs))
(let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1)))) (let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1))))
((out2 envs) (gen-template (cdr tmpl) envs ell? level))) ((out2 envs) (gen-template (cdr tmpl) envs ell? level)))
(values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1) (values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1)
,out2) envs)))) ,out2) envs))))
((and (pair? (car tmpl)) ((and (pair? (car tmpl))
(free-identifier=? (caar tmpl) (rename 'unsyntax-splicing))) (free-identifier=? (caar tmpl) (rename 'unsyntax-splicing)))
(if (and level (zero? level)) (if (and level (zero? level))
(let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level))) (let*-values (((out envs) (gen-template (cdr tmpl) envs ell? level)))
(values `(,(rename 'append) ,@(cdar tmpl) ,out) envs)) (values `(,(rename 'append) ,@(cdar tmpl) ,out) envs))
(let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1)))) (let*-values (((out1 envs) (gen-template (cdar tmpl) envs ell? (and level (- level 1))))
((out2 envs) (gen-template (cdr tmpl) envs ell? level))) ((out2 envs) (gen-template (cdr tmpl) envs ell? level)))
(values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1) (values `(,(rename 'cons) (,(rename 'cons) ,(gen-data (caar tmpl)) ,out1)
,out2) envs)))) ,out2) envs))))
((and (identifier? (car tmpl)) ((and (identifier? (car tmpl))
(ell? (car tmpl))) (ell? (car tmpl)))
(gen-template (cadr tmpl) envs (lambda (id) #f) level)) (gen-template (cadr tmpl) envs (lambda (id) #f) level))
((and (pair? (cdr tmpl)) ((and (pair? (cdr tmpl))
(identifier? (cadr tmpl)) (identifier? (cadr tmpl))
(ell? (cadr tmpl))) (ell? (cadr tmpl)))
(let*-values (((out* envs) (let*-values (((out* envs)
(gen-template (cddr tmpl) envs ell? level)) (gen-template (cddr tmpl) envs ell? level))
((out envs) ((out envs)
(gen-template (car tmpl) (cons '() envs) ell? level))) (gen-template (car tmpl) (cons '() envs) ell? level)))
(if (null? (car envs)) (if (null? (car envs))
(error "too many ellipses following syntax template" (car tmpl))) (error "too many ellipses following syntax template" (car tmpl)))
(values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx)) (values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx))
(,(rename 'cons) ,out ,(rename 'stx))) (,(rename 'cons) ,out ,(rename 'stx)))
,out* ,@(car envs)) ,out* ,@(car envs))
(cdr envs)))) (cdr envs))))
(else (else
(let*-values (((out1 envs) (let*-values (((out1 envs)
(gen-template (car tmpl) envs ell? level)) (gen-template (car tmpl) envs ell? level))
((out2 envs) ((out2 envs)
(gen-template (cdr tmpl) envs ell? level))) (gen-template (cdr tmpl) envs ell? level)))
(values `(,(rename 'cons) ,out1 ,out2) envs))))) (values `(,(rename 'cons) ,out1 ,out2) envs)))))
((vector? tmpl) ((vector? tmpl)
(let*-values (((out envs) (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))) (values `(,(rename 'list->vector) ,out) envs)))
((identifier? tmpl) ((identifier? tmpl)
(cond ((ell? tmpl) (cond ((ell? tmpl)
(error "misplaced ellipsis in syntax template" tmpl)) (error "misplaced ellipsis in syntax template" tmpl))
((pattern-variable tmpl) => ((pattern-variable tmpl) =>
(lambda (binding) (lambda (binding)
(values (car binding) (values (car binding)
(update-envs tmpl (car binding) (cadr binding) envs)))) (update-envs tmpl (car binding) (cadr binding) envs))))
(else (else
(values (gen-data tmpl) envs)))) (values (gen-data tmpl) envs))))
(else (else
(values `(,(rename 'quote) ,tmpl) envs)))) (values `(,(rename 'quote) ,tmpl) envs))))
@ -135,35 +135,35 @@
(define (update-envs id x level envs) (define (update-envs id x level envs)
(let loop ((level level) (envs envs)) (let loop ((level level) (envs envs))
(cond ((zero? level) (cond ((zero? level)
envs) envs)
((null? envs) ((null? envs)
(error "too few ellipses following syntax template" id)) (error "too few ellipses following syntax template" id))
(else (else
(let ((outer-envs (loop (- level 1) (cdr envs)))) (let ((outer-envs (loop (- level 1) (cdr envs))))
(cond ((member x (car envs) bound-identifier=?) (cond ((member x (car envs) bound-identifier=?)
envs) envs)
(else (else
(cons (cons x (car envs)) (cons (cons x (car envs))
outer-envs)))))))) outer-envs))))))))
(define-syntax syntax-case (define-syntax syntax-case
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let ((expr (cadr expr)) (let ((expr (cadr expr))
(lit* (car (cddr expr))) (lit* (car (cddr expr)))
(clause* (reverse (cdr (cddr expr)))) (clause* (reverse (cdr (cddr expr))))
(error #'(error "syntax error" e))) (error #'(error "syntax error" e)))
#`(let ((e #,expr)) #`(let ((e #,expr))
#,(if (null? clause*) #,(if (null? clause*)
error error
#`(let ((fail (lambda () #,error))) #`(let ((fail (lambda () #,error)))
#,(let loop ((clause (car clause*)) #,(let loop ((clause (car clause*))
(clause* (cdr clause*))) (clause* (cdr clause*)))
(if (null? clause*) (if (null? clause*)
(gen-clause lit* clause) (gen-clause lit* clause)
#`(let ((fail (lambda () #`(let ((fail (lambda ()
#,(gen-clause lit* clause)))) #,(gen-clause lit* clause))))
#,(loop (car clause*) (cdr clause*)))))))))))) #,(loop (car clause*) (cdr clause*))))))))))))
(define (gen-clause lit* clause) (define (gen-clause lit* clause)
(if (= 3 (length clause)) (if (= 3 (length clause))
@ -172,121 +172,128 @@
(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 ()
#`(#,(car var) #`(let-syntax
(make-pattern-variable (syntax-quote #,(car var))))) #,(map (lambda (var)
vars) #`(#,(car var)
#,@(map (lambda (var) (make-pattern-variable (syntax-quote #,(car var)))))
#`(define-pattern-variable . #,var)) vars)
vars) #,@(map (lambda (var)
(if #,fender #`(define-pattern-variable . #,var))
#,output-expr vars)
(fail))))))) (if #,fender
#,output-expr
(fail)))))))
(define (gen-matcher e lit* pattern vars) (define (gen-matcher e lit* pattern vars)
(cond ((pair? pattern) (cond
(cond ((pair? pattern)
((and (pair? (cdr pattern)) (cond
(identifier? (cadr pattern)) ((and (pair? (cdr pattern))
(ellipsis-identifier? (cadr pattern))) (identifier? (cadr pattern))
(let* ((l (length+ (cddr pattern))) (ellipsis-identifier? (cadr pattern)))
(h (car (generate-temporaries '(#f)))) (let* ((l (length+ (cddr pattern)))
(t (car (generate-temporaries '(#f))))) (h (car (generate-temporaries '(#f))))
(let*-values (((head-matcher vars) (gen-map h lit* (car pattern) vars)) (t (car (generate-temporaries '(#f)))))
((tail-matcher vars) (gen-matcher* t lit* (cddr pattern) vars))) (let*-values (((head-matcher vars)
(values (lambda (k) (gen-map h lit* (car pattern) vars))
#`(let ((n (length+ #,e))) ((tail-matcher vars)
(if (and n (>= n #,l)) (gen-matcher* t lit* (cddr pattern) vars)))
(let*-values (((#,h #,t) (split-at #,e (- n #,l)))) (values (lambda (k)
#,(head-matcher (lambda () #`(let ((n (length+ #,e)))
(tail-matcher k)))) (if (and n (>= n #,l))
(fail)))) (let*-values (((#,h #,t) (split-at #,e (- n #,l))))
vars)))) #,(head-matcher (lambda ()
(else (tail-matcher k))))
(let ((e1 (car (generate-temporaries '(#f)))) (fail))))
(e2 (car (generate-temporaries '(#f))))) vars))))
(let*-values (((car-matcher vars) (else
(gen-matcher e1 lit* (car pattern) vars)) (let ((e1 (car (generate-temporaries '(#f))))
((cdr-matcher vars) (e2 (car (generate-temporaries '(#f)))))
(gen-matcher e2 lit* (cdr pattern) vars))) (let*-values (((car-matcher vars)
(values (lambda (k) (gen-matcher e1 lit* (car pattern) vars))
#`(if (pair? #,e) ((cdr-matcher vars)
(let ((#,e1 (car #,e)) (gen-matcher e2 lit* (cdr pattern) vars)))
(#,e2 (cdr #,e))) (values (lambda (k)
#,(car-matcher (lambda () #`(if (pair? #,e)
(cdr-matcher k)))) (let ((#,e1 (car #,e))
(fail))) (#,e2 (cdr #,e)))
vars)))))) #,(car-matcher (lambda ()
((identifier? pattern) (cdr-matcher k))))
(cond ((member pattern lit* free-identifier=?) (fail)))
(values (lambda (k) vars))))))
#`(if (free-identifier=? #'#,pattern #,e) ((identifier? pattern)
#,(k) (cond ((member pattern lit* free-identifier=?)
(fail))) (values (lambda (k)
vars)) #`(if (free-identifier=? #'#,pattern #,e)
((ellipsis-identifier? pattern) #,(k)
(error "misplaced ellipsis" pattern)) (fail)))
((free-identifier=? pattern #'_) vars))
(values (lambda (k) ((ellipsis-identifier? pattern)
(k)) (error "misplaced ellipsis" pattern))
vars)) ((free-identifier=? pattern #'_)
(else (values (lambda (k)
(values (lambda (k) (k))
(k)) vars))
(alist-cons pattern (list e 0) vars))))) (else
(else (values (lambda (k)
(values (lambda (k) (k))
#`(if (equal? (syntax->datum #,e) '#,pattern) (alist-cons pattern (list e 0) vars)))))
#,(k) (else
(fail))) (values (lambda (k)
vars)))) #`(if (equal? (syntax->datum #,e) '#,pattern)
#,(k)
(fail)))
vars))))
(define (gen-map h lit* pattern vars) (define (gen-map h lit* pattern vars)
(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
#`(let #,loop ((#,h (reverse #,h)) (lambda (k)
#,@(map (lambda (g) #`(let #,loop ((#,h (reverse #,h))
#`(#,g '())) #,@(map (lambda (g)
g*)) #`(#,g '()))
(if (null? #,h) g*))
#,(k) (if (null? #,h)
(let ((g (car #,h))) #,(k)
#,(matcher (lambda () (let ((g (car #,h)))
#`(#,loop (cdr #,h) #,(matcher
#,@(map (lambda (var g) (lambda ()
#`(cons #,(cadr var) #,g)) #`(#,loop (cdr #,h)
inner-vars g*)))))))) #,@(map (lambda (var g)
(fold (lambda (g var vars) #`(cons #,(cadr var) #,g))
(alist-cons (car var) (list g (+ (cadr (cdr var)) 1)) vars)) inner-vars g*))))))))
vars g* inner-vars))))) (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) (define (gen-matcher* e lit* pattern* vars)
(let loop ((e e) (pattern* pattern*) (vars vars)) (let loop ((e e) (pattern* pattern*) (vars vars))
(cond ((null? pattern*) (cond ((null? pattern*)
(values (lambda (k) (values (lambda (k)
#`(if (null? #,e) #`(if (null? #,e)
#,(k) #,(k)
(fail))) (fail)))
vars)) vars))
((pair? pattern*) ((pair? pattern*)
(let ((e1 (car (generate-temporaries '(#f)))) (let ((e1 (car (generate-temporaries '(#f))))
(e2 (car (generate-temporaries '(#f))))) (e2 (car (generate-temporaries '(#f)))))
(let*-values (((car-matcher vars) (let*-values (((car-matcher vars)
(gen-matcher e1 lit* (car pattern*) vars)) (gen-matcher e1 lit* (car pattern*) vars))
((cdr-matcher vars) ((cdr-matcher vars)
(loop e2 (cdr pattern*) vars))) (loop e2 (cdr pattern*) vars)))
(values (lambda (k) (values (lambda (k)
#`(let ((#,e1 (car #,e)) #`(let ((#,e1 (car #,e))
(#,e2 (cdr #,e))) (#,e2 (cdr #,e)))
#,(car-matcher (lambda () #,(car-matcher (lambda ()
(cdr-matcher k))))) (cdr-matcher k)))))
vars)))) vars))))
(else (else
(gen-matcher e lit* pattern* vars))))) (gen-matcher e lit* pattern* vars)))))
(define (make-synthetic-identifier id) (define (make-synthetic-identifier id)
(close-syntax id (environment))) (close-syntax id (environment)))
@ -299,7 +306,7 @@
(syntax-case x () (syntax-case x ()
((_ ((p e0) ...) e1 e2 ...) ((_ ((p e0) ...) e1 e2 ...)
#'(syntax-case (list e0 ...) () #'(syntax-case (list e0 ...) ()
((p ...) (let () e1 e2 ...))))))) ((p ...) (let () e1 e2 ...)))))))
(define (syntax-violation who message . form*) (define (syntax-violation who message . form*)
(apply error message form*)) (apply error message form*))
@ -309,7 +316,7 @@
(syntax-case stx () (syntax-case stx ()
((_ ellipsis) ((_ ellipsis)
(let ((mac (cdr (env-cell (current-usage-environment) current-ellipsis-id)))) (let ((mac (cdr (env-cell (current-usage-environment) current-ellipsis-id))))
(macro-aux-set! mac #'ellipsis)) (macro-aux-set! mac #'ellipsis))
#'(begin))))) #'(begin)))))
(define-syntax with-ellipsis (define-syntax with-ellipsis
@ -317,6 +324,6 @@
(syntax-case stx () (syntax-case stx ()
((_ ellipsis . body) ((_ ellipsis . body)
(with-syntax ((current-ellipsis current-ellipsis-id)) (with-syntax ((current-ellipsis current-ellipsis-id))
#'(let-syntax ((current-ellipsis (syntax-rules ()))) #'(let-syntax ((current-ellipsis (syntax-rules ())))
(define-current-ellipsis ellipsis) (define-current-ellipsis ellipsis)
. body)))))) . body))))))

16
lib/chibi/syntax-case.sld
View file

@ -1,12 +1,12 @@
(define-library (chibi syntax-case) (define-library (chibi syntax-case)
(export ... _ free-identifier=? bound-identifier=? identifier? (export ... _ free-identifier=? bound-identifier=? identifier?
syntax-case syntax quasisyntax unsyntax unsyntax-splicing syntax-case syntax quasisyntax unsyntax unsyntax-splicing
datum->syntax syntax->datum datum->syntax syntax->datum
generate-temporaries with-syntax syntax-violation generate-temporaries with-syntax syntax-violation
with-ellipsis ellipsis-identifier?) with-ellipsis ellipsis-identifier?)
(import (chibi) (import (chibi)
(chibi ast) (chibi ast)
(meta) (meta)
(srfi 1) (srfi 1)
(srfi 11)) (srfi 11))
(include "syntax-case.scm")) (include "syntax-case.scm"))

8
lib/chibi/system.sld
View file

@ -19,9 +19,9 @@
(body (body
(define (user-information user) (define (user-information user)
(car (if (string? user) (car (if (string? user)
(getpwnam_r user (make-string 1024)) (getpwnam_r user (make-string 1024))
(getpwuid_r user (make-string 1024))))) (getpwuid_r user (make-string 1024)))))
(define (group-information group) (define (group-information group)
(car (if (string? group) (car (if (string? group)
(getgrnam_r group (make-string 1024)) (getgrnam_r group (make-string 1024))
(getgrgid_r group (make-string 1024))))))))) (getgrgid_r group (make-string 1024)))))))))

76
lib/init-7.scm
View file

@ -113,17 +113,17 @@
(define rename (define rename
((lambda (renames) ((lambda (renames)
(lambda (identifier) (lambda (identifier)
((lambda (cell) ((lambda (cell)
(if cell (if cell
(cdr cell) (cdr cell)
((lambda (name) ((lambda (name)
(set! renames (cons (cons identifier name) renames)) (set! renames (cons (cons identifier name) renames))
name) name)
((lambda (id) ((lambda (id)
(syntactic-closure-set-rename! id rename) (syntactic-closure-set-rename! id rename)
id) id)
(close-syntax identifier mac-env))))) (close-syntax identifier mac-env)))))
(assq identifier renames)))) (assq identifier renames))))
'())) '()))
rename)) rename))
@ -131,15 +131,15 @@
(lambda (transformer) (lambda (transformer)
(lambda (expr use-env mac-env) (lambda (expr use-env mac-env)
((lambda (old-use-env old-mac-env old-renamer) ((lambda (old-use-env old-mac-env old-renamer)
(current-usage-environment use-env) (current-usage-environment use-env)
(current-transformer-environment mac-env) (current-transformer-environment mac-env)
(current-renamer (make-renamer mac-env)) (current-renamer (make-renamer mac-env))
((lambda (result) ((lambda (result)
(current-usage-environment old-use-env) (current-usage-environment old-use-env)
(current-transformer-environment old-mac-env) (current-transformer-environment old-mac-env)
(current-renamer old-renamer) (current-renamer old-renamer)
result) result)
(transformer expr))) (transformer expr)))
(current-usage-environment) (current-usage-environment)
(current-transformer-environment) (current-transformer-environment)
(current-renamer))))) (current-renamer)))))
@ -147,15 +147,15 @@
(%define-syntax define-syntax (%define-syntax define-syntax
(lambda (expr use-env mac-env) (lambda (expr use-env mac-env)
(list (close-syntax '%define-syntax mac-env) (list (close-syntax '%define-syntax mac-env)
(cadr expr) (cadr expr)
(list (close-syntax 'make-transformer mac-env) (list (close-syntax 'make-transformer mac-env)
(car (cddr expr)))))) (car (cddr expr))))))
(define free-identifier=? (define free-identifier=?
(lambda (x y) (lambda (x y)
((lambda (use-env cur-env) ((lambda (use-env cur-env)
(identifier=? (if use-env use-env cur-env) x (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-usage-environment)
(current-environment)))) (current-environment))))
@ -163,7 +163,7 @@
(lambda (f) (lambda (f)
(lambda (expr) (lambda (expr)
(close-syntax (f expr (current-usage-environment)) (close-syntax (f expr (current-usage-environment))
(current-transformer-environment))))) (current-transformer-environment)))))
(define rsc-macro-transformer (define rsc-macro-transformer
(lambda (f) (lambda (f)
@ -800,11 +800,11 @@
(define (%point-out point) (vector-ref point 2)) (define (%point-out point) (vector-ref point 2))
(define (%point-parent point) (vector-ref point 3)) (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 (%make-point 0
(lambda () (error "winding in to root!")) (lambda () (error "winding in to root!"))
(lambda () (error "winding out of root!")) (lambda () (error "winding out of root!"))
#f)) #f))
(cond-expand (cond-expand
(threads) (threads)
@ -1129,7 +1129,7 @@
symbol) symbol)
((syntactic-closure-rename id) ((syntactic-closure-rename id)
=> (lambda (renamer) => (lambda (renamer)
(renamer symbol))) (renamer symbol)))
(else (else
symbol))) symbol)))
@ -1137,17 +1137,17 @@
(define (datum->syntax id datum) (define (datum->syntax id datum)
(let loop ((datum datum)) (let loop ((datum datum))
(cond ((pair? datum) (cond ((pair? datum)
(cons (loop (car datum)) (cons (loop (car datum))
(loop (cdr datum)))) (loop (cdr datum))))
((vector? datum) ((vector? datum)
(do ((res (make-vector (vector-length datum))) (do ((res (make-vector (vector-length datum)))
(i 0 (+ i 1))) (i 0 (+ i 1)))
((= i (vector-length datum)) res) ((= i (vector-length datum)) res)
(vector-set! res i (loop (vector-ref datum i))))) (vector-set! res i (loop (vector-ref datum i)))))
((symbol? datum) ((symbol? datum)
(symbol->identifier id datum)) (symbol->identifier id datum))
(else (else
datum)))) datum))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; additional syntax ;; additional syntax

2
lib/srfi/11.sld
View file

@ -15,7 +15,7 @@
(define-syntax let-values (define-syntax let-values
(syntax-rules () (syntax-rules ()
((let-values () . body) ((let-values () . body)
(let () . body)) (let () . body))
((let-values ("step") (binds ...) bind expr maps () () . body) ((let-values ("step") (binds ...) bind expr maps () () . body)
(let*-values (binds ... (bind expr)) (let maps . body))) (let*-values (binds ... (bind expr)) (let maps . body)))
((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body)

2
lib/srfi/128/162-impl.scm
View file

@ -23,7 +23,7 @@
(comparator-min-in-list comp args)) (comparator-min-in-list comp args))
#; #;
(define default-comparator ;Defined in comparators.scm (define default-comparator ;Defined in comparators.scm
(make-default-comparator)) (make-default-comparator))
(define boolean-comparator (define boolean-comparator

32
lib/srfi/128/test.sld
View file

@ -274,22 +274,22 @@
) ; end comparators/bound-salt ) ; end comparators/bound-salt
(test-group "comparators/min-max" (test-group "comparators/min-max"
(test 5 (comparator-max real-comparator 1 5 3 2 -2)) (test 5 (comparator-max real-comparator 1 5 3 2 -2))
(test -2 (comparator-min 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 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))) (test -2 (comparator-min-in-list real-comparator '(1 5 3 2 -2)))
) ; end comparators/min-max ) ; end comparators/min-max
(test-group "comparators/variables" (test-group "comparators/variables"
;; Most of the variables have been tested above. ;; Most of the variables have been tested above.
(test-assert (=? char-comparator #\C #\C)) (test-assert (=? char-comparator #\C #\C))
(test-assert (=? char-ci-comparator #\c #\C)) (test-assert (=? char-ci-comparator #\c #\C))
(test-assert (=? string-comparator "ABC" "ABC")) (test-assert (=? string-comparator "ABC" "ABC"))
(test-assert (=? string-ci-comparator "abc" "ABC")) (test-assert (=? string-ci-comparator "abc" "ABC"))
(test-assert (=? eq-comparator 32 32)) (test-assert (=? eq-comparator 32 32))
(test-assert (=? eqv-comparator 32 32)) (test-assert (=? eqv-comparator 32 32))
(test-assert (=? equal-comparator "ABC" "ABC")) (test-assert (=? equal-comparator "ABC" "ABC"))
) ; end comparators/variables ) ; end comparators/variables
)))) ; end comparators )))) ; end comparators

6
lib/srfi/151/test.sld
View file

@ -169,11 +169,11 @@
(test #b0 (bit-field-rotate #b0 128 0 256)) (test #b0 (bit-field-rotate #b0 128 0 256))
(test #b1 (bit-field-rotate #b1 128 1 256)) (test #b1 (bit-field-rotate #b1 128 1 256))
(test #x100000000000000000000000000000000 (test #x100000000000000000000000000000000
(bit-field-rotate #x100000000000000000000000000000000 128 0 64)) (bit-field-rotate #x100000000000000000000000000000000 128 0 64))
(test #x100000000000000000000000000000008 (test #x100000000000000000000000000000008
(bit-field-rotate #x100000000000000000000000000000001 3 0 64)) (bit-field-rotate #x100000000000000000000000000000001 3 0 64))
(test #x100000000000000002000000000000000 (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 10))
(test #b110 (bit-field-rotate #b110 0 0 256)) (test #b110 (bit-field-rotate #b110 0 0 256))
(test 1 (bit-field-rotate #x100000000000000000000000000000000 1 0 129)) (test 1 (bit-field-rotate #x100000000000000000000000000000000 1 0 129))

8
lib/srfi/158.scm
View file

@ -418,16 +418,16 @@
;; generator->list ;; generator->list
(define generator->list (define generator->list
(case-lambda ((gen n) (case-lambda ((gen n)
(generator->list (gtake gen n))) (generator->list (gtake gen n)))
((gen) ((gen)
(reverse (generator->reverse-list gen))))) (reverse (generator->reverse-list gen)))))
;; generator->reverse-list ;; generator->reverse-list
(define generator->reverse-list (define generator->reverse-list
(case-lambda ((gen n) (case-lambda ((gen n)
(generator->reverse-list (gtake gen n))) (generator->reverse-list (gtake gen n)))
((gen) ((gen)
(generator-fold cons '() gen)))) (generator-fold cons '() gen))))
;; generator->vector ;; generator->vector
(define generator->vector (define generator->vector

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

@ -9,15 +9,19 @@
(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)
(string->symbol (string-append "make-" name-str))) (datum->syntax
(if (pair? make) (car make) make))) name
(string->symbol (string-append "make-" name-str)))
(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)
(string->symbol (string-append name-str "?"))) (datum->syntax
pred)) name
(string->symbol (string-append name-str "?")))
pred))
(fields (cddr procs)) (fields (cddr procs))
(field-names (map (lambda (x) (if (pair? x) (car x) x)) fields)) (field-names (map (lambda (x) (if (pair? x) (car x) x)) fields))
(make-fields (if (pair? make) (cdr make) (and (not parent) field-names))) (make-fields (if (pair? make) (cdr make) (and (not parent) field-names)))

20
lib/srfi/99/test.sld
View file

@ -112,16 +112,16 @@
;;; See issue #494. ;;; See issue #494.
(test-assert (test-assert
(let-syntax (let-syntax
((foo ((foo
(syntax-rules () (syntax-rules ()
((foo) ((foo)
(let () (let ()
(define-record-type record (define-record-type record
#t #t
#t) #t)
(record? (make-record))))))) (record? (make-record)))))))
(foo))) (foo)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let () (let ()