conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* autoconf now properly exports .ss files.

This commit is contained in:
Abdulaziz Ghuloum 2007-10-17 22:50:15 -04:00
parent 99dd633f83
commit 683fb50242
6 changed files with 40 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/Makefile.am
View File

@ -1,6 +1,6 @@
bin_PROGRAMS=ikarus.boot
ikarus_boot_SOURCES=
ikarus_boot_SOURCES=ikarus.boot ikarus.apply.ss ikarus.bytevectors.ss ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss ikarus.hash-tables.ss ikarus.intel-assembler.ss ikarus.io-ports.ss ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss ikarus.io.input-files.ss ikarus.io.input-strings.ss ikarus.io.output-files.ss ikarus.io.output-strings.ss ikarus.lists.ss ikarus.load.ss ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss ikarus.records.procedural.ss ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss ikarus.transcoders.ss ikarus.unicode-data.ss ikarus.vectors.ss ikarus.writer.ss makefile.ss pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss psyntax.compat.ss psyntax.config.ss psyntax.expander.ss psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss ikarus/fasl/write.ss unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss
ikarus.boot$(EXEEXT): $(ikarus_boot_OBJECTS) $(ikarus_boot_DEPENDENCIES)
echo "nothing to do"

BIN
scheme/ikarus.boot
View File

Binary file not shown.

40
scheme/ikarus.compiler.ss
View File

@ -42,7 +42,45 @@
(with-syntax ([body (generate-body #'_ #'(cls* ...))])
#'(let ([v expr]) body))])))
(include "set-operations.ss")
(define (remq1 x ls)
(cond
[(null? ls) '()]
[(eq? x (car ls)) (cdr ls)]
[else
(let ([t (remq1 x (cdr ls))])
(cond
[(eq? t (cdr ls)) ls]
[else (cons (car ls) t)]))]))
(define (singleton x) (list x))
(define (union s1 s2)
(define (add* s1 s2)
(cond
[(null? s1) s2]
[else (add (car s1) (add* (cdr s1) s2))]))
(define (add x s)
(cond
[(memq x s) s]
[else (cons x s)]))
(cond
[(null? s1) s2]
[(null? s2) s1]
[else (add* s1 s2)]))
(define (difference s1 s2)
(define (rem* s1 s2)
(cond
[(null? s1) s2]
[else (remq1 (car s1) (rem* (cdr s1) s2))]))
(cond
[(null? s1) '()]
[(null? s2) s1]
[else (rem* s2 s1)]))
(define-struct constant (value))

32
scheme/ikarus.pretty-print.ss
View File

@ -681,35 +681,3 @@
(f (fxadd1 i))
(error 'test-file "mismatch\n\n~s\n\n~s" x y)))))))))
;#!eof
(for-each test-file
'("fact.ss"
"libhash.ss"
"foo.ss"
"libintelasm.ss"
"libassembler.ss"
"libnumerics.ss"
"libcafe.ss"
"libposix.ss"
"libchezio.ss"
"librecord.ss"
"libcollect.ss"
"libtimers.ss"
"libcompile.ss"
"libtokenizer.ss"
"libcontrol.ss"
"libtoplevel.ss"
"libcore.ss"
"libtrace.ss"
"libcxr.ss"
"libwriter.ss"
"libengines.ss"
"libfasl.ss"
"libguardians.ss"
"libpp.ss"
"self-exporting-module.ss"
"libhandlers.ss"
"set-operations.ss"
"psyntax-7.1.ss"
))

72
scheme/rationalize.ss
View File

@ -1,72 +0,0 @@
#!/usr/bin/env ikarus --r6rs-script
(import (ikarus))
#;
(define (rationalize x eps)
(define who 'rationalize)
(define (simplest x y)
(cond
[(< y x) (simplest y x)]
[(= x y) x]
[(> x 0)
(let ([n (numerator x)] [d (denominator x)]
[n^ (numerator y)] [d^ (denominator y)])
(simplest^ n d n^ d^))]
[(< y 0)
(let ([n (numerator x)] [d (denominator x)]
[n^ (numerator y)] [d^ (denominator y)])
(- (simplest^ (- n^) d^ (- n) d)))]
[else 1]))
(define (simplest^ n d n^ d^)
(let-values ([(q r) (quotient+remainder n d)])
(if (= r 0)
q
(let-values ([(q^ r^) (quotient+remainder n^ d^)])
(if (= q q^)
(let ([v (simplest^ d^ r^ d r)])
(let ([n^^ (numerator v)] [d^^ (denominator v)])
(/ (+ (* q n^^) d^^) n^^)))
(+ q 1))))))
(define (go x eps)
(simplest (- x eps) (+ x eps)))
(cond
[(flonum? x)
(if (flfinite? x)
(cond
[(flonum? eps)
(if (flfinite? eps) (go x eps) +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)]
[else (error who "~s is not a number" eps)])
(cond
[(flonum? eps)
(if (flfinite? eps) x +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
x]
[else (error who "~s is not a number" eps)]))]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(cond
[(flonum? eps)
(if (flfinite? eps) (go x eps) +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)]
[else (error who "~s is not a number" eps)])]
[else (error who "~s is not a number" x)]))
(define (test v0 v1 r)
(let ([s (time (rationalize v0 v1))])
(unless (or (= s r) (and (flnan? s) (flnan? r)))
(error 'test "failed in ~s ~s => ~s, should be ~s"
v0 v1 s r))))
(test 314/100 1/100 22/7)
(test #e0.3 1/10 1/3)
(test 0.3 1/10 #i1/3)
(test +inf.0 3 +inf.0)
(test +inf.0 +inf.0 +nan.0)

38
scheme/set-operations.ss
View File

@ -1,38 +0,0 @@
(define (remq1 x ls)
(cond
[(null? ls) '()]
[(eq? x (car ls)) (cdr ls)]
[else
(let ([t (remq1 x (cdr ls))])
(cond
[(eq? t (cdr ls)) ls]
[else (cons (car ls) t)]))]))
(define (singleton x) (list x))
(define (union s1 s2)
(define (add* s1 s2)
(cond
[(null? s1) s2]
[else (add (car s1) (add* (cdr s1) s2))]))
(define (add x s)
(cond
[(memq x s) s]
[else (cons x s)]))
(cond
[(null? s1) s2]
[(null? s2) s1]
[else (add* s1 s2)]))
(define (difference s1 s2)
(define (rem* s1 s2)
(cond
[(null? s1) s2]
[else (remq1 (car s1) (rem* (cdr s1) s2))]))
(cond
[(null? s1) '()]
[(null? s2) s1]
[else (rem* s2 s1)]))