diff options
Diffstat (limited to 'src/interp/g-boot.boot.pamphlet')
| -rw-r--r-- | src/interp/g-boot.boot.pamphlet | 485 |
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} |