Merge branch 'master' of ssh://git.w21.org/home/git/lis.pl (d068acdf) · Commits · lisp / lis.pl

Builtin.pm

+23 −2

Original line number	Original line	Diff line number	Diff line
	@@ -17,11 +17,28 @@ use Util;
	use Eval;		use Eval;
	use Interp;		use Interp;

	# helper functions

	# Builtins get their arguments directly as a Lisp list, have names		# Builtins get their arguments directly as a Lisp list, have names
	# beginning with 'B', and are defined here (except for, well, exceptions)		# beginning with 'B', and are defined here (except for, well, exceptions)

			sub Bread {
			my ($arglist) = @_;
			my ($input) = checkargs($arglist, ':S');
			if (is_nil($input)) {
			return Read::Read();
			} elsif (stringp ($input)) {
			return Read::Read($input);
			} else {
			...
			}
			}

			sub Brandom {
			my ($arglist) = @_;
			my ($limit) = checkargs($arglist, ':n');
			$limit = 1 if is_nil($limit);
			return rand($limit);
			}

	sub Bsqrt {		sub Bsqrt {
	my ($arglist) = @_;		my ($arglist) = @_;
	my ($arg) = checkargs($arglist, 'n');		my ($arg) = checkargs($arglist, 'n');
	@@ -1028,6 +1045,10 @@ my @builtins = # [name, func, is_special, doc]
	"split STRING into parts SEPARATED by SEP and return the list"],		"split STRING into parts SEPARATED by SEP and return the list"],
	["sqrt", \&Bsqrt, 0, "return the square root of numeric ARG"],		["sqrt", \&Bsqrt, 0, "return the square root of numeric ARG"],
	["isqrt", \&Bsqrt, 0, "return the integer square root of numeric ARG"],		["isqrt", \&Bsqrt, 0, "return the integer square root of numeric ARG"],
			["random", \&Brandom, 0,
			"return a random number a with 0 <= a < LIMIT (or 1)"],
			["read", \&Bread, 0,
			"return an expression read from stdin or &optional INPUT (a string)"],
	);		);

	for my $b (@builtins) {		for my $b (@builtins) {

Fundamental.lisp

+20 −25

Original line number	Original line	Diff line number	Diff line
	@@ -277,11 +277,13 @@
	(apply #'string/= (cons n (cddr args)))		(apply #'string/= (cons n (cddr args)))
	(apply #'string/= (cdr args))))))		(apply #'string/= (cdr args))))))

	(defun length (l)		(defun length (sequence)
	"return the length of list l"		"return the length of SEQUENCE"
	(if (null l)		(if (stringp sequence)
			(setq sequence (split-string sequence "")))
			(if (null sequence)
	0		0
	(1+ (length (cdr l)))))		(1+ (length (cdr sequence)))))

	(defun strlen (s)		(defun strlen (s)
	"return the length of string S"		"return the length of string S"
	@@ -378,29 +380,22 @@
	(cons (car l2) (merge l1 (cdr l2)))))))))		(cons (car l2) (merge l1 (cdr l2)))))))))
	(merge (sort-list l1 pred) (sort-list l2 pred)))))		(merge (sort-list l1 pred) (sort-list l2 pred)))))

	(defun sort (l pred)		(defun sort (s pred)
	"sort list L with predicate PRED and return the resulting list"		"sort sequence S with predicate PRED and return the result"
	(if (or (empty l) (empty (rest l)))		(cond ((stringp s)
	l		(apply #'string (sort-list (split-string s "") pred)))
	(let* ((len (length l))		((listp s) (sort-list s pred))
	(first (div len 2))		(t (error "sort: not a sequence: %s" sequence))))
	(l1 (subseq l 0 first))
	(l2 (subseq l (- len first)))
	(merge (lambda (l1 l2)
	(if (empty l1)
	l2
	(if (empty l2)
	l1
	(if (pred (first l1) (first l2))
	(prepend (first l1) (merge (rest l1) l2))
	(prepend (first l2) (merge l1 (rest l2)))))))))
	(merge (sort l1 pred) (sort l2 pred)))))

	(defun make-string (n el)		(defun make-string (n el)
	"return a string of N occurences of element EL"		"return a string of N occurences of element EL (may be a function)"
	(if (zerop n)		(if (zerop n)
	""		""
	(concat el (make-string (1- n) el))))		(concat (if (functionp el)
			(el)
			(string el))
			(make-string (1- n) el))))

	(defun join (sep &rest args)		(defun join (sep &rest args)
	"append all ARGS (or their elements) to a string, separated by SEP"		"append all ARGS (or their elements) to a string, separated by SEP"
	@@ -421,9 +416,9 @@
	(defun 2+ (n) (+ n 2))		(defun 2+ (n) (+ n 2))
	(defun 2- (n) (- n 2))		(defun 2- (n) (- n 2))
	(defspecial incf (var &optional incr)		(defspecial incf (var &optional incr)
	(set var (eval (list '+ var (or incr 1))))))		(set var (eval (list '+ var (or incr 1)))))
	(defspecial decf (var &optional decr)		(defspecial decf (var &optional decr)
	(set var (eval (list '- var (or decr 1))))))		(set var (eval (list '- var (or decr 1)))))

	(defun fib (n)		(defun fib (n)
	(if (< n 2)		(if (< n 2)

Interp.pm

+4 −3

Original line number	Original line	Diff line number	Diff line
	@@ -32,11 +32,11 @@ sub repl {
	if ($interactive) {		if ($interactive) {
	print("> ");		print("> ");
	# this means we are counting conses including those		# this means we are counting conses including those
	# needed by readob()		# needed by Read()
	eval_count(0);		eval_count(0);
	cons_count(0);		cons_count(0);
	}		}
	my $expr = readob($fh);		my $expr = Read($fh);
	last unless defined($expr);		last unless defined($expr);

	eval_level(0);		eval_level(0);
	@@ -66,7 +66,7 @@ sub load {
	my ($fname, $noerror, $nomessage) = @_;		my ($fname, $noerror, $nomessage) = @_;
	my $fh;		my $fh;

	unless (open($fh, '<', $fname)) {		unless (open($fh, "<:encoding(UTF-8)", $fname)) {
	unless ($noerror) {		unless ($noerror) {
	say("cannot open file ($!): %s", $fname);		say("cannot open file ($!): %s", $fname);
	return $Nil;		return $Nil;
	@@ -74,6 +74,7 @@ sub load {
	return error("cannot open file ($!) %s", $fname);		return error("cannot open file ($!) %s", $fname);
	}		}
	print(";; loading file $fname ... ") unless $nomessage;		print(";; loading file $fname ... ") unless $nomessage;
			$\| = 1;
	my $result = repl($fh, 0);		my $result = repl($fh, 0);
	close($fh);		close($fh);
	if (defined($result) && !$nomessage) {		if (defined($result) && !$nomessage) {

Read.pm

+14 −6

Original line number	Original line	Diff line number	Diff line
	@@ -17,7 +17,7 @@ use Exporter ();

	BEGIN {		BEGIN {
	@ISA = qw(Exporter);		@ISA = qw(Exporter);
	@EXPORT = qw( readob		@EXPORT = qw( Read
	);		);
	}		}

	@@ -25,9 +25,15 @@ my $default_input = \*STDIN;

	my $sepchars = quotemeta("();\n");		my $sepchars = quotemeta("();\n");

	sub readob {		sub Read {
	my ($in) = @_;		my ($in) = @_;
	$in //= $default_input;		$in //= $default_input;
			if (stringp($in)) {
			my $string = $in;
			open(my $str_in, "<", \$string) or
			error("read: cannot open string as filehandle: $!\n");
			$in = $str_in;
			}

	my $t = next_token($in);		my $t = next_token($in);
	#warn("next token: $t");		#warn("next token: $t");
	@@ -40,11 +46,11 @@ sub readob {
	unless $closer eq ')';		unless $closer eq ')';
	return $list;		return $list;
	} elsif ($t eq '\'') {		} elsif ($t eq '\'') {
	$t = readob($in);		$t = Read($in);
	return error("EOF in quote: %s", $in) unless defined($t);		return error("EOF in quote: %s", $in) unless defined($t);
	return list(intern($Quote), $t);		return list(intern($Quote), $t);
	} elsif ($t eq '#\'') {		} elsif ($t eq '#\'') {
	$t = readob($in);		$t = Read($in);
	return error("EOF in quote %s", $in) unless defined($t);		return error("EOF in quote %s", $in) unless defined($t);
	return list(intern($function), $t);		return list(intern($function), $t);
	} elsif ($t eq '.') {		} elsif ($t eq '.') {
	@@ -53,6 +59,8 @@ sub readob {
	return $t;		return $t;
	} elsif ($t =~ m{^\"}) {		} elsif ($t =~ m{^\"}) {
	return substr($t, 1);		return substr($t, 1);
			} elsif ($t eq ')') {
			return error("close paren unexpected");
	} else {		} else {
	return $t;		return $t;
	}		}
	@@ -72,7 +80,7 @@ sub read_list_elems {
	return error("syntax: . at start of list: %s",		return error("syntax: . at start of list: %s",
	$in)		$in)
	unless $end;		unless $end;
	my $sexpr = readob($in);		my $sexpr = Read($in);
	return undef unless defined($t);		return undef unless defined($t);
	$t = next_token($in);		$t = next_token($in);
	return error("syntax: no ) after improper list: %s",		return error("syntax: no ) after improper list: %s",
	@@ -83,7 +91,7 @@ sub read_list_elems {
	return $list;		return $list;
	} else {		} else {
	push_back_token($t);		push_back_token($t);
	my $sexpr = readob($in);		my $sexpr = Read($in);
	return undef unless defined($sexpr);		return undef unless defined($sexpr);
	my $newpair = cons($sexpr, $Nil);		my $newpair = cons($sexpr, $Nil);
	if ($end) {		if ($end) {

Util.pm

+10 −4

Original line number	Original line	Diff line number	Diff line
	@@ -22,7 +22,7 @@ BEGIN {
	}		}

	# check arguments; descriptor is string "xxx:xx" with mandatory args		# check arguments; descriptor is string "xxx:xx" with mandatory args
	# before the :, then# optional args; x is:		# before the :, then optional args; x is:
	# e: any expression		# e: any expression
	# y: symbol		# y: symbol
	# p: pair		# p: pair
	@@ -39,7 +39,7 @@ sub checkargs {
	my $argno = 0;		my $argno = 0;
	my $optional = 0;		my $optional = 0;
	for my $desc (split('', $descriptor)) {		for my $desc (split('', $descriptor)) {
	#warn("checkargs: arglist ", &$Princs($arglist));		#warn("checkargs: desc $desc; arglist ", &$Princs($arglist));
	if ($desc eq 'R') {		if ($desc eq 'R') {
	#warn("checkargs: set $desc to ", &$Princs($arglist));		#warn("checkargs: set $desc to ", &$Princs($arglist));
	push(@result, list2array($arglist));		push(@result, list2array($arglist));
	@@ -51,6 +51,7 @@ sub checkargs {
	last;		last;
	}		}
	if ($desc eq ':') {		if ($desc eq ':') {
			#warn("checkargs: see :optional");
	$optional = 1;		$optional = 1;
	next;		next;
	}		}
	@@ -59,13 +60,18 @@ sub checkargs {
	unless $optional \|\| consp($arglist);		unless $optional \|\| consp($arglist);
	my $arg;		my $arg;
	($arg, $arglist) = cxr($arglist);		($arg, $arglist) = cxr($arglist);
			#warn("\$arg: ", Dumper($arg));
			my $optional_defaulted = 0;
	if (defined($arg)) {		if (defined($arg)) {
	$argno++;		$argno++;
	} else {		} else {
	$arg = $Nil;		$arg = $Nil;
			$optional_defaulted = 1;
	}		}
	if ($desc eq 'e') {		if ($desc eq 'e' \|\| $optional_defaulted) {
	; # this is relatively frequent		; # this is relatively frequent, and we do
			# not need to check the argument type
			# any more
	} elsif ($desc eq 'S') {		} elsif ($desc eq 'S') {
	$arg = &$Princs($arg);		$arg = &$Princs($arg);
	} elsif ($desc eq 'y') {		} elsif ($desc eq 'y') {