diff --git a/lib/Minilisp.pm b/lib/Minilisp.pm index 85ca69b..3e5f9ce 100644 --- a/lib/Minilisp.pm +++ b/lib/Minilisp.pm @@ -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} = \¯o_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} = \¯o_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} = \¯o_or; + sub compile { my ($term) = @_; my @tokens = tokenize($term); diff --git a/t/and_or.t b/t/and_or.t new file mode 100644 index 0000000..3278a90 --- /dev/null +++ b/t/and_or.t @@ -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))) diff --git a/t/bool.t b/t/bool.t index de6b2ca..d81b662 100644 --- a/t/bool.t +++ b/t/bool.t @@ -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))) diff --git a/t/cond.t b/t/cond.t index b874226..51cd92c 100644 --- a/t/cond.t +++ b/t/cond.t @@ -1,5 +1,5 @@ (expect "cond" 2 (cond ((> 1 2) 10) - (f 20) + (nil 20) ((zerop 0) 2) (t 10))) diff --git a/t/unless.t b/t/unless.t index 774b7b7..524eefb 100644 --- a/t/unless.t +++ b/t/unless.t @@ -2,4 +2,4 @@ (null (unless t 'fail))) (expect "unless - false condition" - (equal 'ok (unless f 'ok))) + (equal 'ok (unless nil 'ok))) diff --git a/t/when.t b/t/when.t index 076fcac..11a3c29 100644 --- a/t/when.t +++ b/t/when.t @@ -2,4 +2,4 @@ (equal 'ok (when t 'ok))) (expect "when - false condition" - (null (when f 'fail))) + (null (when nil 'fail)))