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

Merge 31a3316bf2 into af1bc5806d

Browse source
This commit is contained in:
Daphne Preston-Kendal 2025-04-01 16:06:45 +08:00 • committed by GitHub
commit 5d3ba6cb42
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
13 changed files with 524 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -77,7 +77,7 @@
(define (make-pattern-variable pvar)
(lambda (expr)
(error "reference to pattern variable outside syntax" pvar)))
(syntax-violation #f "reference to pattern variable outside syntax" pvar)))
(define (pattern-variable x)
(and-let*
@ -163,7 +163,9 @@
((out envs)
(gen-template (car tmpl) (cons '() envs) ell? level)))
(if (null? (car envs))
(error "too many ellipses following syntax template" (car tmpl)))
(syntax-violation 'syntax
"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))
@ -180,7 +182,9 @@
(values `(,(rename 'list->vector) ,out) envs)))
((identifier? tmpl)
(cond ((ell? tmpl)
(error "misplaced ellipsis in syntax template" tmpl))
(syntax-violation 'syntax
"misplaced ellipsis in syntax template"
tmpl))
((pattern-variable tmpl) =>
(lambda (binding)
(values (car binding)
@ -199,7 +203,7 @@
(cond ((zero? level)
envs)
((null? envs)
(error "too few ellipses following syntax template" id))
(syntax-violation #f "too few ellipses following syntax template" id))
(else
(let ((outer-envs (loop (- level 1) (cdr envs))))
(cond ((member x (car envs) bound-identifier=?)
@ -214,7 +218,7 @@
(let ((expr (cadr expr))
(lit* (car (cddr expr)))
(clause* (reverse (cdr (cddr expr))))
(error #'(error "syntax error" e)))
(error #`(syntax-violation #f "syntax error" e)))
#`(let ((e #,expr))
#,(if (null? clause*)
error
@ -294,7 +298,7 @@
(fail)))
vars))
((ellipsis-identifier? pattern)
(error "misplaced ellipsis" pattern))
(syntax-violation #f "misplaced ellipsis" pattern))
((free-identifier=? pattern #'_)
(values (lambda (k)
(k))
@ -370,8 +374,19 @@
#'(syntax-case (list e0 ...) ()
((p ...) (let () e1 e2 ...)))))))
(define (syntax-violation who message . form*)
(apply error message form*))
(define (syntax-violation who message form . maybe-subform)
(raise (condition (make-syntax-violation form
(if (null? maybe-subform)
#f
(car maybe-subform)))
(cond (who => make-who-condition)
((identifier? form)
(make-who-condition (syntax->datum form)))
((and (pair? form)
(identifier? (car form)))
(make-who-condition (syntax->datum (car form))))
(else (condition)))
(make-message-condition message))))
(define-syntax define-current-ellipsis
(lambda (stx)

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

@ -14,6 +14,7 @@
procedure-arity procedure-variadic?
procedure-variable-transformer?
make-variable-transformer)
(rnrs conditions)
(only (meta) environment)
(srfi 1)
(srfi 2)

54
lib/meta-7.scm
View file

@ -355,6 +355,60 @@
(define-syntax define-library define-library-transformer)
(define-syntax module define-library-transformer)
(define r6rs-library-transformer
(er-macro-transformer
(lambda (expr rename compare)
(define (clean-up-r6rs-library-name name)
(define (srfi-number->exact-integer component)
(if (symbol? component)
(let* ((symbol-name (symbol->string component)))
(if (and (char=? (string-ref symbol-name 0) #\:)
(every char-numeric?
(cdr (string->list symbol-name))))
(string->number maybe-number-as-string)
#f))
#f))
(apply append
(map
(lambda (component)
(cond ((list? component) ; ignore version numbers
'())
((srfi-number->exact-integer component) => list)
(else (list component))))
name)))
(define (clean-up-r6rs-import import-spec)
(cond ((identifier? import-spec) import-spec)
((memq (car import-spec)
'(only except prefix rename))
(cons (car import-spec)
(cons (clean-up-r6rs-library-name (cadr import-spec))
(cddr import-spec))))
((memq (car import-spec)
'(library for))
(clean-up-r6rs-library-name (cadr import-spec)))
(else (clean-up-r6rs-library-name import-spec))))
(if (not (eq? (car expr) 'library))
(error "r6rs-library-transformer: I expect to process declarations called library, but this was a new one to me" (car expr)))
(if (not (and (list? expr)
(>= (length expr) 3)
(list? (list-ref expr 1))
(list? (list-ref expr 2))
(eq? (car (list-ref expr 2)) 'export)
(list? (list-ref expr 3))
(eq? (car (list-ref expr 3)) 'import)))
(error "r6rs-library-transformer: the form of a library declaration is (library <name> (export <export-spec> ...) (import <import-spec> ...) <defexpr> ...)" expr))
(let ((library-name (clean-up-r6rs-library-name (list-ref expr 1)))
(exports (cdr (list-ref expr 2)))
(imports (map clean-up-r6rs-import (cdr (list-ref expr 3))))
(body (cddr (cddr expr))))
`(define-library ,library-name
(export ,@exports)
(import ,@imports)
(begin ,@body))))))
(define-syntax library r6rs-library-transformer)
(define-syntax pop-this-path
(er-macro-transformer
(lambda (expr rename compare)

267
lib/rnrs/base.sld Normal file
View file

@ -0,0 +1,267 @@
(library (rnrs base)
(export *
+
-
...
/
<
<=
=
=>
>
>=
_
abs
acos
and
angle
append
apply
asin
assert
assertion-violation
atan
begin
boolean=?
boolean?
caaaar
caaadr
caaar
caadar
caaddr
caadr
caar
cadaar
cadadr
cadar
caddar
cadddr
caddr
cadr
call-with-current-continuation
call-with-values
call/cc
car
case
cdaaar
cdaadr
cdaar
cdadar
cdaddr
cdadr
cdar
cddaar
cddadr
cddar
cdddar
cddddr
cdddr
cddr
cdr
ceiling
char->integer
char<=?
char<?
char=?
char>=?
char>?
char?
complex?
cond
cons
cos
define
define-syntax
denominator
div
div-and-mod
div0
div0-and-mod0
dynamic-wind
else
eq?
equal?
eqv?
error
even?
exact
exact-integer-sqrt
exact?
exp
expt
finite?
floor
for-each
gcd
identifier-syntax
if
imag-part
inexact
inexact?
infinite?
integer->char
integer-valued?
integer?
lambda
lcm
length
let
let*
let*-values
let-syntax
let-values
letrec
letrec*
letrec-syntax
list
list->string
list->vector
list-ref
list-tail
list?
log
magnitude
make-polar
make-rectangular
make-string
make-vector
map
max
min
mod
mod0
nan?
negative?
not
null?
number->string
number?
numerator
odd?
or
pair?
positive?
procedure?
quasiquote
quote
rational-valued?
rational?
rationalize
real-part
real-valued?
real?
reverse
round
set!
sin
sqrt
string
string->list
string->number
string->symbol
string-append
string-copy
string-for-each
string-length
string-ref
string<=?
string<?
string=?
string>=?
string>?
string?
substring
symbol->string
symbol=?
symbol?
syntax-rules
tan
truncate
unquote
unquote-splicing
values
vector
vector->list
vector-fill!
vector-for-each
vector-length
vector-map
vector-ref
vector-set!
vector?
zero?)
(import (except (scheme base)
define-syntax
let-syntax
letrec-syntax
syntax-rules)
(scheme cxr)
(scheme inexact)
(scheme complex)
(rnrs conditions)
(only (srfi 1) every)
(rename (srfi 141)
(euclidean-quotient div)
(euclidean-remainder mod)
(euclidean/ div-and-mod)
(balanced-quotient div0)
(balanced-remainder mod0)
(balanced/ div0-and-mod0))
(rename (chibi syntax-case)
(splicing-let-syntax let-syntax)
(splicing-letrec-syntax letrec-syntax))
(except (chibi ast) error)
(chibi show))
(define-syntax syntax-rules
(lambda (x)
(syntax-case x ()
((_ (lit ...) ((k . p) t) ...)
(every identifier? #'(lit ... k ...))
#'(lambda (x)
(syntax-case x (lit ...)
((_ . p) #'t) ...))))))
(define-syntax identifier-syntax
(lambda (x)
(syntax-case x (set!)
((_ e)
#'(lambda (x)
(syntax-case x ()
(id (identifier? #'id) #'e)
((_ x (... ...)) #'(e x (... ...))))))
((_ (id exp1) ((set! var val) exp2))
(and (identifier? #'id) (identifier? #'var))
#'(make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! var val) #'exp2)
((id x (... ...)) #'(exp1 x (... ...)))
(id (identifier? #'id) #'exp1))))))))
(define-syntax assert
(syntax-rules ()
((_ expr)
(if (not expr)
(assertion-violation #f "assertion failed" (quote expr))))))
(define (%error make-base who message irritants)
(assert (or (not who) (symbol? who) (string? who)))
(assert (string? message))
(raise (condition (make-base)
(if who (make-who-condition who) (condition))
(make-message-condition message)
(make-irritants-condition irritants))))
(define (error who message . irritants)
(%error make-error who message irritants))
(define (assertion-violation who message . irritants)
(%error make-assertion-violation who message irritants))
(define (real-valued? n) (zero? (imag-part n)))
(define (rational-valued? n)
(and (real-valued? n)
(not (nan? n))
(not (infinite? n))))
(define (integer-valued? n)
(and (rational-valued? n)
(integer? (real-part n)))))

101
lib/rnrs/conditions.sld Normal file
View file

@ -0,0 +1,101 @@
(library (rnrs conditions)
(export &condition
(rename make-compound-condition condition)
simple-conditions
condition-predicate
condition-accessor
(rename define-condition-type/constructor define-condition-type)
;; 7.3 Standard condition types
&message
make-message-condition
message-condition?
condition-message
&warning
make-warning
warning?
&serious
make-serious-condition
serious-condition?
&error
make-error
error?
&violation
make-violation
violation?
&assertion
make-assertion-violation
assertion-violation?
&irritants
make-irritants-condition
irritants-condition?
condition-irritants
&who
make-who-condition
who-condition?
condition-who
&non-continuable
make-non-continuable-violation
non-continuable-violation?
&implementation-restriction
make-implementation-restriction-violation
implementation-restriction-violation?
&lexical
make-lexical-violation
lexical-violation?
&syntax
make-syntax-violation
syntax-violation?
syntax-violation-form
syntax-violation-subform
&undefined
make-undefined-violation
undefined-violation?)
(import (srfi 35 internal))
(define-condition-type/constructor &warning &condition
make-warning warning?)
(define-condition-type/constructor &violation &serious
make-violation violation?)
(define-condition-type/constructor &assertion &violation
make-assertion-violation assertion-violation?)
(define-condition-type/constructor &irritants &condition
make-irritants-condition irritants-condition?
(irritants condition-irritants))
(define-condition-type/constructor &who &condition
make-who-condition who-condition?
(who condition-who))
(define-condition-type/constructor &non-continuable &violation
make-non-continuable-violation non-continuable-violation?)
(define-condition-type/constructor &implementation-restriction &violation
make-implementation-restriction-violation
implementation-restriction-violation?)
(define-condition-type/constructor &lexical &violation
make-lexical-violation lexical-violation?)
(define-condition-type/constructor &syntax &violation
make-syntax-violation syntax-violation?
(form syntax-violation-form)
(subform syntax-violation-subform))
(define-condition-type/constructor &undefined &violation
make-undefined-violation undefined-violation?))

6
lib/rnrs/control.sld Normal file
View file

@ -0,0 +1,6 @@
(library (rnrs control)
(export when unless
do
case-lambda)
(import (scheme base)
(scheme case-lambda)))

4
lib/rnrs/eval.sld Normal file
View file

@ -0,0 +1,4 @@
(library (rnrs eval)
(export eval
environment)
(import (scheme eval)))

35
lib/rnrs/lists.sld Normal file
View file

@ -0,0 +1,35 @@
(library (rnrs lists)
(export find
(rename every for-all)
(rename any exists)
filter partition
fold-left
fold-right
(rename remove remp)
(rename rnrs:remove remove)
remv
remq
(rename find-tail memp)
member
memv
memq
assp
assoc
assv
assq
cons*)
(import (scheme base)
(srfi 1))
(define (fold-left kons knil . lss)
(apply fold
(lambda args
(apply kons (last args) (drop-right args 1)))
knil lss))
(define (rnrs:remove obj ls) (remove (lambda (x) (equal? x obj)) ls))
(define (remv obj ls) (remove (lambda (x) (eqv? x obj)) ls))
(define (remq obj ls) (remove (lambda (x) (eq? x obj)) ls))
(define (assp proc alist)
(find (lambda (x) (proc (car x))) alist)))

3
lib/rnrs/mutable-pairs.sld Normal file
View file

@ -0,0 +1,3 @@
(library (rnrs mutable-pairs)
(export set-car! set-cdr!)
(import (scheme base)))

4
lib/rnrs/mutable-strings.sld Normal file
View file

@ -0,0 +1,4 @@
(library (rnrs mutable-strings)
(export string-set!
string-fill!)
(import (scheme base)))

4
lib/rnrs/programs.sld Normal file
View file

@ -0,0 +1,4 @@
(library (rnrs programs)
(export command-line
exit)
(import (scheme process-context)))

5
lib/rnrs/sorting.sld Normal file
View file

@ -0,0 +1,5 @@
(library (rnrs sorting)
(export (rename list-stable-sort list-sort)
(rename vector-stable-sort vector-sort)
(rename vector-stable-sort! vector-sort!))
(import (srfi 132)))

17
lib/rnrs/syntax-case.sld Normal file
View file

@ -0,0 +1,17 @@
(library (rnrs syntax-case)
(export make-variable-transformer
syntax-case
syntax
identifier?
bound-identifier=?
free-identifier=?
syntax->datum
datum->syntax
generate-temporaries
with-syntax
quasisyntax
unsyntax
unsyntax-splicing
syntax-violation)
(import (chibi ast)
(chibi syntax-case)))