5 files changed, 243 insertions, 198 deletions

@@ -3,39 +3,14 @@
 
 NAME = chicanery
 
-.PHONY: help
-help:
-        @echo "CHICANERY: subtly breaking scheme expectations"
-        @echo "The following schemes are supported:"
-        @sed -n 's/^\([^.].*\): *supported.*/- \1/p' Makefile
-        @echo; echo "The following schemes are NOT supported:"
-        @sed -n 's/^\([^.].*\): *unsupported.*/- \1/p' Makefile
+.PHONY: build
+build:
+        chicken-install -n
+
+.PHONY: install
+install:
+        chicken-install
 
 .PHONY: clean
 clean:
         rm -f $(NAME) *.sh *.import.* *.inline *.link *.o* *.so *.types *.c
-
-# Scheme implementation demoes
-
-.PHONY: supported unsupported
-supported:
-unsupported:
-
-.PHONY: chicken
-chicken: supported chicanery.egg
-        csi -R chicanery
-
-.PHONY: guile
-guile: supported
-        echo '(import (chicanery))' > /tmp/chicanery.guile-bootstrap
-        guile -L . -l /tmp/chicanery.guile-bootstrap
-
-.PHONY: gambit
-gambit: supported
-        gsi . -e '(import (chicanery))' -
-
-.PHONY: cyclone
-cyclone: unsupported
-        @echo "Cyclone is unsupported."
-        @echo "See https://github.com/justinethier/cyclone/issues/413."
-        @false
@@ -1,4 +1,4 @@
-# Chicanery: subtle, opinionated improvements to R7RS Scheme
+# Chicanery: subtle, opinionated improvements to R7RS Scheme (in CHICKEN)
 
 While I was reading the [R7RS
 specification](https://standards.scheme.org/official/r7rs.pdf), I was a little
@@ -40,16 +40,9 @@ Other extras include
 - `(written x)` returns `x` as a string (via `write`)
 - `(print x ...)` displays `x ...` followed by a newline
 
-## Supported Scheme implementations
+## Todo
 
-`chicanery` now supports multiple R7RS implementations!  The full list can be
-found by running `make`, but here's what we have right now:
-
-### [Chicken](https://call-cc.org/)
-### [Guile](https://www.gnu.org/software/guile/)
-### [Gambit](https://gambitscheme.org/)
-
-Other Scheme implementations have been minimally tested and I haven't been able to figure them out yet.  However, [Cyclone](https://justinethier.github.io/cyclone/) is definitively *not* compatible; see [issue #413](https://github.com/justinethier/cyclone/issues/413).
+- Support multiple scheme implementations.  I tried doing this (see the [multiple-impls](https://git.acdw.net/chicanery/?h=multiple-impls) branch), but it kept not working in weird ways, plus it was like whack-a-mole with all the different schemes and just exhausting.
 
 ## License
 
@@ -7,20 +7,10 @@
  (category lang-exts)
  (dependencies r7rs utf8)
  (components
-  (extension chicanery.base
-             (source chicanery.base.scm)
+  (extension chicanery
+             (source chicanery.scm)
              (types-file)               ; I don't know what this does ...
              (inline-file)
              (csc-options "-X" "r7rs" "-R" "r7rs"
-                          "-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))))
+                          "-X" "utf8" "-R" "utf8"
+                          "-no-warnings"))))
@@ -1,145 +1,150 @@
-(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)))))
+(export list-map list-for-each list-append
+        map for-each append)
 
-;;; 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)
+(define list-map map)
+(define list-for-each for-each)
+(define list-append append)
+
+(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? 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)
+     ((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? collection)
-      (list-copy collection))
-     ((vector? collection)
-      (vector-copy collection))
-     ((string? collection)
-      (string-copy collection))
-     ((bytevector? collection)
-      (bytevector-copy collection))
-     (else (error "Bad datatype" collection))))
+     ((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))
+(export read-port
+        read-port-chunk-size)
+
+
+(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-chunk-size
+  (make-parameter 512))
+
+(define read-port
+  (case-lambda
+    (() (%read-port (current-input-port)))
+    ((p) (%read-port p))))
+
+(export atom? defined?)
+
+(define (atom? x)
+  (not (or (null? x)
+           (pair? x))))
+
+(define (defined? sym)
+  (call-with-current-continuation
+   (lambda (k)
+     (with-exception-handler
+         (lambda (e) (k #f))
+       (lambda ()
+         (eval sym (interaction-environment))
+         #t)))))
+
+(export with-output-to-string
+        with-input-from-string)
+
+(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)))))
+
+(export displayed ->string written print)
+
+(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,5 +1,87 @@
-(module chicanery ()
-  (import scheme (chicken module))
-  (reexport (chicanery base)
-            (chicanery extras)))
+;;; chicanery --- subtly breaking scheme expectations
+
+(import (r7rs))
+
+(define-library chicanery
+  ;; All the scheme stuff in one place
+  (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))
+  (import utf8)
+  (export * + - / <= < >= = > abs and #;append apply assoc assq assv begin
+          binary-port? boolean? boolean=? bytevector bytevector-append
+          bytevector-copy bytevector-copy! bytevector-length bytevector-u8-ref
+          bytevector-u8-set! bytevector? car cdr caar cadr cdar cddr
+          call-with-current-continuation call/cc call-with-port call-with-values
+          case ceiling char-ready? char->integer integer->char char=? char<?
+          char>? char<=? char>=? char? close-input-port close-output-port
+          close-port complex? cond cond-expand cons current-input-port
+          current-output-port current-error-port define define-record-type
+          define-syntax define-values denominator numerator do dynamic-wind
+          eof-object eof-object? eq? eqv? equal? error error-object-irritants
+          error-object-message error-object? even? odd? exact inexact
+          exact-integer-sqrt exact-integer? exact? inexact? exp expt features
+          file-error? floor floor/ floor-quotient floor-remainder
+          flush-output-port #;for-each gcd lcm get-output-bytevector
+          get-output-string guard if import import-for-syntax include include-ci
+          input-port-open? output-port-open? input-port? output-port? integer?
+          lambda length let let* letrec letrec* let-values let*-values let-syntax
+          letrec-syntax list list-copy list-ref list-set! list-tail list?
+          list->vector make-bytevector make-list make-parameter make-string
+          make-vector #;map max min member memq memv modulo remainder negative?
+          positive? newline not null? number->string string->number number?
+          open-input-bytevector open-output-bytevector open-input-string
+          open-output-string or pair? parameterize peek-char peek-u8 port?
+          procedure? quasiquote quote quotient remainder raise raise-continuable
+          rational? rationalize read-bytevector read-bytevector! read-char
+          read-error? read-line read-string read-u8 real? reverse round set!
+          set-car! set-cdr! square string string->list list->string string->utf8
+          utf8->string string->symbol symbol->string string->vector
+          string-append string-copy string-copy! string-fill! string-for-each
+          string-length string-map string-ref string-set! string=? string<?
+          string>? string<=? string>=? string? substring symbol=? symbol?
+          syntax-error syntax-rules textual-port? truncate truncate/
+          truncate-quotient truncate-remainder u8-ready? unless #;unquote
+          #;unquote-splicing values vector vector-append vector-copy vector-copy!
+          vector-fill! vector-for-each vector-length vector-map vector-ref
+          vector-set! vector->list vector->string vector? when
+          with-exception-handler write-bytevector write-char write-string
+          write-u8 zero?)
+  (export case-lambda)
+  (export char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=?
+          char-ci>? char-downcase char-foldcase char-lower-case? char-numeric?
+          char-upcase char-upper-case? char-whitespace? digit-value string-ci<=?
+          string-ci<? string-ci=? string-ci>=? string-ci>? string-downcase
+          string-foldcase string-upcase)
+  (export angle imag-part magnitude make-polar make-rectangular real-part)
+  (export caaaar caaadr caaar caadar caaddr caadr cadaar cadadr cadar caddar
+          cadddr caddr cdaaar cdaadr cdaar cdadar cdaddr cdadr cddaar cddadr
+          cddar cdddar cddddr cdddr)
+  (export environment eval)
+  (export call-with-input-file call-with-output-file delete-file file-exists?
+          open-binary-input-file open-binary-output-file open-input-file
+          open-output-file with-input-from-file with-output-to-file)
+  (export acos asin atan cos exp finite? infinite? log nan? sin sqrt tan)
+  (export delay delay-force force make-promise promise?)
+  (export load)
+  (export command-line emergency-exit exit get-environment-variable
+          get-environment-variables)
+  (export read)
+  (export interaction-environment)
+  (export current-jiffy current-second jiffies-per-second)
+  (export display write write-shared write-simple)
+
+  (include "chicanery.extras.scm"))