diff options
Diffstat (limited to 'src/interp/foam_l.lisp.pamphlet')
| -rw-r--r-- | src/interp/foam_l.lisp.pamphlet | 945 |
1 files changed, 945 insertions, 0 deletions
diff --git a/src/interp/foam_l.lisp.pamphlet b/src/interp/foam_l.lisp.pamphlet new file mode 100644 index 00000000..7bf48022 --- /dev/null +++ b/src/interp/foam_l.lisp.pamphlet @@ -0,0 +1,945 @@ +%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/foam\_l.lisp} Pamphlet} +\author{Stephen M. Watt, Timothy Daly} + +\begin{document} +\maketitle + +\begin{abstract} +\end{abstract} + + +\tableofcontents +\eject + +\section{License} + +<<license>>= +;; 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. + +@ + + + +\section{The [[FOAM]] package} + +FOAM is the intermediate language for the aldor compiler. FOAM +means "first order abstract machine" and functions similar to +RTL for the GCC compiler. It is a "machine" that is used as the +target for meta-assembler level statments. These are eventually +expanded for the real target machine (or interpreted directly) +<<FOAM>>= +#+:common-lisp (in-package "COMMON-LISP-USER") +#-:common-lisp (in-package "USER") + +(defpackage "FOAM" + #+:common-lisp (:use "COMMON-LISP") + #-:common-lisp (:use "LISP")) + +@ + +\section{The [[FOAM-USER]] package} + +FOAM-USER is the package containing foam statements and macros +that get inserted into user code versus the foam package which +provides support for compiler code. +<<FOAM>>= +(defpackage "FOAM-USER" + #+:common-lisp (:use "COMMON-LISP") + #-:common-lisp (:use "LISP") + (:use "FOAM")) + +@ + + +<<*>>= +<<license>> +;;; +;;; FOAM Operations for Common Lisp +;;; + +;; +;; Client files should begin with +;; (in-package "FOAM-USER" :use '("FOAM" "LISP")) +;; +;; +;; To Do: +;; Test cases. +;; Scan and format functions need to be rewritten to handle complete syntax. +;; Deftypes for each Foam type? +;; + +<<FOAM>> +(in-package "FOAM") + +(export '( + compile-as-file cases + + |Clos| |Char| |Bool| |Byte| |HInt| |SInt| |BInt| |SFlo| |DFlo| |Ptr| + |Word| |Arb| |Env| |Level| |Arr| |Record| + + |ClosInit| |CharInit| |BoolInit| |ByteInit| |HIntInit| |SIntInit| + |BIntInit| |SFloInit| |DFloInit| |PtrInit| |WordInit| |ArbInit| |EnvInit| + |ArrInit| |RecordInit| |LevelInit| + + |BoolFalse| |BoolTrue| |BoolNot| |BoolAnd| |BoolOr| |BoolEQ| |BoolNE| + + |CharSpace| |CharNewline| |CharMin| |CharMax| |CharIsDigit| + |CharIsLetter| |CharEQ| |CharNE| |CharLT| |CharLE| + |CharLower| |CharUpper| |CharOrd| |CharNum| |CharCode0| + + |SFlo0| |SFlo1| |SFloMin| |SFloMax| |SFloEpsilon| |SFloIsZero| + |SFloIsNeg| |SFloIsPos| |SFloEQ| |SFloNE| |SFloLT| + |SFloLE| |SFloNegate| |SFloPrev| |SFloNext| |SFloPlus| + |SFloMinus| |SFloTimes| |SFloTimesPlus| |SFloDivide| + |SFloRPlus| |SFloRMinus| |SFloRTimes| |SFloRTimesPlus| + |SFloRDivide| |SFloDissemble| |SFloAssemble| + + |DFlo0| |DFlo1| |DFloMin| |DFloMax| |DFloEpsilon| + |DFloIsZero| |DFloIsNeg| |DFloIsPos| |DFloEQ| |DFloNE| + |DFloLT| |DFloLE| |DFloNegate| |DFloPrev| |DFloNext| + |DFloPlus| |DFloMinus| |DFloTimes| |DFloTimesPlus| + |DFloDivide| |DFloRPlus| |DFloRMinus| |DFloRTimes| + |DFloRTimesPlus| |DFloRDivide| |DFloDissemble| + |DFloAssemble| |Byte0| |Byte1| |ByteMin| |ByteMax| + + |HInt0| |HInt1| |HIntMin| |HIntMax| + + |SInt0| |SInt1| |SIntMin| |SIntMax| |SIntIsZero| |SIntIsNeg| + |SIntIsPos| |SIntIsEven| |SIntIsOdd| |SIntEQ| |SIntNE| + |SIntLT| |SIntLE| |SIntNegate| |SIntPrev| |SIntNext| + |SIntPlus| |SIntMinus| |SIntTimes| |SIntTimesPlus| + |SIntMod| |SIntQuo| |SIntRem| |SIntDivide| |SIntGcd| + |SIntPlusMod| |SIntMinusMod| |SIntTimesMod| + |SIntTimesModInv| |SIntLength| |SIntShiftUp| + |SIntShiftDn| |SIntBit| |SIntNot| |SIntAnd| |SIntOr| + + |WordTimesDouble| |WordDivideDouble| |WordPlusStep| |WordTimesStep| + + |BInt0| |BInt1| |BIntIsZero| |BIntIsNeg| |BIntIsPos| |BIntIsEven| + |BIntIsOdd| |BIntIsSingle| |BIntEQ| |BIntNE| |BIntLT| + |BIntLE| |BIntNegate| |BIntPrev| |BIntNext| |BIntPlus| + |BIntMinus| |BIntTimes| |BIntTimesPlus| |BIntMod| + |BIntQuo| |BIntRem| |BIntDivide| |BIntGcd| + |BIntSIPower| |BIntBIPower| |BIntLength| |BIntShiftUp| + |BIntShiftDn| |BIntBit| + + |PtrNil| |PtrIsNil| |PtrMagicEQ| |PtrEQ| |PtrNE| + + |FormatSFlo| |FormatDFlo| |FormatSInt| |FormatBInt| + |fgetss| |fputss| + + |ScanSFlo| |ScanDFlo| |ScanSInt| |ScanBInt| + + |SFloToDFlo| |DFloToSFlo| |ByteToSInt| |SIntToByte| |HIntToSInt| + |SIntToHInt| |SIntToBInt| |BIntToSInt| |SIntToSFlo| + |SIntToDFlo| |BIntToSFlo| |BIntToDFlo| |PtrToSInt| + |SIntToPtr| |BoolToSInt| + + |ArrToSFlo| |ArrToDFlo| |ArrToSInt| |ArrToBInt| + + |PlatformRTE| |PlatformOS| |Halt| + + |Clos| |CCall| |ClosEnv| |ClosFun| |SetClosEnv| |SetClosFun| + |DDecl| |RNew| |ANew| |RElt| |EElt| |AElt| |Lex| + |SetLex| |SetRElt| |SetAElt| |SetEElt| + |FoamFree| + + declare-prog declare-type + defprog ignore-var block-return + defspecials file-exports file-imports + typed-let foamfn |FoamProg| |alloc-prog-info| + + |MakeEnv| |EnvLevel| |EnvNext| |EnvInfo| |SetEnvInfo| |FoamEnvEnsure| + |MakeLit| |MakeLevel| + |printNewLine| |printChar| |printString| |printSInt| |printBInt| |printSFloat| + |printDFloat| + |strLength| |formatSInt| |formatBInt| |formatSFloat| |formatDFloat| + + |ProgHashCode| |SetProgHashCode| |ProgFun| + |G-mainArgc| |G-mainArgv| + |stdinFile| |stdoutFile| |stderrFile| + |fputc| |fputs| |foamfun| + + + ;; trancendental functions + |sqrt| |pow| |log| |exp| |sin| |cos| |tan| |sinh| |cosh| |tanh| + |asin| |acos| |atan| |atan2| + + ;; debuging + |fiSetDebugVar| |fiGetDebugVar| |fiSetDebugger| |fiGetDebugger| + ;; Blatent hacks.. + |G-stdoutVar| |G-stdinVar| |G-stderrVar| + |fiStrHash| + + axiomxl-file-init-name + axiomxl-global-name +)) + + +;; type defs for Foam types +(deftype |Char| () 'character) +(deftype |Clos| () 'list) +(deftype |Bool| () '(member t nil)) +(deftype |Byte| () 'unsigned-byte) +(deftype |HInt| () '(integer #.(- (expt 2 15)) #.(1- (expt 2 15)))) +(deftype |SInt| () 'fixnum) + +#+:AKCL +(deftype |BInt| () t) +#-:AKCL +(deftype |BInt| () 'integer) + +(deftype |SFlo| () 'short-float) + +#+:AKCL +(deftype |DFlo| () t) +#-:AKCL +(deftype |DFlo| () 'long-float) + +(deftype |Level| () t) ;; structure?? + +(deftype |Nil| () t) +(deftype |Ptr| () t) +(deftype |Word| () t) +(deftype |Arr| () t) +(deftype |Record| () t) +(deftype |Arb| () t) +(deftype |Env| () t) ; (or cons nil) + +;; default values for types. Used as initializers in lets. +(defconstant |CharInit| (the |Char| '#\Space)) +(defconstant |ClosInit| (the |Clos| nil)) +(defconstant |BoolInit| (the |Bool| nil)) +(defconstant |ByteInit| (the |Byte| 0)) +(defconstant |HIntInit| (the |HInt| 0)) +(defconstant |SIntInit| (the |SInt| 0)) +(defconstant |BIntInit| (the |BInt| 0)) +(defconstant |SFloInit| (the |SFlo| 0.0s0)) +;; FIXME: Revisit the definition of DFlo as long-double. +(defconstant |DFloInit| (the |DFlo| 0.0l0)) +(defconstant |PtrInit| (the |Ptr| nil)) +(defconstant |ArrInit| (the |Arr| nil)) +(defconstant |RecordInit| (the |Record| nil)) +(defconstant |WordInit| (the |Word| nil)) +(defconstant |ArbInit| (the |Arb| nil)) +(defconstant |EnvInit| (the |Env| nil)) +(defconstant |LevelInit| (the |Level| nil)) + +;; Bool values are assumed to be either 'T or NIL. +;; Thus non-nil values are canonically represented. +(defmacro |BoolFalse| () NIL) +(defmacro |BoolTrue| () 'T) +(defmacro |BoolNot| (x) `(NOT ,x)) +(defmacro |BoolAnd| (x y) + `(let ((xx ,x) (yy ,y)) (AND xx yy))) ;; force evaluation of both args +(defmacro |BoolOr| (x y) + `(let ((xx ,x) (yy ,y)) (OR xx yy))) ;; force evaluation of both args +(defmacro |BoolEQ| (x y) `(EQ ,x ,y)) +(defmacro |BoolNE| (x y) `(NOT (|BoolEQ| ,x ,y))) + +(defconstant |CharCode0| (code-char 0)) + +(defmacro |CharSpace| () '#\Space) +(defmacro |CharNewline| () '#\Newline) +(defmacro |CharMin| () |CharCode0|) +(defmacro |CharMax| () #.(code-char (1- char-code-limit))) +(defmacro |CharIsDigit| (x) `(if (DIGIT-CHAR-P (the |Char| ,x)) 't nil)) +(defmacro |CharIsLetter|(x) `(ALPHA-CHAR-P (the |Char| ,x))) +(defmacro |CharLT| (x y) `(CHAR< (the |Char| ,x) (the |Char| ,y))) +(defmacro |CharLE| (x y) `(CHAR<= (the |Char| ,x) (the |Char| ,y))) +(defmacro |CharEQ| (x y) `(CHAR= (the |Char| ,x) (the |Char| ,y))) +(defmacro |CharNE| (x y) `(CHAR/= (the |Char| ,x) (the |Char| ,y))) +(defmacro |CharLower| (x) `(the |Char| (CHAR-DOWNCASE (the |Char| ,x)))) +(defmacro |CharUpper| (x) `(the |Char| (CHAR-UPCASE (the |Char| ,x)))) +(defmacro |CharOrd| (x) `(CHAR-INT (the |Char| ,x))) +(defmacro |CharNum| (x) `(INT-CHAR (the |SInt| ,x))) + +(defmacro |SFlo0| () 0.0s0) +(defmacro |SFlo1| () 1.0s0) +(defmacro |SFloMin| () most-negative-short-float) +(defmacro |SFloMax| () most-positive-short-float) +(defmacro |SFloEpsilon| () short-float-epsilon) +(defmacro |SFloIsZero| (x) `(zerop (the |SFlo| ,x))) +(defmacro |SFloIsNeg| (x) `(minusp (the |SFlo| ,x))) +(defmacro |SFloIsPos| (x) `(plusp (the |SFlo| ,x))) +(defmacro |SFloLT| (x y) `(< (the |SFlo| ,x) (the |SFlo| ,y))) +(defmacro |SFloLE| (x y) `(<= (the |SFlo| ,x) (the |SFlo| ,y))) +(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 |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 |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")) +(defmacro |SFloRTimesPlus| (x y z r) `(error "unimplemented operation -- SFloTimesPlus")) +(defmacro |SFloRDivide|(x y r) `(error "unimplemented operation -- SFloDivide")) +(defmacro |SFloDissemble| (x) `(error "unimplemented operation -- SFloDissemble")) +(defmacro |SFloAssemble| (w x y) `(error "unimplemented operation -- SFloAssemble")) + +;; These are no longer foam builtins +;;(defmacro |SFloRound| (x) `(the |BInt| (round (the |SFlo| ,x)))) +;;(defmacro |SFloTruncate| (x) `(the |BInt| (truncate (the |SFlo| ,x)))) +;;(defmacro |SFloFloor| (x) `(the |BInt| (floor (the |SFlo| ,x)))) +;;(defmacro |SFloCeiling| (x) `(the |BInt| (ceiling (the |SFlo| ,x)))) + +(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 |DFloIsZero| (x) `(zerop (the |DFlo| ,x))) +(defmacro |DFloIsNeg| (x) `(minusp (the |DFlo| ,x))) +(defmacro |DFloIsPos| (x) `(plusp (the |DFlo| ,x))) +(defmacro |DFloLE| (x y) `(<= (the |DFlo| ,x) (the |DFlo| ,y))) +(defmacro |DFloEQ| (x y) `(= (the |DFlo| ,x) (the |DFlo| ,y))) +(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 |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)))) +(defmacro |DFloDivide| (x y) `(the |DFlo| (/ (the |DFlo| ,x) (the |DFlo| ,y)))) +(defmacro |DFloTimesPlus| (x y z) + `(the |DFlo| (+ (* (the |DFlo| ,x) (the |DFlo| ,y)) (the |DFlo| ,z)))) + +(defmacro |DFloRPlus| (x y r) `(error "unimplemented operation -- DFloRPlus")) +(defmacro |DFloRMinus| (x y r) `(error "unimplemented operation -- DFloRTimes")) +(defmacro |DFloRTimes| (x y r) `(error "unimplemented operation -- DFloRTimes")) +(defmacro |DFloRTimesPlus| (x y z r) `(error "unimplemented operation -- DFloTimesPlus")) +(defmacro |DFloRDivide|(x y r) `(error "unimplemented operation -- DFloDivide")) + +(defmacro |DFloDissemble| (x) `(error "unimplemented operation -- DFloDissemble")) +(defmacro |DFloAssemble| (w x y z) `(error "unimplemented operation -- DFloAssemble")) + +;; Not builtins anymore +;;(defmacro |DFloRound| (x) `(the |BInt| (round (the |DFlo| ,x)))) +;;(defmacro |DFloTruncate| (x) `(the |BInt| (truncate (the |DFlo| ,x)))) +;;(defmacro |DFloFloor| (x) `(the |BInt| (floor (the |DFlo| ,x)))) +;;(defmacro |DFloCeiling| (x) `(the |BInt| (ceiling (the |DFlo| ,x)))) + +(defmacro |Byte0| () 0) +(defmacro |Byte1| () 1) +(defmacro |ByteMin| () 0) +(defmacro |ByteMax| () 255) + +(defmacro |HInt0| () 0) +(defmacro |HInt1| () 1) +(defmacro |HIntMin| () #.(- (expt 2 15))) +(defmacro |HIntMax| () #.(1- (expt 2 15))) + +(defmacro |SInt0| () 0) +(defmacro |SInt1| () 1) +(defmacro |SIntMin| () `(the |SInt| most-negative-fixnum)) +(defmacro |SIntMax| () `(the |SInt| most-positive-fixnum)) +(defmacro |SIntIsZero| (x) `(zerop (the |SInt| ,x))) +(defmacro |SIntIsNeg| (x) `(minusp (the |SInt| ,x))) +(defmacro |SIntIsPos| (x) `(plusp (the |SInt| ,x))) +(defmacro |SIntIsEven| (x) `(evenp (the |SInt| ,x))) +(defmacro |SIntIsOdd| (x) `(oddp (the |SInt| ,x))) +(defmacro |SIntLE| (x y) `(<= (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntEQ| (x y) `(= (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntLT| (x y) `(< (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntNE| (x y) `(/= (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntNegate| (x) `(the |SInt| (- (the |SInt| ,x)))) +(defmacro |SIntPrev| (x) `(the |SInt| (1- (the |SInt| ,x)))) +(defmacro |SIntNext| (x) `(the |SInt| (1+ (the |SInt| ,x)))) +(defmacro |SIntPlus| (x y) `(the |SInt| (+ (the |SInt| ,x) (the |SInt| ,y)))) +(defmacro |SIntMinus| (x y) `(the |SInt| (- (the |SInt| ,x) (the |SInt| ,y)))) +(defmacro |SIntTimes| (x y) `(the |SInt| (* (the |SInt| ,x) (the |SInt| ,y)))) +(defmacro |SIntTimesPlus| (x y z) + `(the |SInt| (+ (* (the |SInt| ,x) (the |SInt| ,y)) (the |SInt| ,z)))) +(defmacro |SIntMod| (x y) `(the |SInt| (mod(the |SInt| ,x)(the |SInt| ,y)))) +(defmacro |SIntQuo| (x y) + `(the |SInt| (values (truncate (the |SInt| ,x) (the |SInt| ,y))))) +(defmacro |SIntRem| (x y) `(the |SInt| (rem(the |SInt| ,x)(the |SInt| ,y)))) +;;! declare all let variables +(defmacro |SIntDivide| (x y) `(truncate (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntGcd| (x y) `(the |SInt| (gcd (the |SInt| ,x) (the |SInt| ,y)))) + +(defmacro |SIntPlusMod| (a b c) + `(the |SInt| (mod (+ (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) +(defmacro |SIntMinusMod| (a b c) + `(the |SInt| (mod (- (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) +(defmacro |SIntTimesMod| (a b c) + `(the |SInt| (mod (* (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) +;; |SIntTimesModInv| +(defmacro |SIntLength| (x) `(the |SInt| (integer-length (the |SInt| ,x)))) +(defmacro |SIntShiftUp| (x y) `(the |SInt| (ash (the |SInt| ,x) (the |SInt| ,y)))) +(defmacro |SIntShiftDn| (x y) `(the |SInt| (ash (the |SInt| ,x) (the |SInt| (- (the |SInt| ,y)))))) + +(defmacro |SIntBit| (x i) + `(let ((xx ,x) (ii ,i)) (declare (type |SInt| xx ii)) (logbitp ii xx))) +(defmacro |SIntNot| (a) `(the |SInt| (lognot (the |SInt| ,a)))) +(defmacro |SIntAnd| (a b) + `(the |SInt| (logand (the |SInt| ,a) (the |SInt| ,b)))) +(defmacro |SIntOr| (a b) + `(the |SInt| (logior (the |SInt| ,a) (the |SInt| ,b)))) + +;; WordTimesDouble +;; WordDivideDouble +;; WordPlusStep +;; WordTimesStep + +(defmacro |SIntSIPower| (x y) + `(let ((xx ,x) (yy ,y)) + (declare (type |SInt| xx yy)) + (if (minusp yy) (error "cannot raise integers to negative powers") + (the |SInt| (expt xx yy))))) +(defmacro |SIntBIPower| (x y) + `(let ((xx ,x) (yy ,y)) + (declare (type |SInt| xx)) + (declare (type |BInt| yy)) + (if (minusp yy) (error "cannot raise integers to negative powers") + (the |SInt| (expt xx yy))))) + +(defmacro |BInt0| () 0) +(defmacro |BInt1| () 1) +(defmacro |BIntIsZero| (x) `(zerop (the |BInt| ,x))) +(defmacro |BIntIsNeg| (x) `(minusp(the |BInt| ,x))) +(defmacro |BIntIsPos| (x) `(plusp (the |BInt| ,x))) +(defmacro |BIntIsEven| (x) `(evenp (the |BInt| ,x))) +(defmacro |BIntIsOdd| (x) `(oddp (the |BInt| ,x))) +(defmacro |BIntIsSingle| (x) `(typep ,x '|SInt|)) +(defmacro |BIntLE| (x y) `(<= (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntEQ| (x y) `(= (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntLT| (x y) `(< (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntNE| (x y) `(/= (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntNegate| (x) `(the |BInt| (- (the |BInt| ,x)))) +(defmacro |BIntPrev| (x) `(the |BInt| (1- (the |BInt| ,x)))) +(defmacro |BIntNext| (x) `(the |BInt| (1+ (the |BInt| ,x)))) +(defmacro |BIntPlus| (x y) `(the |BInt| (+ (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntMinus| (x y) `(the |BInt| (- (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntTimes| (x y) `(the |BInt| (* (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntTimesPlus| (x y z) + `(the |BInt| (+ (* (the |BInt| ,x) (the |BInt| ,y)) (the |BInt| ,z)))) +(defmacro |BIntMod| (x y) `(the |BInt| (mod(the |BInt| ,x)(the |BInt| ,y)))) +(defmacro |BIntQuo| (x y) + `(the |BInt| (values (truncate (the |BInt| ,x) (the |BInt| ,y))))) +(defmacro |BIntRem| (x y) + `(the |BInt| (rem (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntDivide| (x y) `(truncate (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntGcd| (x y) + `(the |BInt| (gcd (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntSIPower| (x y) + `(let ((xx ,x) (yy ,y)) + (declare (type |BInt| xx)) + (declare (type |SInt| yy)) + (if (minusp yy) (error "cannot raise integers to negative powers") + (the |BInt| (expt xx yy))))) +(defmacro |BIntBIPower| (x y) + `(let ((xx ,x) (yy ,y)) + (declare (type |BInt| xx)) + (declare (type |BInt| yy)) + (if (minusp yy) (error "cannot raise integers to negative powers") + (the |BInt| (expt xx yy))))) +(defmacro |BIntLength| (x) `(the |SInt| (integer-length (the |BInt| ,x)))) +(defmacro |BIntShiftUp| (x y) `(the |BInt| (ash (the |BInt| ,x)(the |SInt| ,y)))) +(defmacro |BIntShiftDn| (x y) `(the |BInt| (ash (the |BInt| ,x) (the |SInt| (- (the |SInt| ,y)))))) + +(defmacro |BIntBit| (x i) + `(let ((xx ,x) (ii ,i)) (declare (type |BInt| xx) (type |SInt| ii)) + (logbitp ii xx))) +;;(defmacro |BIntAbs| (x) `(the |BInt| (abs (the |BInt| ,x)))) + +(defmacro |PtrNil| () ()) +(defmacro |PtrIsNil| (x) `(NULL ,x)) +(defmacro |PtrEQ| (x y) `(eq ,x ,y)) +(defmacro |PtrNE| (x y) `(not (eq ,x ,y))) + +;; |WordTimesDouble| |WordDivideDouble| |WordPlusStep| |WordTimesStep| + + +;;(defvar |FoamOutputString| +;; (make-array 80 :element-type 'string-char :adjustable t :fill-pointer 0)) +(defun |FormatNumber| (c arr i) + (setq str (format nil "~a" c)) + (replace arr str :start1 i) +;; (incf i (fill-pointer |FoamOutputString|)) +;; (if (> i (length arr)) (error "not enough space")) +;; (setf (fill-pointer |FoamOutputString|) 0) + (+ i (length str))) + +(defmacro |FormatSFlo| (c arr i) `(|FormatNumber| ,c ,arr ,i)) +(defmacro |FormatDFlo| (c arr i) `(|FormatNumber| ,c ,arr ,i)) +(defmacro |FormatSInt| (c arr i) `(|FormatNumber| ,c ,arr ,i)) +(defmacro |FormatBInt| (c arr i) `(|FormatNumber| ,c ,arr ,i)) + +(set-syntax-from-char (code-char 0) #\space) ;;makes null char act like white space + +(defmacro |ScanSFlo| (arr i) + `(read-from-string ,arr nil (|SFlo0|) + :start ,i :preserve-whitespace t)) +(defmacro |ScanDFlo| (arr i) + `(read-from-string ,arr nil (|DFlo0|) + :start ,i :preserve-whitespace t)) +(defmacro |ScanSInt| (arr i) + `(parse-integer ,arr :start ,i :junk-allowed t)) +(defmacro |ScanBInt| (arr i) + `(parse-integer ,arr :start ,i :junk-allowed t)) + +;; 18/8/93: Evil bug in genfoam---nil generated. +(defmacro hacked-the (type x) + (if x `(the ,type ,x) `(the ,type 0))) + +(defmacro |ByteToSInt| (x) `(coerce (hacked-the |Byte| ,x) '|SInt|)) +(defmacro |BoolToSInt| (x) `(if ,x 1 0)) +(defmacro |BIntToSInt| (x) `(hacked-the |SInt| ,x)) +(defmacro |SIntToBInt| (x) `(hacked-the |BInt| ,x)) +(defmacro |SIntToSFlo| (x) `(coerce (hacked-the |SInt| ,x) '|SFlo|)) +(defmacro |SIntToByte| (x) `(coerce (hacked-the |SInt| ,x) '|Byte|)) +(defmacro |SIntToHInt| (x) `(coerce (hacked-the |SInt| ,x) '|HInt|)) +(defmacro |SIntToDFlo| (x) `(coerce (hacked-the |SInt| ,x) '|DFlo|)) +(defmacro |BIntToSFlo| (x) `(coerce (hacked-the |BInt| ,x) '|SFlo|)) +(defmacro |BIntToDFlo| (x) `(coerce (hacked-the |BInt| ,x) '|DFlo|)) +(defmacro |ArrToSFlo| (x) `(read-from-string ,x nil (|SFlo0|))) +(defmacro |ArrToDFlo| (x) `(read-from-string ,x nil (|DFlo0|))) +(defmacro |ArrToSInt| (x) `(read-from-string ,x nil (|SInt0|))) +(defmacro |ArrToBInt| (x) `(read-from-string ,x nil (|BInt0|))) + +(defmacro |Clos| (x y) `(let ((xx ,x) (yy #',y)) (cons yy xx))) +(defmacro |ClosFun| (x) `(car ,x)) +(defmacro |ClosEnv| (x) `(cdr ,x)) +(defmacro |SetClosFun| (x y) `(rplaca ,x ,y)) +(defmacro |SetClosEnv| (x y) `(rplacd ,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)) + +#+:CCL +(defmacro |FoamEnvEnsure| (e) + `(let ((einf (|EnvInfo| ,e))) + (if einf (|CCall| einf) nil))) +#-:CCL +(defmacro |FoamEnvEnsure| (e) + `(if (|EnvInfo| ,e) (|CCall| (|EnvInfo| ,e)) nil)) + +(defconstant 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 +;; information, and the symbol-function is the function itself. +;; 1-valued lisp should represent progs as either a pair or defstruct. + +(defmacro |FunProg| (x) x) + +(defstruct FoamProgInfoStruct + (funcall nil :type function) + (hashval 0 :type |SInt|)) + +(defun |ProgHashCode| (x) + (let ((aa (foam-function-info x))) + (if (null aa) 0 + (FoamProgInfoStruct-hashval aa)))) + +(defun |SetProgHashCode| (x y) + (let ((aa (foam-function-info x))) + (if (null aa) 0 + (setf (FoamProgInfoStruct-hashval aa) y)))) + +;; In a hurry -> O(n) lookup.. +(defvar foam-function-list ()) + +(defun alloc-prog-info (fun val) + (setq foam-function-list (cons (cons fun val) foam-function-list))) + +(defun foam-function-info (fun) + (let ((xx (assoc fun foam-function-list))) + (if (null xx) nil + (cdr xx)))) + +;; Accessors and constructors +(defmacro |DDecl| (name &rest args) + (setf (get name 'struct-args) args) + `(defstruct ,name ,@(insert-types args))) + +(defun insert-types (slots) + (mapcar #'(lambda (slot) + `(,(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))) + (cond ((> count 2) `(vector ,@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))))) + +(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))))) + +(defmacro |AElt| (name index) + `(aref ,name ,index)) + +(defmacro |SetAElt| (name index val) + `(setf (aref ,name ,index) ,val)) + +(defmacro |MakeLevel| (builder struct) + (if (get struct 'struct-args) + `(,builder) + 'nil)) + + +(defmacro |EElt| (accessor n var) + `(,accessor ,var)) + +(defmacro |SetEElt| (accessor n var val) + `(setf (,accessor ,var) ,val)) + +(defmacro |Lex| (accessor n var) + `(,accessor ,var)) + +(defmacro |SetLex| (accessor n var val) + `(progn ;; (print ',accessor) + (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)))))) + +(defmacro |FoamFree| (o) '()) + +;; macros for defining things + +(defmacro declare-prog (name-result params) + `(proclaim '(function ,(car name-result) ,params ,@(cdr name-result)))) + +(defmacro declare-type (name type) + `(proclaim '(type ,name ,type))) + +(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)))) + +(defmacro defspecials (&rest lst) + `(proclaim '(special ,@lst))) + +(defmacro top-level-define (&rest junk) + `(setq ,@junk)) + +;; Runtime macros + +;; control transfer +(defmacro block-return (obj val) + `(return-from ,obj ,val)) + +#-:CCL +(defmacro typed-let (letvars &rest forms) + `(let ,(mapcar #'(lambda (var) + (list (car var) (type2init (cadr var)))) + letvars ) + (declare ,@(mapcar #'(lambda (var) + (list 'type (cadr var) (car var))) + letvars)) + ,@forms)) + +#+:CCL +(defmacro typed-let (letvars &rest forms) + `(let ,(mapcar #'(lambda (var) (car var)) + letvars ) + ,@forms)) + +(defmacro cases (&rest junk) + `(case ,@junk)) + + +;;; Boot macros +(defmacro file-exports (lst) + `(eval-when (load eval) + (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)) + +(defmacro ignore-var (var) + `(declare (ignore ,var))) + +(defmacro |ANew| (type size) + (if (eq type '|Char|) + `(make-string ,size) + `(make-array ,size + :element-type ',type + :initial-element ,(type2init type)))) + +#-:CCL +(defun type2init (x) + (cond + ((eq x '|Char|) '|CharInit|) + ((eq x '|Clos|) '|ClosInit|) + ((eq x '|Bool|) '|BoolInit|) + ((eq x '|Byte|) '|ByteInit|) + ((eq x '|HInt|) '|HIntInit|) + ((eq x '|SInt|) '|SIntInit|) + ((eq x '|BInt|) '|BIntInit|) + ((eq x '|SFlo|) '|SFloInit|) + ((eq x '|DFlo|) '|DFloInit|) + ((eq x '|Ptr|) '|PtrInit|) + ((eq x '|Word|) '|WordInit|) + ((eq x '|Arr|) '|ArrInit|) + ((eq x '|Record|) '|RecordInit|) + ((eq x '|Arb|) '|ArbInit|) + ((eq x '|Env|) '|EnvInit|) + ((eq x '|Level|) '|LevelInit|) + ((eq x '|Nil|) nil) + (t nil))) + +#+:CCL +(defun type2init (x) nil) + +;; opsys interface +(defvar |G-mainArgc| 0) +(defvar |G-mainArgv| (vector)) +(defmacro |stdinFile| () '*standard-input*) +(defmacro |stdoutFile| () '*standard-output*) +(defmacro |stderrFile| () '*error-output*) + +;; Format functions +;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)))) + (length s)) + +(defun |formatSInt| (n) (format nil "~D" n)) +(defun |formatBInt| (n) (format nil "~D" n)) +(defun |formatSFloat| (x) (format nil "~G" x)) +(defun |formatDFloat| (x) (format nil "~G" x)) + + +;; Printing functions +(defun |printNewLine| (cs) (terpri cs)) +(defun |printChar| (cs c) (princ c cs)) + +;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))))) + +(defun |printSInt| (cs n) (format cs "~D" n)) +(defun |printBInt| (cs n) (format cs "~D" n)) +(defun |printSFloat| (cs x) (format cs "~G" x)) +(defun |printDFloat| (cs x) (format cs "~G" x)) + +(defun |fputc| (si cs) + (|printChar| cs (code-char si)) + si) + +(defun |fputs| (s cs) + (|printString| cs s)) + +;; read a string into s starting at pos i1, ending at i2 +;; we should probably macro-out cases where args are constant + +;; fill s[i1..i2] with a null terminated string read from +;; 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))) + +;; 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))) + +;; 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"))) + (if (null type) + (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)))) + (compile-file (namestring lpath)) + (load (namestring cpath)))) + + +;; given the name of a file (a string), return the name of the AXIOM-XL function +;; that initialises the file. +(defun axiomxl-file-init-name (filename) + (intern (format nil "G-~a" (string-downcase filename)) 'foam-user)) + +;; given the name of the file, id name, and hashcode, return the +;; AXIOM-XL identifier for that object + +(defun axiomxl-global-name (file id hashcode) + (intern (format nil "G-~a_~a_~9,'0d" (string-downcase file) id hashcode) 'foam-user)) + +;; double float elementary functions +(defmacro |sqrt| (x) `(sqrt ,x)) +(defmacro |pow| (a b) `(expt ,a ,b)) +(defmacro |log| (a) `(log ,a)) +(defmacro |exp| (a) `(exp ,a)) + +(defmacro |sin| (a) `(sin ,a)) +(defmacro |cos| (a) `(cos ,a)) +(defmacro |tan| (a) `(tan ,a)) + +(defmacro |sinh| (a) `(sinh ,a)) +(defmacro |cosh| (a) `(cosh ,a)) +(defmacro |tanh| (a) `(tanh ,a)) + +(defmacro |asin| (a) `(asin ,a)) +(defmacro |acos| (a) `(acos ,a)) +(defmacro |atan| (a) `(atan ,a)) +(defmacro |atan2| (a b) `(atan ,a ,b)) + +(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))))) +;; debuging +(defvar *foam-debug-var* nil) +(defun |fiGetDebugVar| () *foam-debug-var*) + +(defun |fiSetDebugVar| (x) (setq *foam-debug-var* x)) +(defun |fiSetDebugger| (x y) ()) +(defun |fiGetDebugger| (x) ()) + +;; Output ports +(setq |G-stdoutVar| t) +(setq |G-stdinVar| t) +(setq |G-stderrVar| t) + +;; !! Not portable !! +(defun foam::|fiStrHash| (x) (boot::|hashString| (subseq x 0 (- (length x) 1)))) + +;; These three functions check that two cons's contain identical entries. +;; We use EQL to test numbers and EQ everywhere else. If the structure +;; of the two items is different, or any elements are different, we +;; return false. +(defmacro |politicallySound| (u v) + `(or (eql ,u ,v) (eq ,u ,v))) + +(defun |PtrMagicEQ| (u v) +;; I find (as-eg4) that these buggers can be numbers + (cond ( (or (NULL u) (NULL v)) nil) + ( (and (ATOM u) (ATOM v)) (eql u v)) + ( (or (ATOM u) (ATOM 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 )) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |