began to move defspecial forms to builtins: incf, decf, cond (a1c5f240) · Commits · lisp / lis.pl

Builtin.pm

+61 −12

Original line number	Diff line number	Diff line
		@@ -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

+14 −14

Original line number	Diff line number	Diff line
		@@ -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

+20 −19

Original line number	Diff line number	Diff line
		@@ -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))
		(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)
		"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)
		"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))
		(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)
		"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")
		"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

+12 −6

Original line number	Diff line number	Diff line
		@@ -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))