shithub: femtolisp

ref: 40b76da107627b529cabd18c6c03304a6226e4d5
dir: /test/test.lsp/

View raw version
; -*- 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 (λ (lst result)
;                     (if (null? lst) result
;                       (rev-help (cdr lst) (cons (car lst) result)))))
;   lst ()))

(define (append- . lsts)
  ((label append-h
          (λ (lsts)
            (cond ((null? lsts) ())
                  ((null? (cdr lsts)) (car lsts))
                  (#t ((label append2 (λ (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 (λ (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 (λ (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-
                (λ (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)
  `((λ (,name) (set! ,name ,fn)) ()))

; 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-
          (λ (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 (λ (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- (λ ()
                    (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
               (λ (catc next)
                 (let ((var    (cadr (cadr catc)))
                       (extype (caadr catc))
                       (todo   (f-body (cddr  catc))))
                   `(λ (,var)
                      (if (or (eq ,var ',extype)
                              (and (pair? ,var)
                                   (eq (car ,var) ',extype)))
                          ,todo
                        (,next ,var)))))

               ; default function; no matches so re-raise
               '(λ (e) (begin (*_try_finally_thunk_*) (raise e)))

               ; make list of catch forms
               (filter (λ (f) (eq (car f) 'catch)) forms))))
    `(let ((*_try_finally_thunk_* (λ () ,final)))
       (prog1 (attempt ,expr ,body)
         (*_try_finally_thunk_*)))))

(define Y
  (λ (f)
    ((λ (h)
       (f (λ (x) ((h h) x))))
     (λ (h)
       (f (λ (x) ((h h) x)))))))

(define yfib
  (Y (λ (fib)
       (λ (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
              (λ (,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)))))))

(let ((*profiles* (table)))
  (set! profile
        (λ (s)
          (let ((f (top-level-value s)))
            (put! *profiles* s (cons 0 0))
            (set-top-level-value! s
             (λ 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
        (λ ()
          (define pr (filter (λ (x) (> (cadr x) 0))
                             (table-pairs *profiles*)))
          (define width (+ 4
                           (apply max
                                  (map (λ (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
           (λ (p)
             (princ (string-rpad (string (caddr p)) width #\ )
                    (string-rpad (string (cadr p)) 11 #\ )
                    (car p))
             (newline))
           (simple-sort (map (λ (l) (reverse (to-proper l)))
                             pr)))))
  (set! clear-profiles
        (λ ()
          (for-each (λ (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
            taboreach 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)))))))