home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / packs / skeem / skbasic.icn < prev    next >
Text File  |  2000-07-29  |  8KB  |  351 lines
  1. ############################################################################
  2. #
  3. #    Name:    skbasic.icn
  4. #
  5. #    Title:    Scheme in Icon
  6. #
  7. #    Author: Bob Alexander
  8. #
  9. #    Date:    March 23, 1995
  10. #
  11. #    Description: see skeem.icn
  12. #
  13. ############################################################################
  14.  
  15. #
  16. # skeem -- Scheme in Icon
  17. #
  18. # Miscellaneous basic syntaxes and procedures:
  19. #
  20. #     Literal expressions
  21. #     Lambda expressions
  22. #     Conditionals
  23. #     Assignments
  24. #     Derived expression types
  25. #     Binding constructs
  26. #     Sequencing
  27. #     Iteration
  28. #     Delayed evaluation
  29. #     Quasiquotation
  30. #     Definitions
  31. #
  32.  
  33. #
  34. # Initialize
  35. #
  36. # List entries are described in skfun.icn.
  37. #
  38. procedure InitBasic()
  39.    DefSyntax([
  40.       AND,&null,
  41.       BEGIN,"oneOrMore",
  42.       CASE,"twoOrMore",
  43.       COND,1,&null,
  44.       DEFINE,"twoOrMore",
  45.       DELAY,
  46.       DO,"twoOrMore",
  47.       IF,2,3,
  48.       LAMBDA,"oneOrMore",
  49.       LET,"twoOrMore",
  50.       LETREC,"twoOrMore",
  51.       LET_STAR_,"twoOrMore","LET*",
  52.       OR,&null,
  53.       QUASIQUOTE,
  54.       QUOTE,
  55.       SET_BANG,2])
  56.    return
  57. end
  58.  
  59.  
  60. #
  61. # Literal expressions
  62. #
  63.  
  64. procedure QUOTE(value)
  65.    return value
  66. end
  67.  
  68.  
  69. #
  70. # Lambda expressions
  71. #
  72.  
  73. procedure LAMBDA(argList,body[])
  74.    local argListMin,argListMax
  75.    if LLIsList(argList) then {
  76.       argListMin := LLLength(argList)
  77.       argListMax := if LLIsNull(LLRest(LLLastPair(argList))) then argListMin
  78.       }
  79.    else argListMin := 0
  80.    return Lambda(LList!push(body,argList),,argListMin,argListMax,CurrentEnv)
  81. end
  82.  
  83.  
  84. #
  85. # Conditionals
  86. #
  87.  
  88. procedure IF(test,clause[])
  89.    test := Eval(test) | fail
  90.    return Eval(
  91.       if F ~=== test then clause[1]
  92.       else (clause[2] | (return F))\1)
  93. end
  94.  
  95.  
  96. #
  97. # Assignments
  98. #
  99.  
  100. procedure SET_BANG(var,value)
  101.    return SetVar(var,Eval(value))
  102. end
  103.  
  104.  
  105. #
  106. # Derived expression types
  107. #
  108.  
  109. procedure COND(body[])
  110.    local clause,test,second
  111.    every clause := !body do {
  112.       second := LLSecond(clause) | return Error(COND,"ill-formed clause")
  113.       test := LLFirst(clause)
  114.       if test === "ELSE" | (test := F ~=== (Eval(test) | fail)\1) then {
  115.      return {
  116.         if second === "=>" then
  117.            Eval(LList(LLThird(clause),LList("QUOTE",test)))
  118.         else
  119.            EvalSeq(LLRest(clause))
  120.         }
  121.      }
  122.       }
  123.    return F
  124. end
  125.  
  126. procedure CASE(key,body[])
  127.    local clause,dataList,exprs
  128.    key := Eval(key) | fail
  129.    every clause := !body do {
  130.       \(exprs := LLRest(clause)) | return Error(CASE,"ill-formed clause")
  131.       dataList := LLFirst(clause)
  132.       if dataList === "ELSE" | Eqv(key,LLElements(dataList)) then
  133.      return EvalSeq(exprs)
  134.       }
  135.    return F
  136. end
  137.  
  138. procedure AND(arg[])
  139.    local result,element
  140.    result := T
  141.    every element := !arg do {
  142.       result := Eval(element) | fail
  143.       if result === F then break
  144.       }
  145.    return result
  146. end
  147.  
  148. procedure OR(arg[])
  149.    local result,element
  150.    result := F
  151.    every element := !arg do {
  152.       result := Eval(element) | fail
  153.       if result ~=== F then break
  154.       }
  155.    return result
  156. end
  157.  
  158.  
  159. #
  160. # Binding constructs
  161. #
  162.  
  163. procedure LET(arg[])
  164.    local result
  165.    result := EvalSeq(Let1(arg)) | fail
  166.    DiscardFrame()
  167.    return result
  168. end
  169.  
  170. procedure Let1(arg)
  171.    local assignList,init,var,argList,loop,body
  172.    assignList := []
  173.    if SymbolP(arg[1]) then {
  174.       var := get(arg)
  175.       argList := LLNull
  176.       every argList := LLPair(LLFirst(LLElements(arg[1])),argList)
  177.       }
  178.    every init := LLElements(get(arg)) do
  179.       put(assignList,LLFirst(init),Eval(LLSecond(init))) | fail
  180.    PushFrame()
  181.    body := LList!arg
  182.    if \var then {
  183.       loop := LAMBDA!push(arg,LLInvert(argList)) | fail
  184.       loop.name := var
  185.       DefVar(var,loop)
  186.       }
  187.    while DefVar(get(assignList),get(assignList))
  188.    return body
  189. end
  190.  
  191. procedure LET_STAR_(inits,body[])
  192.    local init,result
  193.    PushFrame()
  194.    every init := LLElements(inits) do
  195.       DefVar(LLFirst(init),Eval(LLSecond(init))) | {DiscardFrame(); fail}
  196.    result := EvalSeq(LList!body) | {DiscardFrame(); fail}
  197.    DiscardFrame()
  198.    return result
  199. end
  200.  
  201. procedure LETREC(inits,body[])
  202.    local init,result
  203.    PushFrame()
  204.    every init := LLElements(inits) do
  205.       DefVar(LLFirst(init),F)
  206.    every init := LLElements(inits) do
  207.       SetVar(LLFirst(init),Eval(LLSecond(init))) | {DiscardFrame(); fail}
  208.    result := EvalSeq(LList!body) | {DiscardFrame(); fail}
  209.    DiscardFrame()
  210.    return result
  211. end
  212.  
  213.  
  214.  
  215. #
  216. # Sequencing
  217. #
  218.  
  219. procedure BEGIN(sequence[])
  220.    return EvalSeq(LList!sequence)
  221. end
  222.  
  223.  
  224. #
  225. # Iteration
  226. #
  227.  
  228. procedure DO(inits,test,body[])
  229.    local testExpr,init,update,result,initList,initEnv,commandEnv
  230.    testExpr := LLFirst(test) | return Error(DO,"missing test")
  231.    initList := []
  232.    every init := LLElements(inits) do
  233.       put(initList,LLFirst(init),Eval(LLSecond(init))) | fail
  234.    PushFrame()
  235.    while DefVar(get(initList),get(initList))
  236.    body := LList!body
  237.    while F === (Eval(testExpr) | {DiscardFrame(); fail})\1 do {
  238.       if \body then EvalSeq(body) | {DiscardFrame(); fail}
  239.       every init := LLElements(inits) do
  240.      if update := LLThird(init) then
  241.         put(initList,LLFirst(init),Eval(update)) | {DiscardFrame(); fail}
  242.       while SetVar(get(initList),get(initList))
  243.       }
  244.    result := EvalSeq(LLRest(test)) | {DiscardFrame(); fail}
  245.    DiscardFrame()
  246.    return result
  247. end
  248.  
  249.  
  250. #
  251. # Delayed evaluation
  252. #
  253.  
  254. procedure DELAY(expr)
  255.    return Promise(Lambda(LList(LLNull,expr),,0,0,CurrentEnv))
  256. end
  257.  
  258.  
  259. #
  260. # Quasiquotation
  261. #
  262.  
  263. procedure QUASIQUOTE(L)
  264.    return QuasiQuote(L,0)
  265. end
  266.  
  267. invocable "!":1,"|||":2
  268.  
  269. procedure QuasiQuote(x,nest)
  270.    static vecElementGen,vecElementConcat
  271.    initial {
  272.       vecElementGen := proc("!",1)
  273.       vecElementConcat := proc("|||",2)
  274.       }
  275.    return {
  276.       if LLIsList(x) then
  277.      QQExpand(x,nest,LLNull,LLPairs,LLPut,LLAppend,1,LLFirst,LLRest)
  278.       else if VectorP(x) then
  279.      QQExpand(x,nest,[],vecElementGen,put,vecElementConcat,LLToList,1,Fail)
  280.       else
  281.      x
  282.       }
  283. end
  284.  
  285. procedure Fail()
  286. end
  287.  
  288. procedure QQExpand(lst,nest,result,elementGen,elementPut,elementConcat,
  289.       createFromLList,getElement,getDot)
  290.    local elt,thunk,dot
  291.    every thunk := elementGen(lst) do {
  292.       elt := getElement(thunk)
  293.       result := {
  294.      if LLIsPair(elt) then case LLFirst(elt) of {
  295.         "UNQUOTE":
  296.            elementPut(result,
  297.           if nest = 0 then
  298.              Eval(LLSecond(elt)) | fail
  299.           else
  300.              LList("UNQUOTE",QuasiQuote(LLSecond(elt),nest - 1)))
  301.         "UNQUOTE-SPLICING":
  302.            if nest = 0 then
  303.           elementConcat(result,
  304.             createFromLList(Eval(LLSecond(elt)))) | fail
  305.            else
  306.           elementPut(result,
  307.             LLPair("UNQUOTE-SPLICING",
  308.             QuasiQuote(LLSecond(elt),nest - 1)))
  309.         "QUASIQUOTE":
  310.            elementPut(result,LList("QUASIQUOTE",
  311.              QuasiQuote(LLSecond(elt),nest + 1)))
  312.         default:
  313.            elementPut(result,QuasiQuote(elt,nest))
  314.         }
  315.      else if VectorP(elt) & elt[1] === "QUASIQUOTE" then
  316.         elementPut(result,["QUASIQUOTE",QuasiQuote(elt[2],nest + 1)])
  317.      else if elt === "UNQUOTE" then {
  318.         (LLRest(LLLastPair(result)) | result)\1 :=
  319.            if nest = 0 then
  320.           Eval(LLFirst(LLRest(thunk))) | fail
  321.            else
  322.           LList("UNQUOTE",QuasiQuote(LLFirst(LLRest(thunk)),nest - 1))
  323.         return result
  324.         }
  325.      else elementPut(result,QuasiQuote(elt,nest))
  326.      }
  327.       }
  328.    if dot := \getDot(thunk) then
  329.       LLRest(result) := QuasiQuote(dot,nest)
  330.    return result
  331. end
  332.  
  333.  
  334. #
  335. # Definitions
  336. #
  337.  
  338. procedure DEFINE(sym,body[])
  339.    local value
  340.    if LLIsPair(sym) then {
  341.       # (define (f x) ...) -> (define f (lambda (x) ...))
  342.       value := LAMBDA!push(body,LLRest(sym)) | fail
  343.       sym := LLFirst(sym)
  344.       }
  345.    else value := Eval(body[1]) | fail
  346.    if type(value) == ("Lambda" | "Macro") then
  347.       /value.name := sym
  348.    DefVar(sym,value)
  349.    return sym
  350. end
  351.