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

Add basic R6RS library support and (rnrs base) library

Browse source
This commit is contained in:
Daphne Preston-Kendal 2024-10-06 14:23:48 +02:00
parent dce487fa3a
commit 0aa9260727
2 changed files with 296 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
lib/meta-7.scm
View file

@ -355,6 +355,71 @@
(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 (symbolic-id=? id_1 id_2)
(eq? (strip-syntactic-closures id_1)
(strip-syntactic-closures id_2)))
(define (clean-up-r6rs-library-name name)
(define (srfi-number->exact-integer component)
(if (symbol? component)
(let* ((symbol-name (symbol->string component))
(maybe-number-as-string (substring symbol-name 1)))
(if (and (char=? (string-ref symbol-name 0) #\:)
(every char-numeric?
(string->list maybe-number-as-string)))
(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)
((member (car import-spec)
'(only except prefix rename)
symbolic-id=?)
(cons (car import-spec)
(cons (clean-up-r6rs-library-name (cadr import-spec))
(cddr import-spec))))
((member (car import-spec)
'(library for)
symbolic-id=?)
(clean-up-r6rs-library-name (cadr import-spec)))
(else (clean-up-r6rs-library-name import-spec))))
(if (not (symbolic-id=? (car expr) 'library))
(error "r6rs-library-transformer: I expect to process declarations called library, but this was a new one to me" (car expr) 'library))
(if (not (and (list? expr)
(>= (length expr) 3)
(list? (list-ref expr 1))
(list? (list-ref expr 2))
(symbolic-id=? (car (list-ref expr 2)) 'export)
(list? (list-ref expr 3))
(symbolic-id=? (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 (rename 'define-library))
(_export (rename 'export))
(_import (rename 'import))
(_begin (rename 'begin)))
`(,_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)

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

@ -0,0 +1,231 @@
(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 (rename (scheme base)
(error r7rs:error))
(scheme cxr)
(scheme inexact)
(scheme complex)
(rename (srfi 141)
(euclidean-quotient div)
(euclidean-remainder mod)
(euclidean/ div-and-mod)
(balanced-quotient div0)
(balanced-remainder mod0)
(balanced/ div0-and-mod0))
(except (chibi ast) error)
(chibi show))
(define-syntax assert
(syntax-rules ()
((_ expr)
(if (not expr)
(assertion-violation #f "assertion failed" (quote expr))))))
;; for now, errors and assertion violations are the same until we
;; work out what to do about SRFI 35/(rnrs conditions) support
(define (error who message . irritants)
(define full-message
(if who
(show #f (written who) ": " message)
message))
(apply r7rs:error full-message irritants))
(define assertion-violation error)
(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)))))