10 files changed, 185 insertions, 373 deletions

@@ -0,0 +1,20 @@
+;;; chicanery/impl/chicken -*- geiser-scheme-implementation: chicken -*-
+
+(module (chicanery base) ()
+  (import-for-syntax r7rs)
+  (import scheme (chicken module))
+  (reexport (scheme base)
+            (scheme case-lambda)
+            (scheme char)
+            (scheme complex)
+            (scheme cxr)
+            (scheme eval)
+            (scheme file)
+            (scheme inexact)
+            (scheme lazy)
+            (scheme load)
+            (scheme process-context)
+            (scheme read)
+            (scheme repl)
+            (scheme time)
+            (scheme write)))
@@ -2,15 +2,25 @@
 
 ((synopsis "Subtly breaking scheme expectations.")
  (author "Case Duckworth")
- (version "0.2.0")
+ (version "0.3.0")
  (license "God Willing License")
  (category lang-exts)
  (dependencies r7rs utf8)
  (components
-  (extension chicanery
-             (source chicanery.sld)
+  (extension chicanery.base
+             (source chicanery.base.scm)
              (types-file)               ; I don't know what this does ...
              (inline-file)
              (csc-options "-X" "r7rs" "-R" "r7rs"
-                          "-X" "utf8" "-R" "utf8"
-                          "-no-warnings"))))
+                          "-X" "utf8" "-R" "utf8"))
+  (extension chicanery.extras
+             (source chicanery.extras.scm)
+             (component-dependencies chicanery.base)
+             (types-file)
+             (inline-file))
+  (extension chicanery
+             (source chicanery.scm)
+             (component-dependencies chicanery.base
+                                     chicanery.extras)
+             (types-file)
+             (inline-file))))
@@ -0,0 +1,145 @@
+(module (chicanery extras) ( append for-each map
+                             list-append list-for-each list-map
+                             ref copy
+                             atom? defined?
+                             read-port-chunk-size read-port
+                             with-output-to-string with-input-from-string
+                             displayed written print ->string)
+  (import scheme (chicanery base))
+
+  (define list-append append)
+  (define list-for-each for-each)
+  (define list-map map)
+
+  (define (map proc . collections)
+    (let ((first (car collections)))    ; we only need to check the first one
+      (cond
+       ((list? first)
+        (apply list-map proc collections))
+       ((vector? first)
+        (apply vector-map proc collections))
+       ((string? first)
+        (apply string-map proc collections))
+       (else (error "Bad datatype" first)))))
+
+  (define (for-each proc . collections)
+    (let ((first (car collections)))    ; we only need to check the first one
+      (cond
+       ((list? first)
+        (apply list-for-each proc collections))
+       ((vector? first)
+        (apply vector-for-each proc collections))
+       ((string? first)
+        (apply string-for-each proc collections))
+       (else (error "Bad datatype" first)))))
+
+  (define (append . collections)
+    (let ((first (car collections)))    ; we only need to check the first one
+      (cond
+       ((list? first)
+        (apply list-append collections))
+       ((vector? first)
+        (apply vector-append collections))
+       ((string? first)
+        (apply string-append collections))
+       ((bytevector? first)
+        (apply bytevector-append collections))
+       (else (error "Bad datatype" first)))))
+
+;;; Extended generic functions.
+  ;; These functions already have a list- version defined, but no non-prefixed
+  ;; one.  So I'm fixing that.
+  (define (ref collection k)
+    (cond
+     ((list? collection)
+      (list-ref collection k))
+     ((vector? collection)
+      (vector-ref collection k))
+     ((string? collection)
+      (string-ref collection k))
+     ((bytevector? collection)
+      (bytevector-u8-ref collection k))
+     (else (error "Bad datatype" collection))))
+
+  ;; I'm not going to generalize -copy! because I don't think it's a great idea,
+  ;; really.
+  (define (copy collection)
+    (cond
+     ((list? collection)
+      (list-copy collection))
+     ((vector? collection)
+      (vector-copy collection))
+     ((string? collection)
+      (string-copy collection))
+     ((bytevector? collection)
+      (bytevector-copy collection))
+     (else (error "Bad datatype" collection))))
+
+;;; Definitions that should be in scheme
+;; This sections should be as small as possible
+
+  (define (atom? x)
+    (and (not (pair? x))
+         (not (null? x))))
+
+  (define read-port-chunk-size
+    (make-parameter 512))
+
+  (define (%read-port port)
+    (let ((chunk-size (read-port-chunk-size)))
+      (let loop ((next (read-string chunk-size port))
+                 (blank? #f)
+                 (acc '()))
+        (cond
+         ((or (eof-object? next)
+              (and blank? (equal? next "")))
+          (apply string-append (reverse acc)))
+         ((equal? next "")
+          (loop (read-string chunk-size port)
+                #t
+                (cons next acc)))
+         (else
+          (loop (read-string chunk-size port)
+                blank?
+                (cons next acc)))))))
+
+  (define read-port
+    (case-lambda
+      (() (%read-port (current-input-port)))
+      ((p) (%read-port p))))
+
+  (define (defined? sym)
+    (call-with-current-continuation
+     (lambda (k)
+       (with-exception-handler
+           (lambda (e) (k #f))
+         (lambda ()
+           (eval sym (interaction-environment))
+           #t)))))
+
+  (define (with-output-to-string thunk)
+    (call-with-port (open-output-string)
+      (lambda (port)
+        (parameterize ((current-output-port port))
+          (thunk))
+        (get-output-string port))))
+
+  (define (with-input-from-string s thunk)
+    (call-with-port (open-input-string s)
+      (lambda (port)
+        (parameterize ((current-input-port port))
+          (thunk)))))
+
+  (define (displayed x)
+    (with-output-to-string
+      (lambda () (display x))))
+
+  (define (written x)
+    (with-output-to-string
+      (lambda () (write x))))
+
+  (define (print . xs)
+    (for-each display xs)
+    (newline))
+
+  (define ->string displayed))
@@ -0,0 +1,5 @@
+(module chicanery ()
+  (import scheme (chicken module))
+  (reexport (chicanery base)
+            (chicanery extras)))
+
@@ -1,23 +0,0 @@
-(cond-expand
-  (chicken
-   (include "impl/chicken.scm"))
-  (guile
-   (install-r7rs!)
-   (include "impl/guile.scm")
-   (include "extras.scm")
-   (export! append for-each map
-            list-append list-for-each list-map
-            ref copy
-            atom?
-            read-port read-port-chunk-size
-            defined?
-            with-output-to-string with-input-from-string
-            displayed ->string written
-            print))
-  (gambit
-   (include "impl/gambit.scm"))
-  (r7rs
-   (display "R7RS!\n")
-   (define-library (chicanery)
-     (include "impl/r7rs.scm")))
-  (else (exit #f)))
@@ -1,138 +0,0 @@
-;;; Extras
-(display "EXTRAS!\n")
-(define list-append append)
-(define list-for-each for-each)
-(define list-map map)
-
-(define (map proc . collections)
-  (let ((first (car collections)))    ; we only need to check the first one
-    (cond
-     ((list? first)
-      (apply list-map proc collections))
-     ((vector? first)
-      (apply vector-map proc collections))
-     ((string? first)
-      (apply string-map proc collections))
-     (else (error "Bad datatype" first)))))
-
-(define (for-each proc . collections)
-  (let ((first (car collections)))    ; we only need to check the first one
-    (cond
-     ((list? first)
-      (apply list-for-each proc collections))
-     ((vector? first)
-      (apply vector-for-each proc collections))
-     ((string? first)
-      (apply string-for-each proc collections))
-     (else (error "Bad datatype" first)))))
-
-(define (append . collections)
-  (let ((first (car collections)))    ; we only need to check the first one
-    (cond
-     ((list? first)
-      (apply list-append collections))
-     ((vector? first)
-      (apply vector-append collections))
-     ((string? first)
-      (apply string-append collections))
-     ((bytevector? first)
-      (apply bytevector-append collections))
-     (else (error "Bad datatype" first)))))
-
-;;; Extended generic functions.
-;; These functions already have a list- version defined, but no non-prefixed
-;; one.  So I'm fixing that.
-(define (ref collection k)
-  (cond
-   ((list? collection)
-    (list-ref collection k))
-   ((vector? collection)
-    (vector-ref collection k))
-   ((string? collection)
-    (string-ref collection k))
-   ((bytevector? collection)
-    (bytevector-u8-ref collection k))
-   (else (error "Bad datatype" collection))))
-
-;; I'm not going to generalize -copy! because I don't think it's a great idea,
-;; really.
-(define (copy collection)
-  (cond
-   ((list? collection)
-    (list-copy collection))
-   ((vector? collection)
-    (vector-copy collection))
-   ((string? collection)
-    (string-copy collection))
-   ((bytevector? collection)
-    (bytevector-copy collection))
-   (else (error "Bad datatype" collection))))
-
-;;; Definitions that should be in scheme
-;; This sections should be as small as possible
-
-(define (atom? x)
-  (and (not (pair? x))
-       (not (null? x))))
-
-(define read-port-chunk-size
-  (make-parameter 512))
-
-(define (%read-port port)
-  (let ((chunk-size (read-port-chunk-size)))
-    (let loop ((next (read-string chunk-size port))
-               (blank? #f)
-               (acc '()))
-      (cond
-       ((or (eof-object? next)
-            (and blank? (equal? next "")))
-        (apply string-append (reverse acc)))
-       ((equal? next "")
-        (loop (read-string chunk-size port)
-              #t
-              (cons next acc)))
-       (else
-        (loop (read-string chunk-size port)
-              blank?
-              (cons next acc)))))))
-
-(define read-port
-  (case-lambda
-    (() (%read-port (current-input-port)))
-    ((p) (%read-port p))))
-
-(define (defined? sym)
-  (call-with-current-continuation
-   (lambda (k)
-     (with-exception-handler
-         (lambda (e) (k #f))
-       (lambda ()
-         (eval sym (interaction-environment))
-         #t)))))
-
-(define (with-output-to-string thunk)
-  (call-with-port (open-output-string)
-    (lambda (port)
-      (parameterize ((current-output-port port))
-        (thunk))
-      (get-output-string port))))
-
-(define (with-input-from-string s thunk)
-  (call-with-port (open-input-string s)
-    (lambda (port)
-      (parameterize ((current-input-port port))
-        (thunk)))))
-
-(define (displayed x)
-  (with-output-to-string
-    (lambda () (display x))))
-
-(define (written x)
-  (with-output-to-string
-    (lambda () (write x))))
-
-(define (print . xs)
-  (for-each display xs)
-  (newline))
-
-(define ->string displayed)
@@ -1,40 +0,0 @@
-;;; chicanery/impl/chicken -*- geiser-scheme-implementation: chicken -*-
-
-(module chicanery ()
-  (import (scheme base)
-          (scheme eval)
-          (srfi 1)
-          (chicken module))
-  (import-for-syntax r7rs)
-  (reexport (scheme base)
-            (scheme case-lambda)
-            (scheme char)
-            (scheme complex)
-            (scheme cxr)
-            (scheme eval)
-            (scheme file)
-            (scheme inexact)
-            (scheme lazy)
-            (scheme load)
-            (scheme process-context)
-            (scheme read)
-            (scheme repl)
-            (scheme time)
-            (scheme write))
-
-  (define env (environment '(only chicken.base exit)))
-  (##sys#current-environment (##sys#slot env 2))
-  (##sys#macro-environment (filter-map
-                            (lambda (e)
-                              (and (list? e) e))
-                            (##sys#slot env 2)))
-  (include "../extras.scm")
-  (export append for-each map
-          list-append list-for-each list-map
-          ref copy
-          atom?
-          read-port read-port-chunk-size
-          defined?
-          with-output-to-string with-input-from-string
-          displayed ->string written
-          print))
@@ -1,7 +0,0 @@
-;;; -*- geiser-scheme-implementation: gambit -*-
-
-(##include "~~lib/r7rs#.scm")
-
-(define-library (chicanery)
-  (include-library-declarations "r7rs.scm")
-  (namespace ""))
@@ -1,76 +0,0 @@
-;;; chicanery/impl/guile.scm -*- geiser-scheme-implementation: guile -*-
-
-;; XXX : Apparently this doesn't work. I don't know.
-
-(define-module (chicanery))
-
-(use-modules (scheme base)
-             (scheme case-lambda)
-             (scheme char)
-             (scheme complex)
-             (scheme cxr)
-             (scheme eval)
-             (scheme file)
-             (scheme inexact)
-             (scheme lazy)
-             (scheme load)
-             (scheme process-context)
-             (scheme read)
-             (scheme repl)
-             (scheme time)
-             (scheme write))
-
-(export! * + - / < <= = > >= abs acos and angle #;append apply asin
-         assoc assq assv atan begin binary-port? boolean=? boolean? bytevector
-         bytevector-append bytevector-copy bytevector-copy! bytevector-length
-         bytevector-u8-ref bytevector-u8-set! bytevector? caaaar caaadr caaar
-         caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
-         call-with-current-continuation call-with-input-file
-         call-with-output-file call-with-port call-with-values call/cc car
-         case case-lambda cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar
-         cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer
-         char-alphabetic? char-ci<=?  char-ci<? char-ci=?  char-ci>=?
-         char-ci>? char-downcase char-foldcase char-lower-case?  char-numeric?
-         char-ready? char-upcase char-upper-case?  char-whitespace?  char<=?
-         char<? char=? char>=? char>? char? close-input-port close-output-port
-         close-port command-line complex? cond cond-expand cons cos
-         current-error-port current-input-port current-jiffy
-         current-output-port current-second define define-record-type
-         define-syntax define-values delay delay-force delete-file denominator
-         digit-value display do dynamic-wind emergency-exit environment
-         eof-object eof-object? eq? equal? eqv? error error-object-irritants
-         error-object-message error-object? eval even? exact
-         exact-integer-sqrt exact-integer? exact? exit exp expt features
-         file-error?  file-exists? finite? floor floor-quotient
-         floor-remainder floor/ flush-output-port #;for-each force gcd
-         get-environment-variable get-environment-variables
-         get-output-bytevector get-output-string guard if imag-part import
-         include include-ci inexact inexact? infinite? input-port-open?
-         input-port? integer->char integer?  interaction-environment
-         jiffies-per-second lambda lcm length let let* let*-values let-syntax
-         let-values letrec letrec* letrec-syntax list list->string magnitude
-         make-bytevector make-list make-parameter make-polar make-promise
-         make-rectangular make-string make-vector #;map max member memq memv min
-         modulo negative? newline not null? number->string number?  numerator
-         odd? open-binary-input-file open-binary-output-file
-         open-input-bytevector open-input-file open-input-string
-         open-output-bytevector open-output-file open-output-string or
-         output-port-open? output-port? pair?  parameterize peek-char peek-u8
-         port?  positive? procedure? promise? quasiquote quote quotient raise
-         raise-continuable rational? rationalize read read-bytevector
-         read-bytevector! read-char read-error? read-line read-string read-u8
-         real-part real? remainder reverse round set! set-car! set-cdr! sin
-         sqrt square string string->list string->number string->symbol
-         string->utf8 string->vector string-append string-ci<=? string-ci<?
-         string-ci=?  string-ci>=?  string-ci>? string-copy string-copy!
-         string-downcase string-fill!  string-foldcase string-for-each
-         string-length string-map string-ref string-set!  string-upcase
-         string<=? string<? string=?  string>=? string>? string? substring
-         symbol->string symbol=? symbol?  syntax-error syntax-rules tan
-         textual-port?  truncate truncate-quotient truncate-remainder
-         truncate/ u8-ready? unless unquote unquote-splicing utf8->string
-         values vector vector->list vector->string vector-append vector-copy
-         vector-copy! vector-fill! vector-for-each vector-length vector-map
-         vector-ref vector-set! vector? when with-exception-handler
-         with-input-from-file with-output-to-file write write-bytevector
-         write-char write-shared write-simple write-string write-u8 zero?)
@@ -1,84 +0,0 @@
-;;; chicanery/impl/r7rs --- for r7rs-compliant implementations
-
-(import (scheme base))
-(import (scheme case-lambda))
-(import (scheme char))
-(import (scheme complex))
-(import (scheme cxr))
-(import (scheme eval))
-(import (scheme file))
-(import (scheme inexact))
-(import (scheme lazy))
-(import (scheme load))
-(import (scheme process-context))
-(import (scheme read))
-(import (scheme repl))
-(import (scheme time))
-(import (scheme write))
-
-(export * + - / < <= = > >= abs acos and angle #;append apply asin
-        assoc assq assv atan begin binary-port? boolean=? boolean? bytevector
-        bytevector-append bytevector-copy bytevector-copy! bytevector-length
-        bytevector-u8-ref bytevector-u8-set! bytevector? caaaar caaadr caaar
-        caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
-        call-with-current-continuation call-with-input-file
-        call-with-output-file call-with-port call-with-values call/cc car
-        case case-lambda cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar
-        cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer
-        char-alphabetic? char-ci<=?  char-ci<? char-ci=?  char-ci>=?
-        char-ci>? char-downcase char-foldcase char-lower-case?  char-numeric?
-        char-ready? char-upcase char-upper-case?  char-whitespace?  char<=?
-        char<? char=? char>=? char>? char? close-input-port close-output-port
-        close-port command-line complex? cond cond-expand cons cos
-        current-error-port current-input-port current-jiffy
-        current-output-port current-second define define-record-type
-        define-syntax define-values delay delay-force delete-file denominator
-        digit-value display do dynamic-wind emergency-exit environment
-        eof-object eof-object? eq? equal? eqv? error error-object-irritants
-        error-object-message error-object? eval even? exact
-        exact-integer-sqrt exact-integer? exact? exit exp expt features
-        file-error?  file-exists? finite? floor floor-quotient
-        floor-remainder floor/ flush-output-port #;for-each force gcd
-        get-environment-variable get-environment-variables
-        get-output-bytevector get-output-string guard if imag-part import
-        include include-ci inexact inexact? infinite? input-port-open?
-        input-port? integer->char integer?  interaction-environment
-        jiffies-per-second lambda lcm length let let* let*-values let-syntax
-        let-values letrec letrec* letrec-syntax list list->string magnitude
-        make-bytevector make-list make-parameter make-polar make-promise
-        make-rectangular make-string make-vector #;map max member memq memv min
-        modulo negative? newline not null? number->string number?  numerator
-        odd? open-binary-input-file open-binary-output-file
-        open-input-bytevector open-input-file open-input-string
-        open-output-bytevector open-output-file open-output-string or
-        output-port-open? output-port? pair?  parameterize peek-char peek-u8
-        port?  positive? procedure? promise? quasiquote quote quotient raise
-        raise-continuable rational? rationalize read read-bytevector
-        read-bytevector! read-char read-error? read-line read-string read-u8
-        real-part real? remainder reverse round set! set-car! set-cdr! sin
-        sqrt square string string->list string->number string->symbol
-        string->utf8 string->vector string-append string-ci<=? string-ci<?
-        string-ci=?  string-ci>=?  string-ci>? string-copy string-copy!
-        string-downcase string-fill!  string-foldcase string-for-each
-        string-length string-map string-ref string-set!  string-upcase
-        string<=? string<? string=?  string>=? string>? string? substring
-        symbol->string symbol=? symbol?  syntax-error syntax-rules tan
-        textual-port?  truncate truncate-quotient truncate-remainder
-        truncate/ u8-ready? unless unquote unquote-splicing utf8->string
-        values vector vector->list vector->string vector-append vector-copy
-        vector-copy! vector-fill! vector-for-each vector-length vector-map
-        vector-ref vector-set! vector? when with-exception-handler
-        with-input-from-file with-output-to-file write write-bytevector
-        write-char write-shared write-simple write-string write-u8 zero?)
-
-;; Extras
-(include "../extras.scm")
-(export append for-each map
-        list-append list-for-each list-map
-        ref copy
-        atom?
-        read-port read-port-chunk-size
-        defined?
-        with-output-to-string with-input-from-string
-        displayed ->string written
-        print)