* re-integrated the library-manager from the psyntax distro.

src/ikarus.hash-tables.ss

@@ -1,13 +1,14 @@
 
 (library (ikarus hash-tables)
-   (export hash-table? make-hash-table get-hash-table put-hash-table!)
+   (export hash-table? make-hash-table get-hash-table put-hash-table!
+           make-hashtable hashtable-ref hashtable-set!)
    (import 
      (ikarus system $pairs)
      (ikarus system $vectors)
      (ikarus system $tcbuckets)
      (ikarus system $fx)
      (except (ikarus) hash-table? make-hash-table get-hash-table
-             put-hash-table!))
+             make-hashtable put-hash-table! hashtable-ref hashtable-set!))
 
    (define-record hasht (vec count tc))
 
@@ -27,29 +28,6 @@
     (syntax-rules ()
       [(_ x) x]))
 
-  #;(define-syntax inthash
-    (syntax-rules ()
-      [(_ x) ($fxinthash x)]))
-
-  #;(define inthash
-    (lambda (key)
-      ;static int inthash(int key) { /* from Bob Jenkin's */
-      ;  key += ~(key << 15);
-      ;  key ^=  (key >> 10);
-      ;  key +=  (key << 3);
-      ;  key ^=  (key >> 6);
-      ;  key += ~(key << 11);
-      ;  key ^=  (key >> 16);
-      ;  return key;
-      ;}
-      (let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
-             [key ($fxlogxor key ($fxsra key 10))]
-             [key ($fx+ key ($fxsll key 3))]
-             [key ($fxlogxor key ($fxsra key 6))]
-             [key ($fx+ key ($fxlognot ($fxsll key 11)))]
-             [key ($fxlogxor key ($fxsra key 16))])
-        key)))
-
   ;;; assq-like lookup
   (define direct-lookup 
     (lambda (x b)
@@ -219,4 +197,8 @@
           (put-hash! h x v)
           (error 'put-hash-table! "~s is not a hash table" h))))
 
+  (define hashtable-ref get-hash-table)
+  (define hashtable-set! put-hash-table!)
+  (define make-hashtable make-hash-table)
+
 )

src/ikarus.io.output-strings.ss

@@ -1,6 +1,7 @@
 
 (library (ikarus io output-strings)
-  (export open-output-string get-output-string with-output-to-string)
+  (export open-output-string get-output-string with-output-to-string
+          open-string-output-port)
   (import 
     (ikarus system $strings)
     (ikarus system $bytevectors)
@@ -9,7 +10,8 @@
     (ikarus system $pairs)
     (ikarus system $ports)
     (ikarus system $io)
-    (except (ikarus) open-output-string get-output-string with-output-to-string))
+    (except (ikarus) open-output-string get-output-string with-output-to-string
+            open-string-output-port))
 
   (define-syntax message-case
     (syntax-rules (else)
@@ -165,5 +167,10 @@
         (parameterize ([current-output-port p]) (f))
         (get-output-string p))))
   
+  (define (open-string-output-port)
+    (let ([p (open-output-string)])
+      ;;; FIXME: should empty string
+      (values p (lambda () (get-output-string p)))))
+
 
 )

src/ikarus.lists.ss

@@ -3,14 +3,15 @@
   (export $memq list? list cons* make-list append length list-ref reverse
           last-pair memq memp memv member find assq assp assv assoc
           remq remv remove remp filter map for-each andmap ormap list-tail
-          partition)
+          partition for-all exists)
   (import 
     (ikarus system $fx)
     (ikarus system $pairs)
     (except (ikarus) list? list cons* make-list append reverse
             last-pair length list-ref memq memp memv member find
             assq assp assv assoc remq remv remove remp filter
-            map for-each andmap ormap list-tail partition))
+            map for-each andmap ormap list-tail partition
+            for-all exists))
 
   (define $memq
     (lambda (x ls)
@@ -851,5 +852,9 @@
            (error 'partition "~s is not a procedure" p))
          (race ls ls ls p))))
 
+  ;;; FIXME: lost in crash.
+  (define for-all andmap)
+  (define exists ormap)
+
   )
 

src/ikarus.syntax.ss

@@ -17,12 +17,13 @@
       environment environment? identifier?  eval
       generate-temporaries free-identifier=?  bound-identifier=?
       datum->syntax syntax->datum make-variable-transformer
-      null-environment)
+      null-environment define-record)
+    (psyntax compat)
     (rnrs base)
     (rnrs lists)
     (rnrs control)
     (rnrs io simple)
-    (except (ikarus library-manager) installed-libraries)
+    (except (psyntax library-manager) installed-libraries)
     (only (ikarus system $bootstrap) eval-core)
     (chez modules)
     (ikarus symbols)

src/makefile.ss

@@ -63,8 +63,7 @@
     "ikarus.fasl.write.ss"
     "ikarus.fasl.ss"
     "ikarus.compiler.ss"
-    "ikarus.library-manager.ss"
+    "psyntax.library-manager.ss"
-    ;"psyntax.library-manager.ss"
     "ikarus.syntax.ss"
     "ikarus.load.ss"
     "ikarus.pretty-print.ss"
@@ -217,7 +216,7 @@
     [foreign-call                                i]
     [type-descriptor                             i]
     [parameterize                                i parameters]
-    [define-record                               i r]
+    [define-record                               i]
     [include                                     i r]
     [time                                        i]
     [trace-lambda                                i]
@@ -2027,7 +2026,7 @@
   (let ([code `(library (ikarus primlocs)
                   (export) ;;; must be empty
                   (import 
-                    (only (ikarus library-manager)
+                    (only (psyntax library-manager)
                           install-library)
                     (only (ikarus compiler)
                           current-primitive-locations)

src/psyntax.library-manager.ss

@@ -1,25 +1,39 @@
+;;; Copyright (c) 2006, 2007 Abdulaziz Ghuloum and Kent Dybvig
+;;; 
+;;; Permission is hereby granted, free of charge, to any person obtaining a
+;;; copy of this software and associated documentation files (the "Software"),
+;;; to deal in the Software without restriction, including without limitation
+;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;;; and/or sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following conditions:
+;;; 
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;; 
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
+;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE. 
 
-
+(library (psyntax library-manager)
-
+  (export imported-label->binding library-subst installed-libraries
-(library (ikarus library-manager)
+    visit-library library-name library-exists? find-library-by-name
-  (export imported-label->binding library-subst
+    install-library library-spec invoke-library extend-library-subst!
-          installed-libraries visit-library
+    extend-library-env! current-library-expander current-library-collection)
-          library-name
+  (import (rnrs) (psyntax compat) (rnrs r5rs))
-          find-library-by-name install-library
-          library-spec invoke-library 
-          extend-library-subst! extend-library-env!
-          current-library-expander current-library-collection)
-  (import (except (ikarus) installed-libraries))
 
   (define (make-collection)
-    (let ([set '()])
+    (let ((set '()))
       (define (set-cons x ls)
         (cond
-          [(memq x ls) ls]
+          ((memq x ls) ls)
-          [else (cons x ls)]))
+          (else (cons x ls))))
       (case-lambda
-        [() set]
+        (() set)
-        [(x) (set! set (set-cons x set))])))
+        ((x) (set! set (set-cons x set))))))
 
   (define current-library-collection
     ;;; this works now because make-collection is a lambda
@@ -33,80 +47,87 @@
         x)))
 
   (define-record library 
-    (id name ver imp* vis* inv* subst env visit-state invoke-state
+    (id name ver imp* vis* inv* subst env visit-state invoke-state visible?)
-        visible?))
+    (lambda (x p)
+      (unless (library? x)
+        (error 'record-type-printer "not a library"))
+      (display 
+        (format "#<library ~s>" (append (library-name x) (library-ver x)))
+        p)))
 
   (define (find-dependencies ls)
     (cond
-      [(null? ls) '()]
+      ((null? ls) '())
-      [else (error 'find-dependencies "cannot handle deps yet")]))
+      (else (error 'find-dependencies "cannot handle deps yet"))))
 
   (define (find-library-by pred)
-    (let f ([ls ((current-library-collection))])
+    (let f ((ls ((current-library-collection))))
       (cond
-        [(null? ls) #f]
+        ((null? ls) #f)
-        [(pred (car ls)) (car ls)]
+        ((pred (car ls)) (car ls))
-        [else (f (cdr ls))])))
+        (else (f (cdr ls))))))
 
   (define library-path
     (make-parameter
       '(".")
       (lambda (x)
-        (if (and (list? x) (andmap string? x))
+        (if (and (list? x) (for-all string? x))
-            (map values x)
+            ;(map values x)
+            (map (lambda (x) x) x)
             (error 'library-path "~s is not a list of strings" x)))))
   
   (define (library-name->file-name x) 
-    (with-output-to-string
+    (let-values (((p extract) (open-string-output-port)))
-      (lambda ()
       (define (display-hex n)
         (cond
-            [(<= 0 n 9) (display n)]
+          ((<= 0 n 9) (display n p))
-            [else (display 
+          (else (display 
                   (integer->char 
                     (+ (char->integer #\A)
-                         (- n 10))))]))
+                       (- n 10)))
-        (let f ([ls x])
+                  p))))
+      (let f ((ls x))
         (cond
-            [(null? ls) (display ".ss")]
+          ((null? ls) (display ".ss" p))
-            [else
+          (else
-             (display "/")
+           (display "/" p)
            (for-each
              (lambda (c)
                (cond
-                   [(or (char<=? #\a c #\z) 
+                 ((or (char<=? #\a c #\z)
                       (char<=? #\A c #\Z)
                       (char<=? #\0 c #\9)
                       (memv c '(#\- #\. #\_ #\~)))
-                    (display c)]
+                  (display c p))
-                   [else
+                 (else
-                    (display "%")
+                  (display "%" p)
-                    (let ([n (char->integer c)])
+                  (let ((n (char->integer c)))
                     (display-hex (quotient n 16))
-                      (display-hex (remainder n 16)))]))
+                    (display-hex (remainder n 16))))))
              (string->list 
                (symbol->string (car ls))))
-             (f (cdr ls))])))))
+           (f (cdr ls)))))
+      (extract)))
+
   (define file-locator
     (make-parameter
       (lambda (x)
-        (let ([str (library-name->file-name x)])
+        (let ((str (library-name->file-name x)))
-          (let f ([ls (library-path)])
+          (let f ((ls (library-path)))
             (and (pair? ls)
-                 (let ([name (string-append (car ls) str)])
+                 (let ((name (string-append (car ls) str)))
                    (if (file-exists? name)
                        name
                        (f (cdr ls))))))))
       (lambda (f)
         (if (procedure? f)
             f
-            (error 'file-locator 
+            (error 'file-locator "~s is not a procedure" f)))))
-               "~s is not a procedure" f)))))
 
   (define library-locator
     (make-parameter
       (lambda (x)
-        (let ([file-name ((file-locator) x)])
+        (let ((file-name ((file-locator) x)))
           (and (string? file-name)
                (with-input-from-file file-name read))))
       (lambda (f)
@@ -132,9 +153,9 @@
     (when (member name (external-pending-libraries))
       (error #f "circular attempt to import library ~s detected"
              name))
-    (parameterize ([external-pending-libraries
+    (parameterize ((external-pending-libraries
-                    (cons name (external-pending-libraries))])
+                    (cons name (external-pending-libraries))))
-      (let ([lib-expr ((library-locator) name)])
+      (let ((lib-expr ((library-locator) name)))
         (unless lib-expr 
           (error #f "cannot find library ~s" name))
         ((current-library-expander) lib-expr)
@@ -153,41 +174,43 @@
          #t))
 
   (define (find-library-by-spec/die spec)
-    (let ([id (car spec)])
+    (let ((id (car spec)))
       (or (find-library-by
             (lambda (x) (eq? id (library-id x))))
           (error #f "cannot find library with spec ~s" spec))))
 
-  (define label->binding-table (make-hash-table))
+  (define label->binding-table (make-hashtable))
 
   (define (install-library-record lib)
-    (let ([exp-env (library-env lib)])
+    (let ((exp-env (library-env lib)))
       (for-each 
         (lambda (x) 
-          (let ([label (car x)] [binding (cdr x)])
+          (let ((label (car x)) (binding (cdr x)))
-            (let ([binding 
+            (let ((binding 
                    (case (car binding)
-                     [(global) 
+                     ((global) 
-                      (cons 'global (cons lib (cdr binding)))]
+                      (cons 'global (cons lib (cdr binding))))
-                     [(global-macro)
+                     ((global-macro)
-                      (cons 'global-macro (cons lib (cdr binding)))]
+                      (cons 'global-macro (cons lib (cdr binding))))
-                     [else binding])])
+                     ((global-macro!)
-              (put-hash-table! label->binding-table label binding))))
+                      (cons 'global-macro! (cons lib (cdr binding))))
+                     (else binding))))
+              (hashtable-set! label->binding-table label binding))))
         exp-env))
     ((current-library-collection) lib))
 
   (define (install-library id name ver imp* vis* inv* 
             exp-subst exp-env visit-code invoke-code visible?)
-    (let ([imp-lib* (map find-library-by-spec/die imp*)]
+    (let ((imp-lib* (map find-library-by-spec/die imp*))
-          [vis-lib* (map find-library-by-spec/die vis*)]
+          (vis-lib* (map find-library-by-spec/die vis*))
-          [inv-lib* (map find-library-by-spec/die inv*)])
+          (inv-lib* (map find-library-by-spec/die inv*)))
       (unless (and (symbol? id) (list? name) (list? ver))
         (error 'install-library "invalid spec ~s ~s ~s" id name ver))
       (when (library-exists? name)
         (error 'install-library "~s is already installed" name))
-      (let ([lib (make-library id name ver imp-lib* vis-lib* inv-lib* 
+      (let ((lib (make-library id name ver imp-lib* vis-lib* inv-lib* 
                     exp-subst exp-env visit-code invoke-code 
-                    visible?)])
+                    visible?)))
         (install-library-record lib))))
 
   (define extend-library-subst!
@@ -199,13 +222,13 @@
     (lambda (lib label binding)
       (set-library-env! lib
         (cons (cons label binding) (library-env lib)))
-      (put-hash-table! label->binding-table label binding)))
+      (hashtable-set! label->binding-table label binding)))
 
   (define (imported-label->binding lab)
-    (get-hash-table label->binding-table lab #f))
+    (hashtable-ref label->binding-table lab #f))
 
   (define (invoke-library lib)
-    (let ([invoke (library-invoke-state lib)])
+    (let ((invoke (library-invoke-state lib)))
       (when (procedure? invoke)
         (set-library-invoke-state! lib 
           (lambda () (error 'invoke "circularity detected for ~s" lib)))
@@ -217,7 +240,7 @@
 
 
   (define (visit-library lib)
-    (let ([visit (library-visit-state lib)])
+    (let ((visit (library-visit-state lib)))
       (when (procedure? visit)
         (set-library-visit-state! lib 
           (lambda () (error 'visit "circularity detected for ~s" lib)))
@@ -233,29 +256,19 @@
 
   (define installed-libraries 
     (case-lambda
-      [(all?)
+      ((all?)
-       (let f ([ls ((current-library-collection))])
+       (let f ((ls ((current-library-collection))))
          (cond
-           [(null? ls) '()]
+           ((null? ls) '())
-           [(or all? (library-visible? (car ls)))
+           ((or all? (library-visible? (car ls)))
-            (cons (car ls) (f (cdr ls)))]
+            (cons (car ls) (f (cdr ls))))
-           [else (f (cdr ls))]))]
+           (else (f (cdr ls))))))
-      [() (installed-libraries #f)]))
+      (() (installed-libraries #f))))
 
   (define library-spec       
     (lambda (x) 
       (unless (library? x)
         (error 'library-spec "~s is not a library" x))
       (list (library-id x) (library-name x) (library-ver x)))) 
-
-  ;;; init
-  (set-rtd-printer! (type-descriptor library)
-    (lambda (x p)
-      (unless (library? x)
-        (error 'record-type-printer "not a library"))
-      (display 
-        (format "#<library ~s>" (append (library-name x) (library-ver x)))
-        p)))
-
   )
 

src/psyntax/compat.ss

@@ -0,0 +1,17 @@
+
+(library (psyntax compat)
+  (export define-record make-parameter parameterize format)
+  (import 
+    (rename (ikarus) (define-record sys.define-record)))
+
+  (define-syntax define-record
+    (syntax-rules ()
+      [(_ name (field* ...) printer)
+       (begin
+         (sys.define-record name (field* ...))
+         (module ()
+            (set-rtd-printer! (type-descriptor name)
+              printer)))]
+      [(_ name (field* ...))
+       (sys.define-record name (field* ...))])))
+