about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--Makefile39
-rw-r--r--README.md13
-rw-r--r--chicanery.egg18
-rw-r--r--chicanery.extras.scm281
-rw-r--r--chicanery.scm90
5 files changed, 243 insertions, 198 deletions
diff --git a/Makefile b/Makefile index 0b332f5..2fee0e6 100644 --- a/Makefile +++ b/Makefile
@@ -3,39 +3,14 @@
3 3
4NAME = chicanery 4NAME = chicanery
5 5
6.PHONY: help 6.PHONY: build
7help: 7build:
8 @echo "CHICANERY: subtly breaking scheme expectations" 8 chicken-install -n
9 @echo "The following schemes are supported:" 9
10 @sed -n 's/^\([^.].*\): *supported.*/- \1/p' Makefile 10.PHONY: install
11 @echo; echo "The following schemes are NOT supported:" 11install:
12 @sed -n 's/^\([^.].*\): *unsupported.*/- \1/p' Makefile 12 chicken-install
13 13
14.PHONY: clean 14.PHONY: clean
15clean: 15clean:
16 rm -f $(NAME) *.sh *.import.* *.inline *.link *.o* *.so *.types *.c 16 rm -f $(NAME) *.sh *.import.* *.inline *.link *.o* *.so *.types *.c
17
18# Scheme implementation demoes
19
20.PHONY: supported unsupported
21supported:
22unsupported:
23
24.PHONY: chicken
25chicken: supported chicanery.egg
26 csi -R chicanery
27
28.PHONY: guile
29guile: supported
30 echo '(import (chicanery))' > /tmp/chicanery.guile-bootstrap
31 guile -L . -l /tmp/chicanery.guile-bootstrap
32
33.PHONY: gambit
34gambit: supported
35 gsi . -e '(import (chicanery))' -
36
37.PHONY: cyclone
38cyclone: unsupported
39 @echo "Cyclone is unsupported."
40 @echo "See https://github.com/justinethier/cyclone/issues/413."
41 @false
diff --git a/README.md b/README.md index 2f27bc2..6c720b7 100644 --- a/README.md +++ b/README.md
@@ -1,4 +1,4 @@
1# Chicanery: subtle, opinionated improvements to R7RS Scheme 1# Chicanery: subtle, opinionated improvements to R7RS Scheme (in CHICKEN)
2 2
3While I was reading the [R7RS 3While I was reading the [R7RS
4specification](https://standards.scheme.org/official/r7rs.pdf), I was a little 4specification](https://standards.scheme.org/official/r7rs.pdf), I was a little
@@ -40,16 +40,9 @@ Other extras include
40- `(written x)` returns `x` as a string (via `write`) 40- `(written x)` returns `x` as a string (via `write`)
41- `(print x ...)` displays `x ...` followed by a newline 41- `(print x ...)` displays `x ...` followed by a newline
42 42
43## Supported Scheme implementations 43## Todo
44 44
45`chicanery` now supports multiple R7RS implementations! The full list can be 45- 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.
46found by running `make`, but here's what we have right now:
47
48### [Chicken](https://call-cc.org/)
49### [Guile](https://www.gnu.org/software/guile/)
50### [Gambit](https://gambitscheme.org/)
51
52Other 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).
53 46
54## License 47## License
55 48
diff --git a/chicanery.egg b/chicanery.egg index e959cb8..2bce2f1 100644 --- a/chicanery.egg +++ b/chicanery.egg
@@ -7,20 +7,10 @@
7 (category lang-exts) 7 (category lang-exts)
8 (dependencies r7rs utf8) 8 (dependencies r7rs utf8)
9 (components 9 (components
10 (extension chicanery.base 10 (extension chicanery
11 (source chicanery.base.scm) 11 (source chicanery.scm)
12 (types-file) ; I don't know what this does ... 12 (types-file) ; I don't know what this does ...
13 (inline-file) 13 (inline-file)
14 (csc-options "-X" "r7rs" "-R" "r7rs" 14 (csc-options "-X" "r7rs" "-R" "r7rs"
15 "-X" "utf8" "-R" "utf8")) 15 "-X" "utf8" "-R" "utf8"
16 (extension chicanery.extras 16 "-no-warnings"))))
17 (source chicanery.extras.scm)
18 (component-dependencies chicanery.base)
19 (types-file)
20 (inline-file))
21 (extension chicanery
22 (source chicanery.scm)
23 (component-dependencies chicanery.base
24 chicanery.extras)
25 (types-file)
26 (inline-file))))
diff --git a/chicanery.extras.scm b/chicanery.extras.scm index f9bb4a1..ae2823e 100644 --- a/chicanery.extras.scm +++ b/chicanery.extras.scm
@@ -1,145 +1,150 @@
1(module (chicanery extras) ( append for-each map 1(export list-map list-for-each list-append
2 list-append list-for-each list-map 2 map for-each append)
3 ref copy
4 atom? defined?
5 read-port-chunk-size read-port
6 with-output-to-string with-input-from-string
7 displayed written print ->string)
8 (import scheme (chicanery base))
9
10 (define list-append append)
11 (define list-for-each for-each)
12 (define list-map map)
13
14 (define (map proc . collections)
15 (let ((first (car collections))) ; we only need to check the first one
16 (cond
17 ((list? first)
18 (apply list-map proc collections))
19 ((vector? first)
20 (apply vector-map proc collections))
21 ((string? first)
22 (apply string-map proc collections))
23 (else (error "Bad datatype" first)))))
24
25 (define (for-each proc . collections)
26 (let ((first (car collections))) ; we only need to check the first one
27 (cond
28 ((list? first)
29 (apply list-for-each proc collections))
30 ((vector? first)
31 (apply vector-for-each proc collections))
32 ((string? first)
33 (apply string-for-each proc collections))
34 (else (error "Bad datatype" first)))))
35
36 (define (append . collections)
37 (let ((first (car collections))) ; we only need to check the first one
38 (cond
39 ((list? first)
40 (apply list-append collections))
41 ((vector? first)
42 (apply vector-append collections))
43 ((string? first)
44 (apply string-append collections))
45 ((bytevector? first)
46 (apply bytevector-append collections))
47 (else (error "Bad datatype" first)))))
48 3
49;;; Extended generic functions. 4(define list-map map)
50 ;; These functions already have a list- version defined, but no non-prefixed 5(define list-for-each for-each)
51 ;; one. So I'm fixing that. 6(define list-append append)
52 (define (ref collection k) 7
8(define (map proc . collections)
9 (let ((first (car collections))) ; we only need to check the first one
10 (cond
11 ((list? first)
12 (apply list-map proc collections))
13 ((vector? first)
14 (apply vector-map proc collections))
15 ((string? first)
16 (apply string-map proc collections))
17 (else (error "Bad datatype" first)))))
18
19(define (for-each proc . collections)
20 (let ((first (car collections))) ; we only need to check the first one
53 (cond 21 (cond
54 ((list? collection) 22 ((list? first)
55 (list-ref collection k)) 23 (apply list-for-each proc collections))
56 ((vector? collection) 24 ((vector? first)
57 (vector-ref collection k)) 25 (apply vector-for-each proc collections))
58 ((string? collection) 26 ((string? first)
59 (string-ref collection k)) 27 (apply string-for-each proc collections))
60 ((bytevector? collection) 28 (else (error "Bad datatype" first)))))
61 (bytevector-u8-ref collection k)) 29
62 (else (error "Bad datatype" collection)))) 30(define (append . collections)
63 31 (let ((first (car collections))) ; we only need to check the first one
64 ;; I'm not going to generalize -copy! because I don't think it's a great idea,
65 ;; really.
66 (define (copy collection)
67 (cond 32 (cond
68 ((list? collection) 33 ((list? first)
69 (list-copy collection)) 34 (apply list-append collections))
70 ((vector? collection) 35 ((vector? first)
71 (vector-copy collection)) 36 (apply vector-append collections))
72 ((string? collection) 37 ((string? first)
73 (string-copy collection)) 38 (apply string-append collections))
74 ((bytevector? collection) 39 ((bytevector? first)
75 (bytevector-copy collection)) 40 (apply bytevector-append collections))
76 (else (error "Bad datatype" collection)))) 41 (else (error "Bad datatype" first)))))
42
43;;; Extended generic functions.
44;; These functions already have a list- version defined, but no non-prefixed
45;; one. So I'm fixing that.
46(define (ref collection k)
47 (cond
48 ((list? collection)
49 (list-ref collection k))
50 ((vector? collection)
51 (vector-ref collection k))
52 ((string? collection)
53 (string-ref collection k))
54 ((bytevector? collection)
55 (bytevector-u8-ref collection k))
56 (else (error "Bad datatype" collection))))
57
58;; I'm not going to generalize -copy! because I don't think it's a great idea,
59;; really.
60(define (copy collection)
61 (cond
62 ((list? collection)
63 (list-copy collection))
64 ((vector? collection)
65 (vector-copy collection))
66 ((string? collection)
67 (string-copy collection))
68 ((bytevector? collection)
69 (bytevector-copy collection))
70 (else (error "Bad datatype" collection))))
77 71
78;;; Definitions that should be in scheme 72;;; Definitions that should be in scheme
79;; This sections should be as small as possible 73;; This sections should be as small as possible
80 74
81 (define (atom? x) 75(export read-port
82 (and (not (pair? x)) 76 read-port-chunk-size)
83 (not (null? x)))) 77
84 78
85 (define read-port-chunk-size 79(define (%read-port port)
86 (make-parameter 512)) 80 (let ((chunk-size (read-port-chunk-size)))
87 81 (let loop ((next (read-string chunk-size port))
88 (define (%read-port port) 82 (blank? #f)
89 (let ((chunk-size (read-port-chunk-size))) 83 (acc '()))
90 (let loop ((next (read-string chunk-size port)) 84 (cond
91 (blank? #f) 85 ((or (eof-object? next)
92 (acc '())) 86 (and blank? (equal? next "")))
93 (cond 87 (apply string-append (reverse acc)))
94 ((or (eof-object? next) 88 ((equal? next "")
95 (and blank? (equal? next ""))) 89 (loop (read-string chunk-size port)
96 (apply string-append (reverse acc))) 90 #t
97 ((equal? next "") 91 (cons next acc)))
98 (loop (read-string chunk-size port) 92 (else
99 #t 93 (loop (read-string chunk-size port)
100 (cons next acc))) 94 blank?
101 (else 95 (cons next acc)))))))
102 (loop (read-string chunk-size port) 96
103 blank? 97(define read-port-chunk-size
104 (cons next acc))))))) 98 (make-parameter 512))
105 99
106 (define read-port 100(define read-port
107 (case-lambda 101 (case-lambda
108 (() (%read-port (current-input-port))) 102 (() (%read-port (current-input-port)))
109 ((p) (%read-port p)))) 103 ((p) (%read-port p))))
110 104
111 (define (defined? sym) 105(export atom? defined?)
112 (call-with-current-continuation 106
113 (lambda (k) 107(define (atom? x)
114 (with-exception-handler 108 (not (or (null? x)
115 (lambda (e) (k #f)) 109 (pair? x))))
116 (lambda () 110
117 (eval sym (interaction-environment)) 111(define (defined? sym)
118 #t))))) 112 (call-with-current-continuation
119 113 (lambda (k)
120 (define (with-output-to-string thunk) 114 (with-exception-handler
121 (call-with-port (open-output-string) 115 (lambda (e) (k #f))
122 (lambda (port) 116 (lambda ()
123 (parameterize ((current-output-port port)) 117 (eval sym (interaction-environment))
124 (thunk)) 118 #t)))))
125 (get-output-string port)))) 119
126 120(export with-output-to-string
127 (define (with-input-from-string s thunk) 121 with-input-from-string)
128 (call-with-port (open-input-string s) 122
129 (lambda (port) 123(define (with-output-to-string thunk)
130 (parameterize ((current-input-port port)) 124 (call-with-port (open-output-string)
131 (thunk))))) 125 (lambda (port)
132 126 (parameterize ((current-output-port port))
133 (define (displayed x) 127 (thunk))
134 (with-output-to-string 128 (get-output-string port))))
135 (lambda () (display x)))) 129
136 130(define (with-input-from-string s thunk)
137 (define (written x) 131 (call-with-port (open-input-string s)
138 (with-output-to-string 132 (lambda (port)
139 (lambda () (write x)))) 133 (parameterize ((current-input-port port))
140 134 (thunk)))))
141 (define (print . xs) 135
142 (for-each display xs) 136(export displayed ->string written print)
143 (newline)) 137
144 138(define (displayed x)
145 (define ->string displayed)) 139 (with-output-to-string
140 (lambda () (display x))))
141
142(define (written x)
143 (with-output-to-string
144 (lambda () (write x))))
145
146(define (print . xs)
147 (for-each display xs)
148 (newline))
149
150(define ->string displayed)
diff --git a/chicanery.scm b/chicanery.scm index 3677dde..0fc71e4 100644 --- a/chicanery.scm +++ b/chicanery.scm
@@ -1,5 +1,87 @@
1(module chicanery () 1;;; chicanery --- subtly breaking scheme expectations
2 (import scheme (chicken module)) 2
3 (reexport (chicanery base) 3(import (r7rs))
4 (chicanery extras))) 4
5(define-library chicanery
6 ;; All the scheme stuff in one place
7 (import (scheme base))
8 (import (scheme case-lambda))
9 (import (scheme char))
10 (import (scheme complex))
11 (import (scheme cxr))
12 (import (scheme eval))
13 (import (scheme file))
14 (import (scheme inexact))
15 (import (scheme lazy))
16 (import (scheme load))
17 (import (scheme process-context))
18 (import (scheme read))
19 (import (scheme repl))
20 (import (scheme time))
21 (import (scheme write))
22 (import utf8)
23 (export * + - / <= < >= = > abs and #;append apply assoc assq assv begin
24 binary-port? boolean? boolean=? bytevector bytevector-append
25 bytevector-copy bytevector-copy! bytevector-length bytevector-u8-ref
26 bytevector-u8-set! bytevector? car cdr caar cadr cdar cddr
27 call-with-current-continuation call/cc call-with-port call-with-values
28 case ceiling char-ready? char->integer integer->char char=? char<?
29 char>? char<=? char>=? char? close-input-port close-output-port
30 close-port complex? cond cond-expand cons current-input-port
31 current-output-port current-error-port define define-record-type
32 define-syntax define-values denominator numerator do dynamic-wind
33 eof-object eof-object? eq? eqv? equal? error error-object-irritants
34 error-object-message error-object? even? odd? exact inexact
35 exact-integer-sqrt exact-integer? exact? inexact? exp expt features
36 file-error? floor floor/ floor-quotient floor-remainder
37 flush-output-port #;for-each gcd lcm get-output-bytevector
38 get-output-string guard if import import-for-syntax include include-ci
39 input-port-open? output-port-open? input-port? output-port? integer?
40 lambda length let let* letrec letrec* let-values let*-values let-syntax
41 letrec-syntax list list-copy list-ref list-set! list-tail list?
42 list->vector make-bytevector make-list make-parameter make-string
43 make-vector #;map max min member memq memv modulo remainder negative?
44 positive? newline not null? number->string string->number number?
45 open-input-bytevector open-output-bytevector open-input-string
46 open-output-string or pair? parameterize peek-char peek-u8 port?
47 procedure? quasiquote quote quotient remainder raise raise-continuable
48 rational? rationalize read-bytevector read-bytevector! read-char
49 read-error? read-line read-string read-u8 real? reverse round set!
50 set-car! set-cdr! square string string->list list->string string->utf8
51 utf8->string string->symbol symbol->string string->vector
52 string-append string-copy string-copy! string-fill! string-for-each
53 string-length string-map string-ref string-set! string=? string<?
54 string>? string<=? string>=? string? substring symbol=? symbol?
55 syntax-error syntax-rules textual-port? truncate truncate/
56 truncate-quotient truncate-remainder u8-ready? unless #;unquote
57 #;unquote-splicing values vector vector-append vector-copy vector-copy!
58 vector-fill! vector-for-each vector-length vector-map vector-ref
59 vector-set! vector->list vector->string vector? when
60 with-exception-handler write-bytevector write-char write-string
61 write-u8 zero?)
62 (export case-lambda)
63 (export char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=?
64 char-ci>? char-downcase char-foldcase char-lower-case? char-numeric?
65 char-upcase char-upper-case? char-whitespace? digit-value string-ci<=?
66 string-ci<? string-ci=? string-ci>=? string-ci>? string-downcase
67 string-foldcase string-upcase)
68 (export angle imag-part magnitude make-polar make-rectangular real-part)
69 (export caaaar caaadr caaar caadar caaddr caadr cadaar cadadr cadar caddar
70 cadddr caddr cdaaar cdaadr cdaar cdadar cdaddr cdadr cddaar cddadr
71 cddar cdddar cddddr cdddr)
72 (export environment eval)
73 (export call-with-input-file call-with-output-file delete-file file-exists?
74 open-binary-input-file open-binary-output-file open-input-file
75 open-output-file with-input-from-file with-output-to-file)
76 (export acos asin atan cos exp finite? infinite? log nan? sin sqrt tan)
77 (export delay delay-force force make-promise promise?)
78 (export load)
79 (export command-line emergency-exit exit get-environment-variable
80 get-environment-variables)
81 (export read)
82 (export interaction-environment)
83 (export current-jiffy current-second jiffies-per-second)
84 (export display write write-shared write-simple)
85
86 (include "chicanery.extras.scm"))
5 87