From a0ea803003aecec7b3dfa8a0c1126fc439519d8f Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 03:37:56 +0000 Subject: remove pamphlets - part 2 --- src/interp/cfuns.lisp | 101 ++++++ src/interp/cfuns.lisp.pamphlet | 123 ------- src/interp/g-boot.boot | 459 ++++++++++++++++++++++++++ src/interp/g-boot.boot.pamphlet | 485 ---------------------------- src/interp/g-cndata.boot | 240 ++++++++++++++ src/interp/g-cndata.boot.pamphlet | 262 --------------- src/interp/g-error.boot | 199 ++++++++++++ src/interp/g-error.boot.pamphlet | 224 ------------- src/interp/g-opt.boot | 399 +++++++++++++++++++++++ src/interp/g-opt.boot.pamphlet | 421 ------------------------ src/interp/g-timer.boot | 270 ++++++++++++++++ src/interp/g-timer.boot.pamphlet | 292 ----------------- src/interp/g-util.boot | 635 ++++++++++++++++++++++++++++++++++++ src/interp/g-util.boot.pamphlet | 663 -------------------------------------- src/interp/guess.boot | 347 ++++++++++++++++++++ src/interp/guess.boot.pamphlet | 369 --------------------- 16 files changed, 2650 insertions(+), 2839 deletions(-) create mode 100644 src/interp/cfuns.lisp delete mode 100644 src/interp/cfuns.lisp.pamphlet create mode 100644 src/interp/g-boot.boot delete mode 100644 src/interp/g-boot.boot.pamphlet create mode 100644 src/interp/g-cndata.boot delete mode 100644 src/interp/g-cndata.boot.pamphlet create mode 100644 src/interp/g-error.boot delete mode 100644 src/interp/g-error.boot.pamphlet create mode 100644 src/interp/g-opt.boot delete mode 100644 src/interp/g-opt.boot.pamphlet create mode 100644 src/interp/g-timer.boot delete mode 100644 src/interp/g-timer.boot.pamphlet create mode 100644 src/interp/g-util.boot delete mode 100644 src/interp/g-util.boot.pamphlet create mode 100644 src/interp/guess.boot delete mode 100644 src/interp/guess.boot.pamphlet (limited to 'src') diff --git a/src/interp/cfuns.lisp b/src/interp/cfuns.lisp new file mode 100644 index 00000000..dbe77db4 --- /dev/null +++ b/src/interp/cfuns.lisp @@ -0,0 +1,101 @@ +;; 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. + + +(in-package "BOOT") + +#+(and :Lucid (not :ibm/370)) +(progn +; (system:define-foreign-function :c '|findString| :fixnum) + (system:define-foreign-function :c '|addtopath| :fixnum) + (system:define-foreign-function :c '|chdir| :fixnum) + (system:define-foreign-function :c '|writeablep| :fixnum) + (system:define-foreign-function :c '|directoryp| :fixnum) + (system:define-foreign-function :c '|copyEnvValue| :fixnum) + ) + +#+KCL +(progn + (defentry |directoryp| (string) (int "directoryp")) + (defentry |writeablep| (string) (int "writeablep")) +; (defentry |findString| (string string) (int "findString")) + ) + +#+:CCL +(defun |directoryp| (fn) + (cond ((not (probe-file fn)) -1) + ((directoryp fn) 1) + (t 0))) + + + +; (defun |findStringInFile| (str p) +; (|findString| (namestring p) str) ) + + +(defun |getEnv| (var-name) (system::getenv var-name)) + +;;stolen from AXIOM-XL src/strops.c +#+(AND KCL (NOT ELF)) +(Clines +"MYHASH(s)" +"char *s;" +"{" +" register unsigned int h = 0;" +" register int c;" +"" +" while ((c = *s++) != 0) {" +" h ^= (h << 8);" +" h += ((c) + 200041);" +" h &= 0x3FFFFFFF;" +" }" +" return h;" +"}" +) +#+(AND KCL (NOT ELF)) +(defentry |hashString| (string) (int "MYHASH")) +#+(AND KCL ELF) +(defun |hashString| (string) (system:|hashString| string)) + +#+(AND KCL (NOT ELF)) +(Clines +"int MYCOMBINE(i,j)" +"int i,j;" +"{" +"return ( (((((unsigned int)j) & 16777215) << 6)+((unsigned int)i)) % 1073741789);" +"}" +) +#+(AND KCL (NOT ELF)) +(defentry |hashCombine| (int int) (int "MYCOMBINE")) +#+(AND KCL ELF) +(defun |hashCombine| (x y) (system:|hashCombine| x y)) + + diff --git a/src/interp/cfuns.lisp.pamphlet b/src/interp/cfuns.lisp.pamphlet deleted file mode 100644 index d9bf72d5..00000000 --- a/src/interp/cfuns.lisp.pamphlet +++ /dev/null @@ -1,123 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp cfuns.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - -(in-package "BOOT") - -#+(and :Lucid (not :ibm/370)) -(progn -; (system:define-foreign-function :c '|findString| :fixnum) - (system:define-foreign-function :c '|addtopath| :fixnum) - (system:define-foreign-function :c '|chdir| :fixnum) - (system:define-foreign-function :c '|writeablep| :fixnum) - (system:define-foreign-function :c '|directoryp| :fixnum) - (system:define-foreign-function :c '|copyEnvValue| :fixnum) - ) - -#+KCL -(progn - (defentry |directoryp| (string) (int "directoryp")) - (defentry |writeablep| (string) (int "writeablep")) -; (defentry |findString| (string string) (int "findString")) - ) - -#+:CCL -(defun |directoryp| (fn) - (cond ((not (probe-file fn)) -1) - ((directoryp fn) 1) - (t 0))) - - - -; (defun |findStringInFile| (str p) -; (|findString| (namestring p) str) ) - - -(defun |getEnv| (var-name) (system::getenv var-name)) - -;;stolen from AXIOM-XL src/strops.c -#+(AND KCL (NOT ELF)) -(Clines -"MYHASH(s)" -"char *s;" -"{" -" register unsigned int h = 0;" -" register int c;" -"" -" while ((c = *s++) != 0) {" -" h ^= (h << 8);" -" h += ((c) + 200041);" -" h &= 0x3FFFFFFF;" -" }" -" return h;" -"}" -) -#+(AND KCL (NOT ELF)) -(defentry |hashString| (string) (int "MYHASH")) -#+(AND KCL ELF) -(defun |hashString| (string) (system:|hashString| string)) - -#+(AND KCL (NOT ELF)) -(Clines -"int MYCOMBINE(i,j)" -"int i,j;" -"{" -"return ( (((((unsigned int)j) & 16777215) << 6)+((unsigned int)i)) % 1073741789);" -"}" -) -#+(AND KCL (NOT ELF)) -(defentry |hashCombine| (int int) (int "MYCOMBINE")) -#+(AND KCL ELF) -(defun |hashCombine| (x y) (system:|hashCombine| x y)) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-boot.boot b/src/interp/g-boot.boot new file mode 100644 index 00000000..11c45a29 --- /dev/null +++ b/src/interp/g-boot.boot @@ -0,0 +1,459 @@ +-- 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. + + +)package "BOOT" + +-- @(#)g-boot.boot 2.2 89/11/02 14:44:09 + +--% BOOT to LISP Translation + +-- these supplement those in DEF and MACRO LISP + +--% Utilities + + +$LET := 'SPADLET -- LET is a standard macro in Common Lisp + +nakedEXIT? c == + ATOM c => NIL + [a,:d] := c + IDENTP a => + a = 'EXIT => true + a = 'QUOTE => NIL + MEMQ(a,'(SEQ PROG LAMBDA MLAMBDA LAM)) => NIL + nakedEXIT?(d) + nakedEXIT?(a) or nakedEXIT?(d) + +mergeableCOND x == + ATOM(x) or x isnt ['COND,:cls] => NIL + -- to be mergeable, every result must be an EXIT and the last + -- predicate must be a pair + ok := true + while (cls and ok) repeat + [[p,:r],:cls] := cls + PAIRP QCDR r => ok := NIL + CAR(r) isnt ['EXIT,.] => ok := NIL + NULL(cls) and ATOM(p) => ok := NIL + NULL(cls) and (p = ''T) => ok := NIL + ok + +mergeCONDsWithEXITs l == + -- combines things like + -- (COND (foo (EXIT a))) + -- (COND (bar (EXIT b))) + -- into one COND + NULL l => NIL + ATOM l => l + NULL PAIRP QCDR l => l + a := QCAR l + if a is ['COND,:.] then a := flattenCOND a + am := mergeableCOND a + CDR(l) is [b,:k] and am and mergeableCOND(b) => + b:= flattenCOND b + c := ['COND,:QCDR a,:QCDR b] + mergeCONDsWithEXITs [flattenCOND c,:k] + CDR(l) is [b] and am => + [removeEXITFromCOND flattenCOND ['COND,:QCDR a,[''T,b]]] + [a,:mergeCONDsWithEXITs CDR l] + +removeEXITFromCOND? c == + -- c is '(COND ...) + -- only can do it if every clause simply EXITs + ok := true + c := CDR c + while ok and c repeat + [[p,:r],:c] := c + nakedEXIT? p => ok := NIL + [:f,r1] := r + nakedEXIT? f => ok := NIL + r1 isnt ['EXIT,r2] => ok := NIL + nakedEXIT? r2 => ok := NIL + ok + +removeEXITFromCOND c == + -- c is '(COND ...) + z := NIL + for cl in CDR c repeat + ATOM cl => z := CONS(cl,z) + cond := QCAR cl + length1? cl => + PAIRP(cond) and EQCAR(cond,'EXIT) => + z := CONS(QCDR cond,z) + z := CONS(cl,z) + cl' := REVERSE cl + lastSE := QCAR cl' + ATOM lastSE => z := CONS(cl,z) + EQCAR(lastSE,'EXIT) => + z := CONS(REVERSE CONS(CADR lastSE,CDR cl'),z) + z := CONS(cl,z) + CONS('COND,NREVERSE z) + +flattenCOND body == + -- transforms nested COND clauses to flat ones, if possible + body isnt ['COND,:.] => body + ['COND,:extractCONDClauses body] + +extractCONDClauses clauses == + -- extracts nested COND clauses into a flat structure + clauses is ['COND, [pred1,:act1],:restClauses] => + if act1 is [['PROGN,:acts]] then act1 := acts + restClauses is [[''T,restCond]] => + [[pred1,:act1],:extractCONDClauses restCond] + [[pred1,:act1],:restClauses] + [[''T,clauses]] + +--% COND and IF + +bootIF c == + -- handles IF expressions by turning them into CONDs + c is [.,p,t] => bootCOND ['COND,[p,t]] + [.,p,t,e] := c + bootCOND ['COND,[p,t],[''T,e]] + +bootCOND c == + -- handles COND expressions: c is ['COND,:.] + cls := CDR c + NULL cls => NIL + cls is [[''T,r],:.] => r + [:icls,fcls] := cls + ncls := NIL + for cl in icls repeat + [p,:r] := cl + ncls := + r is [['PROGN,:r1]] => CONS([p,:r1],ncls) + CONS(cl,ncls) + fcls := bootPushEXITintoCONDclause fcls + ncls := + fcls is [''T,['COND,:mcls]] => + APPEND(REVERSE mcls,ncls) + fcls is [''T,['PROGN,:mcls]] => + CONS([''T,:mcls],ncls) + CONS(fcls,ncls) + ['COND,:REVERSE ncls] + +bootPushEXITintoCONDclause e == + e isnt [''T,['EXIT,['COND,:cls]]] => e + ncls := NIL + for cl in cls repeat + [p,:r] := cl + ncls := + r is [['EXIT,:.]] => CONS(cl,ncls) + r is [r1] => CONS([p,['EXIT,r1]],ncls) + CONS([p,['EXIT,bootTran ['PROGN,:r]]],ncls) + [''T,['COND,:NREVERSE ncls]] + +--% SEQ and PROGN + +-- following is a more sophisticated def than that in MACRO LISP +-- it is used for boot code + +tryToRemoveSEQ e == + -- returns e if unsuccessful + e isnt ['SEQ,cl,:cls] => NIL + nakedEXIT? cl => + cl is ['COND,[p,['EXIT,r]],:ccls] => + nakedEXIT? p or nakedEXIT? r => e + null ccls => + bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,:cls]]] + bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,['COND,:ccls],:cls]]] + e + bootPROGN ['PROGN,cl,bootSEQ ['SEQ,:cls]] + +bootAbsorbSEQsAndPROGNs e == + -- assume e is a list from a SEQ or a PROGN + ATOM e => e + [:cls,lcl] := e + g := [:flatten(f) for f in cls] where + flatten x == + NULL x => NIL + IDENTP x => + MEMQ(x,$labelsForGO) => [x] + NIL + ATOM x => NIL + x is ['PROGN,:pcls,lpcl] => + ATOM lpcl => pcls + CDR x + -- next usually comes about from if foo then bar := zap + x is ['COND,y,[''T,'NIL]] => [['COND,y]] + [x] + while lcl is ['EXIT,f] repeat + lcl := f + lcl is ['PROGN,:pcls] => APPEND(g,pcls) + lcl is ['COND,[''T,:pcls]] => APPEND(g,pcls) + lcl is ['COND,[pred,['EXIT,h]]] => + APPEND(g,[['COND,[pred,h]]]) + APPEND(g,[lcl]) + +bootSEQ e == + e := ['SEQ,:mergeCONDsWithEXITs bootAbsorbSEQsAndPROGNs CDR e] + if e is [.,:cls,lcl] and IDENTP lcl and not MEMQ(lcl,$labelsForGO) then + e := ['SEQ,:cls,['EXIT,lcl]] + cls := QCDR e + cls is [['SEQ,:.]] => tryToRemoveSEQ QCAR cls + cls is [['EXIT,body]] => + nakedEXIT? body => bootTran ['SEQ,body] + body + not (nakedEXIT?(cls) or "or"/[MEMQ(g,$labelsForGO) for g in cls]) => + bootTran ['PROGN,:cls] + e is ['SEQ,['COND,[pred,['EXIT,r1]]],:r2] => + nakedEXIT?(pred) or nakedEXIT?(r1) or nakedEXIT?(r2) => + tryToRemoveSEQ e + bootTran ['COND,[pred,r1],[''T,:r2]] + tryToRemoveSEQ e + +bootPROGN e == + e := ['PROGN,:bootAbsorbSEQsAndPROGNs CDR e] + [.,:cls] := e + NULL cls => NIL + cls is [body] => body + e + +--% LET + +defLetForm(lhs,rhs) == +--if functionp lhs then +-- sayMSG ['"Danger: Reassigning value to LISP function:",:bright lhs] + [$LET,lhs,rhs] + +defLET1(lhs,rhs) == + IDENTP lhs => defLetForm(lhs,rhs) + lhs is ['FLUID,id] => defLetForm(lhs,rhs) + IDENTP rhs and not CONTAINED(rhs,lhs) => + rhs' := defLET2(lhs,rhs) + EQCAR(rhs',$LET) => MKPROGN [rhs',rhs] + EQCAR(rhs','PROGN) => APPEND(rhs',[rhs]) + if IDENTP CAR rhs' then rhs' := CONS(rhs',NIL) + MKPROGN [:rhs',rhs] + PAIRP(rhs) and EQCAR(rhs, $LET) and IDENTP(name := CADR rhs) => + -- handle things like [a] := x := foo + l1 := defLET1(name,CADDR rhs) + l2 := defLET1(lhs,name) + EQCAR(l2,'PROGN) => MKPROGN [l1,:CDR l2] + if IDENTP CAR l2 then l2 := cons(l2,nil) + MKPROGN [l1,:l2,name] + g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) + $letGenVarCounter := $letGenVarCounter + 1 + rhs' := [$LET,g,rhs] + let' := defLET1(lhs,g) + EQCAR(let','PROGN) => MKPROGN [rhs',:CDR let'] + if IDENTP CAR let' then let' := CONS(let',NIL) + MKPROGN [rhs',:let',g] + +defLET2(lhs,rhs) == + IDENTP lhs => defLetForm(lhs,rhs) + NULL lhs => NIL + lhs is ['FLUID,id] => defLetForm(lhs,rhs) + lhs is [=$LET,a,b] => + a := defLET2(a,rhs) + null (b := defLET2(b,rhs)) => a + ATOM b => [a,b] + PAIRP QCAR b => CONS(a,b) + [a,b] + lhs is ['CONS,var1,var2] => + var1 = "." or (PAIRP(var1) and EQCAR(var1,'QUOTE)) => + defLET2(var2,addCARorCDR('CDR,rhs)) + l1 := defLET2(var1,addCARorCDR('CAR,rhs)) + MEMQ(var2,'(NIL _.)) => l1 + if PAIRP l1 and ATOM CAR l1 then l1 := cons(l1,nil) + IDENTP var2 => + [:l1,defLetForm(var2,addCARorCDR('CDR,rhs))] + l2 := defLET2(var2,addCARorCDR('CDR,rhs)) + if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) + APPEND(l1,l2) + lhs is ['APPEND,var1,var2] => + patrev := defISReverse(var2,var1) + rev := ['REVERSE,rhs] + g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) + $letGenVarCounter := $letGenVarCounter + 1 + l2 := defLET2(patrev,g) + if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) + var1 = "." => [[$LET,g,rev],:l2] + last l2 is [=$LET, =var1, val1] => + [[$LET,g,rev],:REVERSE CDR REVERSE l2, + defLetForm(var1,['NREVERSE,val1])] + [[$LET,g,rev],:l2,defLetForm(var1,['NREVERSE,var1])] + lhs is ['EQUAL,var1] => + ['COND,[['EQUAL,var1,rhs],var1]] + -- let the IS code take over from here + isPred := + $inDefIS => defIS1(rhs,lhs) + defIS(rhs,lhs) + ['COND,[isPred,rhs]] + +defLET(lhs,rhs) == + $letGenVarCounter : local := 1 + $inDefLET : local := true + defLET1(lhs,rhs) + +addCARorCDR(acc,expr) == + NULL PAIRP expr => [acc,expr] + acc = 'CAR and EQCAR(expr,'REVERSE) => + cons('last,QCDR expr) + funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR + CDAAR CDDAR CDADR CDDDR) + p := position(QCAR expr,funs) + p = -1 => [acc,expr] + funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR + CAADDR CADAAR CADDAR CADADR CADDDR) + funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR + CDADDR CDDAAR CDDDAR CDDADR CDDDDR) + if acc = 'CAR then CONS(funsA.p,QCDR expr) + else CONS(funsR.p,QCDR expr) + + +--% IS + +defISReverse(x,a) == + -- reverses forms coming from APPENDs in patterns + -- pretty much just a translation of DEF-IS-REV + x is ['CONS,:.] => + NULL CADDR x => ['CONS,CADR x, a] + y := defISReverse(CADDR x, NIL) + RPLAC(CADDR y,['CONS,CADR x,a]) + y + ERRHUH() + +defIS1(lhs,rhs) == + NULL rhs => + ['NULL,lhs] + STRINGP rhs => + ['EQ,lhs,['QUOTE,INTERN rhs]] + NUMBERP rhs => + ['EQUAL,lhs,rhs] + ATOM rhs => + ['PROGN,defLetForm(rhs,lhs),''T] + rhs is ['QUOTE,a] => + IDENTP a => ['EQ,lhs,rhs] + ['EQUAL,lhs,rhs] + rhs is [=$LET,c,d] => + l := + $inDefLET => defLET1(c,lhs) + defLET(c,lhs) + ['AND,defIS1(lhs,d),MKPROGN [l,''T]] + rhs is ['EQUAL,a] => + ['EQUAL,lhs,a] + PAIRP lhs => + g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) + $isGenVarCounter := $isGenVarCounter + 1 + MKPROGN [[$LET,g,lhs],defIS1(g,rhs)] + rhs is ['CONS,a,b] => + a = "." => + NULL b => + ['AND,['PAIRP,lhs], + ['EQ,['QCDR,lhs],'NIL]] + ['AND,['PAIRP,lhs], + defIS1(['QCDR,lhs],b)] + NULL b => + ['AND,['PAIRP,lhs], + ['EQ,['QCDR,lhs],'NIL],_ + defIS1(['QCAR,lhs],a)] + b = "." => + ['AND,['PAIRP,lhs],defIS1(['QCAR,lhs],a)] + a1 := defIS1(['QCAR,lhs],a) + b1 := defIS1(['QCDR,lhs],b) + a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => + ['AND,['PAIRP,lhs],MKPROGN [c,:cls]] + ['AND,['PAIRP,lhs],a1,b1] + rhs is ['APPEND,a,b] => + patrev := defISReverse(b,a) + g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) + $isGenVarCounter := $isGenVarCounter + 1 + rev := ['AND,['PAIRP,lhs],['PROGN,[$LET,g,['REVERSE,lhs]],''T]] + l2 := defIS1(g,patrev) + if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) + a = "." => ['AND,rev,:l2] + ['AND,rev,:l2,['PROGN,defLetForm(a,['NREVERSE,a]),''T]] + SAY '"WARNING (defIS1): possibly bad IS code being generated" + DEF_-IS [lhs,rhs] + +defIS(lhs,rhs) == + $isGenVarCounter : local := 1 + $inDefIS : local := true + defIS1(DEFTRAN lhs,rhs) + +--% OR and AND + +bootOR e == + -- flatten any contained ORs. + cls := CDR e + NULL cls => NIL + NULL CDR cls => CAR cls + ncls := [:flatten(c) for c in cls] where + flatten x == + x is ['OR,:.] => QCDR x + [x] + ['OR,:ncls] + +bootAND e == + -- flatten any contained ANDs. + cls := CDR e + NULL cls => 'T + NULL CDR cls => CAR cls + ncls := [:flatten(c) for c in cls] where + flatten x == + x is ['AND,:.] => QCDR x + [x] + ['AND,:ncls] + +--% Main Transformation Functions + +bootLabelsForGO e == + ATOM e => NIL + [head,:tail] := e + IDENTP head => + head = 'GO => $labelsForGO := CONS(CAR tail,$labelsForGO) + head = 'QUOTE => NIL + bootLabelsForGO tail + bootLabelsForGO head + bootLabelsForGO tail + +bootTran e == + ATOM e => e + [head,:tail] := e + head = 'QUOTE => e + tail := [bootTran t for t in tail] + e := [head,:tail] + IDENTP head => + head = 'IF => bootIF e + head = 'COND => bootCOND e + head = 'PROGN => bootPROGN e + head = 'SEQ => bootSEQ e + head = 'OR => bootOR e + head = 'AND => bootAND e + e + [bootTran head,:QCDR e] + +bootTransform e == +--NULL $BOOT => e + $labelsForGO : local := NIL + bootLabelsForGO e + bootTran e diff --git a/src/interp/g-boot.boot.pamphlet b/src/interp/g-boot.boot.pamphlet deleted file mode 100644 index 63a7c00a..00000000 --- a/src/interp/g-boot.boot.pamphlet +++ /dev/null @@ -1,485 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/g-boot.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{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. - -@ -<<*>>= -<> - -)package "BOOT" - --- @(#)g-boot.boot 2.2 89/11/02 14:44:09 - ---% BOOT to LISP Translation - --- these supplement those in DEF and MACRO LISP - ---% Utilities - - -$LET := 'SPADLET -- LET is a standard macro in Common Lisp - -nakedEXIT? c == - ATOM c => NIL - [a,:d] := c - IDENTP a => - a = 'EXIT => true - a = 'QUOTE => NIL - MEMQ(a,'(SEQ PROG LAMBDA MLAMBDA LAM)) => NIL - nakedEXIT?(d) - nakedEXIT?(a) or nakedEXIT?(d) - -mergeableCOND x == - ATOM(x) or x isnt ['COND,:cls] => NIL - -- to be mergeable, every result must be an EXIT and the last - -- predicate must be a pair - ok := true - while (cls and ok) repeat - [[p,:r],:cls] := cls - PAIRP QCDR r => ok := NIL - CAR(r) isnt ['EXIT,.] => ok := NIL - NULL(cls) and ATOM(p) => ok := NIL - NULL(cls) and (p = ''T) => ok := NIL - ok - -mergeCONDsWithEXITs l == - -- combines things like - -- (COND (foo (EXIT a))) - -- (COND (bar (EXIT b))) - -- into one COND - NULL l => NIL - ATOM l => l - NULL PAIRP QCDR l => l - a := QCAR l - if a is ['COND,:.] then a := flattenCOND a - am := mergeableCOND a - CDR(l) is [b,:k] and am and mergeableCOND(b) => - b:= flattenCOND b - c := ['COND,:QCDR a,:QCDR b] - mergeCONDsWithEXITs [flattenCOND c,:k] - CDR(l) is [b] and am => - [removeEXITFromCOND flattenCOND ['COND,:QCDR a,[''T,b]]] - [a,:mergeCONDsWithEXITs CDR l] - -removeEXITFromCOND? c == - -- c is '(COND ...) - -- only can do it if every clause simply EXITs - ok := true - c := CDR c - while ok and c repeat - [[p,:r],:c] := c - nakedEXIT? p => ok := NIL - [:f,r1] := r - nakedEXIT? f => ok := NIL - r1 isnt ['EXIT,r2] => ok := NIL - nakedEXIT? r2 => ok := NIL - ok - -removeEXITFromCOND c == - -- c is '(COND ...) - z := NIL - for cl in CDR c repeat - ATOM cl => z := CONS(cl,z) - cond := QCAR cl - length1? cl => - PAIRP(cond) and EQCAR(cond,'EXIT) => - z := CONS(QCDR cond,z) - z := CONS(cl,z) - cl' := REVERSE cl - lastSE := QCAR cl' - ATOM lastSE => z := CONS(cl,z) - EQCAR(lastSE,'EXIT) => - z := CONS(REVERSE CONS(CADR lastSE,CDR cl'),z) - z := CONS(cl,z) - CONS('COND,NREVERSE z) - -flattenCOND body == - -- transforms nested COND clauses to flat ones, if possible - body isnt ['COND,:.] => body - ['COND,:extractCONDClauses body] - -extractCONDClauses clauses == - -- extracts nested COND clauses into a flat structure - clauses is ['COND, [pred1,:act1],:restClauses] => - if act1 is [['PROGN,:acts]] then act1 := acts - restClauses is [[''T,restCond]] => - [[pred1,:act1],:extractCONDClauses restCond] - [[pred1,:act1],:restClauses] - [[''T,clauses]] - ---% COND and IF - -bootIF c == - -- handles IF expressions by turning them into CONDs - c is [.,p,t] => bootCOND ['COND,[p,t]] - [.,p,t,e] := c - bootCOND ['COND,[p,t],[''T,e]] - -bootCOND c == - -- handles COND expressions: c is ['COND,:.] - cls := CDR c - NULL cls => NIL - cls is [[''T,r],:.] => r - [:icls,fcls] := cls - ncls := NIL - for cl in icls repeat - [p,:r] := cl - ncls := - r is [['PROGN,:r1]] => CONS([p,:r1],ncls) - CONS(cl,ncls) - fcls := bootPushEXITintoCONDclause fcls - ncls := - fcls is [''T,['COND,:mcls]] => - APPEND(REVERSE mcls,ncls) - fcls is [''T,['PROGN,:mcls]] => - CONS([''T,:mcls],ncls) - CONS(fcls,ncls) - ['COND,:REVERSE ncls] - -bootPushEXITintoCONDclause e == - e isnt [''T,['EXIT,['COND,:cls]]] => e - ncls := NIL - for cl in cls repeat - [p,:r] := cl - ncls := - r is [['EXIT,:.]] => CONS(cl,ncls) - r is [r1] => CONS([p,['EXIT,r1]],ncls) - CONS([p,['EXIT,bootTran ['PROGN,:r]]],ncls) - [''T,['COND,:NREVERSE ncls]] - ---% SEQ and PROGN - --- following is a more sophisticated def than that in MACRO LISP --- it is used for boot code - -tryToRemoveSEQ e == - -- returns e if unsuccessful - e isnt ['SEQ,cl,:cls] => NIL - nakedEXIT? cl => - cl is ['COND,[p,['EXIT,r]],:ccls] => - nakedEXIT? p or nakedEXIT? r => e - null ccls => - bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,:cls]]] - bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,['COND,:ccls],:cls]]] - e - bootPROGN ['PROGN,cl,bootSEQ ['SEQ,:cls]] - -bootAbsorbSEQsAndPROGNs e == - -- assume e is a list from a SEQ or a PROGN - ATOM e => e - [:cls,lcl] := e - g := [:flatten(f) for f in cls] where - flatten x == - NULL x => NIL - IDENTP x => - MEMQ(x,$labelsForGO) => [x] - NIL - ATOM x => NIL - x is ['PROGN,:pcls,lpcl] => - ATOM lpcl => pcls - CDR x - -- next usually comes about from if foo then bar := zap - x is ['COND,y,[''T,'NIL]] => [['COND,y]] - [x] - while lcl is ['EXIT,f] repeat - lcl := f - lcl is ['PROGN,:pcls] => APPEND(g,pcls) - lcl is ['COND,[''T,:pcls]] => APPEND(g,pcls) - lcl is ['COND,[pred,['EXIT,h]]] => - APPEND(g,[['COND,[pred,h]]]) - APPEND(g,[lcl]) - -bootSEQ e == - e := ['SEQ,:mergeCONDsWithEXITs bootAbsorbSEQsAndPROGNs CDR e] - if e is [.,:cls,lcl] and IDENTP lcl and not MEMQ(lcl,$labelsForGO) then - e := ['SEQ,:cls,['EXIT,lcl]] - cls := QCDR e - cls is [['SEQ,:.]] => tryToRemoveSEQ QCAR cls - cls is [['EXIT,body]] => - nakedEXIT? body => bootTran ['SEQ,body] - body - not (nakedEXIT?(cls) or "or"/[MEMQ(g,$labelsForGO) for g in cls]) => - bootTran ['PROGN,:cls] - e is ['SEQ,['COND,[pred,['EXIT,r1]]],:r2] => - nakedEXIT?(pred) or nakedEXIT?(r1) or nakedEXIT?(r2) => - tryToRemoveSEQ e - bootTran ['COND,[pred,r1],[''T,:r2]] - tryToRemoveSEQ e - -bootPROGN e == - e := ['PROGN,:bootAbsorbSEQsAndPROGNs CDR e] - [.,:cls] := e - NULL cls => NIL - cls is [body] => body - e - ---% LET - -defLetForm(lhs,rhs) == ---if functionp lhs then --- sayMSG ['"Danger: Reassigning value to LISP function:",:bright lhs] - [$LET,lhs,rhs] - -defLET1(lhs,rhs) == - IDENTP lhs => defLetForm(lhs,rhs) - lhs is ['FLUID,id] => defLetForm(lhs,rhs) - IDENTP rhs and not CONTAINED(rhs,lhs) => - rhs' := defLET2(lhs,rhs) - EQCAR(rhs',$LET) => MKPROGN [rhs',rhs] - EQCAR(rhs','PROGN) => APPEND(rhs',[rhs]) - if IDENTP CAR rhs' then rhs' := CONS(rhs',NIL) - MKPROGN [:rhs',rhs] - PAIRP(rhs) and EQCAR(rhs, $LET) and IDENTP(name := CADR rhs) => - -- handle things like [a] := x := foo - l1 := defLET1(name,CADDR rhs) - l2 := defLET1(lhs,name) - EQCAR(l2,'PROGN) => MKPROGN [l1,:CDR l2] - if IDENTP CAR l2 then l2 := cons(l2,nil) - MKPROGN [l1,:l2,name] - g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - rhs' := [$LET,g,rhs] - let' := defLET1(lhs,g) - EQCAR(let','PROGN) => MKPROGN [rhs',:CDR let'] - if IDENTP CAR let' then let' := CONS(let',NIL) - MKPROGN [rhs',:let',g] - -defLET2(lhs,rhs) == - IDENTP lhs => defLetForm(lhs,rhs) - NULL lhs => NIL - lhs is ['FLUID,id] => defLetForm(lhs,rhs) - lhs is [=$LET,a,b] => - a := defLET2(a,rhs) - null (b := defLET2(b,rhs)) => a - ATOM b => [a,b] - PAIRP QCAR b => CONS(a,b) - [a,b] - lhs is ['CONS,var1,var2] => - var1 = "." or (PAIRP(var1) and EQCAR(var1,'QUOTE)) => - defLET2(var2,addCARorCDR('CDR,rhs)) - l1 := defLET2(var1,addCARorCDR('CAR,rhs)) - MEMQ(var2,'(NIL _.)) => l1 - if PAIRP l1 and ATOM CAR l1 then l1 := cons(l1,nil) - IDENTP var2 => - [:l1,defLetForm(var2,addCARorCDR('CDR,rhs))] - l2 := defLET2(var2,addCARorCDR('CDR,rhs)) - if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - APPEND(l1,l2) - lhs is ['APPEND,var1,var2] => - patrev := defISReverse(var2,var1) - rev := ['REVERSE,rhs] - g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - l2 := defLET2(patrev,g) - if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - var1 = "." => [[$LET,g,rev],:l2] - last l2 is [=$LET, =var1, val1] => - [[$LET,g,rev],:REVERSE CDR REVERSE l2, - defLetForm(var1,['NREVERSE,val1])] - [[$LET,g,rev],:l2,defLetForm(var1,['NREVERSE,var1])] - lhs is ['EQUAL,var1] => - ['COND,[['EQUAL,var1,rhs],var1]] - -- let the IS code take over from here - isPred := - $inDefIS => defIS1(rhs,lhs) - defIS(rhs,lhs) - ['COND,[isPred,rhs]] - -defLET(lhs,rhs) == - $letGenVarCounter : local := 1 - $inDefLET : local := true - defLET1(lhs,rhs) - -addCARorCDR(acc,expr) == - NULL PAIRP expr => [acc,expr] - acc = 'CAR and EQCAR(expr,'REVERSE) => - cons('last,QCDR expr) - funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR) - p := position(QCAR expr,funs) - p = -1 => [acc,expr] - funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR - CAADDR CADAAR CADDAR CADADR CADDDR) - funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR - CDADDR CDDAAR CDDDAR CDDADR CDDDDR) - if acc = 'CAR then CONS(funsA.p,QCDR expr) - else CONS(funsR.p,QCDR expr) - - ---% IS - -defISReverse(x,a) == - -- reverses forms coming from APPENDs in patterns - -- pretty much just a translation of DEF-IS-REV - x is ['CONS,:.] => - NULL CADDR x => ['CONS,CADR x, a] - y := defISReverse(CADDR x, NIL) - RPLAC(CADDR y,['CONS,CADR x,a]) - y - ERRHUH() - -defIS1(lhs,rhs) == - NULL rhs => - ['NULL,lhs] - STRINGP rhs => - ['EQ,lhs,['QUOTE,INTERN rhs]] - NUMBERP rhs => - ['EQUAL,lhs,rhs] - ATOM rhs => - ['PROGN,defLetForm(rhs,lhs),''T] - rhs is ['QUOTE,a] => - IDENTP a => ['EQ,lhs,rhs] - ['EQUAL,lhs,rhs] - rhs is [=$LET,c,d] => - l := - $inDefLET => defLET1(c,lhs) - defLET(c,lhs) - ['AND,defIS1(lhs,d),MKPROGN [l,''T]] - rhs is ['EQUAL,a] => - ['EQUAL,lhs,a] - PAIRP lhs => - g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - MKPROGN [[$LET,g,lhs],defIS1(g,rhs)] - rhs is ['CONS,a,b] => - a = "." => - NULL b => - ['AND,['PAIRP,lhs], - ['EQ,['QCDR,lhs],'NIL]] - ['AND,['PAIRP,lhs], - defIS1(['QCDR,lhs],b)] - NULL b => - ['AND,['PAIRP,lhs], - ['EQ,['QCDR,lhs],'NIL],_ - defIS1(['QCAR,lhs],a)] - b = "." => - ['AND,['PAIRP,lhs],defIS1(['QCAR,lhs],a)] - a1 := defIS1(['QCAR,lhs],a) - b1 := defIS1(['QCDR,lhs],b) - a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => - ['AND,['PAIRP,lhs],MKPROGN [c,:cls]] - ['AND,['PAIRP,lhs],a1,b1] - rhs is ['APPEND,a,b] => - patrev := defISReverse(b,a) - g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - rev := ['AND,['PAIRP,lhs],['PROGN,[$LET,g,['REVERSE,lhs]],''T]] - l2 := defIS1(g,patrev) - if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - a = "." => ['AND,rev,:l2] - ['AND,rev,:l2,['PROGN,defLetForm(a,['NREVERSE,a]),''T]] - SAY '"WARNING (defIS1): possibly bad IS code being generated" - DEF_-IS [lhs,rhs] - -defIS(lhs,rhs) == - $isGenVarCounter : local := 1 - $inDefIS : local := true - defIS1(DEFTRAN lhs,rhs) - ---% OR and AND - -bootOR e == - -- flatten any contained ORs. - cls := CDR e - NULL cls => NIL - NULL CDR cls => CAR cls - ncls := [:flatten(c) for c in cls] where - flatten x == - x is ['OR,:.] => QCDR x - [x] - ['OR,:ncls] - -bootAND e == - -- flatten any contained ANDs. - cls := CDR e - NULL cls => 'T - NULL CDR cls => CAR cls - ncls := [:flatten(c) for c in cls] where - flatten x == - x is ['AND,:.] => QCDR x - [x] - ['AND,:ncls] - ---% Main Transformation Functions - -bootLabelsForGO e == - ATOM e => NIL - [head,:tail] := e - IDENTP head => - head = 'GO => $labelsForGO := CONS(CAR tail,$labelsForGO) - head = 'QUOTE => NIL - bootLabelsForGO tail - bootLabelsForGO head - bootLabelsForGO tail - -bootTran e == - ATOM e => e - [head,:tail] := e - head = 'QUOTE => e - tail := [bootTran t for t in tail] - e := [head,:tail] - IDENTP head => - head = 'IF => bootIF e - head = 'COND => bootCOND e - head = 'PROGN => bootPROGN e - head = 'SEQ => bootSEQ e - head = 'OR => bootOR e - head = 'AND => bootAND e - e - [bootTran head,:QCDR e] - -bootTransform e == ---NULL $BOOT => e - $labelsForGO : local := NIL - bootLabelsForGO e - bootTran e -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-cndata.boot b/src/interp/g-cndata.boot new file mode 100644 index 00000000..eaa9dee7 --- /dev/null +++ b/src/interp/g-cndata.boot @@ -0,0 +1,240 @@ +-- 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. + + +--% Manipulation of Constructor Datat + +--======================================================================= +-- Build Table of Lower Case Constructor Names +--======================================================================= +mkLowerCaseConTable() == +--Called at system build time by function BUILD-INTERPSYS (see util.lisp) +--Table is referenced by functions conPageFastPath and grepForAbbrev + $lowerCaseConTb := MAKE_-HASH_-TABLE() + for x in allConstructors() repeat augmentLowerCaseConTable x + $lowerCaseConTb + +augmentLowerCaseConTable x == + y:=GETDATABASE(x,'ABBREVIATION) + item:=[x,y,nil] + HPUT($lowerCaseConTb,x,item) + HPUT($lowerCaseConTb,DOWNCASE x,item) + HPUT($lowerCaseConTb,y,item) + +getCDTEntry(info,isName) == + not IDENTP info => NIL + (entry := HGET($lowerCaseConTb,info)) => + [name,abb,:.] := entry + isName and EQ(name,info) => entry + not isName and EQ(abb,info) => entry + NIL + entry + +putConstructorProperty(name,prop,val) == + null (entry := getCDTEntry(name,true)) => NIL + RPLACD(CDR entry,PUTALIST(CDDR entry,prop,val)) + true + +attribute? name == + MEMQ(name, _*ATTRIBUTES_*) + +abbreviation? abb == + -- if it is an abbreviation, return the corresponding name + GETDATABASE(abb,'CONSTRUCTOR) + +constructor? name == + -- if it is a constructor name, return the abbreviation + GETDATABASE(name,'ABBREVIATION) + +domainForm? d == + GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'domain + +packageForm? d == + GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'package + +categoryForm? c == + op := opOf c + MEMQ(op, $CategoryNames) => true + GETDATABASE(op,'CONSTRUCTORKIND) = 'category => true + nil + +getImmediateSuperDomain(d) == + IFCAR GETDATABASE(opOf d, 'SUPERDOMAIN) + +maximalSuperType d == + d' := GETDATABASE(opOf d, 'SUPERDOMAIN) => maximalSuperType first d' + d + +-- probably will switch over to 'libName soon +getLisplibName(c) == getConstructorAbbreviation(c) + +getConstructorAbbreviation op == + constructor?(op) or throwKeyedMsg("S2IL0015",[op]) + +getConstructorUnabbreviation op == + abbreviation?(op) or throwKeyedMsg("S2IL0019",[op]) + +mkUserConstructorAbbreviation(c,a,type) == + if not atom c then c:= CAR c -- Existing constructors will be wrapped + constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) + clearClams() + clearConstructorCache(c) + installConstructor(c,type) + setAutoLoadProperty(c) + +abbQuery(x) == + abb := GETDATABASE(x,'ABBREVIATION) => + sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x]) + sayKeyedMsg("S2IZ0003",[x]) + +installConstructor(cname,type) == + (entry := getCDTEntry(cname,true)) => entry + item := [cname,GETDATABASE(cname,'ABBREVIATION),nil] + if BOUNDP '$lowerCaseConTb and $lowerCaseConTb then + HPUT($lowerCaseConTb,cname,item) + HPUT($lowerCaseConTb,DOWNCASE cname,item) + +constructorNameConflict(name,kind) == + userError + ["The name",:bright name,"conflicts with the name of an existing rule", + "%l","please choose another ",kind] + +constructorAbbreviationErrorCheck(c,a,typ,errmess) == + siz := SIZE (s := PNAME a) + if typ = 'category and siz > 7 + then throwKeyedErrorMsg('precompilation,"S2IL0021",NIL) + if siz > 8 then throwKeyedErrorMsg('precompilation,"S2IL0006",NIL) + if s ^= UPCASE s then throwKeyedMsg("S2IL0006",NIL) + abb := GETDATABASE(c,'ABBREVIATION) + name:= GETDATABASE(a,'CONSTRUCTOR) + type := GETDATABASE(c,'CONSTRUCTORKIND) + a=abb and c^=name => lisplibError(c,a,typ,abb,name,type,'duplicateAbb) + a=name and c^=name => lisplibError(c,a,typ,abb,name,type,'abbIsName) + c=name and typ^=type => lisplibError(c,a,typ,abb,name,type,'wrongType) + +abbreviationError(c,a,typ,abb,name,type,error) == + sayKeyedMsg("S2IL0009",[a,typ,c]) + error='duplicateAbb => + throwKeyedMsg("S2IL0010",[a,typ,name]) + error='abbIsName => + throwKeyedMsg("S2IL0011",[a,type]) + error='wrongType => + throwKeyedMsg("S2IL0012",[c,type]) + NIL + +abbreviate u == + u is ['Union,:arglist] => + ['Union,:[abbreviate a for a in arglist]] + u is [op,:arglist] => + abb := constructor?(op) => + [abb,:condAbbrev(arglist,getPartialConstructorModemapSig(op))] + u + constructor?(u) or u + +unabbrev u == unabbrev1(u,nil) + +unabbrevAndLoad u == unabbrev1(u,true) + +isNameOfType x == + $doNotAddEmptyModeIfTrue:local:= true + (val := get(x,'value,$InteractiveFrame)) and + (domain := objMode val) and + domain in '((Mode) (Domain) (SubDomain (Domain))) => true + y := opOf unabbrev x + constructor? y + +unabbrev1(u,modeIfTrue) == + atom u => + modeIfTrue => + d:= isDomainValuedVariable u => u + a := abbreviation? u => + GETDATABASE(a,'NILADIC) => [a] + largs := ['_$EmptyMode for arg in + getPartialConstructorModemapSig(a)] + unabbrev1([u,:largs],modeIfTrue) + u + a:= abbreviation?(u) or u + GETDATABASE(a,'NILADIC) => [a] + a + [op,:arglist] := u + op = 'Join => ['Join, :[unabbrev1(x, modeIfTrue) for x in arglist]] + d:= isDomainValuedVariable op => + throwKeyedMsg("S2IL0013",[op,d]) + (r := unabbrevSpecialForms(op,arglist,modeIfTrue)) => r + (cname := abbreviation? op) or (constructor?(op) and (cname := op)) => + (r := unabbrevSpecialForms(cname,arglist,modeIfTrue)) => r + -- ??? if modeIfTrue then loadIfNecessary cname + [cname,:condUnabbrev(op,arglist, + getPartialConstructorModemapSig(cname),modeIfTrue)] + u + +unabbrevSpecialForms(op,arglist,modeIfTrue) == + op = 'Mapping => [op,:[unabbrev1(a,modeIfTrue) for a in arglist]] + op = 'Union => + [op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]] + op = 'Record => + [op,:[unabbrevRecordComponent(a,modeIfTrue) for a in arglist]] + nil + +unabbrevRecordComponent(a,modeIfTrue) == + a is ["Declare",b,T] or a is [":",b,T] => + [":",b,unabbrev1(T,modeIfTrue)] + userError "wrong format for Record type" + +unabbrevUnionComponent(a,modeIfTrue) == + a is ["Declare",b,T] or a is [":",b,T] => + [":",b,unabbrev1(T,modeIfTrue)] + unabbrev1(a, modeIfTrue) + +condAbbrev(arglist,argtypes) == + res:= nil + for arg in arglist for type in argtypes repeat + if categoryForm?(type) then arg:= abbreviate arg + res:=[:res,arg] + res + +condUnabbrev(op,arglist,argtypes,modeIfTrue) == + #arglist ^= #argtypes => + throwKeyedMsg("S2IL0014",[op,plural(#argtypes,'"argument"), + bright(#arglist)]) + [newArg for arg in arglist for type in argtypes] where newArg == + categoryForm?(type) => unabbrev1(arg,modeIfTrue) + arg + +--% Code Being Phased Out + +nAssocQ(x,l,n) == + repeat + if atom l then return nil + if EQ(x,(QCAR l).n) then return QCAR l + l:= QCDR l + + diff --git a/src/interp/g-cndata.boot.pamphlet b/src/interp/g-cndata.boot.pamphlet deleted file mode 100644 index 7e09df96..00000000 --- a/src/interp/g-cndata.boot.pamphlet +++ /dev/null @@ -1,262 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp g-cndata.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - ---% Manipulation of Constructor Datat - ---======================================================================= --- Build Table of Lower Case Constructor Names ---======================================================================= -mkLowerCaseConTable() == ---Called at system build time by function BUILD-INTERPSYS (see util.lisp) ---Table is referenced by functions conPageFastPath and grepForAbbrev - $lowerCaseConTb := MAKE_-HASH_-TABLE() - for x in allConstructors() repeat augmentLowerCaseConTable x - $lowerCaseConTb - -augmentLowerCaseConTable x == - y:=GETDATABASE(x,'ABBREVIATION) - item:=[x,y,nil] - HPUT($lowerCaseConTb,x,item) - HPUT($lowerCaseConTb,DOWNCASE x,item) - HPUT($lowerCaseConTb,y,item) - -getCDTEntry(info,isName) == - not IDENTP info => NIL - (entry := HGET($lowerCaseConTb,info)) => - [name,abb,:.] := entry - isName and EQ(name,info) => entry - not isName and EQ(abb,info) => entry - NIL - entry - -putConstructorProperty(name,prop,val) == - null (entry := getCDTEntry(name,true)) => NIL - RPLACD(CDR entry,PUTALIST(CDDR entry,prop,val)) - true - -attribute? name == - MEMQ(name, _*ATTRIBUTES_*) - -abbreviation? abb == - -- if it is an abbreviation, return the corresponding name - GETDATABASE(abb,'CONSTRUCTOR) - -constructor? name == - -- if it is a constructor name, return the abbreviation - GETDATABASE(name,'ABBREVIATION) - -domainForm? d == - GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'domain - -packageForm? d == - GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'package - -categoryForm? c == - op := opOf c - MEMQ(op, $CategoryNames) => true - GETDATABASE(op,'CONSTRUCTORKIND) = 'category => true - nil - -getImmediateSuperDomain(d) == - IFCAR GETDATABASE(opOf d, 'SUPERDOMAIN) - -maximalSuperType d == - d' := GETDATABASE(opOf d, 'SUPERDOMAIN) => maximalSuperType first d' - d - --- probably will switch over to 'libName soon -getLisplibName(c) == getConstructorAbbreviation(c) - -getConstructorAbbreviation op == - constructor?(op) or throwKeyedMsg("S2IL0015",[op]) - -getConstructorUnabbreviation op == - abbreviation?(op) or throwKeyedMsg("S2IL0019",[op]) - -mkUserConstructorAbbreviation(c,a,type) == - if not atom c then c:= CAR c -- Existing constructors will be wrapped - constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) - clearClams() - clearConstructorCache(c) - installConstructor(c,type) - setAutoLoadProperty(c) - -abbQuery(x) == - abb := GETDATABASE(x,'ABBREVIATION) => - sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x]) - sayKeyedMsg("S2IZ0003",[x]) - -installConstructor(cname,type) == - (entry := getCDTEntry(cname,true)) => entry - item := [cname,GETDATABASE(cname,'ABBREVIATION),nil] - if BOUNDP '$lowerCaseConTb and $lowerCaseConTb then - HPUT($lowerCaseConTb,cname,item) - HPUT($lowerCaseConTb,DOWNCASE cname,item) - -constructorNameConflict(name,kind) == - userError - ["The name",:bright name,"conflicts with the name of an existing rule", - "%l","please choose another ",kind] - -constructorAbbreviationErrorCheck(c,a,typ,errmess) == - siz := SIZE (s := PNAME a) - if typ = 'category and siz > 7 - then throwKeyedErrorMsg('precompilation,"S2IL0021",NIL) - if siz > 8 then throwKeyedErrorMsg('precompilation,"S2IL0006",NIL) - if s ^= UPCASE s then throwKeyedMsg("S2IL0006",NIL) - abb := GETDATABASE(c,'ABBREVIATION) - name:= GETDATABASE(a,'CONSTRUCTOR) - type := GETDATABASE(c,'CONSTRUCTORKIND) - a=abb and c^=name => lisplibError(c,a,typ,abb,name,type,'duplicateAbb) - a=name and c^=name => lisplibError(c,a,typ,abb,name,type,'abbIsName) - c=name and typ^=type => lisplibError(c,a,typ,abb,name,type,'wrongType) - -abbreviationError(c,a,typ,abb,name,type,error) == - sayKeyedMsg("S2IL0009",[a,typ,c]) - error='duplicateAbb => - throwKeyedMsg("S2IL0010",[a,typ,name]) - error='abbIsName => - throwKeyedMsg("S2IL0011",[a,type]) - error='wrongType => - throwKeyedMsg("S2IL0012",[c,type]) - NIL - -abbreviate u == - u is ['Union,:arglist] => - ['Union,:[abbreviate a for a in arglist]] - u is [op,:arglist] => - abb := constructor?(op) => - [abb,:condAbbrev(arglist,getPartialConstructorModemapSig(op))] - u - constructor?(u) or u - -unabbrev u == unabbrev1(u,nil) - -unabbrevAndLoad u == unabbrev1(u,true) - -isNameOfType x == - $doNotAddEmptyModeIfTrue:local:= true - (val := get(x,'value,$InteractiveFrame)) and - (domain := objMode val) and - domain in '((Mode) (Domain) (SubDomain (Domain))) => true - y := opOf unabbrev x - constructor? y - -unabbrev1(u,modeIfTrue) == - atom u => - modeIfTrue => - d:= isDomainValuedVariable u => u - a := abbreviation? u => - GETDATABASE(a,'NILADIC) => [a] - largs := ['_$EmptyMode for arg in - getPartialConstructorModemapSig(a)] - unabbrev1([u,:largs],modeIfTrue) - u - a:= abbreviation?(u) or u - GETDATABASE(a,'NILADIC) => [a] - a - [op,:arglist] := u - op = 'Join => ['Join, :[unabbrev1(x, modeIfTrue) for x in arglist]] - d:= isDomainValuedVariable op => - throwKeyedMsg("S2IL0013",[op,d]) - (r := unabbrevSpecialForms(op,arglist,modeIfTrue)) => r - (cname := abbreviation? op) or (constructor?(op) and (cname := op)) => - (r := unabbrevSpecialForms(cname,arglist,modeIfTrue)) => r - -- ??? if modeIfTrue then loadIfNecessary cname - [cname,:condUnabbrev(op,arglist, - getPartialConstructorModemapSig(cname),modeIfTrue)] - u - -unabbrevSpecialForms(op,arglist,modeIfTrue) == - op = 'Mapping => [op,:[unabbrev1(a,modeIfTrue) for a in arglist]] - op = 'Union => - [op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]] - op = 'Record => - [op,:[unabbrevRecordComponent(a,modeIfTrue) for a in arglist]] - nil - -unabbrevRecordComponent(a,modeIfTrue) == - a is ["Declare",b,T] or a is [":",b,T] => - [":",b,unabbrev1(T,modeIfTrue)] - userError "wrong format for Record type" - -unabbrevUnionComponent(a,modeIfTrue) == - a is ["Declare",b,T] or a is [":",b,T] => - [":",b,unabbrev1(T,modeIfTrue)] - unabbrev1(a, modeIfTrue) - -condAbbrev(arglist,argtypes) == - res:= nil - for arg in arglist for type in argtypes repeat - if categoryForm?(type) then arg:= abbreviate arg - res:=[:res,arg] - res - -condUnabbrev(op,arglist,argtypes,modeIfTrue) == - #arglist ^= #argtypes => - throwKeyedMsg("S2IL0014",[op,plural(#argtypes,'"argument"), - bright(#arglist)]) - [newArg for arg in arglist for type in argtypes] where newArg == - categoryForm?(type) => unabbrev1(arg,modeIfTrue) - arg - ---% Code Being Phased Out - -nAssocQ(x,l,n) == - repeat - if atom l then return nil - if EQ(x,(QCAR l).n) then return QCAR l - l:= QCDR l - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-error.boot b/src/interp/g-error.boot new file mode 100644 index 00000000..47e45e6d --- /dev/null +++ b/src/interp/g-error.boot @@ -0,0 +1,199 @@ +-- 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. + + +import '"diagnostics" +)package "BOOT" + +-- This file contains the error printing code used in BOOT and SPAD. +-- While SPAD only calls "error" (which is then labeled as an algebra +-- error, BOOT calls "userError" and "systemError" when a problem is +-- found. +-- +-- The variable $BreakMode is set using the system command )set breakmode +-- and can have one of the values: +-- break -- always enter a lisp break when an error is signalled +-- nobreak -- do not enter lisp break mode +-- query -- ask the user if break mode should be entered + +SETANDFILEQ($SystemError,'SystemError) +SETANDFILEQ($UserError,'UserError) +SETANDFILEQ($AlgebraError,'AlgebraError) + +-- REDERR is used in BFLOAT LISP, should be a macro +-- REDERR msg == error msg + +-- BFLERRMSG func == +-- errorSupervisor($AlgebraError,STRCONC( +-- '"BigFloat: invalid argument to ",func)) + +argumentDataError(argnum, condit, funname) == + msg := ['"The test",:bright pred2English condit,'"evaluates to", + :bright '"false",'%l,'" for argument",:bright argnum,_ + '"to the function",:bright funname,'"and this indicates",'%l,_ + '" that the argument is not appropriate."] + errorSupervisor($AlgebraError,msg) + +queryUser msg == + -- display message and return reply + sayBrightly msg + READ_-LINE _*TERMINAL_-IO_* + +-- errorSupervisor is the old style error message trapper + +errorSupervisor(errorType,errorMsg) == + errorSupervisor1(errorType,errorMsg,$BreakMode) + +errorSupervisor1(errorType,errorMsg,$BreakMode) == + $cclSystem and $BreakMode = 'trapNumerics => + THROW('trapNumerics,$numericFailure) + BUMPERRORCOUNT "semantic" + errorLabel := + errorType = $SystemError => '"System error" + errorType = $UserError => '"Apparent user error" + errorType = $AlgebraError => + '"Error detected within library code" + STRINGP errorType => errorType + '"Error with unknown classification" + msg := + errorMsg is ['mathprint, :.] => errorMsg + not PAIRP errorMsg => ['" ", errorMsg] + splitmsg := true + if member('%b,errorMsg) then splitmsg := nil + else if member('%d,errorMsg) then splitmsg := nil + else if member('%l,errorMsg) then splitmsg := nil + splitmsg => CDR [:['%l,'" ",u] for u in errorMsg] + ['" ",:errorMsg] + sayErrorly(errorLabel, msg) + handleLispBreakLoop($BreakMode) + +handleLispBreakLoop($BreakMode) == + TERPRI() + -- The next line is to try to deal with some reported cases of unwanted + -- backtraces appearing, MCD. + ENABLE_-BACKTRACE(nil) + $BreakMode = 'break => + sayBrightly '" " + BREAK() + $BreakMode = 'query => + gotIt := nil + while not gotIt repeat + gotIt := true + msgQ := + $cclSystem => + ['%l,'" You have two options. Enter:",'%l,_ + '" ",:bright '"top ",'" to return to top level, or",'%l,_ + '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ + '%l,'" Please enter your choice now:"] + ['%l,'" You have three options. Enter:",'%l,_ + '" ",:bright '"continue",'" to continue processing,",'%l,_ + '" ",:bright '"top ",'" to return to top level, or",'%l,_ + '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ + '%l,'" Please enter your choice now:"] + x := STRING2ID_-N(queryUser msgQ,1) + x := + $cclSystem => + selectOptionLC(x,'(top break),NIL) + selectOptionLC(x,'(top break continue),NIL) + null x => + sayBrightly bright '" That was not one of your choices!" + gotIt := NIL + x = 'top => returnToTopLevel() + x = 'break => + $BreakMode := 'break + if not $cclSystem then + sayBrightly ['" Enter",:bright '":C", + '"when you are ready to continue processing where you ",'%l,_ + '" interrupted the system, enter",:bright '"(TOP)",_ + '"when you wish to return",'%l,'" to top level.",'%l,'%l] + BREAK() + sayBrightly + '" Processing will continue where it was interrupted." + THROW('SPAD__READER, nil) + $BreakMode = 'resume => + returnToReader() + returnToTopLevel() + +TOP() == returnToTopLevel() + +returnToTopLevel() == + SETQ(CHR, "ENDOFLINECHR") + SETQ(TOK, 'END__UNIT) + TOPLEVEL() + +returnToReader() == + ^$ReadingFile => returnToTopLevel() + sayBrightly ['" Continuing to read the file...", '%l] + THROW('SPAD__READER, nil) + +sayErrorly(errorLabel, msg) == + $saturn => saturnSayErrorly(errorLabel, msg) + sayErrorly1(errorLabel, msg) + +saturnSayErrorly(errorLabel, msg) == + _*STANDARD_-OUTPUT_* : fluid := $texOutputStream + old := pushSatOutput("line") + sayString '"\bgroup\color{red}" + sayString '"\begin{verbatim}" + sayErrorly1(errorLabel, msg) + sayString '"\end{verbatim}" + sayString '"\egroup" + popSatOutput(old) + +sayErrorly1(errorLabel, msg) == + sayBrightly '" " + if $testingSystem then sayMSG $testingErrorPrefix + sayBrightly ['" >> ",errorLabel,'":"] + m := msg + msg is ['mathprint, mathexpr] => + mathprint mathexpr + sayBrightly msg + +-- systemError is being phased out. Please use keyedSystemError. +systemError(:x) == errorSupervisor($SystemError,IFCAR x) + +-- unexpectedSystemError() == +-- systemError '"Oh, no. Unexpected internal error." + +userError x == errorSupervisor($UserError,x) + +error(x) == errorSupervisor($AlgebraError,x) + +IdentityError(op) == + error(["No identity element for reduce of empty list using operation",op]) + +throwMessage(:msg) == + if $compilingMap then clearCache $mapName + msg' := mkMessage concatList msg + sayMSG msg' + if $printMsgsToFile then sayMSG2File msg' + spadThrow() + diff --git a/src/interp/g-error.boot.pamphlet b/src/interp/g-error.boot.pamphlet deleted file mode 100644 index 103b8b0a..00000000 --- a/src/interp/g-error.boot.pamphlet +++ /dev/null @@ -1,224 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/g-error.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{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. - -@ -<<*>>= -<> - -import '"diagnostics" -)package "BOOT" - --- This file contains the error printing code used in BOOT and SPAD. --- While SPAD only calls "error" (which is then labeled as an algebra --- error, BOOT calls "userError" and "systemError" when a problem is --- found. --- --- The variable $BreakMode is set using the system command )set breakmode --- and can have one of the values: --- break -- always enter a lisp break when an error is signalled --- nobreak -- do not enter lisp break mode --- query -- ask the user if break mode should be entered - -SETANDFILEQ($SystemError,'SystemError) -SETANDFILEQ($UserError,'UserError) -SETANDFILEQ($AlgebraError,'AlgebraError) - --- REDERR is used in BFLOAT LISP, should be a macro --- REDERR msg == error msg - --- BFLERRMSG func == --- errorSupervisor($AlgebraError,STRCONC( --- '"BigFloat: invalid argument to ",func)) - -argumentDataError(argnum, condit, funname) == - msg := ['"The test",:bright pred2English condit,'"evaluates to", - :bright '"false",'%l,'" for argument",:bright argnum,_ - '"to the function",:bright funname,'"and this indicates",'%l,_ - '" that the argument is not appropriate."] - errorSupervisor($AlgebraError,msg) - -queryUser msg == - -- display message and return reply - sayBrightly msg - READ_-LINE _*TERMINAL_-IO_* - --- errorSupervisor is the old style error message trapper - -errorSupervisor(errorType,errorMsg) == - errorSupervisor1(errorType,errorMsg,$BreakMode) - -errorSupervisor1(errorType,errorMsg,$BreakMode) == - $cclSystem and $BreakMode = 'trapNumerics => - THROW('trapNumerics,$numericFailure) - BUMPERRORCOUNT "semantic" - errorLabel := - errorType = $SystemError => '"System error" - errorType = $UserError => '"Apparent user error" - errorType = $AlgebraError => - '"Error detected within library code" - STRINGP errorType => errorType - '"Error with unknown classification" - msg := - errorMsg is ['mathprint, :.] => errorMsg - not PAIRP errorMsg => ['" ", errorMsg] - splitmsg := true - if member('%b,errorMsg) then splitmsg := nil - else if member('%d,errorMsg) then splitmsg := nil - else if member('%l,errorMsg) then splitmsg := nil - splitmsg => CDR [:['%l,'" ",u] for u in errorMsg] - ['" ",:errorMsg] - sayErrorly(errorLabel, msg) - handleLispBreakLoop($BreakMode) - -handleLispBreakLoop($BreakMode) == - TERPRI() - -- The next line is to try to deal with some reported cases of unwanted - -- backtraces appearing, MCD. - ENABLE_-BACKTRACE(nil) - $BreakMode = 'break => - sayBrightly '" " - BREAK() - $BreakMode = 'query => - gotIt := nil - while not gotIt repeat - gotIt := true - msgQ := - $cclSystem => - ['%l,'" You have two options. Enter:",'%l,_ - '" ",:bright '"top ",'" to return to top level, or",'%l,_ - '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ - '%l,'" Please enter your choice now:"] - ['%l,'" You have three options. Enter:",'%l,_ - '" ",:bright '"continue",'" to continue processing,",'%l,_ - '" ",:bright '"top ",'" to return to top level, or",'%l,_ - '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ - '%l,'" Please enter your choice now:"] - x := STRING2ID_-N(queryUser msgQ,1) - x := - $cclSystem => - selectOptionLC(x,'(top break),NIL) - selectOptionLC(x,'(top break continue),NIL) - null x => - sayBrightly bright '" That was not one of your choices!" - gotIt := NIL - x = 'top => returnToTopLevel() - x = 'break => - $BreakMode := 'break - if not $cclSystem then - sayBrightly ['" Enter",:bright '":C", - '"when you are ready to continue processing where you ",'%l,_ - '" interrupted the system, enter",:bright '"(TOP)",_ - '"when you wish to return",'%l,'" to top level.",'%l,'%l] - BREAK() - sayBrightly - '" Processing will continue where it was interrupted." - THROW('SPAD__READER, nil) - $BreakMode = 'resume => - returnToReader() - returnToTopLevel() - -TOP() == returnToTopLevel() - -returnToTopLevel() == - SETQ(CHR, "ENDOFLINECHR") - SETQ(TOK, 'END__UNIT) - TOPLEVEL() - -returnToReader() == - ^$ReadingFile => returnToTopLevel() - sayBrightly ['" Continuing to read the file...", '%l] - THROW('SPAD__READER, nil) - -sayErrorly(errorLabel, msg) == - $saturn => saturnSayErrorly(errorLabel, msg) - sayErrorly1(errorLabel, msg) - -saturnSayErrorly(errorLabel, msg) == - _*STANDARD_-OUTPUT_* : fluid := $texOutputStream - old := pushSatOutput("line") - sayString '"\bgroup\color{red}" - sayString '"\begin{verbatim}" - sayErrorly1(errorLabel, msg) - sayString '"\end{verbatim}" - sayString '"\egroup" - popSatOutput(old) - -sayErrorly1(errorLabel, msg) == - sayBrightly '" " - if $testingSystem then sayMSG $testingErrorPrefix - sayBrightly ['" >> ",errorLabel,'":"] - m := msg - msg is ['mathprint, mathexpr] => - mathprint mathexpr - sayBrightly msg - --- systemError is being phased out. Please use keyedSystemError. -systemError(:x) == errorSupervisor($SystemError,IFCAR x) - --- unexpectedSystemError() == --- systemError '"Oh, no. Unexpected internal error." - -userError x == errorSupervisor($UserError,x) - -error(x) == errorSupervisor($AlgebraError,x) - -IdentityError(op) == - error(["No identity element for reduce of empty list using operation",op]) - -throwMessage(:msg) == - if $compilingMap then clearCache $mapName - msg' := mkMessage concatList msg - sayMSG msg' - if $printMsgsToFile then sayMSG2File msg' - spadThrow() - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot new file mode 100644 index 00000000..932cff17 --- /dev/null +++ b/src/interp/g-opt.boot @@ -0,0 +1,399 @@ +-- 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. + + +--% OPTIMIZER + +optimizeFunctionDef(def) == + if $reportOptimization then + sayBrightlyI bright '"Original LISP code:" + pp def + + def' := optimize COPY def + + if $reportOptimization then + sayBrightlyI bright '"Optimized LISP code:" + pp def' + sayBrightlyI bright '"Final LISP code:" + [name,[slamOrLam,args,body]] := def' + + body':= + removeTopLevelCatch body where + removeTopLevelCatch body == + body is ["CATCH",g,u] => + removeTopLevelCatch replaceThrowByReturn(u,g) + body + replaceThrowByReturn(x,g) == + fn(x,g) + x + fn(x,g) == + x is ["THROW", =g,:u] => + rplac(first x,"RETURN") + rplac(rest x,replaceThrowByReturn(u,g)) + atom x => nil + replaceThrowByReturn(first x,g) + replaceThrowByReturn(rest x,g) + [name,[slamOrLam,args,body']] + +optimize x == + (opt x; x) where + opt x == + atom x => nil + (y:= first x)='QUOTE => nil + y='CLOSEDFN => nil + y is [["XLAM",argl,body],:a] => + optimize rest x + argl = "ignore" => RPLAC(first x,body) + if not (LENGTH argl<=LENGTH a) then + SAY '"length mismatch in XLAM expression" + PRETTYPRINT y + RPLAC(first x,optimize optXLAMCond SUBLIS(pairList(argl,a),body)) + atom y => + optimize rest x + y="true" => RPLAC(first x,'(QUOTE (QUOTE T))) + y="false" => RPLAC(first x,nil) + if first y="IF" then (RPLAC(first x,optIF2COND y); y:= first x) + op:= GETL(subrname first y,"OPTIMIZE") => + (optimize rest x; RPLAC(first x,FUNCALL(op,optimize first x))) + RPLAC(first x,optimize first x) + optimize rest x + +subrname u == + IDENTP u => u + COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u + nil + +optCatch (x is ["CATCH",g,a]) == + $InteractiveMode => x + atom a => a + if a is ["SEQ",:s,["THROW", =g,u]] then + changeThrowToExit(s,g) where + changeThrowToExit(s,g) == + atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil + s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u)) + changeThrowToExit(first s,g) + changeThrowToExit(rest s,g) + rplac(rest a,[:s,["EXIT",u]]) + ["CATCH",y,a]:= optimize x + if hasNoThrows(a,g) + then (rplac(first x,first a); rplac(rest x,rest a)) where + hasNoThrows(a,g) == + a is ["THROW", =g,:.] => false + atom a => true + hasNoThrows(first a,g) and hasNoThrows(rest a,g) + else + changeThrowToGo(a,g) where + changeThrowToGo(s,g) == + atom s or first s='QUOTE => nil + s is ["THROW", =g,u] => + changeThrowToGo(u,g) + rplac(first s,"PROGN") + rplac(rest s,[["LET",CADR g,u],["GO",CADR g]]) + changeThrowToGo(first s,g) + changeThrowToGo(rest s,g) + rplac(first x,"SEQ") + rplac(rest x,[["EXIT",a],CADR g,["EXIT",CADR g]]) + x + +optSPADCALL(form is ['SPADCALL,:argl]) == + null $InteractiveMode => form + -- last arg is function/env, but may be a form + argl is [:argl,fun] => + fun is ['ELT,dom,slot] or fun is ['LISPELT,dom,slot] => + optCall ['call,['ELT,dom,slot],:argl] + form + form + +optCall (x is ["call",:u]) == + -- destructively optimizes this new x + x:= optimize [u] + -- next should happen only as result of macro expansion + atom first x => first x + [fn,:a]:= first x + atom fn => (RPLAC(rest x,a); RPLAC(first x,fn)) + fn is ["PAC",:.] => optPackageCall(x,fn,a) + fn is ["applyFun",name] => + (RPLAC(first x,"SPADCALL"); RPLAC(rest x,[:a,name]); x) + fn is [q,R,n] and MEMQ(q,'(ELT QREFELT CONST)) => + not $bootStrapMode and (w:= optCallSpecially(q,x,n,R)) => w + q="CONST" => +--+ + ["spadConstant",R,n] + --putInLocalDomainReferences will change this to ELT or QREFELT + RPLAC(first x,"SPADCALL") + if $QuickCode then RPLACA(fn,"QREFELT") + RPLAC(rest x,[:a,fn]) + x + systemErrorHere '"optCall" + +optCallSpecially(q,x,n,R) == + y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) + MEMQ(KAR R,$optimizableConstructorNames) => optSpecialCall(x,R,n) + (y:= get(R,"value",$e)) and + MEMQ(opOf y.expr,$optimizableConstructorNames) => + optSpecialCall(x,y.expr,n) + ( + (y:= lookup(R,$getDomainCode)) and ([op,y,prop]:= y) and + (yy:= LASSOC(y,$specialCaseKeyList)) => + optSpecialCall(x,[op,yy,prop],n)) where + lookup(a,l) == + null l => nil + [l',:l]:= l + l' is ["LET", =a,l',:.] => l' + lookup(a,l) + nil + +optCallEval u == + u is ["List",:.] => List Integer() + u is ["Vector",:.] => Vector Integer() + u is ["PrimitiveArray",:.] => PrimitiveArray Integer() + u is ["FactoredForm",:.] => FactoredForm Integer() + u is ["Matrix",:.] => Matrix Integer() + eval u + +optCons (x is ["CONS",a,b]) == + a="NIL" => + b='NIL => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:'NIL]); x) + b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:c]); x) + x + a is ['QUOTE,a'] => + b='NIL => (rplac(first x,'QUOTE); rplac(rest x,[a',:'NIL]); x) + b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,[a',:c]); x) + x + x + +optSpecialCall(x,y,n) == + yval := optCallEval y + CAAAR x="CONST" => + KAR yval.n = function Undef => + keyedSystemError("S2GE0016",['"optSpecialCall", + '"invalid constant"]) + MKQ yval.n + fn := GETL(compileTimeBindingOf first yval.n,'SPADreplace) => + rplac(rest x,CDAR x) + rplac(first x,fn) + if fn is ["XLAM",:.] then x:=first optimize [x] + x is ["EQUAL",:args] => RPLACW(x,DEF_-EQUAL args) + --DEF-EQUAL is really an optimiser + x + [fn,:a]:= first x + RPLAC(first x,"SPADCALL") + if $QuickCode then RPLACA(fn,"QREFELT") + RPLAC(rest x,[:a,fn]) + x + +compileTimeBindingOf u == + NULL(name:= BPINAME u) => keyedSystemError("S2OO0001",[u]) + name="Undef" => MOAN "optimiser found unknown function" + name + +optMkRecord ["mkRecord",:u] == + u is [x] => ["LIST",x] + #u=2 => ["CONS",:u] + ["VECTOR",:u] + +optCond (x is ['COND,:l]) == + if l is [a,[aa,b]] and TruthP aa and b is ["COND",:c] then + RPLACD(rest x,c) + if l is [[p1,:c1],[p2,:c2],:.] then + if (p1 is ['NULL,p1'] and p1' = p2) or (p2 is ['NULL,p2'] and p2' = p1) then + l:=[[p1,:c1],['(QUOTE T),:c2]] + RPLACD( x,l) + c1 is ['NIL] and p2 = '(QUOTE T) and first c2 = '(QUOTE T) => + p1 is ['NULL,p1']=> return p1' + return ['NULL,p1] + l is [[p1,:c1],[p2,:c2],[p3,:c3]] and TruthP p3 => + EqualBarGensym(c1,c3) => + ["COND",[["OR",p1,["NULL",p2]],:c1],[['QUOTE,true],:c2]] + EqualBarGensym(c1,c2) => ["COND",[["OR",p1,p2],:c1],[['QUOTE,true],:c3]] + x + for y in tails l repeat + while y is [[a1,c1],[a2,c2],:y'] and EqualBarGensym(c1,c2) repeat + a:=['OR,a1,a2] + RPLAC(first first y,a) + RPLAC(rest y,y') + x + +AssocBarGensym(key,l) == + for x in l repeat + PAIRP x => + EqualBarGensym(key,CAR x) => return x + +EqualBarGensym(x,y) == + $GensymAssoc: nil + fn(x,y) where + fn(x,y) == + x=y => true + GENSYMP x and GENSYMP y => + z:= ASSOC(x,$GensymAssoc) => (y=rest z => true; false) + $GensymAssoc:= [[x,:y],:$GensymAssoc] + true + null x => y is [g] and GENSYMP g + null y => x is [g] and GENSYMP g + atom x or atom y => false + fn(first x,first y) and fn(rest x,rest y) + +--Called early, to change IF to COND + +optIF2COND ["IF",a,b,c] == + b is "noBranch" => ["COND",[["NULL",a],c]] + c is "noBranch" => ["COND",[a,b]] + c is ["IF",:.] => ["COND",[a,b],:rest optIF2COND c] + c is ["COND",:p] => ["COND",[a,b],:p] + ["COND",[a,b],[$true,c]] + +optXLAMCond x == + x is ["COND",u:= [p,c],:l] => + (optPredicateIfTrue p => c; ["COND",u,:optCONDtail l]) + atom x => x + RPLAC(first x,optXLAMCond first x) + RPLAC(rest x,optXLAMCond rest x) + x + +optPredicateIfTrue p == + p is ['QUOTE,:.] => true + p is [fn,x] and MEMQ(fn,$BasicPredicates) and FUNCALL(fn,x) => true + nil + +optCONDtail l == + null l => nil + [frst:= [p,c],:l']:= l + optPredicateIfTrue p => [[$true,c]] + null rest l => [frst,[$true,["CondError"]]] + [frst,:optCONDtail l'] + +optSEQ ["SEQ",:l] == + tryToRemoveSEQ SEQToCOND getRidOfTemps l where + getRidOfTemps l == + null l => nil + l is [["LET",g,x,:.],:r] and GENSYMP g and 2>numOfOccurencesOf(g,r) => + getRidOfTemps substitute(x,g,r) + first l="/throwAway" => getRidOfTemps rest l + --this gets rid of unwanted labels generated by declarations in SEQs + [first l,:getRidOfTemps rest l] + SEQToCOND l == + transform:= [[a,b] for x in l while (x is ["COND",[a,["EXIT",b]]])] + before:= take(#transform,l) + aft:= after(l,before) + null before => ["SEQ",:aft] + null aft => ["COND",:transform,'((QUOTE T) (conderr))] + true => ["COND",:transform,['(QUOTE T),optSEQ ["SEQ",:aft]]] + tryToRemoveSEQ l == + l is ["SEQ",[op,a]] and MEMQ(op,'(EXIT RETURN THROW)) => a + l + +optRECORDELT ["RECORDELT",name,ind,len] == + len=1 => + ind=0 => ["QCAR",name] + keyedSystemError("S2OO0002",[ind]) + len=2 => + ind=0 => ["QCAR",name] + ind=1 => ["QCDR",name] + keyedSystemError("S2OO0002",[ind]) + ["QVELT",name,ind] + +optSETRECORDELT ["SETRECORDELT",name,ind,len,expr] == + len=1 => + ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] + keyedSystemError("S2OO0002",[ind]) + len=2 => + ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] + ind=1 => ["PROGN",["RPLACD",name,expr],["QCDR",name]] + keyedSystemError("S2OO0002",[ind]) + ["QSETVELT",name,ind,expr] + +optRECORDCOPY ["RECORDCOPY",name,len] == + len=1 => ["LIST",["CAR",name]] + len=2 => ["CONS",["CAR",name],["CDR",name]] + ["MOVEVEC",["MAKE_-VEC",len],name] + +--mkRecordAccessFunction(ind,len) == +-- stringOfDs:= $EmptyString +-- for i in 0..(ind-1) do stringOfDs:= STRCONC(stringOfDs,PNAME "D") +-- prefix:= if ind=len-1 then PNAME "C" else PNAME "CA" +-- if $QuickCode then prefix:=STRCONC("Q",prefix) +-- INTERN(STRCONC(prefix,stringOfDs,PNAME "R")) + +optSuchthat [.,:u] == ["SUCHTHAT",:u] + +optMINUS u == + u is ['MINUS,v] => + NUMBERP v => -v + u + u + +optQSMINUS u == + u is ['QSMINUS,v] => + NUMBERP v => -v + u + u + +opt_- u == + u is ['_-,v] => + NUMBERP v => -v + u + u + +optLESSP u == + u is ['LESSP,a,b] => + b = 0 => ['MINUSP,a] + ['GREATERP,b,a] + u + +optEQ u == + u is ['EQ,l,r] => + NUMBERP l and NUMBERP r => ['QUOTE,EQ(l,r)] + -- That undoes some weird work in Boolean to do with the definition of true + u + u + +EVALANDFILEACTQ + ( + for x in '( (call optCall) _ + (SEQ optSEQ)_ + (EQ optEQ) + (MINUS optMINUS)_ + (QSMINUS optQSMINUS)_ + (_- opt_-)_ + (LESSP optLESSP)_ + (SPADCALL optSPADCALL)_ + (_| optSuchthat)_ + (CATCH optCatch)_ + (COND optCond)_ + (mkRecord optMkRecord)_ + (RECORDELT optRECORDELT)_ + (SETRECORDELT optSETRECORDELT)_ + (RECORDCOPY optRECORDCOPY)) _ + repeat MAKEPROP(CAR x,'OPTIMIZE,CREATE_-SBC CADR x) + --much quicker to call functions if they have an SBC + ) + + diff --git a/src/interp/g-opt.boot.pamphlet b/src/interp/g-opt.boot.pamphlet deleted file mode 100644 index 33fad9dd..00000000 --- a/src/interp/g-opt.boot.pamphlet +++ /dev/null @@ -1,421 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp g-opt.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - ---% OPTIMIZER - -optimizeFunctionDef(def) == - if $reportOptimization then - sayBrightlyI bright '"Original LISP code:" - pp def - - def' := optimize COPY def - - if $reportOptimization then - sayBrightlyI bright '"Optimized LISP code:" - pp def' - sayBrightlyI bright '"Final LISP code:" - [name,[slamOrLam,args,body]] := def' - - body':= - removeTopLevelCatch body where - removeTopLevelCatch body == - body is ["CATCH",g,u] => - removeTopLevelCatch replaceThrowByReturn(u,g) - body - replaceThrowByReturn(x,g) == - fn(x,g) - x - fn(x,g) == - x is ["THROW", =g,:u] => - rplac(first x,"RETURN") - rplac(rest x,replaceThrowByReturn(u,g)) - atom x => nil - replaceThrowByReturn(first x,g) - replaceThrowByReturn(rest x,g) - [name,[slamOrLam,args,body']] - -optimize x == - (opt x; x) where - opt x == - atom x => nil - (y:= first x)='QUOTE => nil - y='CLOSEDFN => nil - y is [["XLAM",argl,body],:a] => - optimize rest x - argl = "ignore" => RPLAC(first x,body) - if not (LENGTH argl<=LENGTH a) then - SAY '"length mismatch in XLAM expression" - PRETTYPRINT y - RPLAC(first x,optimize optXLAMCond SUBLIS(pairList(argl,a),body)) - atom y => - optimize rest x - y="true" => RPLAC(first x,'(QUOTE (QUOTE T))) - y="false" => RPLAC(first x,nil) - if first y="IF" then (RPLAC(first x,optIF2COND y); y:= first x) - op:= GETL(subrname first y,"OPTIMIZE") => - (optimize rest x; RPLAC(first x,FUNCALL(op,optimize first x))) - RPLAC(first x,optimize first x) - optimize rest x - -subrname u == - IDENTP u => u - COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u - nil - -optCatch (x is ["CATCH",g,a]) == - $InteractiveMode => x - atom a => a - if a is ["SEQ",:s,["THROW", =g,u]] then - changeThrowToExit(s,g) where - changeThrowToExit(s,g) == - atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil - s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u)) - changeThrowToExit(first s,g) - changeThrowToExit(rest s,g) - rplac(rest a,[:s,["EXIT",u]]) - ["CATCH",y,a]:= optimize x - if hasNoThrows(a,g) - then (rplac(first x,first a); rplac(rest x,rest a)) where - hasNoThrows(a,g) == - a is ["THROW", =g,:.] => false - atom a => true - hasNoThrows(first a,g) and hasNoThrows(rest a,g) - else - changeThrowToGo(a,g) where - changeThrowToGo(s,g) == - atom s or first s='QUOTE => nil - s is ["THROW", =g,u] => - changeThrowToGo(u,g) - rplac(first s,"PROGN") - rplac(rest s,[["LET",CADR g,u],["GO",CADR g]]) - changeThrowToGo(first s,g) - changeThrowToGo(rest s,g) - rplac(first x,"SEQ") - rplac(rest x,[["EXIT",a],CADR g,["EXIT",CADR g]]) - x - -optSPADCALL(form is ['SPADCALL,:argl]) == - null $InteractiveMode => form - -- last arg is function/env, but may be a form - argl is [:argl,fun] => - fun is ['ELT,dom,slot] or fun is ['LISPELT,dom,slot] => - optCall ['call,['ELT,dom,slot],:argl] - form - form - -optCall (x is ["call",:u]) == - -- destructively optimizes this new x - x:= optimize [u] - -- next should happen only as result of macro expansion - atom first x => first x - [fn,:a]:= first x - atom fn => (RPLAC(rest x,a); RPLAC(first x,fn)) - fn is ["PAC",:.] => optPackageCall(x,fn,a) - fn is ["applyFun",name] => - (RPLAC(first x,"SPADCALL"); RPLAC(rest x,[:a,name]); x) - fn is [q,R,n] and MEMQ(q,'(ELT QREFELT CONST)) => - not $bootStrapMode and (w:= optCallSpecially(q,x,n,R)) => w - q="CONST" => ---+ - ["spadConstant",R,n] - --putInLocalDomainReferences will change this to ELT or QREFELT - RPLAC(first x,"SPADCALL") - if $QuickCode then RPLACA(fn,"QREFELT") - RPLAC(rest x,[:a,fn]) - x - systemErrorHere '"optCall" - -optCallSpecially(q,x,n,R) == - y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) - MEMQ(KAR R,$optimizableConstructorNames) => optSpecialCall(x,R,n) - (y:= get(R,"value",$e)) and - MEMQ(opOf y.expr,$optimizableConstructorNames) => - optSpecialCall(x,y.expr,n) - ( - (y:= lookup(R,$getDomainCode)) and ([op,y,prop]:= y) and - (yy:= LASSOC(y,$specialCaseKeyList)) => - optSpecialCall(x,[op,yy,prop],n)) where - lookup(a,l) == - null l => nil - [l',:l]:= l - l' is ["LET", =a,l',:.] => l' - lookup(a,l) - nil - -optCallEval u == - u is ["List",:.] => List Integer() - u is ["Vector",:.] => Vector Integer() - u is ["PrimitiveArray",:.] => PrimitiveArray Integer() - u is ["FactoredForm",:.] => FactoredForm Integer() - u is ["Matrix",:.] => Matrix Integer() - eval u - -optCons (x is ["CONS",a,b]) == - a="NIL" => - b='NIL => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:'NIL]); x) - b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:c]); x) - x - a is ['QUOTE,a'] => - b='NIL => (rplac(first x,'QUOTE); rplac(rest x,[a',:'NIL]); x) - b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,[a',:c]); x) - x - x - -optSpecialCall(x,y,n) == - yval := optCallEval y - CAAAR x="CONST" => - KAR yval.n = function Undef => - keyedSystemError("S2GE0016",['"optSpecialCall", - '"invalid constant"]) - MKQ yval.n - fn := GETL(compileTimeBindingOf first yval.n,'SPADreplace) => - rplac(rest x,CDAR x) - rplac(first x,fn) - if fn is ["XLAM",:.] then x:=first optimize [x] - x is ["EQUAL",:args] => RPLACW(x,DEF_-EQUAL args) - --DEF-EQUAL is really an optimiser - x - [fn,:a]:= first x - RPLAC(first x,"SPADCALL") - if $QuickCode then RPLACA(fn,"QREFELT") - RPLAC(rest x,[:a,fn]) - x - -compileTimeBindingOf u == - NULL(name:= BPINAME u) => keyedSystemError("S2OO0001",[u]) - name="Undef" => MOAN "optimiser found unknown function" - name - -optMkRecord ["mkRecord",:u] == - u is [x] => ["LIST",x] - #u=2 => ["CONS",:u] - ["VECTOR",:u] - -optCond (x is ['COND,:l]) == - if l is [a,[aa,b]] and TruthP aa and b is ["COND",:c] then - RPLACD(rest x,c) - if l is [[p1,:c1],[p2,:c2],:.] then - if (p1 is ['NULL,p1'] and p1' = p2) or (p2 is ['NULL,p2'] and p2' = p1) then - l:=[[p1,:c1],['(QUOTE T),:c2]] - RPLACD( x,l) - c1 is ['NIL] and p2 = '(QUOTE T) and first c2 = '(QUOTE T) => - p1 is ['NULL,p1']=> return p1' - return ['NULL,p1] - l is [[p1,:c1],[p2,:c2],[p3,:c3]] and TruthP p3 => - EqualBarGensym(c1,c3) => - ["COND",[["OR",p1,["NULL",p2]],:c1],[['QUOTE,true],:c2]] - EqualBarGensym(c1,c2) => ["COND",[["OR",p1,p2],:c1],[['QUOTE,true],:c3]] - x - for y in tails l repeat - while y is [[a1,c1],[a2,c2],:y'] and EqualBarGensym(c1,c2) repeat - a:=['OR,a1,a2] - RPLAC(first first y,a) - RPLAC(rest y,y') - x - -AssocBarGensym(key,l) == - for x in l repeat - PAIRP x => - EqualBarGensym(key,CAR x) => return x - -EqualBarGensym(x,y) == - $GensymAssoc: nil - fn(x,y) where - fn(x,y) == - x=y => true - GENSYMP x and GENSYMP y => - z:= ASSOC(x,$GensymAssoc) => (y=rest z => true; false) - $GensymAssoc:= [[x,:y],:$GensymAssoc] - true - null x => y is [g] and GENSYMP g - null y => x is [g] and GENSYMP g - atom x or atom y => false - fn(first x,first y) and fn(rest x,rest y) - ---Called early, to change IF to COND - -optIF2COND ["IF",a,b,c] == - b is "noBranch" => ["COND",[["NULL",a],c]] - c is "noBranch" => ["COND",[a,b]] - c is ["IF",:.] => ["COND",[a,b],:rest optIF2COND c] - c is ["COND",:p] => ["COND",[a,b],:p] - ["COND",[a,b],[$true,c]] - -optXLAMCond x == - x is ["COND",u:= [p,c],:l] => - (optPredicateIfTrue p => c; ["COND",u,:optCONDtail l]) - atom x => x - RPLAC(first x,optXLAMCond first x) - RPLAC(rest x,optXLAMCond rest x) - x - -optPredicateIfTrue p == - p is ['QUOTE,:.] => true - p is [fn,x] and MEMQ(fn,$BasicPredicates) and FUNCALL(fn,x) => true - nil - -optCONDtail l == - null l => nil - [frst:= [p,c],:l']:= l - optPredicateIfTrue p => [[$true,c]] - null rest l => [frst,[$true,["CondError"]]] - [frst,:optCONDtail l'] - -optSEQ ["SEQ",:l] == - tryToRemoveSEQ SEQToCOND getRidOfTemps l where - getRidOfTemps l == - null l => nil - l is [["LET",g,x,:.],:r] and GENSYMP g and 2>numOfOccurencesOf(g,r) => - getRidOfTemps substitute(x,g,r) - first l="/throwAway" => getRidOfTemps rest l - --this gets rid of unwanted labels generated by declarations in SEQs - [first l,:getRidOfTemps rest l] - SEQToCOND l == - transform:= [[a,b] for x in l while (x is ["COND",[a,["EXIT",b]]])] - before:= take(#transform,l) - aft:= after(l,before) - null before => ["SEQ",:aft] - null aft => ["COND",:transform,'((QUOTE T) (conderr))] - true => ["COND",:transform,['(QUOTE T),optSEQ ["SEQ",:aft]]] - tryToRemoveSEQ l == - l is ["SEQ",[op,a]] and MEMQ(op,'(EXIT RETURN THROW)) => a - l - -optRECORDELT ["RECORDELT",name,ind,len] == - len=1 => - ind=0 => ["QCAR",name] - keyedSystemError("S2OO0002",[ind]) - len=2 => - ind=0 => ["QCAR",name] - ind=1 => ["QCDR",name] - keyedSystemError("S2OO0002",[ind]) - ["QVELT",name,ind] - -optSETRECORDELT ["SETRECORDELT",name,ind,len,expr] == - len=1 => - ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] - keyedSystemError("S2OO0002",[ind]) - len=2 => - ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] - ind=1 => ["PROGN",["RPLACD",name,expr],["QCDR",name]] - keyedSystemError("S2OO0002",[ind]) - ["QSETVELT",name,ind,expr] - -optRECORDCOPY ["RECORDCOPY",name,len] == - len=1 => ["LIST",["CAR",name]] - len=2 => ["CONS",["CAR",name],["CDR",name]] - ["MOVEVEC",["MAKE_-VEC",len],name] - ---mkRecordAccessFunction(ind,len) == --- stringOfDs:= $EmptyString --- for i in 0..(ind-1) do stringOfDs:= STRCONC(stringOfDs,PNAME "D") --- prefix:= if ind=len-1 then PNAME "C" else PNAME "CA" --- if $QuickCode then prefix:=STRCONC("Q",prefix) --- INTERN(STRCONC(prefix,stringOfDs,PNAME "R")) - -optSuchthat [.,:u] == ["SUCHTHAT",:u] - -optMINUS u == - u is ['MINUS,v] => - NUMBERP v => -v - u - u - -optQSMINUS u == - u is ['QSMINUS,v] => - NUMBERP v => -v - u - u - -opt_- u == - u is ['_-,v] => - NUMBERP v => -v - u - u - -optLESSP u == - u is ['LESSP,a,b] => - b = 0 => ['MINUSP,a] - ['GREATERP,b,a] - u - -optEQ u == - u is ['EQ,l,r] => - NUMBERP l and NUMBERP r => ['QUOTE,EQ(l,r)] - -- That undoes some weird work in Boolean to do with the definition of true - u - u - -EVALANDFILEACTQ - ( - for x in '( (call optCall) _ - (SEQ optSEQ)_ - (EQ optEQ) - (MINUS optMINUS)_ - (QSMINUS optQSMINUS)_ - (_- opt_-)_ - (LESSP optLESSP)_ - (SPADCALL optSPADCALL)_ - (_| optSuchthat)_ - (CATCH optCatch)_ - (COND optCond)_ - (mkRecord optMkRecord)_ - (RECORDELT optRECORDELT)_ - (SETRECORDELT optSETRECORDELT)_ - (RECORDCOPY optRECORDCOPY)) _ - repeat MAKEPROP(CAR x,'OPTIMIZE,CREATE_-SBC CADR x) - --much quicker to call functions if they have an SBC - ) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-timer.boot b/src/interp/g-timer.boot new file mode 100644 index 00000000..b922387a --- /dev/null +++ b/src/interp/g-timer.boot @@ -0,0 +1,270 @@ +-- 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. + + +--% Code instrumentation facilities +-- These functions can be used with arbitrary lists of +-- named stats (listofnames) grouped in classes (listofclasses) +-- and with measurement types (property, classproperty). + +printNamedStatsByProperty(listofnames, property) == + total := +/[GETL(name,property) for [name,:.] in listofnames] + for [name,:.] in listofnames repeat + n := GETL(name, property) + strname := STRINGIMAGE name + strval := STRINGIMAGE n + sayBrightly concat(bright strname, + fillerSpaces(70-#strname-#strval,'"."),bright strval) + sayBrightly bright fillerSpaces(72,'"-") + sayBrightly concat(bright '"Total", + fillerSpaces(65-# STRINGIMAGE total,'"."),bright STRINGIMAGE total) + +makeLongStatStringByProperty _ + (listofnames, listofclasses, property, classproperty, units, flag) == + total := 0 + str := '"" + otherStatTotal := GETL('other, property) + for [name,class,:ab] in listofnames repeat + name = 'other => 'iterate + cl := CAR LASSOC(class,listofclasses) + n := GETL( name, property) + PUT(cl,classproperty, n + GETL(cl,classproperty)) + total := total + n + if n >= 0.01 + then timestr := normalizeStatAndStringify n + else + timestr := '"" + otherStatTotal := otherStatTotal + n + str := makeStatString(str,timestr,ab,flag) + otherStatTotal := otherStatTotal + PUT('other, property, otherStatTotal) + if otherStatTotal > 0 then + str := makeStatString(str,normalizeStatAndStringify otherStatTotal,'O,flag) + total := total + otherStatTotal + cl := CAR LASSOC('other,listofnames) + cl := CAR LASSOC(cl,listofclasses) + PUT(cl,classproperty, otherStatTotal + GETL(cl,classproperty)) + if flag ^= 'long then + total := 0 + str := '"" + for [class,name,:ab] in listofclasses repeat + n := GETL(name, classproperty) + n = 0.0 => 'iterate + total := total + n + timestr := normalizeStatAndStringify n + str := makeStatString(str,timestr,ab,flag) + total := STRCONC(normalizeStatAndStringify total,'" ", units) + str = '"" => total + STRCONC(str, '" = ", total) + +normalizeStatAndStringify t == + RNUMP t => + t := roundStat t + t = 0.0 => '"0" + FORMAT(nil,'"~,2F",t) + INTP t => + K := 1024 + M := K*K + t > 9*M => CONCAT(STRINGIMAGE((t + 512*K)/M), '"M") + t > 9*K => CONCAT(STRINGIMAGE((t + 512)/K), '"K") + STRINGIMAGE t + STRINGIMAGE t + +significantStat t == + RNUMP t => (t > 0.01) + INTP t => (t > 100) + true + +roundStat t == + not RNUMP t => t + (FIX (0.5 + t * 1000.0)) / 1000.0 + +makeStatString(oldstr,time,abb,flag) == + time = '"" => oldstr + opening := (flag = 'long => '"("; '" (") + oldstr = '"" => STRCONC(time,opening,abb,'")") + STRCONC(oldstr,'" + ",time,opening,abb,'")") + +peekTimedName() == IFCAR $timedNameStack + +popTimedName() == + name := IFCAR $timedNameStack + $timedNameStack := IFCDR $timedNameStack + name + +pushTimedName name == + PUSH(name,$timedNameStack) + +--currentlyTimedName() == CAR $timedNameStack + +startTimingProcess name == + updateTimedName peekTimedName() + pushTimedName name + if EQ(name, 'load) then statRecordLoadEvent() + +stopTimingProcess name == + (name ^= peekTimedName()) and null $InteractiveMode => + keyedSystemError("S2GL0015",[name,peekTimedName()]) + updateTimedName peekTimedName() + popTimedName() + +--% Instrumentation specific to the interpreter +SETANDFILEQ($oldElapsedSpace, 0) +SETANDFILEQ($oldElapsedGCTime,0.0) +SETANDFILEQ($oldElapsedTime,0.0) +SETANDFILEQ($gcTimeTotal,0.0) + +-- $timedNameStack is used to hold the names of sections of the +-- code being timed. + +SETANDFILEQ($timedNameStack,'(other)) + +SETANDFILEQ($interpreterTimedNames,'( +-- name class abbrev + (algebra 2 . B) _ + (analysis 1 . A) _ + (coercion 1 . C) _ + (compilation 3 . T) _ + (debug 3 . D) _ + (evaluation 2 . E) _ + (gc 4 . G) _ + (history 3 . H) _ + (instantiation 3 . I) _ + (load 3 . L) _ + (modemaps 1 . M) _ + (optimization 3 . Z) _ + (querycoerce 1 . Q) _ + (other 3 . O) _ + (diskread 3 . K) _ + (print 3 . P) _ + (resolve 1 . R) _ + )) + +SETANDFILEQ($interpreterTimedClasses, '( +-- number class name short name + ( 1 interpreter . IN) _ + ( 2 evaluation . EV) _ + ( 3 other . OT) _ + ( 4 reclaim . GC) _ + )) + +initializeTimedNames(listofnames,listofclasses) == + for [name,:.] in listofnames repeat + PUT(name, 'TimeTotal, 0.0) + PUT(name, 'SpaceTotal, 0) + for [.,name,:.] in listofclasses repeat + PUT( name, 'ClassTimeTotal, 0.0) + PUT( name, 'ClassSpaceTotal, 0) + $timedNameStack := '(other) + computeElapsedTime() + PUT('gc, 'TimeTotal, 0.0) + PUT('gc, 'SpaceTotal, 0) + NIL + +updateTimedName name == + count := (GETL(name,'TimeTotal) or 0) + computeElapsedTime() + PUT(name,'TimeTotal, count) + +printNamedStats listofnames == + printNamedStatsByProperty(listofnames, 'TimeTotal) + sayBrightly '" " + sayBrightly '"Space (in bytes):" + printNamedStatsByProperty(listofnames, 'SpaceTotal) + +makeLongTimeString(listofnames,listofclasses) == + makeLongStatStringByProperty(listofnames, listofclasses, _ + 'TimeTotal, 'ClassTimeTotal, _ + '"sec", $printTimeIfTrue) + +makeLongSpaceString(listofnames,listofclasses) == + makeLongStatStringByProperty(listofnames, listofclasses, _ + 'SpaceTotal, 'ClassSpaceTotal, _ + '"bytes", $printStorageIfTrue) + +computeElapsedTime() == + -- in total time lists, CAR is VIRTCPU and CADR is TOTCPU + currentTime:= elapsedUserTime() + currentGCTime:= elapsedGcTime() + gcDelta := currentGCTime - $oldElapsedGCTime + elapsedSeconds:= + -- In CCL total time does not include GC time. + $cclSystem => 1.*(currentTime-$oldElapsedTime)/$timerTicksPerSecond + 1.*(currentTime-$oldElapsedTime-gcDelta)/$timerTicksPerSecond + PUT('gc, 'TimeTotal,GETL('gc,'TimeTotal) + + 1.*gcDelta/$timerTicksPerSecond) + $oldElapsedTime := elapsedUserTime() + $oldElapsedGCTime := elapsedGcTime() + elapsedSeconds + +computeElapsedSpace() == + currentElapsedSpace := HEAPELAPSED() + elapsedBytes := currentElapsedSpace - $oldElapsedSpace + $oldElapsedSpace := currentElapsedSpace + elapsedBytes + +timedAlgebraEvaluation(code) == + startTimingProcess 'algebra + r := eval code + stopTimingProcess 'algebra + r + +timedOptimization(code) == + startTimingProcess 'optimization + $getDomainCode : local := NIL + r := lispize code + if $reportOptimization then + sayBrightlyI bright '"Optimized LISP code:" + pp r + stopTimingProcess 'optimization + r + +timedEVALFUN(code) == + startTimingProcess 'evaluation + r := timedEvaluate code + stopTimingProcess 'evaluation + r + +timedEvaluate code == + code is ["LIST",:a] and #a > 200 => + "append"/[eval ["LIST",:x] for x in splitIntoBlocksOf200 a] + eval code + +displayHeapStatsIfWanted() == + $printStorageIfTrue => sayBrightly OLDHEAPSTATS() + +--EVALANDFILEACTQ( +-- PUTGCEXIT function displayHeapStatsIfWanted ) + +--% stubs for the stats summary fns +statRecordInstantiationEvent() == nil +statRecordLoadEvent() == nil + +statisticsSummary() == '"No statistics available." diff --git a/src/interp/g-timer.boot.pamphlet b/src/interp/g-timer.boot.pamphlet deleted file mode 100644 index 513e367d..00000000 --- a/src/interp/g-timer.boot.pamphlet +++ /dev/null @@ -1,292 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp g-timer.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - ---% Code instrumentation facilities --- These functions can be used with arbitrary lists of --- named stats (listofnames) grouped in classes (listofclasses) --- and with measurement types (property, classproperty). - -printNamedStatsByProperty(listofnames, property) == - total := +/[GETL(name,property) for [name,:.] in listofnames] - for [name,:.] in listofnames repeat - n := GETL(name, property) - strname := STRINGIMAGE name - strval := STRINGIMAGE n - sayBrightly concat(bright strname, - fillerSpaces(70-#strname-#strval,'"."),bright strval) - sayBrightly bright fillerSpaces(72,'"-") - sayBrightly concat(bright '"Total", - fillerSpaces(65-# STRINGIMAGE total,'"."),bright STRINGIMAGE total) - -makeLongStatStringByProperty _ - (listofnames, listofclasses, property, classproperty, units, flag) == - total := 0 - str := '"" - otherStatTotal := GETL('other, property) - for [name,class,:ab] in listofnames repeat - name = 'other => 'iterate - cl := CAR LASSOC(class,listofclasses) - n := GETL( name, property) - PUT(cl,classproperty, n + GETL(cl,classproperty)) - total := total + n - if n >= 0.01 - then timestr := normalizeStatAndStringify n - else - timestr := '"" - otherStatTotal := otherStatTotal + n - str := makeStatString(str,timestr,ab,flag) - otherStatTotal := otherStatTotal - PUT('other, property, otherStatTotal) - if otherStatTotal > 0 then - str := makeStatString(str,normalizeStatAndStringify otherStatTotal,'O,flag) - total := total + otherStatTotal - cl := CAR LASSOC('other,listofnames) - cl := CAR LASSOC(cl,listofclasses) - PUT(cl,classproperty, otherStatTotal + GETL(cl,classproperty)) - if flag ^= 'long then - total := 0 - str := '"" - for [class,name,:ab] in listofclasses repeat - n := GETL(name, classproperty) - n = 0.0 => 'iterate - total := total + n - timestr := normalizeStatAndStringify n - str := makeStatString(str,timestr,ab,flag) - total := STRCONC(normalizeStatAndStringify total,'" ", units) - str = '"" => total - STRCONC(str, '" = ", total) - -normalizeStatAndStringify t == - RNUMP t => - t := roundStat t - t = 0.0 => '"0" - FORMAT(nil,'"~,2F",t) - INTP t => - K := 1024 - M := K*K - t > 9*M => CONCAT(STRINGIMAGE((t + 512*K)/M), '"M") - t > 9*K => CONCAT(STRINGIMAGE((t + 512)/K), '"K") - STRINGIMAGE t - STRINGIMAGE t - -significantStat t == - RNUMP t => (t > 0.01) - INTP t => (t > 100) - true - -roundStat t == - not RNUMP t => t - (FIX (0.5 + t * 1000.0)) / 1000.0 - -makeStatString(oldstr,time,abb,flag) == - time = '"" => oldstr - opening := (flag = 'long => '"("; '" (") - oldstr = '"" => STRCONC(time,opening,abb,'")") - STRCONC(oldstr,'" + ",time,opening,abb,'")") - -peekTimedName() == IFCAR $timedNameStack - -popTimedName() == - name := IFCAR $timedNameStack - $timedNameStack := IFCDR $timedNameStack - name - -pushTimedName name == - PUSH(name,$timedNameStack) - ---currentlyTimedName() == CAR $timedNameStack - -startTimingProcess name == - updateTimedName peekTimedName() - pushTimedName name - if EQ(name, 'load) then statRecordLoadEvent() - -stopTimingProcess name == - (name ^= peekTimedName()) and null $InteractiveMode => - keyedSystemError("S2GL0015",[name,peekTimedName()]) - updateTimedName peekTimedName() - popTimedName() - ---% Instrumentation specific to the interpreter -SETANDFILEQ($oldElapsedSpace, 0) -SETANDFILEQ($oldElapsedGCTime,0.0) -SETANDFILEQ($oldElapsedTime,0.0) -SETANDFILEQ($gcTimeTotal,0.0) - --- $timedNameStack is used to hold the names of sections of the --- code being timed. - -SETANDFILEQ($timedNameStack,'(other)) - -SETANDFILEQ($interpreterTimedNames,'( --- name class abbrev - (algebra 2 . B) _ - (analysis 1 . A) _ - (coercion 1 . C) _ - (compilation 3 . T) _ - (debug 3 . D) _ - (evaluation 2 . E) _ - (gc 4 . G) _ - (history 3 . H) _ - (instantiation 3 . I) _ - (load 3 . L) _ - (modemaps 1 . M) _ - (optimization 3 . Z) _ - (querycoerce 1 . Q) _ - (other 3 . O) _ - (diskread 3 . K) _ - (print 3 . P) _ - (resolve 1 . R) _ - )) - -SETANDFILEQ($interpreterTimedClasses, '( --- number class name short name - ( 1 interpreter . IN) _ - ( 2 evaluation . EV) _ - ( 3 other . OT) _ - ( 4 reclaim . GC) _ - )) - -initializeTimedNames(listofnames,listofclasses) == - for [name,:.] in listofnames repeat - PUT(name, 'TimeTotal, 0.0) - PUT(name, 'SpaceTotal, 0) - for [.,name,:.] in listofclasses repeat - PUT( name, 'ClassTimeTotal, 0.0) - PUT( name, 'ClassSpaceTotal, 0) - $timedNameStack := '(other) - computeElapsedTime() - PUT('gc, 'TimeTotal, 0.0) - PUT('gc, 'SpaceTotal, 0) - NIL - -updateTimedName name == - count := (GETL(name,'TimeTotal) or 0) + computeElapsedTime() - PUT(name,'TimeTotal, count) - -printNamedStats listofnames == - printNamedStatsByProperty(listofnames, 'TimeTotal) - sayBrightly '" " - sayBrightly '"Space (in bytes):" - printNamedStatsByProperty(listofnames, 'SpaceTotal) - -makeLongTimeString(listofnames,listofclasses) == - makeLongStatStringByProperty(listofnames, listofclasses, _ - 'TimeTotal, 'ClassTimeTotal, _ - '"sec", $printTimeIfTrue) - -makeLongSpaceString(listofnames,listofclasses) == - makeLongStatStringByProperty(listofnames, listofclasses, _ - 'SpaceTotal, 'ClassSpaceTotal, _ - '"bytes", $printStorageIfTrue) - -computeElapsedTime() == - -- in total time lists, CAR is VIRTCPU and CADR is TOTCPU - currentTime:= elapsedUserTime() - currentGCTime:= elapsedGcTime() - gcDelta := currentGCTime - $oldElapsedGCTime - elapsedSeconds:= - -- In CCL total time does not include GC time. - $cclSystem => 1.*(currentTime-$oldElapsedTime)/$timerTicksPerSecond - 1.*(currentTime-$oldElapsedTime-gcDelta)/$timerTicksPerSecond - PUT('gc, 'TimeTotal,GETL('gc,'TimeTotal) + - 1.*gcDelta/$timerTicksPerSecond) - $oldElapsedTime := elapsedUserTime() - $oldElapsedGCTime := elapsedGcTime() - elapsedSeconds - -computeElapsedSpace() == - currentElapsedSpace := HEAPELAPSED() - elapsedBytes := currentElapsedSpace - $oldElapsedSpace - $oldElapsedSpace := currentElapsedSpace - elapsedBytes - -timedAlgebraEvaluation(code) == - startTimingProcess 'algebra - r := eval code - stopTimingProcess 'algebra - r - -timedOptimization(code) == - startTimingProcess 'optimization - $getDomainCode : local := NIL - r := lispize code - if $reportOptimization then - sayBrightlyI bright '"Optimized LISP code:" - pp r - stopTimingProcess 'optimization - r - -timedEVALFUN(code) == - startTimingProcess 'evaluation - r := timedEvaluate code - stopTimingProcess 'evaluation - r - -timedEvaluate code == - code is ["LIST",:a] and #a > 200 => - "append"/[eval ["LIST",:x] for x in splitIntoBlocksOf200 a] - eval code - -displayHeapStatsIfWanted() == - $printStorageIfTrue => sayBrightly OLDHEAPSTATS() - ---EVALANDFILEACTQ( --- PUTGCEXIT function displayHeapStatsIfWanted ) - ---% stubs for the stats summary fns -statRecordInstantiationEvent() == nil -statRecordLoadEvent() == nil - -statisticsSummary() == '"No statistics available." -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot new file mode 100644 index 00000000..30c5ccd4 --- /dev/null +++ b/src/interp/g-util.boot @@ -0,0 +1,635 @@ +-- 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. + + +)package "BOOT" + +--% Utility Functions of General Use + +ELEMN(x, n, d) == + null x => d + n = 1 => car x + ELEMN(cdr x, SUB1 n, d) + +PPtoFile(x, fname) == + stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0) + PRETTYPRINT(x, stream) + SHUT stream + x + +-- Convert an arbitrary lisp object to canonical boolean. +bool x == + NULL NULL x + +--% Various lispy things + +Identity x == x + +length1? l == PAIRP l and not PAIRP QCDR l + +length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l + +pairList(u,v) == [[x,:y] for x in u for y in v] + +-- GETALIST(alist,prop) == IFCDR assoc(prop,alist) +GETALIST(alist,prop) == CDR assoc(prop,alist) + +PUTALIST(alist,prop,val) == + null alist => [[prop,:val]] + pair := assoc(prop,alist) => + CDR pair = val => alist + -- else we fall over Lucid's read-only storage feature again + QRPLACD(pair,val) + alist + QRPLACD(LASTPAIR alist,[[prop,:val]]) + alist + +REMALIST(alist,prop) == + null alist => alist + alist is [[ =prop,:.],:r] => + null r => NIL + QRPLACA(alist,CAR r) + QRPLACD(alist,CDR r) + alist + null rest alist => alist + l := alist + ok := true + while ok repeat + [.,[p,:.],:r] := l + p = prop => + ok := NIL + QRPLACD(l,r) + if null (l := QCDR l) or null rest l then ok := NIL + alist + +deleteLassoc(x,y) == + y is [[a,:.],:y'] => + EQ(x,a) => y' + [first y,:deleteLassoc(x,y')] + y + +--% association list functions + +deleteAssoc(x,y) == + y is [[a,:.],:y'] => + a=x => deleteAssoc(x,y') + [first y,:deleteAssoc(x,y')] + y + +deleteAssocWOC(x,y) == + null y => y + [[a,:.],:t]:= y + x=a => t + (fn(x,y);y) where fn(x,y is [h,:t]) == + t is [[a,:.],:t1] => + x=a => RPLACD(y,t1) + fn(x,t) + nil + +insertWOC(x,y) == + null y => [x] + (fn(x,y); y) where fn(x,y is [h,:t]) == + x=h => nil + null t => + RPLACD(y,[h,:t]) + RPLACA(y,x) + fn(x,t) + + + +--% Miscellaneous Functions for Working with Strings + +fillerSpaces(n,:charPart) == + n <= 0 => '"" + MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ") + +centerString(text,width,fillchar) == + wid := entryWidth text + wid >= width => text + f := DIVIDE(width - wid,2) + fill1 := "" + for i in 1..(f.0) repeat + fill1 := STRCONC(fillchar,fill1) + fill2:= fill1 + if f.1 ^= 0 then fill1 := STRCONC(fillchar,fill1) + [fill1,text,fill2] + +stringPrefix?(pref,str) == + -- sees if the first #pref letters of str are pref + -- replaces STRINGPREFIXP + null (STRINGP(pref) and STRINGP(str)) => NIL + (lp := QCSIZE pref) = 0 => true + lp > QCSIZE str => NIL + ok := true + i := 0 + while ok and (i < lp) repeat + not EQ(SCHAR(pref,i),SCHAR(str,i)) => ok := NIL + i := i + 1 + ok + +stringChar2Integer(str,pos) == + -- replaces GETSTRINGDIGIT in UT LISP + -- returns small integer represented by character in position pos + -- in string str. Returns NIL if not a digit or other error. + if IDENTP str then str := PNAME str + null (STRINGP(str) and + INTEGERP(pos) and (pos >= 0) and (pos < QCSIZE(str))) => NIL + not DIGITP(d := SCHAR(str,pos)) => NIL + DIG2FIX d + +dropLeadingBlanks str == + str := object2String str + l := QCSIZE str + nb := NIL + i := 0 + while (i < l) and not nb repeat + if SCHAR(str,i) ^= " " then nb := i + else i := i + 1 + nb = 0 => str + nb => SUBSTRING(str,nb,NIL) + '"" + +concat(:l) == concatList l + +concatList [x,:y] == + null y => x + null x => concatList y + concat1(x,concatList y) + +concat1(x,y) == + null x => y + atom x => (null y => x; atom y => [x,y]; [x,:y]) + null y => x + atom y => [:x,y] + [:x,:y] + +--% BOOT ravel and reshape + +ravel a == a + +reshape(a,b) == a + +--% Some functions for algebra code + +boolODDP x == ODDP x + +--% Miscellaneous + +freeOfSharpVars x == + atom x => not isSharpVarWithNum x + freeOfSharpVars first x and freeOfSharpVars rest x + +listOfSharpVars x == + atom x => (isSharpVarWithNum x => LIST x; nil) + setUnion(listOfSharpVars first x,listOfSharpVars rest x) + +listOfPatternIds x == + isPatternVar x => [x] + atom x => nil + x is ['QUOTE,:.] => nil + UNIONQ(listOfPatternIds first x,listOfPatternIds rest x) + +isPatternVar v == + -- a pattern variable consists of a star followed by a star or digit(s) + IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10 + _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true + +removeZeroOne x == + -- replace all occurrences of (Zero) and (One) with + -- 0 and 1 + x = $Zero => 0 + x = $One => 1 + atom x => x + [removeZeroOne first x,:removeZeroOne rest x] + +removeZeroOneDestructively t == + -- replace all occurrences of (Zero) and (One) with + -- 0 and 1 destructively + t = $Zero => 0 + t = $One => 1 + atom t => t + RPLNODE(t,removeZeroOneDestructively first t, + removeZeroOneDestructively rest t) + +flattenSexpr s == + null s => s + ATOM s => s + [f,:r] := s + ATOM f => [f,:flattenSexpr r] + [:flattenSexpr f,:flattenSexpr r] + +isLowerCaseLetter c == charRangeTest CHAR2NUM c + +isUpperCaseLetter c == charRangeTest QSDIFFERENCE(CHAR2NUM c,64) + +isLetter c == + n:= CHAR2NUM c + charRangeTest n or charRangeTest QSDIFFERENCE(CHAR2NUM c,64) + +charRangeTest n == + QSLESSP(153,n) => + QSLESSP(169,n) => false + QSLESSP(161,n) => true + false + QSLESSP(128,n) => + QSLESSP(144,n) => true + QSLESSP(138,n) => false + true + false + +update() == + OBEY + STRCONC('"SPADEDIT ",STRINGIMAGE _/VERSION,'" ",STRINGIMAGE _/WSNAME,'" A") + _/UPDATE() + +--% Inplace Merge Sort for Lists +-- MBM April/88 + +-- listSort(pred,list) or listSort(pred,list,key) +-- the pred function is a boolean valued function defining the ordering +-- the key function extracts the key from an item for comparison by pred + +listSort(pred,list,:optional) == + NOT functionp pred => error "listSort: first arg must be a function" + NOT LISTP list => error "listSort: second argument must be a list" + NULL optional => mergeSort(pred,function Identity,list,LENGTH list) + key := CAR optional + NOT functionp key => error "listSort: last arg must be a function" + mergeSort(pred,key,list,LENGTH list) + +-- non-destructive merge sort using NOT GGREATERP as predicate +MSORT list == listSort(function GLESSEQP, COPY_-LIST list) + +-- destructive merge sort using NOT GGREATERP as predicate +NMSORT list == listSort(function GLESSEQP, list) + +-- non-destructive merge sort using ?ORDER as predicate +orderList l == listSort(function _?ORDER, COPY_-LIST l) + +-- dummy defn until clean-up +-- order l == orderList l + +mergeInPlace(f,g,p,q) == + -- merge the two sorted lists p and q + if NULL p then return p + if NULL q then return q + if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q)) + then (r := t := p; p := QCDR p) + else (r := t := q; q := QCDR q) + while not NULL p and not NULL q repeat + if FUNCALL(f,FUNCALL(g,QCAR p),FUNCALL(g,QCAR q)) + then (QRPLACD(t,p); t := p; p := QCDR p) + else (QRPLACD(t,q); t := q; q := QCDR q) + if NULL p then QRPLACD(t,q) else QRPLACD(t,p) + r + +mergeSort(f,g,p,n) == + if EQ(n,2) and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then + t := p + p := QCDR p + QRPLACD(p,t) + QRPLACD(t,NIL) + if QSLESSP(n,3) then return p + -- split the list p into p and q of equal length + l := QSQUOTIENT(n,2) + t := p + for i in 1..l-1 repeat t := QCDR t + q := rest t + QRPLACD(t,NIL) + p := mergeSort(f,g,p,l) + q := mergeSort(f,g,q,QSDIFFERENCE(n,l)) + mergeInPlace(f,g,p,q) + +--% Throwing with glorious highlighting (maybe) + +spadThrow() == + if $interpOnly and $mapName then + putHist($mapName,'localModemap, nil, $e) + THROW("SPAD__READER",nil) + +spadThrowBrightly x == + sayBrightly x + spadThrow() + +--% Type Formatting Without Abbreviation + +formatUnabbreviatedSig sig == + null sig => ["() -> ()"] + [target,:args] := sig + target := formatUnabbreviated target + null args => ['"() -> ",:target] + null rest args => [:formatUnabbreviated QCAR args,'" -> ",:target] + args := formatUnabbreviatedTuple args + ['"(",:args,'") -> ",:target] + +formatUnabbreviatedTuple t == + -- t is a list of types + null t => t + atom t => [t] + t0 := formatUnabbreviated QCAR t + null rest t => t0 + [:t0,'",",:formatUnabbreviatedTuple QCDR t] + +formatUnabbreviated t == + atom t => + [t] + null t => + ['"()"] + t is [p,sel,arg] and p in '(_: ":") => + [sel,'": ",:formatUnabbreviated arg] + t is ['Union,:args] => + ['Union,'"(",:formatUnabbreviatedTuple args,'")"] + t is ['Mapping,:args] => + formatUnabbreviatedSig args + t is ['Record,:args] => + ['Record,'"(",:formatUnabbreviatedTuple args,'")"] + t is [arg] => + t + t is [arg,arg1] => + [arg,'" ",:formatUnabbreviated arg1] + t is [arg,:args] => + [arg,'"(",:formatUnabbreviatedTuple args,'")"] + t + +sublisNQ(al,e) == + atom al => e + fn(al,e) where fn(al,e) == + atom e => + for x in al repeat + EQ(first x,e) => return (e := rest x) + e + EQ(a := first e,'QUOTE) => e + u := fn(al,a) + v := fn(al,rest e) + EQ(a,u) and EQ(rest e,v) => e + [u,:v] + +-- function for turning strings in tex format + +str2Outform s == + parse := ncParseFromString s or systemError '"String for TeX will not parse" + parse2Outform parse + +parse2Outform x == + x is [op,:argl] => + nargl := [parse2Outform y for y in argl] + op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]] + op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r] + [op,:nargl] + x + +str2Tex s == + outf := str2Outform s + val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat)) + val := objValUnwrap val + CAR val.1 + +opOf x == + atom x => x + first x + +getProplist(x,E) == + not atom x => getProplist(first x,E) + u:= search(x,E) => u + --$InteractiveMode => nil + --$InteractiveMode and (u:= search(x,$InteractiveFrame)) => u + (pl:=search(x,$CategoryFrame)) => + pl +-- (pl:=PROPLIST x) => pl +-- Above line commented out JHD/BMT 2.Aug.90 + +search(x,e is [curEnv,:tailEnv]) == + searchCurrentEnv(x,curEnv) or searchTailEnv(x,tailEnv) + +searchCurrentEnv(x,currentEnv) == + for contour in currentEnv repeat + if u:= ASSQ(x,contour) then return (signal:= u) + KDR signal + +searchTailEnv(x,e) == + for env in e repeat + signal:= + for contour in env repeat + if (u:= ASSQ(x,contour)) and ASSQ("FLUID",u) then return (signal:= u) + if signal then return signal + KDR signal + +augProplist(proplist,prop,val) == + $InteractiveMode => augProplistInteractive(proplist,prop,val) + while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist' + val=(u:= LASSOC(prop,proplist)) => proplist + null val => + null u => proplist + DELLASOS(prop,proplist) + [[prop,:val],:proplist] + +augProplistOf(var,prop,val,e) == + proplist:= getProplist(var,e) + semchkProplist(var,proplist,prop,val) + augProplist(proplist,prop,val) + +semchkProplist(x,proplist,prop,val) == + prop="isLiteral" => + LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x + MEMQ(prop,'(mode value)) => + LASSOC("isLiteral",proplist) => warnLiteral x + +addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == + EQ(proplist,getProplist(var,e)) => e + $InteractiveMode => addBindingInteractive(var,proplist,e) + if curContour is [[ =var,:.],:.] then curContour:= rest curContour + --Previous line should save some space + [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] + +position(x,l) == + posn(x,l,0) where + posn(x,l,n) == + null l => -1 + x=first l => n + posn(x,rest l,n+1) + +insert(x,y) == + member(x,y) => y + [x,:y] + +after(u,v) == + r:= u + for x in u for y in v repeat r:= rest r + r + + +$blank := char ('_ ) + +trimString s == + leftTrim rightTrim s + +leftTrim s == + k := MAXINDEX s + k < 0 => s + s.0 = $blank => + for i in 0..k while s.i = $blank repeat (j := i) + SUBSTRING(s,j + 1,nil) + s + +rightTrim s == -- assumed a non-empty string + k := MAXINDEX s + k < 0 => s + s.k = $blank => + for i in k..0 by -1 while s.i = $blank repeat (j := i) + SUBSTRING(s,0,j) + s + +pp x == + PRETTYPRINT x + x + +pr x == + F_,PRINT_-ONE x + nil + +quickAnd(a,b) == + a = true => b + b = true => a + a = false or b = false => false + simpBool ['AND,a,b] + +quickOr(a,b) == + a = true or b = true => true + b = false => a + a = false => b + simpCatPredicate simpBool ['OR,a,b] + +intern x == + STRINGP x => + DIGITP x.0 => string2Integer x + INTERN x + x + +--------------------> NEW DEFINITION (override in interop.boot.pamphlet) +isDomain a == + REFVECP a and #a>5 and GETDATABASE(a.0,'CONSTRUCTORKIND) = 'domain + +-- variables used by browser + +$htHash := MAKE_-HASH_-TABLE() +$glossHash := MAKE_-HASH_-TABLE() +$lispHash := MAKE_-HASH_-TABLE() +$sysHash := MAKE_-HASH_-TABLE() +$htSystemCommands := '( + (boot . development) clear display (fin . development) edit help + frame history load quit read set show synonym system + trace what ) +$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root +$outStream := nil +$recheckingFlag := false --see transformAndRecheckComments +$exposeFlag := false --if true, messages go to $outStream +$exposeFlagHeading := false --see htcheck.boot +$checkingXmptex? := false --see htcheck.boot +$exposeDocHeading:= nil --see htcheck.boot +$charPlus := char '_+ +$charBlank:= (char '_ ) +$charLbrace:= char '_{ +$charRbrace:= char '_} +$charBack := char '_\ +$charDash := char '_- + +$charTab := CODE_-CHAR(9) +$charNewline := CODE_-CHAR(10) +$charFauxNewline := CODE_-CHAR(25) +$stringNewline := PNAME CODE_-CHAR(10) +$stringFauxNewline := PNAME CODE_-CHAR(25) + +$charExclusions := [char 'a, char 'A] +$charQuote := char '_' +$charSemiColon := char '_; +$charComma := char '_, +$charPeriod := char '_. +$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]] +$charEscapeList:= [char '_%,char '_#,$charBack] +$charIdentifierEndings := [char '__, char '_!, char '_?] +$charSplitList := [$charComma,$charPeriod,char '_[, char '_],$charLbrace, $charRbrace, char '_(, char '_), char '_$, char '_%] +$charDelimiters := [$charBlank, char '_(, char '_), $charBack] +$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s") +$HTmacs := [ + ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"], + ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"], + ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"], + ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"], + ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"], + ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]] + +$HTlinks := '( + "\downlink" + "\menulink" + "\menudownlink" + "\menuwindowlink" + "\menumemolink") + +$HTlisplinks := '( + "\lispdownlink" + "\menulispdownlink" + "\menulispwindowlink" + "\menulispmemolink" + "\lispwindowlink" + "\lispmemolink") + +$beginEndList := '( + "page" + "items" + "menu" + "scroll" + "verbatim" + "detail") + +isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& + + +-- gensym utils + +charDigitVal c == + digits := '"0123456789" + n := -1 + for i in 0..#digits-1 while n < 0 repeat + if c = digits.i then n := i + n < 0 => error '"Character is not a digit" + n + +gensymInt g == + not GENSYMP g => error '"Need a GENSYM" + p := PNAME g + n := 0 + for i in 2..#p-1 repeat n := 10 * n + charDigitVal p.i + n + + + +-- Push into the BOOT package when invoked in batch mode. +AxiomCore::$sysScope := '"BOOT" diff --git a/src/interp/g-util.boot.pamphlet b/src/interp/g-util.boot.pamphlet deleted file mode 100644 index 05e262c8..00000000 --- a/src/interp/g-util.boot.pamphlet +++ /dev/null @@ -1,663 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/g-util.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} - -\maketitle -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\section{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. - -@ -<<*>>= -<> - -)package "BOOT" - ---% Utility Functions of General Use - -ELEMN(x, n, d) == - null x => d - n = 1 => car x - ELEMN(cdr x, SUB1 n, d) - -PPtoFile(x, fname) == - stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0) - PRETTYPRINT(x, stream) - SHUT stream - x - --- Convert an arbitrary lisp object to canonical boolean. -bool x == - NULL NULL x - ---% Various lispy things - -Identity x == x - -length1? l == PAIRP l and not PAIRP QCDR l - -length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l - -pairList(u,v) == [[x,:y] for x in u for y in v] - --- GETALIST(alist,prop) == IFCDR assoc(prop,alist) -GETALIST(alist,prop) == CDR assoc(prop,alist) - -PUTALIST(alist,prop,val) == - null alist => [[prop,:val]] - pair := assoc(prop,alist) => - CDR pair = val => alist - -- else we fall over Lucid's read-only storage feature again - QRPLACD(pair,val) - alist - QRPLACD(LASTPAIR alist,[[prop,:val]]) - alist - -REMALIST(alist,prop) == - null alist => alist - alist is [[ =prop,:.],:r] => - null r => NIL - QRPLACA(alist,CAR r) - QRPLACD(alist,CDR r) - alist - null rest alist => alist - l := alist - ok := true - while ok repeat - [.,[p,:.],:r] := l - p = prop => - ok := NIL - QRPLACD(l,r) - if null (l := QCDR l) or null rest l then ok := NIL - alist - -deleteLassoc(x,y) == - y is [[a,:.],:y'] => - EQ(x,a) => y' - [first y,:deleteLassoc(x,y')] - y - ---% association list functions - -deleteAssoc(x,y) == - y is [[a,:.],:y'] => - a=x => deleteAssoc(x,y') - [first y,:deleteAssoc(x,y')] - y - -deleteAssocWOC(x,y) == - null y => y - [[a,:.],:t]:= y - x=a => t - (fn(x,y);y) where fn(x,y is [h,:t]) == - t is [[a,:.],:t1] => - x=a => RPLACD(y,t1) - fn(x,t) - nil - -insertWOC(x,y) == - null y => [x] - (fn(x,y); y) where fn(x,y is [h,:t]) == - x=h => nil - null t => - RPLACD(y,[h,:t]) - RPLACA(y,x) - fn(x,t) - - - ---% Miscellaneous Functions for Working with Strings - -fillerSpaces(n,:charPart) == - n <= 0 => '"" - MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ") - -centerString(text,width,fillchar) == - wid := entryWidth text - wid >= width => text - f := DIVIDE(width - wid,2) - fill1 := "" - for i in 1..(f.0) repeat - fill1 := STRCONC(fillchar,fill1) - fill2:= fill1 - if f.1 ^= 0 then fill1 := STRCONC(fillchar,fill1) - [fill1,text,fill2] - -stringPrefix?(pref,str) == - -- sees if the first #pref letters of str are pref - -- replaces STRINGPREFIXP - null (STRINGP(pref) and STRINGP(str)) => NIL - (lp := QCSIZE pref) = 0 => true - lp > QCSIZE str => NIL - ok := true - i := 0 - while ok and (i < lp) repeat - not EQ(SCHAR(pref,i),SCHAR(str,i)) => ok := NIL - i := i + 1 - ok - -stringChar2Integer(str,pos) == - -- replaces GETSTRINGDIGIT in UT LISP - -- returns small integer represented by character in position pos - -- in string str. Returns NIL if not a digit or other error. - if IDENTP str then str := PNAME str - null (STRINGP(str) and - INTEGERP(pos) and (pos >= 0) and (pos < QCSIZE(str))) => NIL - not DIGITP(d := SCHAR(str,pos)) => NIL - DIG2FIX d - -dropLeadingBlanks str == - str := object2String str - l := QCSIZE str - nb := NIL - i := 0 - while (i < l) and not nb repeat - if SCHAR(str,i) ^= " " then nb := i - else i := i + 1 - nb = 0 => str - nb => SUBSTRING(str,nb,NIL) - '"" - -concat(:l) == concatList l - -concatList [x,:y] == - null y => x - null x => concatList y - concat1(x,concatList y) - -concat1(x,y) == - null x => y - atom x => (null y => x; atom y => [x,y]; [x,:y]) - null y => x - atom y => [:x,y] - [:x,:y] - ---% BOOT ravel and reshape - -ravel a == a - -reshape(a,b) == a - ---% Some functions for algebra code - -boolODDP x == ODDP x - ---% Miscellaneous - -freeOfSharpVars x == - atom x => not isSharpVarWithNum x - freeOfSharpVars first x and freeOfSharpVars rest x - -listOfSharpVars x == - atom x => (isSharpVarWithNum x => LIST x; nil) - setUnion(listOfSharpVars first x,listOfSharpVars rest x) - -listOfPatternIds x == - isPatternVar x => [x] - atom x => nil - x is ['QUOTE,:.] => nil - UNIONQ(listOfPatternIds first x,listOfPatternIds rest x) - -isPatternVar v == - -- a pattern variable consists of a star followed by a star or digit(s) - IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10 - _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true - -removeZeroOne x == - -- replace all occurrences of (Zero) and (One) with - -- 0 and 1 - x = $Zero => 0 - x = $One => 1 - atom x => x - [removeZeroOne first x,:removeZeroOne rest x] - -removeZeroOneDestructively t == - -- replace all occurrences of (Zero) and (One) with - -- 0 and 1 destructively - t = $Zero => 0 - t = $One => 1 - atom t => t - RPLNODE(t,removeZeroOneDestructively first t, - removeZeroOneDestructively rest t) - -flattenSexpr s == - null s => s - ATOM s => s - [f,:r] := s - ATOM f => [f,:flattenSexpr r] - [:flattenSexpr f,:flattenSexpr r] - -isLowerCaseLetter c == charRangeTest CHAR2NUM c - -isUpperCaseLetter c == charRangeTest QSDIFFERENCE(CHAR2NUM c,64) - -isLetter c == - n:= CHAR2NUM c - charRangeTest n or charRangeTest QSDIFFERENCE(CHAR2NUM c,64) - -charRangeTest n == - QSLESSP(153,n) => - QSLESSP(169,n) => false - QSLESSP(161,n) => true - false - QSLESSP(128,n) => - QSLESSP(144,n) => true - QSLESSP(138,n) => false - true - false - -update() == - OBEY - STRCONC('"SPADEDIT ",STRINGIMAGE _/VERSION,'" ",STRINGIMAGE _/WSNAME,'" A") - _/UPDATE() - ---% Inplace Merge Sort for Lists --- MBM April/88 - --- listSort(pred,list) or listSort(pred,list,key) --- the pred function is a boolean valued function defining the ordering --- the key function extracts the key from an item for comparison by pred - -listSort(pred,list,:optional) == - NOT functionp pred => error "listSort: first arg must be a function" - NOT LISTP list => error "listSort: second argument must be a list" - NULL optional => mergeSort(pred,function Identity,list,LENGTH list) - key := CAR optional - NOT functionp key => error "listSort: last arg must be a function" - mergeSort(pred,key,list,LENGTH list) - --- non-destructive merge sort using NOT GGREATERP as predicate -MSORT list == listSort(function GLESSEQP, COPY_-LIST list) - --- destructive merge sort using NOT GGREATERP as predicate -NMSORT list == listSort(function GLESSEQP, list) - --- non-destructive merge sort using ?ORDER as predicate -orderList l == listSort(function _?ORDER, COPY_-LIST l) - --- dummy defn until clean-up --- order l == orderList l - -mergeInPlace(f,g,p,q) == - -- merge the two sorted lists p and q - if NULL p then return p - if NULL q then return q - if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q)) - then (r := t := p; p := QCDR p) - else (r := t := q; q := QCDR q) - while not NULL p and not NULL q repeat - if FUNCALL(f,FUNCALL(g,QCAR p),FUNCALL(g,QCAR q)) - then (QRPLACD(t,p); t := p; p := QCDR p) - else (QRPLACD(t,q); t := q; q := QCDR q) - if NULL p then QRPLACD(t,q) else QRPLACD(t,p) - r - -mergeSort(f,g,p,n) == - if EQ(n,2) and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then - t := p - p := QCDR p - QRPLACD(p,t) - QRPLACD(t,NIL) - if QSLESSP(n,3) then return p - -- split the list p into p and q of equal length - l := QSQUOTIENT(n,2) - t := p - for i in 1..l-1 repeat t := QCDR t - q := rest t - QRPLACD(t,NIL) - p := mergeSort(f,g,p,l) - q := mergeSort(f,g,q,QSDIFFERENCE(n,l)) - mergeInPlace(f,g,p,q) - ---% Throwing with glorious highlighting (maybe) - -spadThrow() == - if $interpOnly and $mapName then - putHist($mapName,'localModemap, nil, $e) - THROW("SPAD__READER",nil) - -spadThrowBrightly x == - sayBrightly x - spadThrow() - ---% Type Formatting Without Abbreviation - -formatUnabbreviatedSig sig == - null sig => ["() -> ()"] - [target,:args] := sig - target := formatUnabbreviated target - null args => ['"() -> ",:target] - null rest args => [:formatUnabbreviated QCAR args,'" -> ",:target] - args := formatUnabbreviatedTuple args - ['"(",:args,'") -> ",:target] - -formatUnabbreviatedTuple t == - -- t is a list of types - null t => t - atom t => [t] - t0 := formatUnabbreviated QCAR t - null rest t => t0 - [:t0,'",",:formatUnabbreviatedTuple QCDR t] - -formatUnabbreviated t == - atom t => - [t] - null t => - ['"()"] - t is [p,sel,arg] and p in '(_: ":") => - [sel,'": ",:formatUnabbreviated arg] - t is ['Union,:args] => - ['Union,'"(",:formatUnabbreviatedTuple args,'")"] - t is ['Mapping,:args] => - formatUnabbreviatedSig args - t is ['Record,:args] => - ['Record,'"(",:formatUnabbreviatedTuple args,'")"] - t is [arg] => - t - t is [arg,arg1] => - [arg,'" ",:formatUnabbreviated arg1] - t is [arg,:args] => - [arg,'"(",:formatUnabbreviatedTuple args,'")"] - t - -sublisNQ(al,e) == - atom al => e - fn(al,e) where fn(al,e) == - atom e => - for x in al repeat - EQ(first x,e) => return (e := rest x) - e - EQ(a := first e,'QUOTE) => e - u := fn(al,a) - v := fn(al,rest e) - EQ(a,u) and EQ(rest e,v) => e - [u,:v] - --- function for turning strings in tex format - -str2Outform s == - parse := ncParseFromString s or systemError '"String for TeX will not parse" - parse2Outform parse - -parse2Outform x == - x is [op,:argl] => - nargl := [parse2Outform y for y in argl] - op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]] - op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r] - [op,:nargl] - x - -str2Tex s == - outf := str2Outform s - val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat)) - val := objValUnwrap val - CAR val.1 - -opOf x == - atom x => x - first x - -getProplist(x,E) == - not atom x => getProplist(first x,E) - u:= search(x,E) => u - --$InteractiveMode => nil - --$InteractiveMode and (u:= search(x,$InteractiveFrame)) => u - (pl:=search(x,$CategoryFrame)) => - pl --- (pl:=PROPLIST x) => pl --- Above line commented out JHD/BMT 2.Aug.90 - -search(x,e is [curEnv,:tailEnv]) == - searchCurrentEnv(x,curEnv) or searchTailEnv(x,tailEnv) - -searchCurrentEnv(x,currentEnv) == - for contour in currentEnv repeat - if u:= ASSQ(x,contour) then return (signal:= u) - KDR signal - -searchTailEnv(x,e) == - for env in e repeat - signal:= - for contour in env repeat - if (u:= ASSQ(x,contour)) and ASSQ("FLUID",u) then return (signal:= u) - if signal then return signal - KDR signal - -augProplist(proplist,prop,val) == - $InteractiveMode => augProplistInteractive(proplist,prop,val) - while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist' - val=(u:= LASSOC(prop,proplist)) => proplist - null val => - null u => proplist - DELLASOS(prop,proplist) - [[prop,:val],:proplist] - -augProplistOf(var,prop,val,e) == - proplist:= getProplist(var,e) - semchkProplist(var,proplist,prop,val) - augProplist(proplist,prop,val) - -semchkProplist(x,proplist,prop,val) == - prop="isLiteral" => - LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x - MEMQ(prop,'(mode value)) => - LASSOC("isLiteral",proplist) => warnLiteral x - -addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == - EQ(proplist,getProplist(var,e)) => e - $InteractiveMode => addBindingInteractive(var,proplist,e) - if curContour is [[ =var,:.],:.] then curContour:= rest curContour - --Previous line should save some space - [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] - -position(x,l) == - posn(x,l,0) where - posn(x,l,n) == - null l => -1 - x=first l => n - posn(x,rest l,n+1) - -insert(x,y) == - member(x,y) => y - [x,:y] - -after(u,v) == - r:= u - for x in u for y in v repeat r:= rest r - r - - -$blank := char ('_ ) - -trimString s == - leftTrim rightTrim s - -leftTrim s == - k := MAXINDEX s - k < 0 => s - s.0 = $blank => - for i in 0..k while s.i = $blank repeat (j := i) - SUBSTRING(s,j + 1,nil) - s - -rightTrim s == -- assumed a non-empty string - k := MAXINDEX s - k < 0 => s - s.k = $blank => - for i in k..0 by -1 while s.i = $blank repeat (j := i) - SUBSTRING(s,0,j) - s - -pp x == - PRETTYPRINT x - x - -pr x == - F_,PRINT_-ONE x - nil - -quickAnd(a,b) == - a = true => b - b = true => a - a = false or b = false => false - simpBool ['AND,a,b] - -quickOr(a,b) == - a = true or b = true => true - b = false => a - a = false => b - simpCatPredicate simpBool ['OR,a,b] - -intern x == - STRINGP x => - DIGITP x.0 => string2Integer x - INTERN x - x - ---------------------> NEW DEFINITION (override in interop.boot.pamphlet) -isDomain a == - REFVECP a and #a>5 and GETDATABASE(a.0,'CONSTRUCTORKIND) = 'domain - --- variables used by browser - -$htHash := MAKE_-HASH_-TABLE() -$glossHash := MAKE_-HASH_-TABLE() -$lispHash := MAKE_-HASH_-TABLE() -$sysHash := MAKE_-HASH_-TABLE() -$htSystemCommands := '( - (boot . development) clear display (fin . development) edit help - frame history load quit read set show synonym system - trace what ) -$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root -$outStream := nil -$recheckingFlag := false --see transformAndRecheckComments -$exposeFlag := false --if true, messages go to $outStream -$exposeFlagHeading := false --see htcheck.boot -$checkingXmptex? := false --see htcheck.boot -$exposeDocHeading:= nil --see htcheck.boot -$charPlus := char '_+ -$charBlank:= (char '_ ) -$charLbrace:= char '_{ -$charRbrace:= char '_} -$charBack := char '_\ -$charDash := char '_- - -$charTab := CODE_-CHAR(9) -$charNewline := CODE_-CHAR(10) -$charFauxNewline := CODE_-CHAR(25) -$stringNewline := PNAME CODE_-CHAR(10) -$stringFauxNewline := PNAME CODE_-CHAR(25) - -$charExclusions := [char 'a, char 'A] -$charQuote := char '_' -$charSemiColon := char '_; -$charComma := char '_, -$charPeriod := char '_. -$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]] -$charEscapeList:= [char '_%,char '_#,$charBack] -$charIdentifierEndings := [char '__, char '_!, char '_?] -$charSplitList := [$charComma,$charPeriod,char '_[, char '_],$charLbrace, $charRbrace, char '_(, char '_), char '_$, char '_%] -$charDelimiters := [$charBlank, char '_(, char '_), $charBack] -$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s") -$HTmacs := [ - ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"], - ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"], - ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"], - ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"], - ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"], - ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]] - -$HTlinks := '( - "\downlink" - "\menulink" - "\menudownlink" - "\menuwindowlink" - "\menumemolink") - -$HTlisplinks := '( - "\lispdownlink" - "\menulispdownlink" - "\menulispwindowlink" - "\menulispmemolink" - "\lispwindowlink" - "\lispmemolink") - -$beginEndList := '( - "page" - "items" - "menu" - "scroll" - "verbatim" - "detail") - -isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& - - --- gensym utils - -charDigitVal c == - digits := '"0123456789" - n := -1 - for i in 0..#digits-1 while n < 0 repeat - if c = digits.i then n := i - n < 0 => error '"Character is not a digit" - n - -gensymInt g == - not GENSYMP g => error '"Need a GENSYM" - p := PNAME g - n := 0 - for i in 2..#p-1 repeat n := 10 * n + charDigitVal p.i - n - - - --- Push into the BOOT package when invoked in batch mode. -AxiomCore::$sysScope := '"BOOT" -@ - - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/guess.boot b/src/interp/guess.boot new file mode 100644 index 00000000..8dde919c --- /dev/null +++ b/src/interp/guess.boot @@ -0,0 +1,347 @@ +-- 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. + + +$minThreshold := 3 +$maxThreshold := 7 + +--======================================================================= +-- Build Directories +--======================================================================= +buildOperationWordTable() == + $opWordTable := buildWordTable [PNAME x for x in allOperations()] + +buildWordTable u == + table:= MAKE_-HASHTABLE 'ID + for s in u repeat + words := wordsOfString s + key := UPCASE s.0 + HPUT(table,key,[[s,:words],:HGET(table,key)]) + for key in HKEYS table repeat + HPUT(table,key, + listSort(function GLESSEQP,removeDupOrderedAlist + listSort(function GLESSEQP, HGET(table,key),function CAR), + function CADR)) + table + +measureWordTable u == + +/[+/[#entry for entry in HGET(u,key)] for key in HKEYS u] + +removeDupOrderedAlist u == + -- removes duplicate entries in ordered alist + -- (where duplicates are adjacent) + for x in tails u repeat + (y := rest x) and first first x = first first y => RPLACD(x,rest y) + u + +wordsOfString(s) == [UPCASE x for x in wordsOfStringKeepCase s] + +wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] + +wordsOfString1(s,j) == + k := or/[i for i in j..SUB1(MAXINDEX(s)) | UPPER_-CASE_-P s.i] => + tailWords:= + UPPER_-CASE_-P s.(k+1) => + n:= or/[i for i in (k+2)..SUB1(MAXINDEX(s))|not UPPER_-CASE_-P s.i] + null n => [SUBSTRING(s,k,nil)] + n > k+1 => [SUBSTRING(s,k,n-k-1),:wordsOfString1(s,n-1)] + m := or/[i for i in (k+2)..SUB1(MAXINDEX(s)) | UPPER_-CASE_-P s.i] => + [SUBSTRING(s,k,m-k),:wordsOfString1(s,m)] + [SUBSTRING(s,k,nil)] + k > j+1 => [SUBSTRING(s,j,k-j),:tailWords] + tailWords + nil + +wordKeys s == + REMDUP [UPCASE s.0,:fn(s,1,-1,MAXINDEX s,nil)] where fn(s,i,lastKeyIndex,n,acc) == + i > n => acc + UPPER_-CASE_-P s.i => +-- i = lastKeyIndex + 1 => fn(s,i + 1,i,n,[s.i,:rest acc]) + fn(s,i + 1,i,n,[s.i,:acc]) + fn(s,i + 1,lastKeyIndex,n,acc) + +--======================================================================= +-- Augment Function Directories +--======================================================================= +add2WordFunctionTable fn == +--called from DEF + $functionTable and + null LASSOC(s := PNAME fn,HGET($functionTable,(key := UPCASE s.0))) => + HPUT($functionTable,key,[[s,:wordsOfString s],:HGET($functionTable,key)]) + +--======================================================================= +-- Guess Function Name +--======================================================================= +findWords(word,table) == + $lastWord := word + $lastTable:= table + $totalWords:= nil + $countThreshold := $minThreshold + $lastMinimum := -1 + res := findApproximateWords(word,table) + if null res then + $countThreshold := $countThreshold + 2 + res := findApproximateWords(word,table) + $lastAlist := mySort res => +-- $lastMinimum := CAR LAST $lastAlist +-- $lastWords := wordSort CDAR $lastAlist +-- $totalWords:= $lastWords +-- $lastAlist := CDR $lastAlist +-- $totalWords + $lastMinimum := CAAR $lastAlist + $lastWords := wordSort CDAR $lastAlist + $totalWords:= $lastWords + $lastAlist := CDR $lastAlist + $totalWords + $lastWords := nil + +wordSort u == REMDUP listSort(function GLESSEQP,u) + +more() == moreWords($lastWord,$lastTable) + +moreWords(word,table) == + $lastAlist => + $lastMinimum := CAR LAST pp $lastAlist + numberOfLastWords := #$lastWords + $lastWords := "append"/(ASSOCRIGHT $lastAlist) + if #$lastWords > numberOfLastWords then + trialLastAlist := + [p for p in $lastAlist | p.0 < $maxThreshold] + trialLastWords := "append"/(ASSOCRIGHT trialLastAlist) + if #trialLastWords > numberOfLastWords then + $lastWords := trialLastWords + $totalWords:= wordSort [:$lastWords,:$totalWords] + $lastAlist := nil + $totalWords + $countThreshold := $countThreshold + 2 + $lastAlist := findApproximateWords(word,table) + moreWords(word,table) + +findApproximateWords(word,table) == + count := $countThreshold + words:= wordsOfString word + upperWord:= UPCASE COPY word + n := #words + threshold:= + n = 1 => count + count+1 + + --first try to break up as list of words + alist:= nil + for i in 1..#words repeat + $penalty :local := (i = 1 => 0; 1) + wordAlist:= HGET(table,UPCASE (first words).0) + for [x,:wordList] in wordAlist repeat + k := findApproxWordList(words,wordList,n,threshold,#wordList) + k => + k := k + $penalty + k <= $lastMinimum => 'skip + alist := consAlist(k,x,alist) + + if i = 1 and null alist then + --no winners, so try flattening to upper case and checking again + wordSize := SIZE word + lastThreshold := MAX(threshold - 1,wordSize/2) + for [x,:.] in wordAlist repeat + k := deltaWordEntry(upperWord,UPCASE x) + k < lastThreshold => alist := consAlist(k,x,alist) + + rotateWordList words + + alist + +consAlist(x,y,alist) == + u := ASSOC(x,alist) => + RPLACD(u,[y,:CDR u]) + alist + [[x,y],:alist] + +findApproxWordList(words,wordList,n,threshold,w) == + val := findApproxWordList1(words,wordList,n,threshold,w) + null val => val +--pp [val,:wordList] + val + +findApproxWordList1(words,wordList,n,threshold,w) == + two := threshold - 2 + n = w => + k := findApproxSimple(words,wordList,threshold) => k + + n < 3 => false + threshold := threshold - 1 + sum := 0 --next, throw out one bad word + + badWord := false + for entry in wordList for part in words while sum < threshold repeat + k:= deltaWordEntry(part,entry) + k < two => sum:= sum + k + null badWord => badWord := true + sum := 1000 + sum < threshold => +-- pp [2,sum,wordList] + sum + 2 + + n+1 = w => --assume one word is missing + sum := 0 + badWord := false + for entries in tails wordList for part in words + while sum < threshold repeat + entry := first entries + k:= deltaWordEntry(part,entry) + k < two => sum:= sum + k + null badWord => + badWord := true + entries := rest entries --skip this bad word + entry := first entries + k := deltaWordEntry(part,entry) + k < two => sum := sum + k + sum := 1000 + sum := 1000 + sum < threshold => +-- pp [3,sum,wordList] + sum + 2 + false + n-1 = w => --assume one word too many + sum := 0 --here: KEEP it hard to satisfy + badWord := false + for entry in wordList for parts in tails words + while sum < threshold repeat + part := first parts + k:= deltaWordEntry(part,entry) + k < 2 => sum:= sum + k + null badWord => + badWord := true + parts := rest parts --skip this bad word + part := first parts + k := deltaWordEntry(part,entry) + k < 2 => sum := sum + k + return (sum := 1000) + return (sum := 1000) + sum < threshold => +-- pp [4,sum,wordList] + $penalty = 1 => sum + sum + 1 + false + false + +findApproxSimple(words,wordList,threshold) == + sum := 0 + --first try matching words in order + for entry in wordList for part in words while sum < threshold repeat + sum:= sum + deltaWordEntry(part,entry) + sum < threshold => +-- pp ['"--->",sum,:wordList] + sum + nil + +rotateWordList u == + v := u + p := CAR v + while QCDR v repeat + RPLACA(v,CADR v) + v := QCDR v + RPLACA(v,p) + u + +deltaWordEntry(word,entry) == + word = entry => 0 + word.0 ^= entry.0 => 1000 + #word > 2 and stringPrefix?(word,entry) => 1 + ABS(diff := SIZE word - SIZE entry) > 4 => 1000 + canForgeWord(word,entry) + +--+ Note these are optimized definitions below-- see commented out versions +--+ to understand the algorithm +canForgeWord(word,entry) == + forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0) + +forge(word,w,W,entry,e,E,n) == + w > W => + e > E => n + QSADD1 QSPLUS(E-e,n) + e > E => QSADD1 QSPLUS(W-w,n) + word.w = entry.e => forge(word,w+1,W,entry,e+1,E,n) + w=W or e=E => forge(word,w+1,W,entry,e+1,E,QSADD1 n) + word.w=entry.(e+1) => + word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,QSADD1 n) + forge(word,w+1,W,entry,e+2,E,QSADD1 n) + word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,QSADD1 n) + + (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => + --if word is long, can we delete chars to match 2 consective chars + deltaW >= deltaE and + (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) + and word.(k+1) = entry.(e+1) => + forge(word,k+2,W,entry,e+2,E,QSPLUS(k-w,n)) + deltaW <= deltaE and + --if word is short, can we insert chars so as to match 2 consecutive chars + (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) + and word.(w+1) = entry.(k+1) => + forge(word,w+2,W,entry,k+2,E,QSPLUS(n,k-e)) + forge(word,w+1,W,entry,e+1,E,QSADD1 n) + --check for two consecutive matches down the line + forge(word,w+1,W,entry,e+1,E,QSADD1 n) + +--+ DO NOT REMOVE DEFINITIONS BELOW which explain the algorithm +--+ canForgeWord(word,entry) ==-- +--+ [d,i,s,t] := forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0,0,0,0) +--+ --d=deletions, i=insertions, s=substitutions, t=transpositions +--+ --list is formed only for tuning purposes-- remove later on +--+ d + i + s + t + +--+forge(word,w,W,entry,e,E,d,i,s,t) == +--+ w > W => +--+ e > E => [d,i,s,t] +--+ [d,E-e+i+1,s,t] +--+ e > E => [W-w+d+1,i,s,t] +--+ word.w = entry.e => forge(word,w+1,W,entry,e+1,E,d,i,s,t) +--+ w=W or e=E => forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) +--+ word.w=entry.(e+1) => +--+ word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,d,i,s,t+1) +--+ forge(word,w+1,W,entry,e+2,E,d,i+1,s,t) +--+ word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,d+1,i,s,t) +--+ +--+ (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => +--+ --if word is long, can we delete chars to match 2 consective chars +--+ deltaW >= deltaE and +--+ (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) +--+ and word.(k+1) = entry.(e+1) => +--+ forge(word,k+2,W,entry,e+2,E,d+k-w,i,s,t) +--+ deltaW <= deltaE and +--+ --if word is short, can we insert chars so as to match 2 consecutive chars +--+ (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) +--+ and word.(w+1) = entry.(k+1) => +--+ forge(word,w+2,W,entry,k+2,E,d,i+k-e,s,t) +--+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) +--+ --check for two consecutive matches down the line +--+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) + +mySort u == listSort(function GLESSEQP,u) diff --git a/src/interp/guess.boot.pamphlet b/src/interp/guess.boot.pamphlet deleted file mode 100644 index 4f4d2544..00000000 --- a/src/interp/guess.boot.pamphlet +++ /dev/null @@ -1,369 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp guess.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - -$minThreshold := 3 -$maxThreshold := 7 - ---======================================================================= --- Build Directories ---======================================================================= -buildOperationWordTable() == - $opWordTable := buildWordTable [PNAME x for x in allOperations()] - -buildWordTable u == - table:= MAKE_-HASHTABLE 'ID - for s in u repeat - words := wordsOfString s - key := UPCASE s.0 - HPUT(table,key,[[s,:words],:HGET(table,key)]) - for key in HKEYS table repeat - HPUT(table,key, - listSort(function GLESSEQP,removeDupOrderedAlist - listSort(function GLESSEQP, HGET(table,key),function CAR), - function CADR)) - table - -measureWordTable u == - +/[+/[#entry for entry in HGET(u,key)] for key in HKEYS u] - -removeDupOrderedAlist u == - -- removes duplicate entries in ordered alist - -- (where duplicates are adjacent) - for x in tails u repeat - (y := rest x) and first first x = first first y => RPLACD(x,rest y) - u - -wordsOfString(s) == [UPCASE x for x in wordsOfStringKeepCase s] - -wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] - -wordsOfString1(s,j) == - k := or/[i for i in j..SUB1(MAXINDEX(s)) | UPPER_-CASE_-P s.i] => - tailWords:= - UPPER_-CASE_-P s.(k+1) => - n:= or/[i for i in (k+2)..SUB1(MAXINDEX(s))|not UPPER_-CASE_-P s.i] - null n => [SUBSTRING(s,k,nil)] - n > k+1 => [SUBSTRING(s,k,n-k-1),:wordsOfString1(s,n-1)] - m := or/[i for i in (k+2)..SUB1(MAXINDEX(s)) | UPPER_-CASE_-P s.i] => - [SUBSTRING(s,k,m-k),:wordsOfString1(s,m)] - [SUBSTRING(s,k,nil)] - k > j+1 => [SUBSTRING(s,j,k-j),:tailWords] - tailWords - nil - -wordKeys s == - REMDUP [UPCASE s.0,:fn(s,1,-1,MAXINDEX s,nil)] where fn(s,i,lastKeyIndex,n,acc) == - i > n => acc - UPPER_-CASE_-P s.i => --- i = lastKeyIndex + 1 => fn(s,i + 1,i,n,[s.i,:rest acc]) - fn(s,i + 1,i,n,[s.i,:acc]) - fn(s,i + 1,lastKeyIndex,n,acc) - ---======================================================================= --- Augment Function Directories ---======================================================================= -add2WordFunctionTable fn == ---called from DEF - $functionTable and - null LASSOC(s := PNAME fn,HGET($functionTable,(key := UPCASE s.0))) => - HPUT($functionTable,key,[[s,:wordsOfString s],:HGET($functionTable,key)]) - ---======================================================================= --- Guess Function Name ---======================================================================= -findWords(word,table) == - $lastWord := word - $lastTable:= table - $totalWords:= nil - $countThreshold := $minThreshold - $lastMinimum := -1 - res := findApproximateWords(word,table) - if null res then - $countThreshold := $countThreshold + 2 - res := findApproximateWords(word,table) - $lastAlist := mySort res => --- $lastMinimum := CAR LAST $lastAlist --- $lastWords := wordSort CDAR $lastAlist --- $totalWords:= $lastWords --- $lastAlist := CDR $lastAlist --- $totalWords - $lastMinimum := CAAR $lastAlist - $lastWords := wordSort CDAR $lastAlist - $totalWords:= $lastWords - $lastAlist := CDR $lastAlist - $totalWords - $lastWords := nil - -wordSort u == REMDUP listSort(function GLESSEQP,u) - -more() == moreWords($lastWord,$lastTable) - -moreWords(word,table) == - $lastAlist => - $lastMinimum := CAR LAST pp $lastAlist - numberOfLastWords := #$lastWords - $lastWords := "append"/(ASSOCRIGHT $lastAlist) - if #$lastWords > numberOfLastWords then - trialLastAlist := - [p for p in $lastAlist | p.0 < $maxThreshold] - trialLastWords := "append"/(ASSOCRIGHT trialLastAlist) - if #trialLastWords > numberOfLastWords then - $lastWords := trialLastWords - $totalWords:= wordSort [:$lastWords,:$totalWords] - $lastAlist := nil - $totalWords - $countThreshold := $countThreshold + 2 - $lastAlist := findApproximateWords(word,table) - moreWords(word,table) - -findApproximateWords(word,table) == - count := $countThreshold - words:= wordsOfString word - upperWord:= UPCASE COPY word - n := #words - threshold:= - n = 1 => count - count+1 - - --first try to break up as list of words - alist:= nil - for i in 1..#words repeat - $penalty :local := (i = 1 => 0; 1) - wordAlist:= HGET(table,UPCASE (first words).0) - for [x,:wordList] in wordAlist repeat - k := findApproxWordList(words,wordList,n,threshold,#wordList) - k => - k := k + $penalty - k <= $lastMinimum => 'skip - alist := consAlist(k,x,alist) - - if i = 1 and null alist then - --no winners, so try flattening to upper case and checking again - wordSize := SIZE word - lastThreshold := MAX(threshold - 1,wordSize/2) - for [x,:.] in wordAlist repeat - k := deltaWordEntry(upperWord,UPCASE x) - k < lastThreshold => alist := consAlist(k,x,alist) - - rotateWordList words - - alist - -consAlist(x,y,alist) == - u := ASSOC(x,alist) => - RPLACD(u,[y,:CDR u]) - alist - [[x,y],:alist] - -findApproxWordList(words,wordList,n,threshold,w) == - val := findApproxWordList1(words,wordList,n,threshold,w) - null val => val ---pp [val,:wordList] - val - -findApproxWordList1(words,wordList,n,threshold,w) == - two := threshold - 2 - n = w => - k := findApproxSimple(words,wordList,threshold) => k - - n < 3 => false - threshold := threshold - 1 - sum := 0 --next, throw out one bad word - - badWord := false - for entry in wordList for part in words while sum < threshold repeat - k:= deltaWordEntry(part,entry) - k < two => sum:= sum + k - null badWord => badWord := true - sum := 1000 - sum < threshold => --- pp [2,sum,wordList] - sum + 2 - - n+1 = w => --assume one word is missing - sum := 0 - badWord := false - for entries in tails wordList for part in words - while sum < threshold repeat - entry := first entries - k:= deltaWordEntry(part,entry) - k < two => sum:= sum + k - null badWord => - badWord := true - entries := rest entries --skip this bad word - entry := first entries - k := deltaWordEntry(part,entry) - k < two => sum := sum + k - sum := 1000 - sum := 1000 - sum < threshold => --- pp [3,sum,wordList] - sum + 2 - false - n-1 = w => --assume one word too many - sum := 0 --here: KEEP it hard to satisfy - badWord := false - for entry in wordList for parts in tails words - while sum < threshold repeat - part := first parts - k:= deltaWordEntry(part,entry) - k < 2 => sum:= sum + k - null badWord => - badWord := true - parts := rest parts --skip this bad word - part := first parts - k := deltaWordEntry(part,entry) - k < 2 => sum := sum + k - return (sum := 1000) - return (sum := 1000) - sum < threshold => --- pp [4,sum,wordList] - $penalty = 1 => sum - sum + 1 - false - false - -findApproxSimple(words,wordList,threshold) == - sum := 0 - --first try matching words in order - for entry in wordList for part in words while sum < threshold repeat - sum:= sum + deltaWordEntry(part,entry) - sum < threshold => --- pp ['"--->",sum,:wordList] - sum - nil - -rotateWordList u == - v := u - p := CAR v - while QCDR v repeat - RPLACA(v,CADR v) - v := QCDR v - RPLACA(v,p) - u - -deltaWordEntry(word,entry) == - word = entry => 0 - word.0 ^= entry.0 => 1000 - #word > 2 and stringPrefix?(word,entry) => 1 - ABS(diff := SIZE word - SIZE entry) > 4 => 1000 - canForgeWord(word,entry) - ---+ Note these are optimized definitions below-- see commented out versions ---+ to understand the algorithm -canForgeWord(word,entry) == - forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0) - -forge(word,w,W,entry,e,E,n) == - w > W => - e > E => n - QSADD1 QSPLUS(E-e,n) - e > E => QSADD1 QSPLUS(W-w,n) - word.w = entry.e => forge(word,w+1,W,entry,e+1,E,n) - w=W or e=E => forge(word,w+1,W,entry,e+1,E,QSADD1 n) - word.w=entry.(e+1) => - word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,QSADD1 n) - forge(word,w+1,W,entry,e+2,E,QSADD1 n) - word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,QSADD1 n) - - (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => - --if word is long, can we delete chars to match 2 consective chars - deltaW >= deltaE and - (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) - and word.(k+1) = entry.(e+1) => - forge(word,k+2,W,entry,e+2,E,QSPLUS(k-w,n)) - deltaW <= deltaE and - --if word is short, can we insert chars so as to match 2 consecutive chars - (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) - and word.(w+1) = entry.(k+1) => - forge(word,w+2,W,entry,k+2,E,QSPLUS(n,k-e)) - forge(word,w+1,W,entry,e+1,E,QSADD1 n) - --check for two consecutive matches down the line - forge(word,w+1,W,entry,e+1,E,QSADD1 n) - ---+ DO NOT REMOVE DEFINITIONS BELOW which explain the algorithm ---+ canForgeWord(word,entry) ==-- ---+ [d,i,s,t] := forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0,0,0,0) ---+ --d=deletions, i=insertions, s=substitutions, t=transpositions ---+ --list is formed only for tuning purposes-- remove later on ---+ d + i + s + t - ---+forge(word,w,W,entry,e,E,d,i,s,t) == ---+ w > W => ---+ e > E => [d,i,s,t] ---+ [d,E-e+i+1,s,t] ---+ e > E => [W-w+d+1,i,s,t] ---+ word.w = entry.e => forge(word,w+1,W,entry,e+1,E,d,i,s,t) ---+ w=W or e=E => forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) ---+ word.w=entry.(e+1) => ---+ word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,d,i,s,t+1) ---+ forge(word,w+1,W,entry,e+2,E,d,i+1,s,t) ---+ word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,d+1,i,s,t) ---+ ---+ (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => ---+ --if word is long, can we delete chars to match 2 consective chars ---+ deltaW >= deltaE and ---+ (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) ---+ and word.(k+1) = entry.(e+1) => ---+ forge(word,k+2,W,entry,e+2,E,d+k-w,i,s,t) ---+ deltaW <= deltaE and ---+ --if word is short, can we insert chars so as to match 2 consecutive chars ---+ (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) ---+ and word.(w+1) = entry.(k+1) => ---+ forge(word,w+2,W,entry,k+2,E,d,i+k-e,s,t) ---+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) ---+ --check for two consecutive matches down the line ---+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) - -mySort u == listSort(function GLESSEQP,u) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3