ref: ca1b12064ff8d177c5642645b25b13aa192dfdc4
parent: 1ef3c13acf54fafc080c2dfada62e13dddf1c75b
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sat Aug 30 01:05:31 EDT 2008
removing some redundant/irrelevant files
binary files a/femtolisp/ast/rpasses.exe /dev/null differ
--- a/femtolisp/ast/system.lsp
+++ /dev/null
@@ -1,477 +1,0 @@
-; femtoLisp standard library
-; by Jeff Bezanson
-; Public Domain
-
-(set 'list (lambda args args))
-
-(set-syntax 'setq (lambda (name val)
- (list set (list 'quote name) val)))
-
-; convert a sequence of body statements to a single expression.
-; this allows define, defun, defmacro, let, etc. to contain multiple
-; body expressions as in Common Lisp.
-(setq f-body (lambda (e)
- (cond ((atom e) e)
- ((eq (cdr e) ()) (car e))
- (T (cons 'progn e)))))
-
-(set-syntax 'defmacro
- (lambda (name args . body)
- (list 'set-syntax (list 'quote name)
- (list 'lambda args (f-body body)))))
-
-(defmacro label (name fn)
- (list (list 'lambda (cons name nil) (list 'setq name fn)) nil))
-
-; support both CL defun and Scheme-style define
-(defmacro defun (name args . body)
- (list 'setq name (list 'lambda args (f-body body))))
-
-(defmacro define (name . body)
- (if (symbolp name)
- (list 'setq name (car body))
- (cons 'defun (cons (car name) (cons (cdr name) body)))))
-
-(defun identity (x) x)
-(setq null not)
-
-(defun map (f lst)
- (if (atom lst) lst
- (cons (f (car lst)) (map f (cdr lst)))))
-
-(defmacro let (binds . body)
- (cons (list 'lambda
- (map (lambda (c) (if (consp c) (car c) c)) binds)
- (f-body body))
- (map (lambda (c) (if (consp c) (cadr c) nil)) binds)))
-
-(defun nconc lsts
- (cond ((null lsts) ())
- ((null (cdr lsts)) (car lsts))
- (T ((lambda (l d) (if (null l) d
- (prog1 l
- (while (consp (cdr l)) (set 'l (cdr l)))
- (rplacd l d))))
- (car lsts) (apply nconc (cdr lsts))))))
-
-(defun append 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) (apply append (cdr lsts))))))
-
-(defun member (item lst)
- (cond ((atom lst) ())
- ((equal (car lst) item) lst)
- (T (member item (cdr lst)))))
-
-(defun macrocallp (e) (and (symbolp (car e))
- (symbol-syntax (car e))))
-
-(defun functionp (x)
- (or (builtinp x)
- (and (consp x) (eq (car x) 'lambda))))
-
-(defun macroexpand-1 (e)
- (if (atom e) e
- (let ((f (macrocallp e)))
- (if f (apply f (cdr e))
- e))))
-
-; convert to proper list, i.e. remove "dots", and append
-(defun append.2 (l tail)
- (cond ((null l) tail)
- ((atom l) (cons l tail))
- (T (cons (car l) (append.2 (cdr l) tail)))))
-
-(define (cadr x) (car (cdr x)))
-
-(setq *special-forms* '(quote cond if and or while lambda label trycatch
- %top progn))
-
-(defun macroexpand (e)
- ((label mexpand
- (lambda (e env f)
- (progn
- (while (and (consp e)
- (not (member (car e) env))
- (set 'f (macrocallp e)))
- (set 'e (apply f (cdr e))))
- (cond ((and (consp e)
- (not (eq (car e) 'quote)))
- (let ((newenv
- (if (and (or (eq (car e) 'lambda)
- (eq (car e) 'label))
- (consp (cdr e)))
- (append.2 (cadr e) env)
- env)))
- (map (lambda (x) (mexpand x newenv nil)) e)))
- ((and (symbolp e) (constantp e)) (eval e))
- ;((and (symbolp e)
- ; (not (member e *special-forms*))
- ; (not (member e env))) (cons '%top e))
- (T e)))))
- e nil nil))
-
-; uncomment this to macroexpand functions at definition time.
-; makes typical code ~25% faster, but only works for defun expressions
-; at the top level.
-(defmacro defun (name args . body)
- (list 'setq name (macroexpand (list 'lambda args (f-body body)))))
-
-; same thing for macros. enabled by default because macros are usually
-; defined at the top level.
-(defmacro defmacro (name args . body)
- (list 'set-syntax (list 'quote name)
- (macroexpand (list 'lambda args (f-body body)))))
-
-(setq = equal)
-(setq eql equal)
-(define (/= a b) (not (equal a b)))
-(define != /=)
-(define (> a b) (< b a))
-(define (<= a b) (not (< b a)))
-(define (>= a b) (not (< a b)))
-(define (1+ n) (+ n 1))
-(define (1- n) (- n 1))
-(define (mod x y) (- x (* (/ x y) y)))
-(define (abs x) (if (< x 0) (- x) x))
-(setq K prog1) ; K combinator ;)
-(define (funcall f . args) (apply f args))
-(define (symbol-value sym) (eval sym))
-(define symbol-function symbol-value)
-(define (terpri) (princ "\n") nil)
-
-(define (caar x) (car (car x)))
-(define (cdar x) (cdr (car x)))
-(define (cddr x) (cdr (cdr x)))
-(define (caaar x) (car (car (car x))))
-(define (caadr x) (car (car (cdr x))))
-(define (cadar x) (car (cdr (car x))))
-(define (caddr x) (car (cdr (cdr x))))
-(define (cdaar x) (cdr (car (car x))))
-(define (cdadr x) (cdr (car (cdr x))))
-(define (cddar x) (cdr (cdr (car x))))
-(define (cdddr x) (cdr (cdr (cdr x))))
-
-(defun every (pred lst)
- (or (atom lst)
- (and (pred (car lst))
- (every pred (cdr lst)))))
-
-(defun any (pred lst)
- (and (consp lst)
- (or (pred (car lst))
- (any pred (cdr lst)))))
-
-(defun listp (a) (or (eq a ()) (consp a)))
-
-(defun nthcdr (n lst)
- (if (<= n 0) lst
- (nthcdr (- n 1) (cdr lst))))
-
-(defun list-ref (lst n)
- (car (nthcdr n lst)))
-
-(defun list* l
- (if (atom (cdr l))
- (car l)
- (cons (car l) (apply list* (cdr l)))))
-
-(defun nlist* l
- (if (atom (cdr l))
- (car l)
- (rplacd l (apply nlist* (cdr l)))))
-
-(defun lastcdr (l)
- (if (atom l) l
- (lastcdr (cdr l))))
-
-(defun last (l)
- (cond ((atom l) l)
- ((atom (cdr l)) l)
- (T (last (cdr l)))))
-
-(defun map! (f lst)
- (prog1 lst
- (while (consp lst)
- (rplaca lst (f (car lst)))
- (set 'lst (cdr lst)))))
-
-(defun mapcar (f . lsts)
- ((label mapcar-
- (lambda (lsts)
- (cond ((null lsts) (f))
- ((atom (car lsts)) (car lsts))
- (T (cons (apply f (map car lsts))
- (mapcar- (map cdr lsts)))))))
- lsts))
-
-(defun transpose (M) (apply mapcar (cons list M)))
-
-(defun filter (pred lst)
- (cond ((null lst) ())
- ((pred (car lst)) (cons (car lst) (filter pred (cdr lst))))
- (T (filter pred (cdr lst)))))
-
-(define (foldr f zero lst)
- (if (null lst) zero
- (f (car lst) (foldr f zero (cdr lst)))))
-
-(define (foldl f zero lst)
- (if (null lst) zero
- (foldl f (f (car lst) zero) (cdr lst))))
-
-(define (reverse lst) (foldl cons nil lst))
-
-(defun reduce (f zero lst)
- (if (null lst) zero
- (reduce f (f zero (car lst)) (cdr lst))))
-
-(define (copy-list l)
- (if (atom l) l
- (cons (car l)
- (copy-list (cdr l)))))
-(define (copy-tree l)
- (if (atom l) l
- (cons (copy-tree (car l))
- (copy-tree (cdr l)))))
-
-(define (nreverse l)
- (let ((prev nil))
- (while (consp l)
- (set 'l (prog1 (cdr l)
- (rplacd l (prog1 prev
- (set 'prev l))))))
- prev))
-
-(defmacro let* (binds . body)
- (cons (list 'lambda (map car binds)
- (cons 'progn
- (nconc (map (lambda (b) (cons 'setq b)) binds)
- body)))
- (map (lambda (x) nil) binds)))
-
-(defmacro labels (binds . body)
- (cons (list 'lambda (map car binds)
- (cons 'progn
- (nconc (map (lambda (b)
- (list 'setq (car b) (cons 'lambda (cdr b))))
- binds)
- body)))
- (map (lambda (x) nil) binds)))
-
-(defmacro when (c . body) (list 'if c (f-body body) nil))
-(defmacro unless (c . body) (list 'if c nil (f-body body)))
-
-(defmacro dotimes (var . body)
- (let ((v (car var))
- (cnt (cadr var)))
- (list 'let (list (list v 0))
- (list 'while (list < v cnt)
- (list prog1 (f-body body) (list 'setq v (list + v 1)))))))
-
-(defun map-int (f n)
- (if (<= n 0)
- ()
- (let ((first (cons (f 0) nil)))
- ((label map-int-
- (lambda (acc i n)
- (if (= i n)
- first
- (progn (rplacd acc (cons (f i) nil))
- (map-int- (cdr acc) (+ i 1) n)))))
- first 1 n))))
-
-(defun iota (n) (map-int identity n))
-
-(defun error args (raise (cons 'error args)))
-
-(defmacro throw (tag value) `(raise (list 'thrown-value ,tag ,value)))
-(defmacro catch (tag expr)
- (let ((e (gensym)))
- `(trycatch ,expr
- (lambda (,e) (if (and (consp ,e)
- (eq (car ,e) 'thrown-value)
- (eq (cadr ,e) ,tag))
- (caddr ,e)
- (raise ,e))))))
-
-(defmacro unwind-protect (expr finally)
- (let ((e (gensym)))
- `(prog1 (trycatch ,expr
- (lambda (,e) (progn ,finally (raise ,e))))
- ,finally)))
-
-; (try expr
-; (catch (type-error e) . exprs)
-; (catch (io-error e) . exprs)
-; (catch (e) . exprs)
-; (finally . exprs))
-(defmacro try (expr . forms)
- (let* ((e (gensym))
- (reraised (gensym))
- (final (f-body (cdr (or (assoc 'finally forms) '(())))))
- (catches (filter (lambda (f) (eq (car f) 'catch)) forms))
- (catchblock `(cond
- ,.(map (lambda (catc)
- (let* ((specific (cdr (cadr catc)))
- (extype (caadr catc))
- (var (if specific (car specific)
- extype))
- (todo (cddr catc)))
- `(,(if specific
- ; exception matching logic
- `(or (eq ,e ',extype)
- (and (consp ,e)
- (eq (car ,e)
- ',extype)))
- T); (catch (e) ...), match anything
- (let ((,var ,e)) (progn ,@todo)))))
- catches)
- (T (raise ,e))))) ; no matches, reraise
- (if final
- (if catches
- ; form with both catch and finally
- `(prog1 (trycatch ,expr
- (lambda (,e)
- (trycatch ,catchblock
- (lambda (,reraised)
- (progn ,final
- (raise ,reraised))))))
- ,final)
- ; finally only; same as unwind-protect
- `(prog1 (trycatch ,expr (lambda (,e)
- (progn ,final (raise ,e))))
- ,final))
- ; catch, no finally
- `(trycatch ,expr (lambda (,e) ,catchblock)))))
-
-; setf
-; expands (setf (place x ...) v) to (mutator (f x ...) v)
-; (mutator (identity x ...) v) is interpreted as (mutator x ... v)
-(setq *setf-place-list*
- ; place mutator f
- '((car rplaca identity)
- (cdr rplacd identity)
- (caar rplaca car)
- (cadr rplaca cdr)
- (cdar rplacd car)
- (cddr rplacd cdr)
- (caaar rplaca caar)
- (caadr rplaca cadr)
- (cadar rplaca cdar)
- (caddr rplaca cddr)
- (cdaar rplacd caar)
- (cdadr rplacd cadr)
- (cddar rplacd cdar)
- (cdddr rplacd cddr)
- (get put identity)
- (aref aset identity)
- (symbol-function set identity)
- (symbol-value set identity)
- (symbol-plist set-symbol-plist identity)
- (symbol-syntax set-syntax identity)))
-
-(defun setf-place-mutator (place val)
- (if (symbolp place)
- (list 'setq place val)
- (let ((mutator (assoc (car place) *setf-place-list*)))
- (if (null mutator)
- (error '|setf: unknown place | (car place))
- (if (eq (caddr mutator) 'identity)
- (cons (cadr mutator) (append (cdr place) (list val)))
- (list (cadr mutator)
- (cons (caddr mutator) (cdr place))
- val))))))
-
-(defmacro setf args
- (f-body
- ((label setf-
- (lambda (args)
- (if (null args)
- nil
- (cons (setf-place-mutator (car args) (cadr args))
- (setf- (cddr args))))))
- args)))
-
-(defun revappend (l1 l2) (nconc (reverse l1) l2))
-(defun nreconc (l1 l2) (nconc (nreverse l1) l2))
-
-(defun list-to-vector (l) (apply vector l))
-(defun vector-to-list (v)
- (let ((i (- (length v) 1))
- (l nil))
- (while (>= i 0)
- (setq l (cons (aref v i) l))
- (setq i (- i 1)))
- l))
-
-(defun self-evaluating-p (x)
- (or (eq x nil)
- (eq x T)
- (and (atom x)
- (not (symbolp x)))))
-
-; backquote
-(defmacro backquote (x) (bq-process x))
-
-(defun splice-form-p (x)
- (or (and (consp x) (or (eq (car x) '*comma-at*)
- (eq (car x) '*comma-dot*)))
- (eq x '*comma*)))
-
-(defun bq-process (x)
- (cond ((self-evaluating-p x)
- (if (vectorp x)
- (let ((body (bq-process (vector-to-list x))))
- (if (eq (car body) 'list)
- (cons vector (cdr body))
- (list apply vector body)))
- x))
- ((atom x) (list 'quote x))
- ((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
- ((eq (car x) '*comma*) (cadr x))
- ((not (any splice-form-p x))
- (let ((lc (lastcdr x))
- (forms (map bq-bracket1 x)))
- (if (null lc)
- (cons 'list forms)
- (nconc (cons 'nlist* forms) (list (bq-process lc))))))
- (T (let ((p x) (q ()))
- (while (and (consp p)
- (not (eq (car p) '*comma*)))
- (setq q (cons (bq-bracket (car p)) q))
- (setq p (cdr p)))
- (let ((forms
- (cond ((consp p) (nreconc q (list (cadr p))))
- ((null p) (nreverse q))
- (T (nreconc q (list (bq-process p)))))))
- (if (null (cdr forms))
- (car forms)
- (cons 'nconc forms)))))))
-
-(defun bq-bracket (x)
- (cond ((atom x) (list cons (bq-process x) nil))
- ((eq (car x) '*comma*) (list cons (cadr x) nil))
- ((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
- ((eq (car x) '*comma-dot*) (cadr x))
- (T (list cons (bq-process x) nil))))
-
-; bracket without splicing
-(defun bq-bracket1 (x)
- (if (and (consp x) (eq (car x) '*comma*))
- (cadr x)
- (bq-process x)))
-
-(defmacro assert (expr) `(if ,expr T (raise '(assert-failed ,expr))))
-
-(defmacro time (expr)
- (let ((t0 (gensym)))
- `(let ((,t0 (time.now)))
- (prog1
- ,expr
- (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
binary files a/femtolisp/site/home.gif /dev/null differ
binary files a/femtolisp/site/software.gif /dev/null differ
binary files a/femtolisp/site/source.gif /dev/null differ
binary files a/femtolisp/site/text.gif /dev/null differ