source: project/release/3/fp/tags/2.2.1/fplib.scm @ 9927

Last change on this file since 9927 was 9927, checked in by Kon Lovett, 12 years ago

Re. 2.2.1 w/ Explict use of SRFI 69.

File size: 7.8 KB
Line 
1;;;; fplib.scm
2
3
4(use srfi-1 srfi-69 utils regex posix)
5
6
7#|
8
9Functional forms:
10
11 debug ATOM:x -> x
12 error ATOM:x -> _|_
13 /f:<x, ...> -> y
14 \f:<x, ...> -> y
15 {f, ...}:x -> F | <y, ...>
16
17Primitives:
18
19 show:x -> x
20 eq:<x, y> -> bool
21 apndl:<x, <y, ...>> -> <x, y, ...>
22 apndr:<<x, ...>, y> -> <x, ..., y>
23 +:<x, y> -> x + y
24 -:<x, y> -> x - y
25 x:<x, y> -> x * y
26 %:<x, y> -> x / y
27 gt:<x, y> -> x > y
28 lt:<x, y> -> x < y
29 id:x -> x
30 type:x -> atom
31 tl:<x1 x2, ...> -> <x2, ...>
32 null:x -> bool
33 length:<x1, ...> -> N
34 reverse:<x1, ...> -> <..., x1>
35 cat:<<x1, ...>, <y1, ...>> -> <x1, ..., y1, ...>
36 atom:x -> bool
37 code:a -> x
38 forget:<a, ...> -> <a, ...>
39 compile:<a, x> -> a
40 pack:<n, ...> -> a
41 unpack:x -> <n, ...>
42 number:a -> n
43 defined:_ -> <a, ...>
44 read:n -> <c, ...>
45 write:x
46 throw:x
47 system:a
48 readf:a -> <c, ...>
49 writef:<a, <c, ...>>
50 existsf:a -> bool
51 readp:a -> <c, ...>
52 writep:<a, <c, ...>>
53 statf:a -> <n, ...>
54
55;|#
56
57
58#+compiling
59(declare 
60  (export fp:_debug fp:_error fp:show fp:_insert
61          fp:_pcons fp:eq fp:apndl fp:apndr fp:+ fp:code
62          fp:- fp:x fp:% fp:gt fp:lt fp:id fp:tl fp:null
63          fp:compile fp:forget fp:pack fp:unpack 
64          fp:number fp:defined fp:_insert-right fp:read
65          fp:write fp:_catch fp:throw fp:_select
66          fp:system fp:_trace fp:_load fp:readf fp:writef
67          fp:existsf fp:readp fp:writep fp:statf
68          fp:reverse fp:length fp:cat fp:type fp:atom) )
69
70
71(define-macro (binary name . body)
72  `(match-lambda
73     ((x y) ,@body)
74     (args (error ',name "argument is not a sequence" args)) ) )
75
76(define (boolify x)
77  (if (eq? 'F x) #f #t) )
78
79(define (unboolify x)
80  (if x 'T 'F) )
81
82(define (num loc pos x)
83  (cond ((number? x) x)
84        ((symbol? x) 
85         (or (string->number (symbol->string x))
86             (badarg loc pos x "a number")))
87        ((char? x) (char->integer x))
88        ((string? x) 
89         (or (string->number x)
90             (badarg loc pos x "a number")))
91        (else (badarg loc pos x "a number"))))
92
93(define (atm loc pos x)
94  (cond ((symbol? x) x)
95        ((number? x) (string->symbol (number->string x)))
96        ((string? x) (string->symbol x))
97        ((boolean? x) (if x 'T 'F))
98        ((char? x) (string->symbol (string x)))
99        (else (badarg loc pos x "an atom"))))
100
101(define (seq loc pos x)
102  (cond ((pair? x) x)
103        ((null? x) x)
104        ((vector? x) (vector->list x))
105        (else (badarg loc pos x "a sequence"))))
106
107(define (badarg loc pos x msg)
108  (error 
109   loc
110   (string-append
111    "argument is not " 
112    msg
113    (if pos
114        (sprintf " in position ~a" pos)
115        "") )
116   x) )
117
118(define (fp:_select i x)
119  (cond ((zero? i) '())
120        ((negative? i) (list-tail (seq i #f x) (- i)))
121        (else (list-ref (seq i #f x) (sub1 i)))))
122
123(define (fp:_debug s x)
124  (fprintf (current-error-port) "~a: " s)
125  (fp:show x) 
126  x)
127
128(define (fp:_error loc msg arg)
129  (error (cond ((number? loc) (string->symbol (number->string loc)))
130               (else loc))
131         (atm '_ #f msg) arg))
132
133(define fp:show
134  (let ((rx (regexp "^[A-Z][A-Za-z0-9_]*$")))
135    (lambda (x)
136      (define (show1 x)
137        (cond ((null? x) (display "<>"))
138              ((symbol? x) 
139               (let ((name (symbol->string x)))
140                 ((if (string-match rx name) display write) name) ) )
141              ((atom? x) (display x))
142              (else
143               (write-char #\<)
144               (show1 (car x))
145               (do ((x (cdr x) (cdr x)))
146                   ((null? x))
147                 (display ", ")
148                 (show1 (car x)) )
149               (write-char #\>) ) ) )
150      (show1 x)
151      (newline)
152      x) ) )
153
154(define (unit f)
155  (cond ((eq? f fp:+) 0)
156        ((eq? f fp:x) 1)
157        (else (error 'unit "unknown unit value" f))))
158
159(define (fp:_insert f x)
160  (if (null? x)
161      (unit f)
162      (reduce (lambda (x y) (f (list y x))) #f x) ) )
163
164(define (fp:_insert-right f x)
165  (if (null? x)
166      (unit f)
167      (reduce-right (lambda (x y) (f (list x y))) #f x) ) )
168
169(define (fp:_pcons x . fs)
170  (let loop ((x x) (fs fs))
171    (cond ((null? fs) (unboolify (null? x)))
172          ((eq? '... (car fs)) 'T)
173          ((not (pair? x)) 'F)
174          ((boolify ((car fs) (car x)))
175           (loop (cdr x) (cdr fs)) )
176          (else 'F) ) ) )
177
178(define fp:eq (binary eq (unboolify (equal? x y)) ))
179(define fp:apndl (binary apndl (cons x (seq 'apndl 2 y))))
180(define fp:apndr (binary apdnr (append (seq 'apndr 1 x) (list y))))
181(define fp:+ (binary + (+ (num '+ 1 x) (num '+ 2 y))))
182(define fp:- (binary - (- (num '- 1 x) (num '- 2 y))))
183(define fp:x (binary x (* (num 'x 1 x) (num 'x 2 y))))
184(define fp:% (binary % (quotient (num '% 1 x) (num '% 2 y))))
185(define fp:gt (binary gt (unboolify (> (num 'gt 1 x) (num 'gt 2 y)))))
186(define fp:lt (binary lt (unboolify (< (num 'lt 1 x) (num 'lt 2 y)))))
187(define fp:id identity)
188(define fp:tl cdr)
189(define (fp:null x) (unboolify (null? x)))
190(define (fp:reverse x) (reverse (seq 'reverse #f x)))
191(define (fp:length x) (length (seq 'length #f x)))
192
193(define (fp:cat x)
194  (concatenate (map (cut seq 'cat #f <>) (seq 'cat #f x))))
195
196(define (fp:type x)
197  (cond ((symbol? x) 'ATOM)
198        ((number? x) 'NUMBER)
199        ((or (null? x) (pair? x)) 'SEQUENCE)
200        (else (error 'type "internal - unknown type of object" x)) ) )
201
202(define (fp:atom x)
203  (unboolify (or (null? x) (symbol? x) (number? x))))
204
205(define (fp:code x)
206  (or (fp-code (atm 'code #f x)) 'F) )
207
208(define (fp:forget lst)
209  (if (pair? lst)
210      (for-each (cut hash-table-delete! *code-table* <>) lst)
211      (set! *code-table* (make-hash-table eq?)))
212  lst)
213
214(define (fp:compile x)
215  (eval
216   (fp->scheme 
217    `(def ,(atm 'compile 1 (car x)) 
218          ,(cadr (seq 'compile 2 (cadr x)))))))
219
220(define (fp:_load files)
221  (do ((i 0 (add1 i))
222       (fs (seq '<load> #f files) (cdr fs)))
223      ((null? fs) files)
224    (eval
225     `(begin
226        ,@(map fp->scheme
227               (call-with-input-file (symbol->string (atm '<load> i (car fs)))
228                 fp-parse)))) ) )
229
230(define (fp:pack x)
231  (string->symbol (list->string (map integer->char (seq 'pack #f x)))))
232
233(define (fp:unpack x)
234  (map char->integer (string->list (symbol->string (atm 'unpack #f x)))))
235
236(define (fp:number x)
237  (cond ((number? x) x)
238        ((symbol? x) (or (string->number (symbol->string x)) 'F))
239        ((char? x) (char->integer x))
240        ((string? x) (or (string->number x) 'F))
241        (else 'F)))
242
243(define (fp:defined _) (hash-table-keys *code-table*))
244
245(define (fp:read n)
246  (map char->integer
247       (string->list
248        (cond ((number? n) (read-string n))
249              ((eq? 'LINE n) (read-line))
250              (else (read-all) ) ) ) ) )
251
252(define (fp:write x)
253  (cond ((number? x) (write-char (integer->char x)))
254        ((pair? x) (for-each (o write-char integer->char) x))
255        ((or (symbol? x) (string? x) (char? x)) (display x))
256        (else (badarg 'write #f x "a number or sequence")))
257  x)
258
259(define fp:_catch
260  (let ((msg (condition-property-accessor 'exn 'message)))
261    (lambda (h f x)
262      (condition-case (f x)
263        (ex (exn) (h (cons 'error (msg ex))))
264        (ex () (h ex)) ) ) ) )
265
266(define fp:throw signal)
267
268(define (fp:system x)
269  (system* (symbol->string (atm 'system #f x))))
270
271(define *indent* "")
272
273(define (fp:_trace loc arg thunk)
274  (let ((indent #f)
275        (result '_))
276    (dynamic-wind
277        (lambda ()
278          (printf "[~a~a:~s]~%" *indent* loc arg)
279          (set! indent *indent*)
280          (set! *indent* (string-append *indent* " ")) )
281        (lambda ()
282          (set! result (thunk))
283          result)
284        (lambda ()
285          (set! *indent* indent) 
286          (printf "[~a~a -> ~s]~%" *indent* loc result) ) ) ) )
287
288(define (fp:readf fn)
289  (map char->integer (string->list (read-all (symbol->string (atm 'readf #f fn))))))
290
291(define (fp:writef x)
292  (with-output-to-file (symbol->string (atm 'writef 1 (car x)))
293    (lambda () (display (map integer->char (seq 'writef 2 (cadr x)))))))
294
295(define (fp:existsf fn)
296  (unboolify (file-exists? (atm 'existsf #f fn))))
297
298(define (fp:statf fn)
299  (file-stat (symbol->string (atm 'statf #f fn)) ))
300
301(define (fp:readp cmd)
302  (with-input-from-pipe (symbol->string (atm 'readp #f cmd))
303    (lambda ()
304      (map char->integer (string->list (read-all) ) ) ) ) )
305
306(define (fp:writep x)
307  (with-output-to-pipe 
308   (symbol->string (atm 'writep 1 (car x)))
309   (lambda ()
310     (write-string
311      (let ((arg (cadr x)))
312        (cond ((string? arg) arg)
313              ((symbol? arg) (symbol->string arg))
314              ((number? arg) (number->string arg))
315              (else (list->string (map integer->char arg)))))))) )
Note: See TracBrowser for help on using the repository browser.