Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 14:49:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

more primitives

Browse source
This commit is contained in:
Alex Shinn 2009-03-31 13:57:50 +09:00
parent 95240dbe74
commit 1f6493cb3d
2 changed files with 215 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
init.scm
View file

@ -1,35 +1,31 @@
;; define set! let let* letrec lambda if cond case delay and or begin do ;; let* cond case delay and do
;; quote quasiquote unquote unquote-splicing define-syntax let-syntax ;; quasiquote unquote unquote-splicing let-syntax
;; letrec-syntax syntax-rules eqv? eq? equal? not boolean? number? ;; letrec-syntax syntax-rules eqv? equal? not boolean? number?
;; complex? real? rational? integer? exact? inexact? = < > <= >= zero? ;; complex? real? rational? integer? exact? inexact?
;; positive? negative? odd? even? max min + * - / abs quotient remainder ;; positive? negative? odd? even? max min quotient remainder
;; modulo gcd lcm numerator denominator floor ceiling truncate round ;; modulo numerator denominator floor ceiling truncate round
;; rationalize exp log sin cos tan asin acos atan sqrt expt ;; rationalize sqrt expt
;; make-rectangular make-polar real-part imag-part magnitude angle ;; make-rectangular make-polar real-part imag-part magnitude angle
;; exact->inexact inexact->exact number->string string->number pair? cons ;; exact->inexact inexact->exact number->string string->number
;; car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr ;; list? list-tail list-ref memv
;; cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr ;; member assv assoc symbol->string string->symbol
;; caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr ;; char-alphabetic? char-numeric? char-whitespace?
;; null? list? list length append reverse list-tail list-ref memq memv
;; member assq assv assoc symbol? symbol->string string->symbol char?
;; char=? char<? char>? char<=? char>=? char-ci=? char-ci<? char-ci>?
;; char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace?
;; char-upper-case? char-lower-case? char->integer integer->char ;; char-upper-case? char-lower-case? char->integer integer->char
;; char-upcase char-downcase string? make-string string string-length ;; char-upcase char-downcase make-string string string-length
;; string-ref string-set! string=? string-ci=? string<? string>? ;; string=? string-ci=? string<? string>?
;; string<=? string>=? string-ci<? string-ci>? string-ci<=? string-ci>=? ;; string<=? string>=? string-ci<? string-ci>? string-ci<=? string-ci>=?
;; substring string-append string->list list->string string-copy ;; substring string-append string->list list->string string-copy
;; string-fill! vector? make-vector vector vector-length vector-ref ;; string-fill! make-vector vector vector-length
;; vector-set! vector->list list->vector vector-fill! procedure? apply ;; vector->list list->vector vector-fill! procedure? apply
;; map for-each force call-with-current-continuation values ;; map for-each force call-with-current-continuation values
;; call-with-values dynamic-wind scheme-report-environment ;; call-with-values dynamic-wind scheme-report-environment
;; null-environment call-with-input-file call-with-output-file ;; null-environment call-with-input-file call-with-output-file
;; input-port? output-port? current-input-port current-output-port ;; current-input-port current-output-port
;; with-input-from-file with-output-to-file open-input-file ;; with-input-from-file with-output-to-file open-input-file
;; open-output-file close-input-port close-output-port read read-char ;; open-output-file close-input-port close-output-port
;; peek-char eof-object? char-ready? write display newline write-char ;; peek-char eof-object? char-ready?
;; load eval ;; eval
;; provide c[ad]{2,4}r ;; provide c[ad]{2,4}r
@ -143,6 +139,25 @@
'tmp 'tmp
(make-syntactic-closure use-env '() (cons 'or (cddr expr)))))))))) (make-syntactic-closure use-env '() (cons 'or (cddr expr))))))))))
;; char utils
;; (define (char=? a b) (= (char->integer a) (char->integer b)))
;; (define (char<? a b) (< (char->integer a) (char->integer b)))
;; (define (char>? a b) (> (char->integer a) (char->integer b)))
;; (define (char<=? a b) (<= (char->integer a) (char->integer b)))
;; (define (char>=? a b) (>= (char->integer a) (char->integer b)))
;; (define (char-ci=? a b)
;; (= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; (define (char-ci<? a b)
;; (< (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; (define (char-ci>? a b)
;; (> (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; (define (char-ci<=? a b)
;; (<= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; (define (char-ci>=? a b)
;; (>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; math ;; math
;; (define (abs x) (if (< x 0) (- x) x)) ;; (define (abs x) (if (< x 0) (- x) x))

177
syntax-rules.scm Normal file
View file

@ -0,0 +1,177 @@
(define-syntax syntax-rules
(er-macro-transformer
(lambda (expr rename compare)
(let ((lits (cadr expr))
(forms (cddr expr))
(count 0)
(_er-macro-transformer (rename 'er-macro-transformer))
(_lambda (rename 'lambda)) (_let (rename 'let))
(_begin (rename 'begin)) (_if (rename 'if))
(_and (rename 'and)) (_or (rename 'or))
(_eq? (rename 'eq?)) (_equal? (rename 'equal?))
(_car (rename 'car)) (_cdr (rename 'cdr))
(_cons (rename 'cons)) (_pair? (rename 'pair?))
(_null? (rename 'null?)) (_expr (rename 'expr))
(_rename (rename 'rename)) (_compare (rename 'compare))
(_quote (rename 'quote)) (_apply (rename 'apply))
(_append (rename 'append)) (_map (rename 'map))
(_vector? (rename 'vector?)) (_list? (rename 'list?))
(_lp (rename 'lp)) (_reverse (rename 'reverse))
(_vector->list (rename 'vector->list))
(_list->vector (rename 'list->vector)))
(define (next-v)
(set! count (+ count 1))
(rename (string->symbol (string-append "v." (number->string count)))))
(define (expand-pattern pat tmpl)
(let lp ((p (cdr pat))
(x (list _cdr _expr))
(dim 0)
(vars '())
(k (lambda (vars)
(or (expand-template tmpl vars)
(list _begin #f)))))
(let ((v (next-v)))
(list
_let (list (list v x))
(cond
((symbol? p)
(if (memq p lits)
(list _and (list _eq? v p) (k vars))
(list _let (list (list p v)) (k (cons (cons p dim) vars)))))
((ellipse? p)
(cond
((not (null? (cddr p)))
(error "non-trailing ellipse" p))
((symbol? (car p))
(list _and (list _list? v)
(list _let (list (list (car p) v))
(k (cons (cons (car p) (+ 1 dim)) vars)))))
(else
(let* ((w (next-v))
(new-vars (all-vars (car p) (+ dim 1)))
(ls-vars (map (lambda (x)
(rename (string->symbol
(string-append
(symbol->string (car x))
"-ls"))))
new-vars))
(once
(lp (car p) (list _car w) (+ dim 1) '()
(lambda (_)
(cons
_lp
(cons
(list _cdr w)
(map (lambda (x l)
(list _cons (car x) l))
new-vars
ls-vars)))))))
(list
_let
_lp (list (list w v)
(map (lambda (x) (list x '())) ls-vars))
(list _if (list _null? w)
(list _let (map (lambda (x l)
(list (car x) (list _reverse l)))
new-vars
ls-vars)
(k (append new-vars vars)))
(list _and (list _pair? w) once)))))))
((pair? p)
(list _and (list _pair? v)
(lp (car p)
(list _car v)
dim
vars
(lambda (vars)
(lp (cdr p) (list _cdr v) dim vars k)))))
((vector? p)
(list _and
(list _vector? v)
(lp (vector->list p) (list _vector->list v) dim vars k)))
((null? p) (list _and (list _null? v) (k vars)))
(else (list _and (list _equal? v p) (k vars))))))))
(define (ellipse? x)
(and (pair? x) (pair? (cdr x)) (eq? '... (cadr x))))
(define (ellipse-depth x)
(if (ellipse? x)
(+ 1 (ellipse-depth (cdr x)))
0))
(define (ellipse-tail x)
(if (ellipse? x)
(ellipse-tail (cdr x))
(cdr x)))
(define (all-vars x dim)
(let lp ((x x) (dim dim) (vars '()))
(cond ((symbol? x) (if (memq x lits) vars (cons (cons x dim) vars)))
((ellipse? x) (lp (car x) (+ dim 1) vars))
((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
((vector? x) (lp (vector->list x) dim vars))
(else vars))))
(define (free-vars x vars dim)
(let lp ((x x) (free '()))
(cond ((symbol? x)
(if (and (not (memq x free))
(cond ((assq x vars)
=> (lambda (cell) (>= (cdr cell) dim)))
(else #f)))
(cons x free)
free))
((pair? x) (free-vars (car x) (free-vars (cdr x) free)))
((vector? x) (lp (vector->list x) free))
(else free))))
(define (expand-template tmpl vars)
(let lp ((t tmpl) (dim 0))
(cond
((symbol? t)
(cond
((assq t vars)
=> (lambda (cell)
(if (<= (cdr cell) dim)
t
(error "too few ...'s for" t tmpl))))
(else
(list _rename (list _quote t)))))
((pair? t)
(if (ellipse? t)
(let* ((depth (ellipse-depth t))
(ell-dim (+ dim depth))
(ell-vars (free-vars (car t) vars ell-dim)))
(if (null? ell-vars)
(error "too many ...'s" tmpl t)
(let* ((once (lp (car t) ell-dim))
(nest (if (and (null? (cdr ell-vars))
(symbol? once)
(eq? once (car vars)))
once ;; shortcut
(cons _map
(cons (list _lambda ell-vars once)
ell-vars))))
(many (do ((d depth (- d 1))
(many nest
(list _apply _append many)))
((= d 1) many))))
(if (null? (ellipse-tail t))
many ;; shortcut
(list _append many (lp (ellipse-tail t) dim))))))
(list _cons (lp (car t) dim) (lp (cdr t) dim))))
((vector? t) (list _list->vector (lp (vector->list t) dim)))
((null? t) (list _quote '()))
(else t))))
(list
_er-macro-transformer
(list _lambda (list _expr _rename _compare)
(cons
_or
(map
(lambda (clause) (expand-pattern (car clause) (cadr clause)))
forms)
(error "no expansion for" _expr))))))))
;; Local Variables:
;; eval: (put '_lambda 'scheme-indent-function 1)
;; eval: (put '_let 'scheme-indent-function 'scheme-let-indent)
;; eval: (put '_if 'scheme-indent-function 3)
;; End: