ref: b09398e98563c23b6988e77b7b5ab84c0e03ceb7
dir: /test/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)) #| (define-macro (dotimes var . body) (let ((v (car var)) (cnt (cadr var))) `(let ((,v 0)) (while (< ,v ,cnt) (prog1 ,(cons 'begin 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 (set-cdr! 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 (expt b p) (cond ((= p 0) 1) ((= b 0) 0) ((even? p) (square (expt b (div0 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 (set-cdr! c (K (swapad (car c)) (set-car! 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 ((acc (gensym))) `(let ((,acc (list ()))) (cdr (prog1 ,acc (while ,cnd (begin (set! ,acc (cdr (set-cdr! ,acc (cons ,what ())))) ,@body))))))) (define-macro (accumulate-for var lo hi what . body) (let ((acc (gensym))) `(let ((,acc (list ()))) (cdr (prog1 ,acc (for ,lo ,hi (lambda (,var) (begin (set! ,acc (cdr (set-cdr! ,acc (cons ,what ())))) ,@body)))))))) (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))))))) (define (string.findall haystack needle . offs) (define (sub h n offs lst) (let ((i (string.find h n offs))) (if i (sub h n (string.inc h i) (cons i lst)) (reverse! lst)))) (sub haystack needle (if (null? offs) 0 (car offs)) ())) (let ((*profiles* (table))) (set! profile (lambda (s) (let ((f (top-level-value s))) (put! *profiles* s (cons 0 0)) (set-top-level-value! s (lambda args (define tt (get *profiles* s)) (define count (car tt)) (define time (cdr tt)) (define t0 (time.now)) (define v (apply f args)) (set-cdr! tt (+ time (- (time.now) t0))) (set-car! tt (+ count 1)) v))))) (set! show-profiles (lambda () (define pr (filter (lambda (x) (> (cadr x) 0)) (table.pairs *profiles*))) (define width (+ 4 (apply max (map (lambda (x) (length (string x))) (cons 'Function (map car pr)))))) (princ (string.rpad "Function" width #\ ) "#Calls Time (seconds)") (newline) (princ (string.rpad "--------" width #\ ) "------ --------------") (newline) (for-each (lambda (p) (princ (string.rpad (string (caddr p)) width #\ ) (string.rpad (string (cadr p)) 11 #\ ) (car p)) (newline)) (simple-sort (map (lambda (l) (reverse (to-proper l))) pr))))) (set! clear-profiles (lambda () (for-each (lambda (k) (put! *profiles* k (cons 0 0))) (table.keys *profiles*))))) #;(for-each profile '(emit encode-byte-code const-to-idx-vec index-of lookup-sym in-env? any every compile-sym compile-if compile-begin compile-arglist expand builtin->instruction compile-app separate nconc get-defined-vars compile-in compile compile-f delete-duplicates map length> length= count filter append lastcdr to-proper reverse reverse! list->vector table.foreach list-head list-tail assq memq assoc member assv memv nreconc bq-process)) (define (filt1 pred lst) (define (filt1- pred lst accum) (if (null? lst) accum (if (pred (car lst)) (filt1- pred (cdr lst) (cons (car lst) accum)) (filt1- pred (cdr lst) accum)))) (filt1- pred lst ())) (define (filto pred lst (accum ())) (if (atom? lst) accum (if (pred (car lst)) (filto pred (cdr lst) (cons (car lst) accum)) (filto pred (cdr lst) accum)))) ; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d)) (define (pairwise? pred . args) (or (null? args) (let f ((a (car args)) (d (cdr args))) (or (null? d) (and (pred a (car d)) (f (car d) (cdr d)))))))