1; This file contains the lisp library code for the Munger interpreter.
2
3; Copyright (c) 2001, 2002, 2003, James Bailie <jimmy@mammothcheese.ca>.
4; All rights reserved.
5;
6; Redistribution and use in source form, with or without
7; modification, are permitted provided that the following conditions are met:
8;
9;     * Redistributions of source code must retain the above copyright
10; notice, this list of conditions and the following disclaimer.
11;     * The name of James Bailie may not be used to endorse or promote
12; products derived from this software without specific prior written permission.
13;
14; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS"
15; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
18; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
19; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
20; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
21; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
22; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
23; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26(set 'caar (lambda (x) (car (car x))))
27(set 'cdar (lambda (x) (cdr (car x))))
28(set 'cadr (lambda (x) (car (cdr x))))
29(set 'cddr (lambda (x) (cdr (cdr x))))
30(set 'caddr (lambda (x) (car (cdr (cdr x)))))
31(set 'cdddr (lambda (x) (cdr (cdr (cdr x)))))
32(set 'cadddr (lambda (x) (car (cdr (cdr (cdr x))))))
33(set 'cddddr (lambda (x) (cdr (cdr (cdr (cdr x))))))
34(set 'caddddr (lambda (x) (car (cdr (cdr (cdr (cdr x)))))))
35
36(set 'nullp (lambda (x) (eq x ())))
37(set 'pairp (lambda (x) (and (not (atomp x)) (not (nullp x)))))
38
39(set 'equal
40   (lambda (x y)
41       (if (eq x y)
42           1
43           (and (pairp x)
44                (pairp y)
45                (equal (car x) (car y))
46                (equal (cdr x) (cdr y))))))
47
48(set 'reverse
49   (lambda (x)
50      (if (stringp x)
51         (join "" (reverse (split "" x)))
52
53         (if (pairp x)
54            (append (reverse (cdr x)) (list (car x)))
55            ()))))
56
57(set 'remove
58   (lambda (y x)
59      (if (not (pairp x))
60         x
61         (if (equal (car x) y)
62            (remove y (cdr x))
63            (cons (car x) (remove y (cdr x)))))))
64
65(set 'alist_lookup
66   (lambda (x y)
67      (if (not (pairp y))
68         ()
69         (catch
70            (while y
71               (if (equal (caar y) x)
72                  (throw (cdar y))
73                  (set 'y (cdr y))))))))
74
75(set 'alist_remove
76   (lambda (x y)
77      (let ((z y))
78         (catch
79            (while y
80               (if (equal (caar y) x)
81                  (throw (remove (car y) z)))
82               (set 'y (cdr y)))
83            z))))
84
85(set 'alist_replace
86   (lambda (x y z)
87
88      (let ((w y))
89         (catch
90            (while y
91               (if (equal (caar y) x)
92                  (throw (cons (cons x z) (remove (car y) w))))
93               (set 'y (cdr y)))
94
95            (cons (cons x z) w)))))
96
97(set 'upcase
98   (lambda (s a)
99      (when s
100         (let ((x 1))
101
102            (join ""
103               (mapcar
104                  (lambda (c)
105                     (let ((d (code c)))
106                        (if (not (and x (<= d 122) (>= d 97)))
107                           c
108                           (when (not a) (setq x 0))
109                           (char (- d 32)))))
110
111                  (split "" s)))))))
112
113(set 'downcase
114   (lambda (s a)
115      (when s
116         (let ((x 1))
117
118            (join ""
119               (mapcar
120                  (lambda (c)
121                     (let ((d (code c)))
122                        (if (not (and x (<= d 90) (>= d 65)))
123                           c
124                           (when (not a) (setq x 0))
125                           (char (+ d 32)))))
126
127                  (split "" s)))))))
128
129(setq mapcar
130   (lambda (f l)
131      (when l
132         (let ((n ()))
133            (while l
134               (setq n (cons (f (car l)) n))
135               (setq l (cdr l)))
136            (reverse n)))))
137
138(set 'map
139   (lambda (f l (more))
140      (if (not more)
141         (mapcar f l)
142
143         (letf map_more ((l l)
144                         (more more))
145
146            (when l
147               (cons (eval (cons f (cons (car l) (map car more))))
148                  (map_more (cdr l) (map cdr more))))))))
149
150(set 'foreach
151   (lambda (f l)
152      (while l
153         (f (car l))
154         (setq l (cdr l)))))
155
156(set 'member
157   (lambda (x l)
158      (if (not l)
159         0
160         (if (equal (car l) x)
161            1
162            (member x (cdr l))))))
163
164(set 'apply
165   (macro (a b)
166      (list 'eval (list 'cons a b))))
167
168(set 'quit (macro () '(exit 0)))
169
170(set 'qquote
171   (macro (args)
172      (labels ((buildit
173                  (lambda (args)
174                     (and args
175                        (cons (cond ((eq (car args) ',)
176                                     (car (set 'args (cdr args))))
177
178                                    ((pairp (car args))
179                                     (cons 'list (buildit (car args))))
180
181                                    (1 (list 'quote (car args))))
182
183                              (buildit (cdr args)))))))
184
185         (cons 'list (buildit args)))))
186
187(set 'with_input_file
188   (macro (file (code))
189      (qquote
190         (when (> (redirect 0 ,file) 0)
191            (protect ,(cons 'progn code)
192               (resume 0))))))
193
194(set 'with_output_file
195   (macro (file (code))
196      (qquote
197         (when (> (redirect 1 ,file) 0)
198            (protect ,(cons 'progn code)
199               (resume 1))))))
200
201(set 'with_error_file
202   (macro (file (code))
203      (qquote
204         (when (> (redirect 2 ,file) 0)
205            (protect ,(cons 'progn code)
206               (resume 2))))))
207
208(let ((r (gensym)))
209
210   (set 'with_error_file_appending
211      (macro (file (code))
212         (qquote
213            (let ((,r 0))
214               (if (> (setq ,r (redirect 2 ,file 1)) 0)
215                  (protect ,(cons 'progn code)
216                     (resume 2))
217                  ,r))))))
218
219(let ((r (gensym)))
220
221   (set 'with_output_file_appending
222      (macro (file (code))
223         (qquote
224            (let ((,r 0))
225               (if (> (setq ,r (redirect 1 ,file 1)) 0)
226                  (protect ,(cons 'progn code)
227                     (resume 1))
228                  ,r))))))
229
230(set 'with_input_process
231   (macro (cmd (code))
232      (qquote
233         (progn
234            (pipe 0 ,cmd)
235            (protect ,(cons 'progn code)
236               (resume 0))))))
237
238(set 'with_output_process
239   (macro (cmd (code))
240      (qquote
241         (progn
242            (pipe 1 ,cmd)
243            (protect ,(cons 'progn code)
244               (resume 1))))))
245
246(let ((line (gensym)))
247
248   (set 'foreach_line
249      (macro (func)
250
251         (qquote
252            (if (not (next))
253               (while (set (quote ,line) (getline))
254                  (,func ,line))
255
256               (do
257                  (when (> (redirect 0 (current)) 0)
258                     (while (set (quote ,line) (getline))
259                        (,func ,line)))
260                  (next))
261
262               (resume 0))))))
263
264(let ((line (gensym)))
265
266   (set 'foreach_line_callback
267      (macro (func callback (after))
268
269         (qquote
270            (if (not (next))
271               (progn
272                  (while (set (quote ,line) (getline))
273                     (,func ,line))
274                  (,callback))
275
276               (do
277                  (when (> (redirect 0 (current)) 0)
278                     (while (set (quote ,line) (getline))
279                        (,func ,line)))
280
281                  ,(if (and after (car after))
282                     (qquote
283                        (prog1
284                           (next)
285                           (,callback)))
286
287                     (qquote
288                        (progn
289                           (,callback)
290                           (next)))))
291
292               (resume 0))))))
293
294(set 'assign
295   (lambda (s l)
296
297      (let ((n 0)
298            (len (length l)))
299
300         (progn
301            (while (< (used s) len)
302               (push s ()))
303
304            (while l
305               (store s n (car l))
306               (inc n)
307               (set 'l (cdr l)))
308
309            s))))
310
311(set 'flatten
312   (lambda (s)
313
314      (let ((r ())
315            (i (used s)))
316
317         (progn
318            (while i
319               (set 'r (cons (index s (dec i)) r)))
320
321            r))))
322
323(let ((buff (gensym)))
324
325   (set 'with_buffer
326      (macro (x (y))
327
328         (qquote
329            (let ((,buff (buffer)))
330               (switch ,x)
331               (protect ,(cons 'progn y)
332                  (switch ,buff)))))))
333
334(set 'defun
335   (macro (name args (body))
336      (qquote
337         (set (quote ,name)
338            ,(cons 'lambda (cons args body))))))
339
340(set 'defmac
341   (macro (name args (body))
342      (qquote
343         (set (quote ,name)
344            ,(cons 'macro (cons args body))))))
345
346(defmac letf (name args (body))
347   (qquote
348      (labels ((,name ,(append (list 'lambda (mapcar car args)) body)))
349         ,(cons name (mapcar cadr args)))))
350
351(let ((r (gensym)))
352
353   (defmac prog1 ((args))
354      (when args
355         (qquote
356            (let ((,r 0))
357               (setq ,r ,(car args))
358               ,(cons 'progn (cdr args))
359               ,r)))))
360
361(defmac concat ((args))
362   (cons 'join (cons "" args)))
363
364(defmac explode (arg)
365   (list 'split "" arg))
366
367(defun split_rx (rx arg (limit))
368
369   (let ((m (match rx arg))
370         (limit (if limit (- (abs (car limit)) 1) -1))
371         (r ()))
372
373      (if (not m)
374         (list arg)
375
376         (catch
377            (while (and limit m)
378               (when (car m)
379                  (dec limit)
380                  (setq r (cons (substring arg 0 (car m)) r)))
381
382               (when (eq (length arg) (cadr m))
383                  (throw (reverse r)))
384
385               (setq arg (substring arg (cadr m) 0))
386               (setq m (match rx arg)))
387
388            (reverse (cons arg r))))))
389
390(let ((rx (regcomp (concat "[\b\t" (char 10) (char 13) "]+"))))
391   (defun tokenize (arg)
392      (split_rx rx arg)))
393
394(let ((m (gensym))
395      (i (gensym))
396      (l (gensym))
397      (r (gensym))
398      (c (gensym))
399      (p (gensym)))
400
401   (defmac replace (rx expr str (limit))
402      (qquote
403
404         (let ((,m (matches ,rx ,str))
405               (,i -1)
406               (,l "")
407               (,r "")
408               (,c 0)
409               (,p ()))
410
411            (if (not ,m)
412               ,str
413
414               (setq ,p ,m)
415               (while ,p
416                  (extend (intern (stringify "m" (inc ,i))) (car ,p))
417                  (setq ,p (cdr ,p)))
418
419               (setq ,l ,str)
420               (setq ,c (if (quote ,limit) (+ 1 (car (quote ,limit))) -1))
421
422               (catch
423                  (while (and (dec ,c) ,m)
424                     (setq ,p (match ,rx ,l))
425
426                     (setq ,r
427                        (concat ,r
428                           (if (car ,p) (substring ,l 0 (car ,p)) "")
429                           (substitute ,rx
430                              ,expr
431                              (if (cadr ,p) (substring ,l (car ,p) (- (cadr ,p) (car ,p))) "")
432                              1)))
433
434                     (when (eq (cadr ,p) (length ,l))
435                        (throw ,r))
436
437                     (setq ,l (substring ,l (cadr ,p) 0))
438                     (setq ,m (matches ,rx ,l))
439
440                     (setq ,i -1)
441                     (foreach (lambda (x) (set (intern (stringify "m" (inc ,i))) x)) ,m))
442
443                  (concat ,r ,l)))))))
444
445(let ((root_rx (regcomp "^(.*)(\.[^.]*)$")))
446
447   (defun rootname (str)
448      (substitute root_rx "\1" str))
449
450   (defun suffix (str)
451      (substitute root_rx  "\2" str)))
452
453(defmac case (expr (clauses))
454
455   (let ((c (gensym)) (l ()))
456
457      (while clauses
458         (setq l (cons (cons (if (eq (caar clauses) '?) 1 (list 'eq (caar clauses) c))
459                             (cdar clauses))
460                       l))
461         (setq clauses (cdr clauses)))
462
463      (qquote
464         (let ((,c ,expr))
465            ,(cons 'cond (reverse l))))))
466
467(defun getstring (cmd)
468   (let ((line "") (str ""))
469      (with_input_process cmd
470         (while (setq line (getline))
471            (setq str (concat str line)))
472         str)))
473
474(defun filter_server (start end server port)
475   (when (>= (buffer) 0)
476
477      (let ((last (lastline)) (line "") (lines (stack)) (tmp "") (idx 0)
478            (count 0)
479            (rx (regcomp (concat "^[^" (char 10) "]*" (char 10)))))
480
481         (when (and (> start 0) (> end 0) (<= start last) (<= end last)
482                    (child_open server port))
483
484            (for (n start end)
485               (child_write (retrieve n)))
486
487            (while (setq line (child_read))
488               (push lines line))
489
490            (child_close)
491
492            (for (((setq idx end) (setq tmp ""))
493                  ((setq line (shift lines)) (when tmp (inc count) (insert idx tmp 1)))
494                  ((setq tmp line)))
495
496               (setq line (concat tmp line))
497
498               (while (setq last (match rx line))
499                  (insert idx (substring line (car last) (- (cadr last) (car last))) 1)
500                  (inc idx)
501                  (inc count)
502                  (setq line (if (> (length line) (cadr last)) (substring line (cadr last) 0) ""))))
503
504            (for (n start end)
505               (delete start))
506
507            count))))
508
509(let ((blank_rx (regcomp (join "" "^[" (char 13) (char 10) "]+$")))
510      (chunked_rx (regcomp "^Transfer-Encoding: chunked"))
511      (count_rx (regcomp "[0-9A-Fa-f]+"))
512      (count 0)
513      (f ())
514      (idx 1))
515
516   (defun remove_http_stuff ()
517
518      (when (lastline)
519
520         ; Find the end of the HTTP header.
521
522         (setq f (find 1 1 0 blank_rx 0))
523         (setq idx (car f))
524
525         ; Search the header for a Transfer-Encoding: chunked header line.
526
527         (setq f (find -1 idx 0 chunked_rx 0))
528
529         ; Delete the HTTP header.
530
531         (for (n 1 idx) (delete 1))
532
533         ; If data in chunks, merge them.
534
535         (when (car f)
536            (setq idx 1)
537
538            (while (and (<= idx (lastline))
539                        (setq count (hex2dec (car (matches count_rx (retrieve idx))))))
540               (delete idx)
541
542               (while (and count (<= idx (lastline)))
543                  (setq count (- count (car (slice idx 0 0 1 1))))
544                  (inc idx))
545
546               (when (<= idx (lastline))
547                  (delete idx)))
548
549            (while (<= idx (lastline))
550               (delete idx))))))
551
552(let ((g (gensym)))
553   (defmac with_temporary_output_file ((exprs))
554      (qquote
555         (let ((,g (temporary)))
556            (protect
557               ,(cons 'progn exprs)
558               (resume 1))
559            ,g))))
560