madmaurice/Minilisp.pm
1
1
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Improve bool system

Browse source 
lisp has true in form of t and false in form of nil
This commit is contained in:
madmaurice 2021-04-05 00:06:49 +02:00
parent 61df548e00
commit 7f1283eecc
6 changed files with 124 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

142
lib/Minilisp.pm
View file

@ -14,6 +14,19 @@ use constant {
LIST => 7,
};
use constant {
LISP_TRUE => 1,
LISP_FALSE => undef,
};
sub to_lisp_bool {
return shift ? LISP_TRUE : LISP_FALSE;
}
sub from_lisp_bool {
return defined(shift);
}
sub tokenize {
my $str = shift;
my @tokens;
@ -160,26 +173,26 @@ sub lisp_equal {
my ($a, $b) = @_;
if ( ref($a) eq "ARRAY" && ref($b) eq "ARRAY" )
{
return 0 unless scalar(@$a) == scalar(@$b);
return LISP_FALSE unless scalar(@$a) == scalar(@$b);
for(my $i = 0; $i < @$a; $i++)
{
return 0 unless lisp_equal($a->[$i], $b->[$i]);
return LISP_FALSE unless lisp_equal($a->[$i], $b->[$i]);
}
return 1;
return LISP_TRUE;
}
elsif ( ref($a) eq "KEYWORD" && ref($b) eq "KEYWORD" )
{
return $a->{value} eq $b->{value};
return to_lisp_bool($a->{value} eq $b->{value});
}
elsif ( ref($a) eq "" && ref($b) eq "" )
{
return $a == $b;
return to_lisp_bool($a == $b);
}
else
{
return 0;
return LISP_FALSE;
}
}
@ -215,32 +228,22 @@ my %stdctx = (
return undef;
},
'null' => sub { my ($a) = @_; return ! defined $a; },
'evenp' => sub { my ($a) = @_; return ($a % 2 == 0); },
'oddp' => sub { my ($a) = @_; return ($a % 2 != 0); },
'zerop' => sub { my ($a) = @_; return $a == 0; },
'eq' => sub { my ($a, $b) = @_; return ($a == $b); },
'ne' => sub { my ($a, $b) = @_; return ($a != $b); },
'evenp' => sub { my ($a) = @_; return to_lisp_bool($a % 2 == 0); },
'oddp' => sub { my ($a) = @_; return to_lisp_bool($a % 2 != 0); },
'zerop' => sub { my ($a) = @_; return to_lisp_bool($a == 0); },
'eq' => sub { my ($a, $b) = @_; return to_lisp_bool($a == $b); },
'ne' => sub { my ($a, $b) = @_; return to_lisp_bool($a != $b); },
# Logical operators
'not' => sub { my ($a) = @_; return !$a; },
'and' => sub {
my $v = 1;
$v &&= $_ foreach (@_);
return $v;
},
'or' => sub {
my $v = 0;
$v ||= $_ foreach(@_);
return $v;
},
'not' => sub { my ($a) = @_; return to_lisp_bool(!from_lisp_bool($a)); },
# Numeric comparison
'=' => sub { my ($a, $b) = @_; return ($a == $b); },
'/=' => sub { my ($a, $b) = @_; return ($a != $b); },
'>' => sub { my ($a,$b) = @_; return ($a > $b); },
'<' => sub { my ($a,$b) = @_; return ($a < $b); },
'>=' => sub { my ($a,$b) = @_; return ($a >= $b); },
'<=' => sub { my ($a,$b) = @_; return ($a <= $b); },
'=' => sub { my ($a, $b) = @_; return to_lisp_bool($a == $b); },
'/=' => sub { my ($a, $b) = @_; return to_lisp_bool($a != $b); },
'>' => sub { my ($a,$b) = @_; return to_lisp_bool($a > $b); },
'<' => sub { my ($a,$b) = @_; return to_lisp_bool($a < $b); },
'>=' => sub { my ($a,$b) = @_; return to_lisp_bool($a >= $b); },
'<=' => sub { my ($a,$b) = @_; return to_lisp_bool($a <= $b); },
'max' => sub {
die "max: At least 2 parameters" unless scalar(@_) >= 2;
my $v = shift;
@ -261,18 +264,18 @@ my %stdctx = (
},
# String comparison
'string=' => sub { my ($a, $b) = @_; return ($a eq $b); },
'string/=' => sub { my ($a, $b) = @_; return ($a ne $b); },
'string<' => sub { my ($a, $b) = @_; return ($a lt $b); },
'string>' => sub { my ($a, $b) = @_; return ($a gt $b); },
'string<=' => sub { my ($a, $b) = @_; return !($a gt $b); },
'string>=' => sub { my ($a, $b) = @_; return !($a lt $b); },
'string-equal' => sub { my ($a, $b) = @_; return ( lc($a) eq lc($b)); },
'string-not-equal' => sub { my ($a, $b) = @_; return (lc($a) ne lc($b)); },
'string-lessp' => sub { my ($a, $b) = @_; return (lc($a) lt lc($b)); },
'string-greaterp' => sub { my ($a, $b) = @_; return (lc($a) gt lc($b)); },
'string-not-greaterp' => sub { my ($a, $b) = @_; return !(lc($a) gt lc($b)); },
'string-not-lessp' => sub { my ($a, $b) = @_; return !(lc($a) lt lc($b)); },
'string=' => sub { my ($a, $b) = @_; return to_lisp_bool($a eq $b); },
'string/=' => sub { my ($a, $b) = @_; return to_lisp_bool($a ne $b); },
'string<' => sub { my ($a, $b) = @_; return to_lisp_bool($a lt $b); },
'string>' => sub { my ($a, $b) = @_; return to_lisp_bool($a gt $b); },
'string<=' => sub { my ($a, $b) = @_; return to_lisp_bool(!($a gt $b)); },
'string>=' => sub { my ($a, $b) = @_; return to_lisp_bool(!($a lt $b)); },
'string-equal' => sub { my ($a, $b) = @_; return to_lisp_bool( lc($a) eq lc($b)); },
'string-not-equal' => sub { my ($a, $b) = @_; return to_lisp_bool(lc($a) ne lc($b)); },
'string-lessp' => sub { my ($a, $b) = @_; return to_lisp_bool(lc($a) lt lc($b)); },
'string-greaterp' => sub { my ($a, $b) = @_; return to_lisp_bool(lc($a) gt lc($b)); },
'string-not-greaterp' => sub { my ($a, $b) = @_; return to_lisp_bool(!(lc($a) gt lc($b))); },
'string-not-lessp' => sub { my ($a, $b) = @_; return to_lisp_bool(!(lc($a) lt lc($b))); },
# string operations
'string-upcase' => sub { return uc(shift); },
@ -354,9 +357,8 @@ my %stdctx = (
},
# Constants
't' => 1,
'f' => 0,
'nil' => undef,
't' => LISP_TRUE,
'nil' => LISP_FALSE,
# Multi-purpose
'equal' => \&lisp_equal,
@ -614,7 +616,7 @@ sub macro_if {
my $ctx = shift;
my $condresult = $cond->($ctx);
if ($condresult) {
if (defined $condresult) {
return $tbranch->($ctx);
} else {
return $fbranch->($ctx);
@ -714,7 +716,7 @@ sub macro_when {
return sub {
my $ctx = shift;
if ($condition->($ctx))
if (defined($condition->($ctx)))
{
return $work->($ctx);
}
@ -733,7 +735,7 @@ sub macro_unless {
return sub {
my $ctx = shift;
if (!$condition->($ctx))
if (!defined($condition->($ctx)))
{
return $work->($ctx);
}
@ -762,6 +764,54 @@ sub macro_set {
}
$macros{set} = \&macro_set;
sub macro_and {
my $ts = shift;
my @operands_parsed;
while ( $ts->[0]->{type} != RPAREN )
{
push @operands_parsed, parser_expr($ts);
}
return sub {
my $ctx = shift;
my $v = LISP_TRUE;
my @operands = @operands_parsed;
while (from_lisp_bool($v) && (my $op = shift @operands))
{
$v = $op->($ctx);
}
return $v;
};
}
$macros{and} = \&macro_and;
sub macro_or {
my $ts = shift;
my @operands_parsed;
while ( $ts->[0]->{type} != RPAREN )
{
push @operands_parsed, parser_expr($ts);
}
return sub {
my $ctx = shift;
my $v = LISP_FALSE;
my @operands = @operands_parsed;
while (!from_lisp_bool($v) && (my $op = shift @operands))
{
$v = $op->($ctx);
}
return $v;
};
}
$macros{or} = \&macro_or;
sub compile {
my ($term) = @_;
my @tokens = tokenize($term);

13
t/and_or.t Normal file
View file

@ -0,0 +1,13 @@
(let ((a 'ok))
(and nil (set a 'fail))
(expect "and - Short circuit" (equal a 'ok)))
;; (let ((a 'ok))
;; (or t (set a 'fail))
;; (expect "or - short circuit" (equal a 'ok)))
(expect "and - returns last value if all operands evaluate to true"
(equal (and t 'ok) 'ok))
(expect "and - returns nil if any operand evaluates to false"
(null (and nil t)))

18
t/bool.t
View file

@ -1,9 +1,9 @@
;; Constants
(expect "True is true" (eq 1 (if t 1 0)))
(expect "False is false" (eq 1 (if f 0 1)))
(expect "False is false" (eq 1 (if nil 0 1)))
(expect "not f == t" (not f))
(expect "not f == t" (not nil))
(expect "not t == f" (eq 1 (if (not t) 0 1)))
;; operator and
@ -12,17 +12,23 @@
(and t t))
(expect "and operator: t && f == f"
(not (and t f)))
(not (and t nil)))
(expect "and operator: f && t == f"
(not (and nil t)))
(expect "and operator: f && f == f"
(not (and f f)))
(not (and nil nil)))
;; operator or
(expect "or operator: t || t == t"
(or t t))
(expect "or operator: t || f == t"
(or t f))
(or t nil))
(expect "or operator: f || t == t"
(or nil t))
(expect "or operator: f || f == f"
(not (or f f)))
(not (or nil nil)))

2
t/cond.t
View file

@ -1,5 +1,5 @@
(expect "cond" 2
(cond ((> 1 2) 10)
(f 20)
(nil 20)
((zerop 0) 2)
(t 10)))

2
t/unless.t
View file

@ -2,4 +2,4 @@
(null (unless t 'fail)))
(expect "unless - false condition"
(equal 'ok (unless f 'ok)))
(equal 'ok (unless nil 'ok)))

2
t/when.t
View file

@ -2,4 +2,4 @@
(equal 'ok (when t 'ok)))
(expect "when - false condition"
(null (when f 'fail)))
(null (when nil 'fail)))