5 files changed, 345 insertions, 0 deletions

@@ -0,0 +1,138 @@
+;;; 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)
@@ -0,0 +1,40 @@
+;;; 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))
@@ -0,0 +1,7 @@
+;;; -*- geiser-scheme-implementation: gambit -*-
+
+(##include "~~lib/r7rs#.scm")
+
+(define-library (chicanery)
+  (include-library-declarations "r7rs.scm")
+  (namespace ""))
@@ -0,0 +1,76 @@
+;;; 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?)
@@ -0,0 +1,84 @@
+;;; 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)