Commit 9f815fd9 authored by Juergen Nickelsen's avatar Juergen Nickelsen

more defspecials converted to builtins: pop push sublist dolist

parent a1c5f240
......@@ -20,6 +20,101 @@ 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 Bpush {
my ($item, $var) = checkargs($_[0], 'ey');
my $list = Eval($var);
my $newel = Eval($item);
return set($var, cons($newel, $list));
}
sub Bpop {
my ($var) = checkargs($_[0], 'y');
my $list = Eval($var);
error("pop: value of %s is not a list: %s", $var, $list)
unless listp($list);
my $item;
($item, $list) = cxr($list);
set($var, $list);
return $item;
}
sub sublist {
my ($list, $start, $end) = @_;
my $skip = $start;
while (consp($list) && $skip > 0) {
$list = cdr($list);
$skip--;
}
return $list if is_nil($end);
my $result = $Nil;
my $lastpair;
$end -= $start;
while (consp($list) && $end > 0) {
my $elem;
($elem, $list) = cxr($list);
my $newpair = cons($elem, $Nil);
if (defined($lastpair)) {
rplacd($lastpair, $newpair);
$lastpair = $newpair;
} else {
$result = $lastpair = $newpair;
}
$end--;
}
return $result;
}
sub Bsublist {
my ($list, $start, $end) = checkargs($_[0], 'ln:n');
return sublist($list, $start, $end);
}
sub eval_forms {
my ($forms) = @_;
my $result = $Nil;
while (consp($forms)) {
my $form;
($form, $forms) = cxr($forms);
$result = Eval($form);
}
return $result;
}
sub Bdolist {
my ($formargs, $body) = checkargs($_[0], 'lr');
my @formargs = list2array($formargs);
#warn("formargs: @formargs");
my $loopvar = $formargs[0];
error("dolist: loopvar not a symbol: %s", $loopvar)
unless symbolp($loopvar);
my $listform = $formargs[1] or error("dolist: listform undefined");
my $resultform = $formargs[2] // $Nil;
my $start = $formargs[3] // 0;
error("dolist: start arg not numeric: %s", $start)
unless numberp($start);
my $end = $formargs[4] // $Nil;
error("dolist: end arg not numeric: %s", $end)
unless is_nil($end) || numberp($end);
my $saved_env = enter_environment();
my $result = eval {
my $list = sublist(Eval($listform), $start, $end);
while (consp($list)) {
my $elem;
($elem, $list) = cxr($list);
bind($loopvar, $elem);
eval_forms($body);
}
return Eval($resultform);
};
backto_environment($saved_env);
if ($@) {
return error($@);
}
return $result;
}
sub Bincf {
my ($var, $delta) = checkargs($_[0], 'y:e');
my $num = Eval($var);
......@@ -764,17 +859,6 @@ 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');
......@@ -1050,6 +1134,14 @@ my @builtins = # [name, func, is_special, doc]
"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"],
["dolist", \&Bdolist, 1,
"iterate over list (dolist (loopvar listform [resultform]) . bodyforms)"],
["sublist", \&Bsublist, 0,
"return sublist of LIST beginning at START ending at END (zero-based)"],
["push", \&Bpush, 1,
"prepend ITEM to the list in VAR and store the result in VAR"],
["pop", \&Bpop, 1,
"remove the first item of list in VAR, store changed VAR, return item"],
);
sub init {
......
......@@ -157,28 +157,28 @@
;; nil))
;; deeply unhygienic, alas
(defspecial push (pusharg-elem pusharg-var)
"prepend ELEM to the list stored in VAR, store result in VAR, and return it"
(set pusharg-var (cons (eval pusharg-elem) (eval pusharg-var))))
(defspecial pop (poparg-var)
"pop the first item off the list in VAR, store result, and return the item"
(let* ((poparg-l (eval poparg-var))
(poparg-item (car poparg-l)))
(set poparg-var (cdr poparg-l))
poparg-item))
(defspecial dolist (formargs &rest body)
"(dolist (loopvar listform [resultform [start [end]]]) . body)"
(let* ((dolist-loopvar (car formargs))
(dolist-start (or (eval (cadddr formargs)) 0))
(dolist-end (eval (car (cddddr formargs))))
(dolist-list (sublist (eval (cadr formargs)) dolist-start dolist-end))
(dolist-resultform (caddr formargs)))
;; (format t "dolist-list %s\n" dolist-list)
(while (set dolist-loopvar (pop dolist-list))
(eval-list body))
(eval dolist-resultform)))
;; (defspecial push (pusharg-elem pusharg-var)
;; "prepend ELEM to the list stored in VAR, store result in VAR, and return it"
;; (set pusharg-var (cons (eval pusharg-elem) (eval pusharg-var))))
;; (defspecial pop (poparg-var)
;; "pop the first item off the list in VAR, store result, and return the item"
;; (let* ((poparg-l (eval poparg-var))
;; (poparg-item (car poparg-l)))
;; (set poparg-var (cdr poparg-l))
;; poparg-item))
;; (defspecial dolist (formargs &rest body)
;; "(dolist (loopvar listform [resultform [start [end]]]) . body)"
;; (let* ((dolist-loopvar (car formargs))
;; (dolist-start (or (eval (cadddr formargs)) 0))
;; (dolist-end (eval (car (cddddr formargs))))
;; (dolist-list (sublist (eval (cadr formargs)) dolist-start dolist-end))
;; (dolist-resultform (caddr formargs)))
;; ;; (format t "dolist-list %s\n" dolist-list)
;; (while (set dolist-loopvar (pop dolist-list))
;; (eval-list body))
;; (eval dolist-resultform)))
(defun sequencep (object)
"return t if OBJECT is a sequence (list or string), nil else"
......
......@@ -182,9 +182,6 @@ sub defvar {
sub bind {
my ($sym, $value) = @_;
my $name = symbol_name($sym);
if (exists($Env->{$name})) {
...
}
$Env->{$name} = $value;
}
......
......@@ -17,10 +17,11 @@ use Exporter ();
BEGIN {
@ISA = qw(Exporter);
@EXPORT = qw( is_def is_sym is_list tornil array2list list2array
checkargs
checkargs eval_forms
);
}
sub caller_name {
my ($level) = @_;
my (undef, undef, undef, $name) = caller($level + 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