about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--extras.scm138
-rw-r--r--impl/chicken.scm40
-rw-r--r--impl/gambit.scm7
-rw-r--r--impl/guile.scm76
-rw-r--r--impl/r7rs.scm84
5 files changed, 345 insertions, 0 deletions
diff --git a/extras.scm b/extras.scm new file mode 100644 index 0000000..ea19be8 --- /dev/null +++ b/extras.scm
@@ -0,0 +1,138 @@
1;;; Extras
2(display "EXTRAS!\n")
3(define list-append append)
4(define list-for-each for-each)
5(define list-map map)
6
7(define (map proc . collections)
8 (let ((first (car collections))) ; we only need to check the first one
9 (cond
10 ((list? first)
11 (apply list-map proc collections))
12 ((vector? first)
13 (apply vector-map proc collections))
14 ((string? first)
15 (apply string-map proc collections))
16 (else (error "Bad datatype" first)))))
17
18(define (for-each proc . collections)
19 (let ((first (car collections))) ; we only need to check the first one
20 (cond
21 ((list? first)
22 (apply list-for-each proc collections))
23 ((vector? first)
24 (apply vector-for-each proc collections))
25 ((string? first)
26 (apply string-for-each proc collections))
27 (else (error "Bad datatype" first)))))
28
29(define (append . collections)
30 (let ((first (car collections))) ; we only need to check the first one
31 (cond
32 ((list? first)
33 (apply list-append collections))
34 ((vector? first)
35 (apply vector-append collections))
36 ((string? first)
37 (apply string-append collections))
38 ((bytevector? first)
39 (apply bytevector-append collections))
40 (else (error "Bad datatype" first)))))
41
42;;; Extended generic functions.
43;; These functions already have a list- version defined, but no non-prefixed
44;; one. So I'm fixing that.
45(define (ref collection k)
46 (cond
47 ((list? collection)
48 (list-ref collection k))
49 ((vector? collection)
50 (vector-ref collection k))
51 ((string? collection)
52 (string-ref collection k))
53 ((bytevector? collection)
54 (bytevector-u8-ref collection k))
55 (else (error "Bad datatype" collection))))
56
57;; I'm not going to generalize -copy! because I don't think it's a great idea,
58;; really.
59(define (copy collection)
60 (cond
61 ((list? collection)
62 (list-copy collection))
63 ((vector? collection)
64 (vector-copy collection))
65 ((string? collection)
66 (string-copy collection))
67 ((bytevector? collection)
68 (bytevector-copy collection))
69 (else (error "Bad datatype" collection))))
70
71;;; Definitions that should be in scheme
72;; This sections should be as small as possible
73
74(define (atom? x)
75 (and (not (pair? x))
76 (not (null? x))))
77
78(define read-port-chunk-size
79 (make-parameter 512))
80
81(define (%read-port port)
82 (let ((chunk-size (read-port-chunk-size)))
83 (let loop ((next (read-string chunk-size port))
84 (blank? #f)
85 (acc '()))
86 (cond
87 ((or (eof-object? next)
88 (and blank? (equal? next "")))
89 (apply string-append (reverse acc)))
90 ((equal? next "")
91 (loop (read-string chunk-size port)
92 #t
93 (cons next acc)))
94 (else
95 (loop (read-string chunk-size port)
96 blank?
97 (cons next acc)))))))
98
99(define read-port
100 (case-lambda
101 (() (%read-port (current-input-port)))
102 ((p) (%read-port p))))
103
104(define (defined? sym)
105 (call-with-current-continuation
106 (lambda (k)
107 (with-exception-handler
108 (lambda (e) (k #f))
109 (lambda ()
110 (eval sym (interaction-environment))
111 #t)))))
112
113(define (with-output-to-string thunk)
114 (call-with-port (open-output-string)
115 (lambda (port)
116 (parameterize ((current-output-port port))
117 (thunk))
118 (get-output-string port))))
119
120(define (with-input-from-string s thunk)
121 (call-with-port (open-input-string s)
122 (lambda (port)
123 (parameterize ((current-input-port port))
124 (thunk)))))
125
126(define (displayed x)
127 (with-output-to-string
128 (lambda () (display x))))
129
130(define (written x)
131 (with-output-to-string
132 (lambda () (write x))))
133
134(define (print . xs)
135 (for-each display xs)
136 (newline))
137
138(define ->string displayed)
diff --git a/impl/chicken.scm b/impl/chicken.scm new file mode 100644 index 0000000..eeb69bd --- /dev/null +++ b/impl/chicken.scm
@@ -0,0 +1,40 @@
1;;; chicanery/impl/chicken -*- geiser-scheme-implementation: chicken -*-
2
3(module chicanery ()
4 (import (scheme base)
5 (scheme eval)
6 (srfi 1)
7 (chicken module))
8 (import-for-syntax r7rs)
9 (reexport (scheme base)
10 (scheme case-lambda)
11 (scheme char)
12 (scheme complex)
13 (scheme cxr)
14 (scheme eval)
15 (scheme file)
16 (scheme inexact)
17 (scheme lazy)
18 (scheme load)
19 (scheme process-context)
20 (scheme read)
21 (scheme repl)
22 (scheme time)
23 (scheme write))
24
25 (define env (environment '(only chicken.base exit)))
26 (##sys#current-environment (##sys#slot env 2))
27 (##sys#macro-environment (filter-map
28 (lambda (e)
29 (and (list? e) e))
30 (##sys#slot env 2)))
31 (include "../extras.scm")
32 (export append for-each map
33 list-append list-for-each list-map
34 ref copy
35 atom?
36 read-port read-port-chunk-size
37 defined?
38 with-output-to-string with-input-from-string
39 displayed ->string written
40 print))
diff --git a/impl/gambit.scm b/impl/gambit.scm new file mode 100644 index 0000000..3b3bc65 --- /dev/null +++ b/impl/gambit.scm
@@ -0,0 +1,7 @@
1;;; -*- geiser-scheme-implementation: gambit -*-
2
3(##include "~~lib/r7rs#.scm")
4
5(define-library (chicanery)
6 (include-library-declarations "r7rs.scm")
7 (namespace ""))
diff --git a/impl/guile.scm b/impl/guile.scm new file mode 100644 index 0000000..6bd5387 --- /dev/null +++ b/impl/guile.scm
@@ -0,0 +1,76 @@
1;;; chicanery/impl/guile.scm -*- geiser-scheme-implementation: guile -*-
2
3;; XXX : Apparently this doesn't work. I don't know.
4
5(define-module (chicanery))
6
7(use-modules (scheme base)
8 (scheme case-lambda)
9 (scheme char)
10 (scheme complex)
11 (scheme cxr)
12 (scheme eval)
13 (scheme file)
14 (scheme inexact)
15 (scheme lazy)
16 (scheme load)
17 (scheme process-context)
18 (scheme read)
19 (scheme repl)
20 (scheme time)
21 (scheme write))
22
23(export! * + - / < <= = > >= abs acos and angle #;append apply asin
24 assoc assq assv atan begin binary-port? boolean=? boolean? bytevector
25 bytevector-append bytevector-copy bytevector-copy! bytevector-length
26 bytevector-u8-ref bytevector-u8-set! bytevector? caaaar caaadr caaar
27 caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
28 call-with-current-continuation call-with-input-file
29 call-with-output-file call-with-port call-with-values call/cc car
30 case case-lambda cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar
31 cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer
32 char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=?
33 char-ci>? char-downcase char-foldcase char-lower-case? char-numeric?
34 char-ready? char-upcase char-upper-case? char-whitespace? char<=?
35 char<? char=? char>=? char>? char? close-input-port close-output-port
36 close-port command-line complex? cond cond-expand cons cos
37 current-error-port current-input-port current-jiffy
38 current-output-port current-second define define-record-type
39 define-syntax define-values delay delay-force delete-file denominator
40 digit-value display do dynamic-wind emergency-exit environment
41 eof-object eof-object? eq? equal? eqv? error error-object-irritants
42 error-object-message error-object? eval even? exact
43 exact-integer-sqrt exact-integer? exact? exit exp expt features
44 file-error? file-exists? finite? floor floor-quotient
45 floor-remainder floor/ flush-output-port #;for-each force gcd
46 get-environment-variable get-environment-variables
47 get-output-bytevector get-output-string guard if imag-part import
48 include include-ci inexact inexact? infinite? input-port-open?
49 input-port? integer->char integer? interaction-environment
50 jiffies-per-second lambda lcm length let let* let*-values let-syntax
51 let-values letrec letrec* letrec-syntax list list->string magnitude
52 make-bytevector make-list make-parameter make-polar make-promise
53 make-rectangular make-string make-vector #;map max member memq memv min
54 modulo negative? newline not null? number->string number? numerator
55 odd? open-binary-input-file open-binary-output-file
56 open-input-bytevector open-input-file open-input-string
57 open-output-bytevector open-output-file open-output-string or
58 output-port-open? output-port? pair? parameterize peek-char peek-u8
59 port? positive? procedure? promise? quasiquote quote quotient raise
60 raise-continuable rational? rationalize read read-bytevector
61 read-bytevector! read-char read-error? read-line read-string read-u8
62 real-part real? remainder reverse round set! set-car! set-cdr! sin
63 sqrt square string string->list string->number string->symbol
64 string->utf8 string->vector string-append string-ci<=? string-ci<?
65 string-ci=? string-ci>=? string-ci>? string-copy string-copy!
66 string-downcase string-fill! string-foldcase string-for-each
67 string-length string-map string-ref string-set! string-upcase
68 string<=? string<? string=? string>=? string>? string? substring
69 symbol->string symbol=? symbol? syntax-error syntax-rules tan
70 textual-port? truncate truncate-quotient truncate-remainder
71 truncate/ u8-ready? unless unquote unquote-splicing utf8->string
72 values vector vector->list vector->string vector-append vector-copy
73 vector-copy! vector-fill! vector-for-each vector-length vector-map
74 vector-ref vector-set! vector? when with-exception-handler
75 with-input-from-file with-output-to-file write write-bytevector
76 write-char write-shared write-simple write-string write-u8 zero?)
diff --git a/impl/r7rs.scm b/impl/r7rs.scm new file mode 100644 index 0000000..b1a2d5c --- /dev/null +++ b/impl/r7rs.scm
@@ -0,0 +1,84 @@
1;;; chicanery/impl/r7rs --- for r7rs-compliant implementations
2
3(import (scheme base))
4(import (scheme case-lambda))
5(import (scheme char))
6(import (scheme complex))
7(import (scheme cxr))
8(import (scheme eval))
9(import (scheme file))
10(import (scheme inexact))
11(import (scheme lazy))
12(import (scheme load))
13(import (scheme process-context))
14(import (scheme read))
15(import (scheme repl))
16(import (scheme time))
17(import (scheme write))
18
19(export * + - / < <= = > >= abs acos and angle #;append apply asin
20 assoc assq assv atan begin binary-port? boolean=? boolean? bytevector
21 bytevector-append bytevector-copy bytevector-copy! bytevector-length
22 bytevector-u8-ref bytevector-u8-set! bytevector? caaaar caaadr caaar
23 caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
24 call-with-current-continuation call-with-input-file
25 call-with-output-file call-with-port call-with-values call/cc car
26 case case-lambda cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar
27 cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer
28 char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=?
29 char-ci>? char-downcase char-foldcase char-lower-case? char-numeric?
30 char-ready? char-upcase char-upper-case? char-whitespace? char<=?
31 char<? char=? char>=? char>? char? close-input-port close-output-port
32 close-port command-line complex? cond cond-expand cons cos
33 current-error-port current-input-port current-jiffy
34 current-output-port current-second define define-record-type
35 define-syntax define-values delay delay-force delete-file denominator
36 digit-value display do dynamic-wind emergency-exit environment
37 eof-object eof-object? eq? equal? eqv? error error-object-irritants
38 error-object-message error-object? eval even? exact
39 exact-integer-sqrt exact-integer? exact? exit exp expt features
40 file-error? file-exists? finite? floor floor-quotient
41 floor-remainder floor/ flush-output-port #;for-each force gcd
42 get-environment-variable get-environment-variables
43 get-output-bytevector get-output-string guard if imag-part import
44 include include-ci inexact inexact? infinite? input-port-open?
45 input-port? integer->char integer? interaction-environment
46 jiffies-per-second lambda lcm length let let* let*-values let-syntax
47 let-values letrec letrec* letrec-syntax list list->string magnitude
48 make-bytevector make-list make-parameter make-polar make-promise
49 make-rectangular make-string make-vector #;map max member memq memv min
50 modulo negative? newline not null? number->string number? numerator
51 odd? open-binary-input-file open-binary-output-file
52 open-input-bytevector open-input-file open-input-string
53 open-output-bytevector open-output-file open-output-string or
54 output-port-open? output-port? pair? parameterize peek-char peek-u8
55 port? positive? procedure? promise? quasiquote quote quotient raise
56 raise-continuable rational? rationalize read read-bytevector
57 read-bytevector! read-char read-error? read-line read-string read-u8
58 real-part real? remainder reverse round set! set-car! set-cdr! sin
59 sqrt square string string->list string->number string->symbol
60 string->utf8 string->vector string-append string-ci<=? string-ci<?
61 string-ci=? string-ci>=? string-ci>? string-copy string-copy!
62 string-downcase string-fill! string-foldcase string-for-each
63 string-length string-map string-ref string-set! string-upcase
64 string<=? string<? string=? string>=? string>? string? substring
65 symbol->string symbol=? symbol? syntax-error syntax-rules tan
66 textual-port? truncate truncate-quotient truncate-remainder
67 truncate/ u8-ready? unless unquote unquote-splicing utf8->string
68 values vector vector->list vector->string vector-append vector-copy
69 vector-copy! vector-fill! vector-for-each vector-length vector-map
70 vector-ref vector-set! vector? when with-exception-handler
71 with-input-from-file with-output-to-file write write-bytevector
72 write-char write-shared write-simple write-string write-u8 zero?)
73
74;; Extras
75(include "../extras.scm")
76(export append for-each map
77 list-append list-for-each list-map
78 ref copy
79 atom?
80 read-port read-port-chunk-size
81 defined?
82 with-output-to-string with-input-from-string
83 displayed ->string written
84 print)