Dear Peter,
Thank you for your answer.
>>
https://svn.origo.ethz.ch/algebraist/trunk/aldor/aldor/lib/libfoam/foam_l.lsp>>
>> But when does that come in? You have no reference to it in srcaldor3 and
>> only
>>
>> #
>> # .lsp -> .o
>> #
>>
>> ALL_DIRS += $(OBJ)/$(SYS)/aldor/build
>>
>> $(ALL_LISP_O_TARGETS): %.$(O): $(OBJ)/$(SYS)/aldor/build/.dir
>> echo LSP->O: $(notdir $@)
>> @echo '(progn (load "$(OBJ)/$(SYS)/interp/foam_l.o") (compile-file
>> "$(filter %.lsp,$^)" :output-file "$@") (${BYE}))' | ${DEPSYS} >
>> $(OBJ)/$(SYS)/aldor/build/$(notdir $@).log ;
>> @if test -f $@; then echo "Built $(notdir $@)" ; else cat
>> $(OBJ)/$(SYS)/aldor/build/$(notdir $@).log; false; fi
>>
>> in srcaldor2.
>>
>> But which foam_l should I take? The one from above or
>>
http://fricas.svn.sourceforge.net/viewvc/fricas/trunk/src/interp/foam_l.lisp?view=markup>>
>
>
>> They do not differ much, but since I have only a vague knowledge of lisp,
>> I'd highly appreciate any hints of what foam_l to take.
>>
>
> Can't comment on that here - I don't have the sourcecode to hand. I
> doubt if there are any significant differences, maybe a few extra fns.
But that is why I included the links to the sources...
https://svn.origo.ethz.ch/algebraist/trunk/aldor/aldor/lib/libfoam/foam_l.lsphttp://fricas.svn.sourceforge.net/viewvc/fricas/trunk/src/interp/foam_l.lisp?view=markupdiff -Naur aldor-foam_l.lsp fricas-foam_l.lisp is attached.
But to reduce your time... here a summary.
fricas: (deftype |Char| () 'character)
aldor: (deftype |Char| () 'string-char)
and then similar things:
fricas aldor
double-float long-float
most-negative-double-float most-negative-long-float
most-positive-double-float most-positive-long-float
double-float-epsilon long-float-epsilon
defparameter defconstant
OBEY system
And in the function |PtrMagicEQ| we have:
fricas:
( (equal (length u) (length v)) (|magicEq1| u v))
nil ))
aldor:
;; removed for Aldor integration
;; ( (equal (length u) (length v)) (|magicEq1| u v))
(t (eq u v) )))
That's all, but I cannot decide which one is better.
Ralf
--- aldor-foam_l.lsp 2008-06-25 11:21:20.000000000 +0200
+++ fricas-foam_l.lisp 2008-06-25 11:22:22.000000000 +0200
@@ -1,7 +1,37 @@
+;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in
+;; the documentation and/or other materials provided with the
+;; distribution.
+;;
+;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+;; names of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
;;;
;;; FOAM Operations for Common Lisp
;;;
-;;; Copyright (c) 1990-2007 Aldor Software Organization Ltd (Aldor.org).
;;
;; Client files should begin with
@@ -14,7 +44,7 @@
;; Deftypes for each Foam type?
;;
-(in-package "FOAM" :use '("LISP"))
+(in-package "FOAM")
(export '(
compile-as-file cases
@@ -122,7 +152,7 @@
;; type defs for Foam types
-(deftype |Char| () 'string-char)
+(deftype |Char| () 'character)
(deftype |Clos| () 'list)
(deftype |Bool| () '(member t nil))
(deftype |Byte| () 'unsigned-byte)
@@ -139,7 +169,7 @@
#+:AKCL
(deftype |DFlo| () t)
#-:AKCL
-(deftype |DFlo| () 'long-float)
+(deftype |DFlo| () 'double-float)
(deftype |Level| () t) ;; structure??
@@ -211,13 +241,13 @@
(defmacro |SFloEQ| (x y) `(= (the |SFlo| ,x) (the |SFlo| ,y)))
(defmacro |SFloNE| (x y) `(/= (the |SFlo| ,x) (the |SFlo| ,y)))
(defmacro |SFloNegate| (x) `(the |SFlo| (- (the |SFlo| ,x))))
-(defmacro |SFloNext| (x) `(the |SFlo| (+ (the |SFlo| ,x) 1.0s0)))
-(defmacro |SFloPrev| (x) `(the |SFlo| (- (the |SFlo| ,x) 1.0s0)))
+(defmacro |SFloNext| (x) `(the |SFlo| (+ (the |SFlo| ,x) 1.0s0)))
+(defmacro |SFloPrev| (x) `(the |SFlo| (- (the |SFlo| ,x) 1.0s0)))
(defmacro |SFloMinus| (x y) `(the |SFlo| (- (the |SFlo| ,x) (the |SFlo| ,y))))
(defmacro |SFloTimes| (x y) `(the |SFlo| (* (the |SFlo| ,x) (the |SFlo| ,y))))
(defmacro |SFloTimesPlus| (x y z)
`(the |SFlo| (+ (* (the |SFlo| ,x) (the |SFlo| ,y)) (the |SFlo| ,z))))
-(defmacro |SFloDivide| (x y) `(the |SFlo| (/ (the |SFlo| ,x) (the |SFlo| ,y))))
+(defmacro |SFloDivide| (x y) `(the |SFlo| (/ (the |SFlo| ,x) (the |SFlo| ,y))))
(defmacro |SFloRPlus| (x y r) `(error "unimplemented operation -- SFloRPlus"))
(defmacro |SFloRMinus| (x y r) `(error "unimplemented operation -- SFloRTimes"))
(defmacro |SFloRTimes| (x y r) `(error "unimplemented operation -- SFloRTimes"))
@@ -234,9 +264,9 @@
(defmacro |DFlo0| () 0.0d0)
(defmacro |DFlo1| () 1.0d0)
-(defmacro |DFloMin| () most-negative-long-float)
-(defmacro |DFloMax| () most-positive-long-float)
-(defmacro |DFloEpsilon| () long-float-epsilon)
+(defmacro |DFloMin| () most-negative-double-float)
+(defmacro |DFloMax| () most-positive-double-float)
+(defmacro |DFloEpsilon| () double-float-epsilon)
(defmacro |DFloIsZero| (x) `(zerop (the |DFlo| ,x)))
(defmacro |DFloIsNeg| (x) `(minusp (the |DFlo| ,x)))
(defmacro |DFloIsPos| (x) `(plusp (the |DFlo| ,x)))
@@ -245,8 +275,8 @@
(defmacro |DFloLT| (x y) `(< (the |DFlo| ,x) (the |DFlo| ,y)))
(defmacro |DFloNE| (x y) `(/= (the |DFlo| ,x) (the |DFlo| ,y)))
(defmacro |DFloNegate| (x) `(the |DFlo| (- (the |DFlo| ,x))))
-(defmacro |DFloNext| (x) `(the |DFlo| (+ (the |DFlo| ,x) 1.0d0)))
-(defmacro |DFloPrev| (x) `(the |DFlo| (- (the |DFlo| ,x) 1.0d0)))
+(defmacro |DFloNext| (x) `(the |DFlo| (+ (the |DFlo| ,x) 1.0d0)))
+(defmacro |DFloPrev| (x) `(the |DFlo| (- (the |DFlo| ,x) 1.0d0)))
(defmacro |DFloPlus| (x y) `(the |DFlo| (+ (the |DFlo| ,x) (the |DFlo| ,y))))
(defmacro |DFloMinus| (x y) `(the |DFlo| (- (the |DFlo| ,x) (the |DFlo| ,y))))
(defmacro |DFloTimes| (x y) `(the |DFlo| (* (the |DFlo| ,x) (the |DFlo| ,y))))
@@ -390,7 +420,7 @@
(defmacro |BIntBit| (x i)
`(let ((xx ,x) (ii ,i)) (declare (type |BInt| xx) (type |SInt| ii))
- (logbitp ii xx)))
+ (logbitp ii xx)))
;;(defmacro |BIntAbs| (x) `(the |BInt| (abs (the |BInt| ,x))))
(defmacro |PtrNil| () ())
@@ -420,10 +450,10 @@
(defmacro |ScanSFlo| (arr i)
`(read-from-string ,arr nil (|SFlo0|)
- :start ,i :preserve-whitespace t))
+ :start ,i :preserve-whitespace t))
(defmacro |ScanDFlo| (arr i)
`(read-from-string ,arr nil (|DFlo0|)
- :start ,i :preserve-whitespace t))
+ :start ,i :preserve-whitespace t))
(defmacro |ScanSInt| (arr i)
`(parse-integer ,arr :start ,i :junk-allowed t))
(defmacro |ScanBInt| (arr i)
@@ -454,14 +484,14 @@
(defmacro |SetClosFun| (x y) `(rplaca ,x ,y))
(defmacro |SetClosEnv| (x y) `(rplacd ,x ,y))
-(defmacro |MakeEnv| (x y)
+(defmacro |MakeEnv| (x y)
`(let ((xx ,x) (yy ,y)) (cons yy (cons xx nil))))
-(defmacro |EnvLevel| (x) `(car ,x))
-(defmacro |EnvNext| (x) `(cadr ,x))
-(defmacro |EnvInfo| (x) `(if (and (consp ,x) (consp (cdr ,x)))
- (cddr ,x) nil))
-(defmacro |SetEnvInfo| (x val) `(rplacd (cdr ,x) ,val))
+(defmacro |EnvLevel| (x) `(car ,x))
+(defmacro |EnvNext| (x) `(cadr ,x))
+(defmacro |EnvInfo| (x) `(if (and (consp ,x) (consp (cdr ,x)))
+ (cddr ,x) nil))
+(defmacro |SetEnvInfo| (x val) `(rplacd (cdr ,x) ,val))
#+:CCL
(defmacro |FoamEnvEnsure| (e)
@@ -471,7 +501,7 @@
(defmacro |FoamEnvEnsure| (e)
`(if (|EnvInfo| ,e) (|CCall| (|EnvInfo| ,e)) nil))
-(defconstant null-char-string (string (code-char 0)))
+(defparameter null-char-string (string (code-char 0)))
(defmacro |MakeLit| (s) `(concatenate 'string ,s null-char-string))
;; functions are represented by symbols, with the symbol-value being some
@@ -512,32 +542,32 @@
(defun insert-types (slots)
(mapcar #'(lambda (slot)
- `(,(car slot) ,(type2init (cadr slot))
- :type ,(cadr slot)))
- slots))
+ `(,(car slot) ,(type2init (cadr slot))
+ :type ,(cadr slot)))
+ slots))
(defmacro |RNew| (name)
(let* ((struct-args (get name 'struct-args))
- (init-args (mapcar #'(lambda (x) (type2init (cadr x)))
- struct-args))
- (count (length struct-args)))
+ (init-args (mapcar #'(lambda (x) (type2init (cadr x)))
+ struct-args))
+ (count (length struct-args)))
(cond ((> count 2) `(vector ,@init-args))
- ((= count 2) `(cons ,@init-args))
- (t `(list ,@init-args)))))
+ ((= count 2) `(cons ,@init-args))
+ (t `(list ,@init-args)))))
(defmacro |RElt| (name field index rec)
(let ((count (length (get name 'struct-args))))
(cond ((> count 2) `(svref ,rec ,index))
- ((= count 2)
- (if (zerop index) `(car ,rec) `(cdr ,rec)))
- (t `(car ,rec)))))
+ ((= count 2)
+ (if (zerop index) `(car ,rec) `(cdr ,rec)))
+ (t `(car ,rec)))))
(defmacro |SetRElt| (name field index rec val)
(let ((count (length (get name 'struct-args))))
(cond ((> count 2) `(setf (svref ,rec ,index) ,val))
- ((= count 2)
- (if (zerop index) `(rplaca ,rec ,val) `(rplacd ,rec ,val)))
- (t `(rplaca ,rec ,val)))))
+ ((= count 2)
+ (if (zerop index) `(rplaca ,rec ,val) `(rplacd ,rec ,val)))
+ (t `(rplaca ,rec ,val)))))
(defmacro |AElt| (name index)
`(aref ,name ,index))
@@ -562,25 +592,25 @@
(defmacro |SetLex| (accessor n var val)
`(progn ;; (print ',accessor)
- (setf (,accessor ,var) ,val)))
+ (setf (,accessor ,var) ,val)))
;; Atomic arguments for fun don't need a let to hold the fun.
;; CCall's with arguments need a let to hold the prog and the env.
(defmacro |CCall| (fun &rest args)
(cond ((and (atom fun) (null args))
- `(funcall (|FunProg| (|ClosFun| ,fun)) (|ClosEnv| ,fun)))
- ((null args)
- `(let ((c ,fun))
- (funcall (|FunProg| (|ClosFun| c)) (|ClosEnv| c))))
- ((atom fun)
- `(let ((fun (|FunProg| (|ClosFun| ,fun)))
- (env (|ClosEnv| ,fun)))
- (funcall fun ,@args env)))
- (t
- `(let ((c ,fun))
- (let ((fun (|FunProg| (|ClosFun| c)))
- (env (|ClosEnv| c)))
- (funcall fun ,@args env))))))
+ `(funcall (|FunProg| (|ClosFun| ,fun)) (|ClosEnv| ,fun)))
+ ((null args)
+ `(let ((c ,fun))
+ (funcall (|FunProg| (|ClosFun| c)) (|ClosEnv| c))))
+ ((atom fun)
+ `(let ((fun (|FunProg| (|ClosFun| ,fun)))
+ (env (|ClosEnv| ,fun)))
+ (funcall fun ,@args env)))
+ (t
+ `(let ((c ,fun))
+ (let ((fun (|FunProg| (|ClosFun| c)))
+ (env (|ClosEnv| c)))
+ (funcall fun ,@args env))))))
(defmacro |FoamFree| (o) '())
@@ -594,8 +624,8 @@
(defmacro defprog (type temps &rest body)
`(progn (defun ,(caar type) ,(mapcar #'car (cadr type))
- (typed-let ,temps ,@body))
- (alloc-prog-info #',(caar type) (make-FoamProgInfoStruct))))
+ (typed-let ,temps ,@body))
+ (alloc-prog-info #',(caar type) (make-FoamProgInfoStruct))))
(defmacro defspecials (&rest lst)
`(proclaim '(special ,@lst)))
@@ -612,17 +642,17 @@
#-:CCL
(defmacro typed-let (letvars &rest forms)
`(let ,(mapcar #'(lambda (var)
- (list (car var) (type2init (cadr var))))
- letvars )
+ (list (car var) (type2init (cadr var))))
+ letvars )
(declare ,@(mapcar #'(lambda (var)
- (list 'type (cadr var) (car var)))
- letvars))
+ (list 'type (cadr var) (car var)))
+ letvars))
,@forms))
#+:CCL
(defmacro typed-let (letvars &rest forms)
`(let ,(mapcar #'(lambda (var) (car var))
- letvars )
+ letvars )
,@forms))
(defmacro cases (&rest junk)
@@ -632,15 +662,15 @@
;;; Boot macros
(defmacro file-exports (lst)
`(eval-when (load eval)
- (when (fboundp 'process-export-entry)
- (mapcar #'process-export-entry ,lst))
- nil))
+ (when (fboundp 'process-export-entry)
+ (mapcar #'process-export-entry ,lst))
+ nil))
(defmacro file-imports (lst)
`(eval-when (load eval)
- (when (fboundp 'process-import-entry)
- (mapcar #'process-import-entry ,lst))
- nil))
+ (when (fboundp 'process-import-entry)
+ (mapcar #'process-import-entry ,lst))
+ nil))
(defmacro ignore-var (var)
`(declare (ignore ,var)))
@@ -649,8 +679,8 @@
(if (eq type '|Char|)
`(make-string ,size)
`(make-array ,size
- :element-type ',type
- :initial-element ,(type2init type))))
+ :element-type ',type
+ :initial-element ,(type2init type))))
#-:CCL
(defun type2init (x)
@@ -688,9 +718,9 @@
;needs to stop when it gets a null character
(defun |strLength| (s)
(dotimes (i (length s))
- (let ((c (schar s i)))
- (if (char= c |CharCode0|)
- (return i))))
+ (let ((c (schar s i)))
+ (if (char= c |CharCode0|)
+ (return i))))
(length s))
(defun |formatSInt| (n) (format nil "~D" n))
@@ -706,10 +736,10 @@
;needs to stop when it gets a null character
(defun |printString| (cs s)
(dotimes (i (length s))
- (let ((c (schar s i)))
- (if (char= c |CharCode0|)
- (return i)
- (princ c cs)))))
+ (let ((c (schar s i)))
+ (if (char= c |CharCode0|)
+ (return i)
+ (princ c cs)))))
(defun |printSInt| (cs n) (format cs "~D" n))
(defun |printBInt| (cs n) (format cs "~D" n))
@@ -730,46 +760,46 @@
;; the given input stream
(defun |fgetss| (s i1 i2 f)
(labels ((aux (n)
- (if (= n i2)
- (progn (setf (schar s n) (code-char 0))
- (- n i1))
- (let ((c (read-char f)))
- (setf (schar s n) c)
- (if (equal c #\newline)
- (progn (setf (char s (+ n 1)) (code-char 0))
- (- n i1))
- (aux (+ n 1)))))))
- (aux i1)))
-
+ (if (= n i2)
+ (progn (setf (schar s n) (code-char 0))
+ (- n i1))
+ (let ((c (read-char f)))
+ (setf (schar s n) c)
+ (if (equal c #\newline)
+ (progn (setf (char s (+ n 1)) (code-char 0))
+ (- n i1))
+ (aux (+ n 1)))))))
+ (aux i1)))
+
;; write s[i1..i2) to the output stream f
;; stop on any null characters
(defun |fputss| (s i1 i2 f)
(labels ((aux (n)
- (if (= n i2) (- n i1)
- (let ((c (schar s n)))
- (if (equal (code-char 0) c)
- (- n i1)
- (progn (princ c f)
- (aux (+ n 1))))))))
- (setq i2 (if (minusp i2) (|strLength| s)
- (min i2 (|strLength| s))))
- (aux i1)))
+ (if (= n i2) (- n i1)
+ (let ((c (schar s n)))
+ (if (equal (code-char 0) c)
+ (- n i1)
+ (progn (princ c f)
+ (aux (+ n 1))))))))
+ (setq i2 (if (minusp i2) (|strLength| s)
+ (min i2 (|strLength| s))))
+ (aux i1)))
;; function for compiling and loading from lisp
(defun compile-as-file (file &optional (opts nil))
(let* ((path (pathname file))
- (name (pathname-name path))
- (dir (pathname-directory path))
- (type (pathname-type path))
- (lpath (make-pathname :name name :type "l"))
- (cpath (make-pathname :name name :type "o")))
+ (name (pathname-name path))
+ (dir (pathname-directory path))
+ (type (pathname-type path))
+ (lpath (make-pathname :name name :type "l"))
+ (cpath (make-pathname :name name :type "o")))
(if (null type)
- (setq path (make-pathname :directory dir :name name :type "as")))
+ (setq path (make-pathname :directory dir :name name :type "as")))
(if opts
- (system (format nil "axiomxl ~A -Flsp ~A" opts (namestring path)))
- (system (format nil "axiomxl -Flsp ~A" (namestring path))))
+ (OBEY (format nil "axiomxl ~A -Flsp ~A" opts (namestring path)))
+ (OBEY (format nil "axiomxl -Flsp ~A" (namestring path))))
(compile-file (namestring lpath))
(load (namestring cpath))))
@@ -806,10 +836,10 @@
(defun |Halt| (n)
(error (cond ((= n 101) "System Error: Unfortunate use of dependant type")
- ((= n 102) "User error: Reached a 'never'")
- ((= n 103) "User error: Bad union branch")
- ((= n 104) "User error: Assertion failed")
- (t (format nil "Unknown halt condition ~a" n)))))
+ ((= n 102) "User error: Reached a 'never'")
+ ((= n 103) "User error: Bad union branch")
+ ((= n 104) "User error: Assertion failed")
+ (t (format nil "Unknown halt condition ~a" n)))))
;; debuging
(defvar *foam-debug-var* nil)
(defun |fiGetDebugVar| () *foam-debug-var*)
@@ -838,12 +868,13 @@
(cond ( (or (NULL u) (NULL v)) nil)
( (and (ATOM u) (ATOM v)) (eql u v))
( (or (ATOM u) (ATOM v)) nil)
- ( (equal (length u) (length v)) (|magicEq1| u v))
- nil ))
+;; removed for Aldor integration
+;; ( (equal (length u) (length v)) (|magicEq1| u v))
+ (t (eq u v) )))
(defun |magicEq1| (u v)
(cond ( (and (atom u) (atom v)) (|politicallySound| u v))
( (or (atom u) (atom v)) nil)
( (|politicallySound| (car u) (car v)) (|magicEq1| (cdr u) (cdr v)))
- nil ))
+ (t nil) ))
_______________________________________________
Aldor-l mailing list
Aldor-l@...
http://aldor.org/mailman/listinfo/aldor-l_aldor.org
