diff --git a/femtolisp/ast/rpasses.exe b/femtolisp/ast/rpasses.exe deleted file mode 100755 index d00fd26..0000000 Binary files a/femtolisp/ast/rpasses.exe and /dev/null differ diff --git a/femtolisp/ast/system.lsp b/femtolisp/ast/system.lsp deleted file mode 100644 index 514ddd0..0000000 --- a/femtolisp/ast/system.lsp +++ /dev/null @@ -1,477 +0,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"))))) diff --git a/femtolisp/site/home.gif b/femtolisp/site/home.gif deleted file mode 100755 index cff7e8a..0000000 Binary files a/femtolisp/site/home.gif and /dev/null differ diff --git a/femtolisp/site/software.gif b/femtolisp/site/software.gif deleted file mode 100755 index 5644763..0000000 Binary files a/femtolisp/site/software.gif and /dev/null differ diff --git a/femtolisp/site/source.gif b/femtolisp/site/source.gif deleted file mode 100755 index dde5a6a..0000000 Binary files a/femtolisp/site/source.gif and /dev/null differ diff --git a/femtolisp/site/text.gif b/femtolisp/site/text.gif deleted file mode 100755 index e15f9a5..0000000 Binary files a/femtolisp/site/text.gif and /dev/null differ