From 4a058e40b26c2b614ac68bad96a412809a7bac13 Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Wed, 5 Jul 2023 16:14:13 -0500
Subject: Initial commit

---
 .gitignore           |  7 +++++
 COPYING              | 10 ++++++
 Makefile             | 13 ++++++++
 README.md            | 14 +++++++++
 chicanery.egg        | 14 +++++++++
 chicanery.extras.scm | 78 ++++++++++++++++++++++++++++++++++++++++++++++
 chicanery.scm        | 87 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 7 files changed, 223 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 COPYING
 create mode 100644 Makefile
 create mode 100644 README.md
 create mode 100644 chicanery.egg
 create mode 100644 chicanery.extras.scm
 create mode 100644 chicanery.scm

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..07b8758
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,7 @@
+*.sh
+*.import.*
+*.inline
+*.link
+*.o
+*.so
+*.types
\ No newline at end of file
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..ab3d3dc
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,10 @@
+Copyright (C) Case Duckworth under the terms of the
+
+ = = = = = = = = = = = = = GOD WILLING LICENSE v1.0 = = = = = = = = = = = = = =
+
+Permission to use, distribute, modify, or otherwise interact with this software
+is up to the good Lord, who in Their wisdom makes all things possible.  I really
+recommend you take it up with Them whether you should use this software for any reason, including incorporating this software into your project.
+
+This software comes with no warranties from the copyright holder; I cannot speak
+for God.
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..38d0ce0
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,13 @@
+# chicanery
+## this makefile exists only to ... make ... cleaning up easier, really.
+
+.PHONY: build install clean
+
+build:
+	chicken-install -n
+
+install:
+	chicken-install
+
+clean:
+	rm -f *.sh *.import.* *.inline *.link *.o *.so *.types
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..1d5e86b
--- /dev/null
+++ b/README.md
@@ -0,0 +1,14 @@
+# Chicanery: subtle, opinionated improvements to R7RS in CHICKEN
+
+`chicanery` is my attempt at a prelude module for CHICKEN scheme.  It imports and re-exports all `r7rs` modules, using `utf8` where possible, and it corrects a few (in my mind) rough spots in the language, to whit:
+
+- `map`, `for-each`, and `append` are now generalized over lists, vectors, strings, and bytevectors (where appropriate).  The list versions of these procedures have been named `list-map`, `list-for-each`, and `list-append` respectively.
+- `ref` and `copy` have been defined as generalized functions over the above data types.
+
+## Todo
+
+- Make sure `set!` works in, like, `(set! (ref 5 '(1 2 3 4 5)) 10)`
+
+## License
+
+This software is licensed under the GWL, v. 1.0.  See COPYING for details.
diff --git a/chicanery.egg b/chicanery.egg
new file mode 100644
index 0000000..4fddaec
--- /dev/null
+++ b/chicanery.egg
@@ -0,0 +1,14 @@
+;; chicanery -*- scheme -*-
+
+((synopsis "Subtly breaking scheme expectations.")
+ (author "Case Duckworth")
+ (version "0.1.0")
+ (license "God Willing License")
+ (category lang-exts)
+ (dependencies r7rs utf8)
+ (components
+  (extension chicanery
+             (source chicanery.scm)
+             (types-file)               ; I don't know what this does ...
+             (inline-file)
+             (csc-options "-X" "r7rs" "-R" "r7rs"))))
diff --git a/chicanery.extras.scm b/chicanery.extras.scm
new file mode 100644
index 0000000..24cdff9
--- /dev/null
+++ b/chicanery.extras.scm
@@ -0,0 +1,78 @@
+;;; chicanery extras --- extra stuff from ur old pal acdw
+
+(export list-map list-for-each list-append)
+
+;; Generalized map, for-each, ...
+;; List versions are renamed `list-<function>'.  Un-prefixed versions work
+;; with any (default) datatype.  TODO: generalize?
+(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? 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 ref copy)
+
+;; 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))))
+
+;; TODO: look at set! semantics -- generalizable?
diff --git a/chicanery.scm b/chicanery.scm
new file mode 100644
index 0000000..a46cd91
--- /dev/null
+++ b/chicanery.scm
@@ -0,0 +1,87 @@
+;;; 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"))
+
-- 
cgit 1.4.1-21-gabe81