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 / skcontrl.icn < prev    next >
Text File  |  2000-07-29  |  3KB  |  151 lines
  1. ############################################################################
  2. #
  3. #    Name:    skcontrl.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. # Control procedures
  19. #
  20.  
  21. #
  22. # Initialize
  23. #
  24. # List entries are described in skfun.icn.
  25. #
  26. procedure InitControl()
  27.    DefFunction([
  28.       APPLY,"oneOrMore",
  29.       CALL_WITH_CURRENT_CONTINUATION,
  30.       CALL_WITH_CURRENT_CONTINUATION,"CALL/CC",
  31.       FOR_EACH,"oneOrMore",
  32.       FORCE,
  33.       MAP,"twoOrMore",
  34.       PROCEDURE_P])
  35.    return
  36. end
  37.  
  38.  
  39. #
  40. # Control features
  41. #
  42.  
  43. procedure PROCEDURE_P(x)
  44.    return (type(x) ==
  45.      ("Lambda" | "Function" | "Syntax" | "Macro"),T) | F
  46. end
  47.  
  48. procedure APPLY(fcn,arg[])
  49.    local last,argList
  50.    last := pull(arg)
  51.    argList := LList!arg
  52.    LLRest(\argList) | argList := last
  53.    return Apply(fcn,argList)
  54. end
  55.  
  56. procedure MAP(fcn,lsts[])
  57.    local arg,result
  58.    result := LLNull
  59.    repeat {
  60.       arg := MapArgs(lsts) | break
  61.       result := LLPair(Apply(fcn,arg),result) | fail
  62.       }
  63.    return LLInvert(result)
  64. end
  65.  
  66. procedure MapArgs(lsts)
  67.    local arg,i,x
  68.    arg := LLNull
  69.    every i := 1 to *lsts do {
  70.       x := lsts[i]
  71.       if /x then fail
  72.       arg := LLPair(LLFirst(x),arg)
  73.       lsts[i] := LLRest(x)
  74.       }
  75.    return LLInvert(arg)
  76. end
  77.  
  78. procedure FOR_EACH(fcn,lsts[])
  79.    local arg,result
  80.    result := F
  81.    repeat {
  82.       arg := MapArgs(lsts) | break
  83.       result := Apply(fcn,arg) | fail
  84.       }
  85.    return result
  86. end
  87.  
  88. procedure FORCE(promise)
  89.    return Force(promise)
  90. end
  91.  
  92. procedure Force(promise)
  93.    local x
  94.    return {
  95.       if \promise.ready then
  96.      promise.result
  97.       else {
  98.      x := Apply(promise.proc,LLNull) | fail
  99.      if \promise.ready then
  100.         promise.result
  101.      else {
  102.         promise.ready := "true"
  103.         .(promise.result := x)
  104.         }
  105.      }
  106.       }
  107. end
  108.  
  109. procedure CALL_WITH_CURRENT_CONTINUATION(func)
  110.    local continuationProc,checkObj
  111.    static invokeContinuation,continuationExpr
  112.    initial {
  113.       invokeContinuation :=
  114.      Function(InvokeContinuation,"InvokeContinuation",3,3)
  115.       continuationExpr :=
  116.      [LList("VALUE"),
  117.         LList("INVOKE-CONTINUATION","CONT-LEVEL","VALUE","CHECK-OBJ")]
  118.       }
  119.    PushFrame()
  120.    DefVar("CONT-LEVEL",&level)
  121.    DefVar("INVOKE-CONTINUATION",invokeContinuation)
  122.    DefVar("CHECK-OBJ",checkObj := CurrentEnv)
  123.    #
  124.    # (define continuationProc
  125.    #   (lambda (value) (invoke-continuaton cont-level value check-obj)))
  126.    #
  127.    continuationProc := LAMBDA!continuationExpr
  128.    #
  129.    DiscardFrame()
  130.    return Apply(func,LLPair(continuationProc)) |
  131.       EscapeCheck(&level,checkObj)
  132. end
  133.  
  134. procedure InvokeContinuation(data[])
  135.    EscapeData := data
  136.    fail
  137. end
  138.  
  139. procedure EscapeCheck(level,checkObj)
  140.    local escapeData
  141.    if \EscapeData & (/level | EscapeData[1] = level) then {
  142.       escapeData := EscapeData
  143.       EscapeData := &null
  144.       if /level | checkObj ~=== escapeData[3] then
  145.      return Error(CALL_WITH_CURRENT_CONTINUATION,
  146.         "escape procedure no longer valid (expires when its call/cc returns)")
  147.       FailProc := &null
  148.       return escapeData[2]
  149.       }
  150. end
  151.