Skip to content

GitLab

L
lis.pl
Commit a1c5f240 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files
Options

began to move defspecial forms to builtins: incf, decf, cond

parent b8e21589
Hide whitespace changes
Inline Side-by-side
Showing with 107 additions and 51 deletions
Builtin.pm
View file @ a1c5f240
......@@ -20,6 +20,49 @@ use Interp;
# Builtins get their arguments directly as a Lisp list, have names
# beginning with 'B', and are defined here (except for, well, exceptions)
sub Bincf {
my ($var, $delta) = checkargs($_[0], 'y:e');
my $num = Eval($var);
error("incf: %s has no numeric value: %s", $var, $num)
unless numberp($num);
if (is_nil($delta)) {
$delta = 1;
} else {
$delta = Eval($delta);
error("incf: delta arg is not numeric: %s", $delta)
unless numberp($delta);
}
return set($var, $num + $delta);
}
sub Bdecf {
my ($var, $delta) = checkargs($_[0], 'y:e');
my $num = Eval($var);
error("decf: %s has no numeric value: %s", $var, $num)
unless numberp($num);
if (is_nil($delta)) {
$delta = 1;
} else {
$delta = Eval($delta);
error("decf: delta arg is not numeric: %s", $delta)
unless numberp($delta);
}
return set($var, $num - $delta);
}
sub Bcond {
my ($arglist) = @_;
while (consp($arglist)) {
my $clause;
($clause, $arglist) = cxr($arglist);
my ($condition, $clausebody) = cxr($clause);
if (!is_nil(Eval($condition))) {
return eval_forms($clausebody);
}
}
return $Nil;
}
sub Bfunction_environment {
my ($func) = checkargs($_[0], 'e');
$func = evalfun($func);
......@@ -721,6 +764,17 @@ sub Bnum_less {
return $T;
}
sub eval_forms {
my ($forms) = @_;
my $result = $Nil;
while (consp($forms)) {
my $form;
($form, $forms) = cxr($forms);
$result = Eval($form);
}
return $result;
}
sub Bwhile {
my ($cond, $bodyforms) = checkargs($_[0], 'er');
......@@ -731,18 +785,7 @@ sub Bwhile {
return error($@);
}
last if is_nil($cval);
my $body = $bodyforms;
while (consp($body)) {
my $form;
($form, $body) = cxr($body);
my $value = Eval($form);
unless (defined($value)) {
say("while clause: ", princs($form))
unless in_errset();
return error($@);
}
}
eval_forms($bodyforms);
}
return $Nil;
}
......@@ -1001,6 +1044,12 @@ my @builtins = # [name, func, is_special, doc]
"show all vars in ENV, &optional not in NOPARENTS"],
["function-environment", \&Bfunction_environment, 0,
"return the environment of the specified FUNCTION"],
["cond", \&Bcond, 1,
"eval car of clauses until one is true, then eval rest of the clause"],
["incf", \&Bincf, 1,
"increment number VAR by DELTA (or 1) and return the new value"],
["decf", \&Bdecf, 1,
"decrement number VAR by DELTA (or 1) and return the new value"],
);
sub init {
......
Fundamental.lisp
View file @ a1c5f240
......@@ -145,8 +145,8 @@
(fset 'not #'null)
(fset 'string-concat #'concat)
(defspecial defvar (sym &optional init-value)
(set sym (eval init-value)))
;; (defspecial defvar (sym &optional init-value)
;; (set sym (eval init-value)))
;; (defspecial while (cond &rest body)
;; "while COND is true, eval &rest BODY"
......@@ -440,10 +440,10 @@
(defun 1- (n) (- n 1))
(defun 2+ (n) (+ n 2))
(defun 2- (n) (- n 2))
(defspecial incf (var &optional incr)
(set var (eval (list '+ var (or incr 1)))))
(defspecial decf (var &optional decr)
(set var (eval (list '- var (or decr 1)))))
;; (defspecial incf (var &optional incr)
;; (set var (eval (list '+ var (or incr 1)))))
;; (defspecial decf (var &optional decr)
;; (set var (eval (list '- var (or decr 1)))))
(defun fib (n)
(if (< n 2)
......@@ -539,14 +539,14 @@
(if (eval cond)
(eval-list bodyforms)))
(defspecial cond (&rest clauses)
"eval the car of each of CLAUSES until true, then the rest of this clause"
(if (null clauses)
nil
(let ((clause (car clauses)))
(if (eval (car clause))
(eval (cons 'progn (cdr clause)))
(apply 'cond (cdr clauses))))))
;; (defspecial cond (&rest clauses)
;; "eval the car of each of CLAUSES until true, then the rest of this clause"
;; (if (null clauses)
;; nil
;; (let ((clause (car clauses)))
;; (if (eval (car clause))
;; (eval (cons 'progn (cdr clause)))
;; (apply 'cond (cdr clauses))))))
(defun progn (&rest body)
(last body))
......
tests/021-incfdecf.lisp
View file @ a1c5f240
......@@ -2,24 +2,25 @@
(let ((n 4)
(m 7.25)
(o -123456))
(testcmp "incf 1" '(progn (incf n)
n)
"5")
(testcmp "incf 2" '(incf n) "6")
(testcmp "incf 3" '(incf n 3) "9")
(testcmp "incf 4" '(progn (errset (incf n 'b))
*last-error*)
"argument 2 to builtin function plus is not a number: b")
(testcmp "incf 5" '(incf m) "8.25")
(testcmp "incf 6" '(incf o (- 3)) "-123459")
(testcmp "decf 1" '(progn (decf n)
n)
(testcmp "incf 1" (lambda () (incf n) n) "5")
(testcmp "incf 2" (lambda () (incf n)) "6")
(testcmp "incf 3" (lambda () (incf n 3)) "9")
(testcmp "incf 4" (lambda ()
(errset (incf n 'b))
*last-error*)
"incf: delta arg is not numeric: b")
(testcmp "incf 5" (lambda () (incf m)) "8.25")
(testcmp "incf 6" (lambda () (incf o (- 3))) "-123459")
(testcmp "decf 1" (lambda ()
(decf n)
n)
"8")
(testcmp "decf 2" '(decf n) "7")
(testcmp "decf 3" '(decf n 3) "4")
(testcmp "decf 4" '(progn (errset (decf n 'b))
*last-error*)
"argument 2 to builtin function minus is not a number: b")
(testcmp "decf 5" '(decf m) "7.25")
(testcmp "decf 6" '(decf o (- 3)) "-123456")
(testcmp "decf 2" (lambda () (decf n)) "7")
(testcmp "decf 3" (lambda () (decf n 3)) "4")
(testcmp "decf 4" (lambda()
(errset (decf n 'b))
*last-error*)
"decf: delta arg is not numeric: b")
(testcmp "decf 5" (lambda () (decf m)) "7.25")
(testcmp "decf 6" (lambda () (decf o (- 3))) "-123456")
)
tests/run-tests.lisp
View file @ a1c5f240
......@@ -9,19 +9,22 @@
"Run the test called NAME and print the result.
The test is successful if the printed representations of
the evaluation of FORM and VALUE are equal."
(let ((result (errset (eval form)))
(let ((result (errset (if (functionp form)
(form)
(eval form))))
(target (princs value)))
(incf ntests)
(setq ntests (1+ ntests))
(if (atom result)
(progn (format out "Test FAIL: %s RAISED ERROR: %s\n"
name *last-error*)
(push (cons name test-file) fails))
(setq fails (cons (cons name test-file) fails)))
(let ((resultvalue (princs (car result))))
(if (eq resultvalue target)
(format out "Test pass: %s\t%s\n" name resultvalue)
(format out "Test FAIL: %s\n calculated: %s\n expected: %s\n"
name resultvalue target)
(push (cons name test-file) fails))))))
(setq (cons (cons name test-file) fails)))))))
(testcmp 'testcmp ''lala "lala") ;check if the *testing* works
(let ((files (or *ARGS* (glob-filenames (string-concat testdir
......@@ -34,8 +37,11 @@ the evaluation of FORM and VALUE are equal."
(load test-file))))
(format t "%d tests, %d FAILS" ntests (length fails))
(dolist (err (reverse fails))
(format t "\n FAIL \"%s:%s\"" (cdr err) (car err)))
(let ((rfails (reverse fails)))
(while rfails
(let ((err (car rfails)))
(format t "\n FAIL \"%s:%s\"" (cdr err) (car err))
(setq rfails (cdr rfails)))))
(terpri)
(when fails
(exit 1))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment