From 0ef117f547d2bb254c69c21078d3ad0b42a65b1e Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Sun, 29 Apr 2012 21:37:23 +0000
Subject: * boot/ast.boot (bfNumber?): Rename from bfSmintable. Check
for floating point literals too. Adjust callers. (bfLessp): Check for
integer or floating pointer numbers. * interp/vmlisp.lisp (complex?): New.
(complex): Likewise. (realPart): Likewise. (imagPart): Likewise.
(conjugate): Likewise. (sqrt): Likewise.
---
src/ChangeLog | 12 ++++++++++++
src/boot/ast.boot | 14 +++++++-------
src/boot/strap/ast.clisp | 9 +++++----
src/interp/boot-pkg.lisp | 21 +++++++++++++++++++++
4 files changed, 45 insertions(+), 11 deletions(-)
(limited to 'src')
diff --git a/src/ChangeLog b/src/ChangeLog
index 4e45dcb6..a64c9eba 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,15 @@
+2012-04-29 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * boot/ast.boot (bfNumber?): Rename from bfSmintable. Check for
+ floating point literals too. Adjust callers.
+ (bfLessp): Check for integer or floating pointer numbers.
+ * interp/vmlisp.lisp (complex?): New.
+ (complex): Likewise.
+ (realPart): Likewise.
+ (imagPart): Likewise.
+ (conjugate): Likewise.
+ (sqrt): Likewise.
+
2012-04-28 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/compiler.boot (finishLambdaExpression): Tidy.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index c45ade39..945af4bc 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -876,9 +876,9 @@ defQuoteId x==
bfChar? x ==
char? x or cons? x and x.op in '(char CODE_-CHAR SCHAR)
-bfSmintable x==
- integer? x or cons? x and
- x.op in '(SIZE LENGTH CHAR_-CODE MAXINDEX _+ _-)
+bfNumber? x==
+ integer? x or float? x or
+ cons? x and x.op in '(SIZE LENGTH CHAR_-CODE MAXINDEX _+ _-)
bfString? x ==
string? x
@@ -886,7 +886,7 @@ bfString? x ==
bfQ(l,r)==
bfChar? l or bfChar? r => ["CHAR=",l,r]
- bfSmintable l or bfSmintable r => ["EQL",l,r]
+ bfNumber? l or bfNumber? r => ["EQL",l,r]
defQuoteId l or defQuoteId r => ["EQ",l,r]
l = nil => ["NULL",r]
r = nil => ["NULL",l]
@@ -896,8 +896,8 @@ bfQ(l,r)==
["EQUAL",l,r]
bfLessp(l,r)==
- l = 0 => ["PLUSP",r]
- r = 0 => ["MINUSP", l]
+ (integer? l or float? l) and l = 0 => ["PLUSP",r]
+ (integer? r or float? r) and r = 0 => ["MINUSP", l]
bfChar? l or bfChar? r => ["CHAR<",l,r]
bfString? l or bfString? r => ["STRING<",l,r]
["<",l,r]
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 8d1d93f4..092da1dd 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -1431,8 +1431,8 @@
(OR (CHARACTERP |x|)
(AND (CONSP |x|) (|symbolMember?| (CAR |x|) '(|char| CODE-CHAR SCHAR)))))
-(DEFUN |bfSmintable| (|x|)
- (OR (INTEGERP |x|)
+(DEFUN |bfNumber?| (|x|)
+ (OR (INTEGERP |x|) (FLOATP |x|)
(AND (CONSP |x|)
(|symbolMember?| (CAR |x|) '(SIZE LENGTH CHAR-CODE MAXINDEX + -)))))
@@ -1443,7 +1443,7 @@
(DEFUN |bfQ| (|l| |r|)
(COND ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR= |l| |r|))
- ((OR (|bfSmintable| |l|) (|bfSmintable| |r|)) (LIST 'EQL |l| |r|))
+ ((OR (|bfNumber?| |l|) (|bfNumber?| |r|)) (LIST 'EQL |l| |r|))
((OR (|defQuoteId| |l|) (|defQuoteId| |r|)) (LIST 'EQ |l| |r|))
((NULL |l|) (LIST 'NULL |r|)) ((NULL |r|) (LIST 'NULL |l|))
((OR (EQ |l| T) (EQ |r| T)) (LIST 'EQ |l| |r|))
@@ -1452,7 +1452,8 @@
(T (LIST 'EQUAL |l| |r|))))
(DEFUN |bfLessp| (|l| |r|)
- (COND ((EQL |l| 0) (LIST 'PLUSP |r|)) ((EQL |r| 0) (LIST 'MINUSP |l|))
+ (COND ((AND (OR (INTEGERP |l|) (FLOATP |l|)) (EQL |l| 0)) (LIST 'PLUSP |r|))
+ ((AND (OR (INTEGERP |r|) (FLOATP |r|)) (EQL |r| 0)) (LIST 'MINUSP |l|))
((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR< |l| |r|))
((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING< |l| |r|))
(T (LIST '< |l| |r|))))
diff --git a/src/interp/boot-pkg.lisp b/src/interp/boot-pkg.lisp
index 0bfffad7..8f3e4d91 100644
--- a/src/interp/boot-pkg.lisp
+++ b/src/interp/boot-pkg.lisp
@@ -54,6 +54,27 @@
(defun |gensym?| (s)
(and (symbolp s) (null (symbol-package s))))
+(defmacro |complex?| (x)
+ `(complexp ,x))
+
+(defmacro |complex| (x (&optional (y 0.0)))
+ `(complex ,x ,y))
+
+(defmacro |realPart| (z)
+ `(realpart ,z))
+
+(defmacro |imagPart| (z)
+ `(imagpart ,z))
+
+(defmacro |conjugate| (z)
+ `(conjugate ,z))
+
+(defmacro |integerAndFractionalParts| (x)
+ `(multiple-value-list (floor ,x)))
+
+(defmacro |sqrt| (x)
+ `(sqrt ,x))
+
;; Below are some missing functions. There here for lack of better
;; place (sys-funs.lisp?)
;;
--
cgit v1.2.3