aboutsummaryrefslogtreecommitdiff
path: root/src/interp/g-boot.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/g-boot.boot.pamphlet')
-rw-r--r--src/interp/g-boot.boot.pamphlet485
1 files changed, 485 insertions, 0 deletions
diff --git a/src/interp/g-boot.boot.pamphlet b/src/interp/g-boot.boot.pamphlet
new file mode 100644
index 00000000..63a7c00a
--- /dev/null
+++ b/src/interp/g-boot.boot.pamphlet
@@ -0,0 +1,485 @@
+\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}
+<<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.
+
+@
+<<*>>=
+<<license>>
+
+)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}