ref: e5cbdb2d92963fccf56980ea7a60ecc2b03204cf
parent: 17bd705b9375def88831e9e10f64618b98831b75
author: aap <aap@papnet.eu>
date: Mon Aug 22 06:39:42 EDT 2022
make set(q) also set value cell; various fixes
--- a/lib.l
+++ b/lib.l
@@ -1,4 +1,3 @@
-;;; taken from MACLISP
(defprop defun
(lambda (l)
(cond ((and (caddr l)
@@ -25,12 +24,14 @@
;;; examples
;;;
+(defun countargs expr nargs
+ nargs)
;;; compute greatest common divisor
(defun gcd (a b)
- (cond ((lessp a b) (gcd b a))
+ (cond ((< a b) (gcd b a))
((eq b 0) a)
- (t (gcd b (difference a b)))))
+ (t (gcd b (- a b)))))
;;; differentiate expression exp w.r.t. x
@@ -37,13 +38,13 @@
(defun diff (exp x)
(cond ((eq exp x) 1)
((atom exp) 0)
- ((eq (car exp) 'plus)
- (cons 'plus (mapcar #'(lambda (j) (diff j x)) (cdr exp))))
- ((eq (car exp) 'times)
- (cons 'plus
+ ((eq (car exp) '+)
+ (cons '+ (mapcar #'(lambda (j) (diff j x)) (cdr exp))))
+ ((eq (car exp) '*)
+ (cons '+
(maplist
#'(lambda (J)
- (cons 'times
+ (cons '*
(maplist
#'(lambda (K)
(cond ((equal J K) (diff (car K) x))
@@ -57,8 +58,8 @@
;;; simplify mathematical expression
(defun simplify (exp)
(cond ((atom exp) exp)
- ((eq (car exp) 'plus) (simpsum (simplis (cdr exp))))
- ((eq (car exp) 'times) (simpprod (simplis (cdr exp))))
+ ((eq (car exp) '+) (simpsum (simplis (cdr exp))))
+ ((eq (car exp) '*) (simpprod (simplis (cdr exp))))
(t exp)))
;;; simplify a list of expressions
@@ -71,12 +72,12 @@
(setq sep (separate terms nil nil))
(setq const (car sep))
(setq var (cadr sep))
- (setq const (eval (cons 'plus const) nil))
+ (setq const (eval (cons '+ const) nil))
(return (cond ((null var) const)
((eq const 0)
(cond ((null (cdr var)) (car var))
- (t (cons 'plus var))))
- (t (cons 'plus (cons const var)))))))
+ (t (cons '+ var))))
+ (t (cons '+ (cons const var)))))))
;;; simplify the terms of a product
(defun simpprod (terms)
@@ -84,13 +85,13 @@
(setq sep (separate terms nil nil))
(setq const (car sep))
(setq var (cadr sep))
- (setq const (eval (cons 'times const) nil))
+ (setq const (eval (cons '* const) nil))
(return (cond ((null var) const)
((eq const 0) 0)
((eq const 1)
(cond ((null (cdr var)) (car var))
- (t (cons 'times var))))
- (t (cons 'times (cons const var)))))))
+ (t (cons '* var))))
+ (t (cons '* (cons const var)))))))
;;; separate constants from variables in a list
(defun separate (lst const var)
--- a/lisp.c
+++ b/lisp.c
@@ -55,7 +55,6 @@
C *star;
C *digits[10];
-C *plus, *minus;
jmp_buf tljmp;
@@ -182,6 +181,12 @@
}
int
+symbolp(C *c)
+{+ return c == nil || (c->ap&~CAR_MARK) == CAR_ATOM;
+}
+
+int
fixnump(C *c)
{return c != nil && c->ap & CAR_ATOM && c->ap & CAR_FIX;
@@ -638,28 +643,32 @@
C*
evbody(C *c, C *a)
{- C *t;
- t = nil;
- for(; c != nil; c = c->d)
- t = eval(c->a, a);
- return t;
+ C *tt;
+ int spdp;
+
+ spdp = pdp;
+ push(c);
+ push(a);
+ for(tt = nil; c != nil; c = c->d)
+ tt = eval(c->a, a);
+ pdp = spdp;
+ return tt;
}
C*
evcon(C *c, C *a)
{- C *tt;
int spdp;
+
spdp = pdp;
push(c);
push(a);
- for(; c != nil; c = c->d){- tt = eval(c->a->a, a);
- if(tt != nil){+ for(; c != nil; c = c->d)
+ if(eval(c->a->a, a) != nil){pdp = spdp;
return evbody(c->a->d, a);
}
- }
+ pdp = spdp;
return nil;
}
@@ -707,11 +716,11 @@
if(numberp(form) || stringp(form))
return form;
if(atom(form)){+ if(tt = assq(form, a), tt != nil)
+ return tt->d;
if(tt = getx(form, value), tt != nil)
return tt->a;
- if(tt = assq(form, a), tt == nil)
- err("error: no value");- return tt->d;
+ err("error: no value");}
if(form->a == cond)
return evcon(form->d, a);
@@ -719,7 +728,7 @@
push(form);
push(a);
if(atom(form->a)){- if(form->a == nil || numberp(form->a))
+ if(form->a == nil || !symbolp(form->a))
lprint(form),
err("error: no function"); for(tt = form->a->d; tt != nil; tt = tt->d->d){@@ -755,12 +764,13 @@
goto tail;
}
}
- if(tt = assq(form->a, a), tt == nil)
+ if(tt = assq(form->a, a), tt != nil){+ form = cons(tt->d, form->d);
+ pdp = spdp;
+ goto tail;
+ }
lprint(form),
- err("error: no function");- form = cons(tt->d, form->d);
- pdp = spdp;
- goto tail;
+ err("error: no function");}
arg = evlis(form->d, a);
pdp = spdp;
@@ -788,12 +798,12 @@
C*
apply(C *fn, C *args, C *a)
{- C *tt;
+ C *tt, *n;
int spdp;
Arglist al, ll;
if(atom(fn)){- if(fn == nil || numberp(fn))
+ if(fn == nil || !symbolp(fn))
lprint(fn),
err("error: no function"); for(tt = fn->d; tt != nil; tt = tt->d->d){@@ -804,10 +814,10 @@
else if(tt->a == lsubr)
return applylsubr(tt->d->a, args);
}
- if(tt = assq(fn, a), tt == nil)
+ if(tt = assq(fn, a), tt != nil)
+ return apply(tt->d, args, a);
lprint(fn),
- err("error: no function");- return apply(tt->d, args, a);
+ err("error: no function");}
spdp = pdp;
push(fn);
@@ -814,8 +824,7 @@
push(args);
push(a);
if(fn->a == label){- tt = cons(fn->d->a, fn->d->d->a);
- a = cons(tt, a);
+ a = cons(cons(fn->d->a, fn->d->d->a), a);
pdp = spdp;
return apply(fn->d->d->a, args, a);
}
@@ -824,14 +833,16 @@
return apply(fn->d->a, args, fn->d->d->a);
}
if(fn->a == lambda){- if(fn->d->a && atom(fn->d->a)){- tt = cons(fn->d->a, mkfix(length(args)));
+ if(fn->d->a != nil && symbolp(fn->d->a)){+ a = cons(cons(fn->d->a, n = mkfix(0)), a);
pdp = spdp;
+ /* almost same code as applylsubr... */
al = spread(args);
ll = largs;
largs.nargs = nargs;
largs.alist = alist-1;
- tt = evbody(fn->d->d, cons(tt, a));
+ n->fix = nargs;
+ tt = evbody(fn->d->d, a);
largs = ll;
restore(al);
return tt;
@@ -894,8 +905,6 @@
digits[i]->fix = i;
oblist = cons(digits[i], oblist);
}
- plus = intern("+");- minus = intern("-");initsubr();
--- a/lisp.h
+++ b/lisp.h
@@ -186,7 +186,6 @@
C *get(C *l, C *p);
C *assq(C *x, C *y);
C *putprop(C *l, C *p, C *ind);
-C *pair(C *x, C *y);
C *intern(char *name);
C *readsxp(void);
void lprint(C *c);
--- a/subr.c
+++ b/subr.c
@@ -356,53 +356,39 @@
/* Symbols, values */
C *setq_fsubr(void){- C *tt, *l, *last;
+ C *tt, *a, *l, *last;
last = nil;
for(l = alist[0]; l != nil; l = l->d->d){- tt = l->a;
- if(!atom(tt))
+ a = l->a;
+ if(!atom(a))
err("error: need atom");- tt = assq(tt, alist[1]);
+ last = eval(l->d->a, alist[1]);
+ tt = assq(a, alist[1]);
if(tt == nil)
- err("error: undefined");- tt->d = last = eval(l->d->a, alist[1]);
+ putprop(a, last, value);
+ else
+ tt->d = last;
}
return last;
}
/* Has to be FSUBR here, also extended syntax */
C *set_fsubr(void){- C *tt, *l, *last;
+ C *tt, *a, *l, *last;
last = nil;
for(l = alist[0]; l != nil; l = l->d->d){- tt = eval(l->a, alist[1]);
- if(!atom(tt))
+ a = eval(l->a, alist[1]);
+ if(!atom(a))
err("error: need atom");- tt = assq(tt, alist[1]);
+ last = eval(l->d->a, alist[1]);
+ tt = assq(a, alist[1]);
if(tt == nil)
- err("error: undefined");- tt->d = last = eval(l->d->a, alist[1]);
+ putprop(a, last, value);
+ else
+ tt->d = last;
}
return last;
}
-/* slightly advanced cset functions */
-C *cset_subr(void){- return putprop(alist[0], alist[1], value);
-}
-C *csetq_fsubr(void){- C *l;
- for(l = alist[0]; l != nil; l = l->d->d){- if(!atom(l->a))
- err("error: need atom");- if(l->d == nil){- putprop(l->a, nil, value);
- break;
- }
- putprop(l->a, eval(l->d->a, alist[1]), value);
- }
- return noval;
-}
-
/* Property list */
C *get_subr(void){@@ -847,11 +833,13 @@
C *maplist_lsubr(void){ return maplist_aux(ziplist); } C *mapcar_lsubr(void){ return maplist_aux(zipcar); } C *map_aux(int (*zip)(void)){+ C *ret;
if(largs.nargs < 2)
err("error: arg count");+ ret = largs.alist[2];
while(!zip())
apply(largs.alist[1], pop(), nil);
- return nil;
+ return ret;
}
C *map_lsubr(void){ return map_aux(ziplist); } C *mapc_lsubr(void){ return map_aux(zipcar); }@@ -899,16 +887,16 @@
Prog prog;
C *go_fsubr(void){- C *t, *p;
+ C *tt, *p;
if(prog.prog == nil)
err("error: not in prog");if(alist[0] == nil)
err("error: arg count");- t = alist[0]->a;
- while(!atom(t))
- t = eval(t, alist[1]);
+ tt = alist[0]->a;
+ while(!atom(tt))
+ tt = eval(tt, alist[1]);
for(p = prog.prog; p != nil; p = p->d)
- if(p->a == t){+ if(p->a == tt){prog.pc = p->d;
return nil;
}
@@ -1058,8 +1046,6 @@
FSUBR("SETQ", setq_fsubr) FSUBR("SET", set_fsubr)- SUBR("CSET", cset_subr, 2)- FSUBR("CSETQ", csetq_fsubr) SUBR("GET", get_subr, 2) SUBR("PUTPROP", putprop_subr, 3)