ref: f1927a3b57f5fe4001297f44045e2b06f8cd3942
dir: /femtolisp/test.lsp/
; -*- scheme -*-
; make label self-evaluating, but evaluating the lambda in the process
;(defmacro labl (name f)
; (list list ''labl (list 'quote name) f))
(define-macro (labl name f)
`(let (,name) (set! ,name ,f)))
;(define (reverse lst)
; ((label rev-help (lambda (lst result)
; (if (null? lst) result
; (rev-help (cdr lst) (cons (car lst) result)))))
; lst ()))
(define (append- . lsts)
((label append-h
(lambda (lsts)
(cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts))
(#t ((label append2 (lambda (l d)
(if (null? l) d
(cons (car l)
(append2 (cdr l) d)))))
(car lsts) (append-h (cdr lsts)))))))
lsts))
;(princ 'Hello '| | 'world! "\n")
;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
;(princ (time (fib 34)) "\n")
;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8))
;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
;(dotimes (i 80000) (list 1 2 3 4 5))
;(set! a (map-int identity 10000))
;(dotimes (i 200) (rfoldl cons () a))
; iterative filter
(define (ifilter pred lst)
((label f (lambda (accum lst)
(cond ((null? lst) (nreverse accum))
((not (pred (car lst))) (f accum (cdr lst)))
(#t (f (cons (car lst) accum) (cdr lst))))))
() lst))
(define (sort l)
(if (or (null? l) (null? (cdr l))) l
(let* ((piv (car l))
(halves (separate (lambda (x) (< x piv)) (cdr l))))
(nconc (sort (car halves))
(list piv)
(sort (cdr halves))))))
(define-macro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
`(let ((,v 0))
(while (< ,v ,cnt)
(prog1
,(f-body body)
(set! ,v (+ ,v 1)))))))
(define (map-int f n)
(if (<= n 0)
()
(let ((first (cons (f 0) ())))
((label map-int-
(lambda (acc i n)
(if (= i n)
first
(begin (rplacd acc (cons (f i) ()))
(map-int- (cdr acc) (+ i 1) n)))))
first 1 n))))
(define-macro (labl name fn)
`((lambda (,name) (set! ,name ,fn)) ()))
(define (square x) (* x x))
(define (evenp x) (= x (* (/ x 2) 2)))
(define (expt b p)
(cond ((= p 0) 1)
((= b 0) 0)
((evenp p) (square (expt b (/ p 2))))
(#t (* b (expt b (- p 1))))))
(define (gcd a b)
(cond ((= a 0) b)
((= b 0) a)
((< a b) (gcd a (- b a)))
(#t (gcd b (- a b)))))
; like eval-when-compile
(define-macro (literal expr)
(let ((v (eval expr)))
(if (self-evaluating? v) v (list quote v))))
(define (cardepth l)
(if (atom? l) 0
(+ 1 (cardepth (car l)))))
(define (nestlist f zero n)
(if (<= n 0) ()
(cons zero (nestlist f (f zero) (- n 1)))))
(define (mapl f . lsts)
((label mapl-
(lambda (lsts)
(if (null? (car lsts)) ()
(begin (apply f lsts) (mapl- (map cdr lsts))))))
lsts))
; test to see if a symbol begins with :
(define (keywordp s)
(and (>= s '|:|) (<= s '|:~|)))
; swap the cars and cdrs of every cons in a structure
(define (swapad c)
(if (atom? c) c
(rplacd c (K (swapad (car c))
(rplaca c (swapad (cdr c)))))))
(define (without x l)
(filter (lambda (e) (not (eq e x))) l))
(define (conscount c)
(if (pair? c) (+ 1
(conscount (car c))
(conscount (cdr c)))
0))
; _ Welcome to
; (_ _ _ |_ _ | . _ _ 2
; | (-||||_(_)|__|_)|_)
; ==================|==
;[` _ ,_ |- | . _ 2
;| (/_||||_()|_|_\|)
; |
(define-macro (while- test . forms)
`((label -loop- (lambda ()
(if ,test
(begin ,@forms
(-loop-))
())))))
; this would be a cool use of thunking to handle 'finally' clauses, but
; this code doesn't work in the case where the user manually re-raises
; inside a catch block. one way to handle it would be to replace all
; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk.
; (try expr
; (catch (TypeError e) . exprs)
; (catch (IOError e) . exprs)
; (finally . exprs))
(define-macro (try expr . forms)
(let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
(body (foldr
; create a function to check for and handle one exception
; type, and pass off control to the next when no match
(lambda (catc next)
(let ((var (cadr (cadr catc)))
(extype (caadr catc))
(todo (f-body (cddr catc))))
`(lambda (,var)
(if (or (eq ,var ',extype)
(and (pair? ,var)
(eq (car ,var) ',extype)))
,todo
(,next ,var)))))
; default function; no matches so re-raise
'(lambda (e) (begin (*_try_finally_thunk_*) (raise e)))
; make list of catch forms
(filter (lambda (f) (eq (car f) 'catch)) forms))))
`(let ((*_try_finally_thunk_* (lambda () ,final)))
(prog1 (attempt ,expr ,body)
(*_try_finally_thunk_*)))))
(define Y
(lambda (f)
((lambda (h)
(f (lambda (x) ((h h) x))))
(lambda (h)
(f (lambda (x) ((h h) x)))))))
(define yfib
(Y (lambda (fib)
(lambda (n)
(if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) )))
;(tt)
;(tt)
;(tt)
(define-macro (accumulate-while cnd what . body)
(let ((first (gensym))
(acc (gensym)))
`(let ((,first ())
(,acc (list ())))
(set! ,first ,acc)
(while ,cnd
(begin (set! ,acc
(cdr (rplacd ,acc (cons ,what ()))))
,@body))
(cdr ,first))))
(define-macro (accumulate-for var lo hi what . body)
(let ((first (gensym))
(acc (gensym)))
`(let ((,first ())
(,acc (list ())))
(set! ,first ,acc)
(for ,lo ,hi
(lambda (,var)
(begin (set! ,acc
(cdr (rplacd ,acc (cons ,what ()))))
,@body)))
(cdr ,first))))
(define (map-indexed f lst)
(if (atom? lst) lst
(let ((i 0))
(accumulate-while (pair? lst) (f (car lst) i)
(begin (set! lst (cdr lst))
(set! i (1+ i)))))))