Revert commits to the wrong tree.

1 files changed, 0 insertions, 459 deletions

diff --git a/src/interp/g-boot.boot b/src/interp/g-boot.boot
deleted file mode 100644
index 11c45a29..00000000
--- a/src/interp/g-boot.boot
+++ /dev/null
@@ -1,459 +0,0 @@
--- 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