diff --git a/R6RS-TODO.txt b/R6RS-TODO.txt deleted file mode 100644 index da079bf..0000000 --- a/R6RS-TODO.txt +++ /dev/null @@ -1,89 +0,0 @@ - - -TODO for (R6RS BASE) - -* Compiler + libraries: - - letrec and letrec* restrictions (references and multiple returns) - - prohibit export of mutable bindings - - library versioning - - library phases (simply ignore) - - internal imports - - Recognize (define x) - - Add identifier-syntax - - Add do, let*-values. - -* Numerics: - - Add rational, complex, and single-precision numbers - - Make sure the following primitives work: - - rationalize - - make-rectangular make-polar - real-part imag-part - magnitude angle - - expt log - sin cos tan - asin acos atan - - sqrt exact-integer-sqrt - - number? complex? real? rational? integer? - real-valued? rational-valued? integer-values? - - exact? inexact? ->exact ->inexact - - real->flonum real->single real->double - - = < <= > >= - zero? positive? negative? - odd? even? - finite? infinite? nan? - min max abs - - + - * / - - div mod div-and-mod - div0 mod0 div0-and-mod0 - - gcd lcm (don't deal with inexact ints yet) - - floor ceiling truncate round - - number->string(radix,precision) string->number(radix) - -* Read: - - recognize rational, complex and flonum syntax - - recognize inline-hex sequences (strings, chars, and symbols) - - #!r6rs - - #\ sequnces: nul, alarm, backspace, tab, linefeed, vtab, page, - return, esc, space, delete - - respect unicode constituents - - recognize \a, \b, \t, \n, \v, \f, \r, \", \\, \, \, - \xXXX; sequences in strings. - - Add unsyntax, unsyntax-splicing, and quasisyntax. - -* Bytevectors: - - equal? for bytevectors - -* Strings: - - string-copy - - string-fill! - -* Vectors: - - vector-fill! - - vector-map - - vector-for-each - -* Errors: - - (error who msg irritants ...) - - (assertion-violation who message irritants ...) - - - - - - -Completed for (R6RS BASE): - - Add let-syntax and letrec-syntax - numerator denominator diff --git a/TODO b/TODO deleted file mode 100644 index fa6b49d..0000000 --- a/TODO +++ /dev/null @@ -1,32 +0,0 @@ -* Fix pretty-print to handle shared/cyclic data. -* Fix pretty-print to print records properly. - -CHECK * Recognize calls to call-with-values where the second argument is a - case-lambda and handle them sensibly. - -* Guardians: -CHECK - Implement guardians. -CHECK - clean up after file ports are dead by flushing/closing the - underlying file handle. - - Flush and close output-port on exit. - -* Interrupts: -CHECK - pcb should have an engine-counter field that's decremented on - every procedure call. -CHECK - a do-event procedure must be called when the counter goes - negative. It should capture the current continuation and - reschedule the process. -CHECK - figure out what to do when a process gets interrupted while - reading from a file. -CHECK - Implement [CTRL-C] keyboard interruption with the ability to - resume the computation, reset to the repl, or terminate the - program (at least for now). - -* FFI: - - provide a general mechanism for calling foreign procedures - without having to extend the VM. - (foreign-call void: FOO int32: x char*: y ptr: z) - - may dump the bignum stuff in the VM and move it to scheme. - -CHECK * Read-invariant gensym. - diff --git a/scheme/asm-tests.ss b/lab/asm-tests.ss similarity index 100% rename from scheme/asm-tests.ss rename to lab/asm-tests.ss diff --git a/scheme/dotests.ss b/scheme/dotests.ss deleted file mode 100755 index 123a61d..0000000 --- a/scheme/dotests.ss +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/env ikarus --script - -;;; Ikarus Scheme -- A compiler for R6RS Scheme. -;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License version 3 as -;;; published by the Free Software Foundation. -;;; -;;; This program is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(import scheme) - -(define (test-one input str) - (printf " T: ~s " input) - (let ([v0 (eval input)]) - (printf "c") -; (collect) - (let ([v1 (alt-compile input)]) - (printf "r") - (if (equal? v0 v1) - (printf "d ok\n") - (error "values differed, expected ~s, got ~s" v0 v1))))) - - - -(define-syntax add-tests-with-string-output - (syntax-rules (=>) - [(_ name [test => res] ...) - (begin - (printf "TESTING ~a ...\n" 'name) - (test-one 'test 'res) ... - (printf "OK\n"))])) - -(load "tests/tests-1.1-req.scm") -(load "tests/tests-1.2-req.scm") -(load "tests/tests-1.3-req.scm") -(load "tests/tests-1.4-req.scm") -(load "tests/tests-1.5-req.scm") -(load "tests/tests-1.6-req.scm") -(load "tests/tests-1.7-req.scm") -(load "tests/tests-1.8-req.scm") -(load "tests/tests-1.9-req.scm") -(load "tests/tests-2.1-req.scm") -(load "tests/tests-2.2-req.scm") -(load "tests/tests-2.3-req.scm") -(load "tests/tests-2.4-req.scm") -(load "tests/tests-2.6-req.scm") -(load "tests/tests-4.1-req.scm") -(load "tests/tests-new.scm") -;(load "tests/tests-5.2-req.scm") -;(load "tests/tests-5.3-req.scm") -(printf "HAPPY HAPPY JOY JOY\n") -(exit) diff --git a/scheme/ikarus.hash-tables.ss b/scheme/ikarus.hash-tables.ss index 18ae537..67aecfd 100644 --- a/scheme/ikarus.hash-tables.ss +++ b/scheme/ikarus.hash-tables.ss @@ -15,23 +15,23 @@ (library (ikarus hash-tables) - (export make-eq-hashtable hashtable-ref hashtable-set! hashtable? - hashtable-size hashtable-delete! hashtable-contains? - hashtable-update! hashtable-keys hashtable-mutable? - hashtable-clear! hashtable-entries hashtable-copy - string-hash string-ci-hash symbol-hash) - (import - (ikarus system $pairs) - (ikarus system $vectors) - (ikarus system $tcbuckets) - (ikarus system $fx) - (except (ikarus) make-eq-hashtable hashtable-ref hashtable-set! hashtable? - hashtable-size hashtable-delete! hashtable-contains? - hashtable-update! hashtable-keys hashtable-mutable? - hashtable-clear! hashtable-entries hashtable-copy - string-hash string-ci-hash symbol-hash)) + (export make-eq-hashtable hashtable-ref hashtable-set! hashtable? + hashtable-size hashtable-delete! hashtable-contains? + hashtable-update! hashtable-keys hashtable-mutable? + hashtable-clear! hashtable-entries hashtable-copy + string-hash string-ci-hash symbol-hash) + (import + (ikarus system $pairs) + (ikarus system $vectors) + (ikarus system $tcbuckets) + (ikarus system $fx) + (except (ikarus) make-eq-hashtable hashtable-ref hashtable-set! hashtable? + hashtable-size hashtable-delete! hashtable-contains? + hashtable-update! hashtable-keys hashtable-mutable? + hashtable-clear! hashtable-entries hashtable-copy + string-hash string-ci-hash symbol-hash)) - (define-struct hasht (vec count tc mutable?)) + (define-struct hasht (vec count tc mutable?)) ;;; directly from Dybvig's paper (define tc-pop @@ -45,10 +45,6 @@ ($set-cdr! x #f) v))))) - (define-syntax inthash - (syntax-rules () - [(_ x) x])) - ;;; assq-like lookup (define direct-lookup (lambda (x b) @@ -108,19 +104,17 @@ ($set-tcbucket-tconc! b (hasht-tc h)) ;;; then add it to the new place (let ([k ($tcbucket-key b)]) - (let ([ih (inthash (pointer-value k))]) + (let ([ih (pointer-value k)]) (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))]) (let ([n ($vector-ref vec idx)]) ($set-tcbucket-next! b n) ($vector-set! vec idx b) (void)))))))) - - (define (get-bucket h x) (let ([pv (pointer-value x)] [vec (hasht-vec h)]) - (let ([ih (inthash pv)]) + (let ([ih pv]) (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))]) (let ([b ($vector-ref vec idx)]) (or (direct-lookup x b) @@ -132,7 +126,7 @@ (lambda (b) ($tcbucket-val b))] [else v])) - (define (in-hash? h x) + (define (in-hash? h x) (and (get-bucket h x) #t)) (define (del-hash h x) @@ -164,7 +158,7 @@ (lambda (h x v) (let ([pv (pointer-value x)] [vec (hasht-vec h)]) - (let ([ih (inthash pv)]) + (let ([ih pv]) (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))]) (let ([b ($vector-ref vec idx)]) (cond @@ -178,7 +172,7 @@ ($make-tcbucket (hasht-tc h) x v ($vector-ref vec idx))]) (if ($fx= (pointer-value x) pv) ($vector-set! vec idx bucket) - (let* ([ih (inthash (pointer-value x))] + (let* ([ih (pointer-value x)] [idx ($fxlogand ih ($fx- ($vector-length vec) 1))]) ($set-tcbucket-next! bucket ($vector-ref vec idx)) @@ -187,8 +181,6 @@ (set-hasht-count! h ($fxadd1 ct)) (when ($fx> ct ($vector-length vec)) (enlarge-table h)))]))))))) - - (define (update-hash! h x proc default) (cond @@ -196,13 +188,11 @@ (lambda (b) ($set-tcbucket-val! b (proc ($tcbucket-val b))))] [else (put-hash! h x (proc default))])) - - (define insert-b (lambda (b vec mask) (let* ([x ($tcbucket-key b)] [pv (pointer-value x)] - [ih (inthash pv)] + [ih pv] [idx ($fxlogand ih mask)] [next ($tcbucket-next b)]) ($set-tcbucket-next! b ($vector-ref vec idx)) @@ -330,7 +320,6 @@ (get-hash h x v) (error 'hashtable-ref "not a hash table" h)))) - (define hashtable-contains? (lambda (h x) (if (hasht? h) @@ -345,7 +334,6 @@ (error 'hashtable-set! "hashtable is immutable" h)) (error 'hashtable-set! "not a hash table" h)))) - (define hashtable-update! (lambda (h x proc default) (if (hasht? h) @@ -356,7 +344,6 @@ (error 'hashtable-update! "hashtable is immutable" h)) (error 'hashtable-update! "not a hash table" h)))) - (define hashtable-size (lambda (h) (if (hasht? h) @@ -398,13 +385,13 @@ (define hashtable-copy (case-lambda [(h) - (if (hasht? h) + (if (hasht? h) (if (hasht-mutable? h) (hasht-copy h #f) h) (error 'hashtable-copy "not a hash table" h))] [(h mutable?) - (if (hasht? h) + (if (hasht? h) (if (or mutable? (hasht-mutable? h)) (hasht-copy h (and mutable? #t)) h) diff --git a/scheme/r6rs-records.ss b/scheme/r6rs-records.ss deleted file mode 100644 index 4df2f1d..0000000 --- a/scheme/r6rs-records.ss +++ /dev/null @@ -1,52 +0,0 @@ -;;; procedural layer: - - -(make-record-type-descriptor name parent uid sealed? opaque? fields) -;;; name is a symbol, for informational purposes only -;;; parent is #f or an rtd -;;; uid is #f or symbol. -;;; symbol => nongenerative (or interned by that name) -;;; #f => generative (can use a gensym for uid) -;;; if parent is sealed?, then it cannot be extended, -;;; therefore, parent must not be sealed. -;;; if parent is opaque, then so is the rtd (overrides opaque?) -;;; if parent is not opaque, then use opaque? -;;; fields is a vector where each element is either: -;;; (mutable ) or (immutable ) -;;; symbols need not be unique, they're informational. - -(record-type-descriptor? x) -;;; self explanatory. - -(make-record-constructor-descriptor - rtd parent-constructor-descriptor protocol) -;;; returns a record constructor descriptor -;;; protocol is either a procedure or #f -;;; if rtd has no parent, then protocol must be #f -;;; typical protocol procedure is: -;;; (lambda (new) -;;; (lambda (bar baz) ;;; constructor of 2 args -;;; ;;; for a record of three fields -;;; (new bar baz (* bar baz)))) -;;; default protocol procedure is (lambda (new) new) -;;; an extension protocol is typically: -;;; (lambda (parent-new) -;;; (lambda (px py pz x y z) -;;; (let ([new (parent-new px py pz)]) -;;; (new x y z)))) -;;; or (lambda (parent-new) -;;; (lambda (px py pz x y z) -;;; ((parent-new px py pz) x y z))) -;;; - - -(record-constructor rcd) -;;; returns a procedure that constructs records. The number of -;;; arguments that the procedure takes is the same number of -;;; arguments in the protocol's inner lambda. - -(record-predicate rtd) ;=> predicate procedure. -(record-accessor rtd k) ;=> accessor procedure. -(record-mutator rtd k) ;=> mutator procedure. - -