path: root/src/interp/g-boot.boot

-- 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