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 / skextra.icn < prev    next >
Text File  |  2000-07-29  |  3KB  |  178 lines
  1. ############################################################################
  2. #
  3. #    Name:    skextra.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. # Some additional stuff not in the standard
  19. #
  20.  
  21. #
  22. # Initialize
  23. #
  24. # List entries are described in skfun.icn.
  25. #
  26. procedure InitExtra()
  27.    #
  28.    # Functions
  29.    #
  30.    DefFunction([
  31.       ADD1,
  32.       ATOM_P,
  33.       BREAK,0,
  34.       BREAK_LEVEL,0,
  35.       EVAL,1,2,
  36.       QUIT,0,1,
  37.       READ_LINE,0,1,
  38.       RESUME,0,1,
  39.       SUB1,
  40.       TOP,0,
  41.       TRACE,&null,
  42.       UNTRACE,&null])
  43.    #
  44.    # Syntaxes
  45.    #
  46.    DefSyntax([
  47.       DEFINE_MACRO,"twoOrMore",
  48.       ITRACE,
  49.       ITRACEOFF,0,
  50.       ITRACEON,0,
  51.       REPEAT,"oneOrMore",
  52.       TRACE_ALL,0,
  53.       UNLESS,"oneOrMore",
  54.       WHEN,"oneOrMore"])
  55.    return
  56. end
  57.  
  58. procedure EVAL(ex,env)
  59.    return Eval(ex,env)
  60. end
  61.  
  62. procedure QUIT(exitCode)
  63.    exit(exitCode)
  64. end
  65.  
  66. procedure WHEN(test,body[])
  67.    return if F ~=== (Eval(test) | fail)\1 then
  68.       EvalSeq(LList!body) | fail
  69. end
  70.  
  71. procedure UNLESS(test,body[])
  72.    return if F === (Eval(test) | fail)\1 then
  73.       EvalSeq(LList!body) | fail
  74. end
  75.  
  76. procedure REPEAT(count,body[])
  77.    local result
  78.    body := LList!body
  79.    every 1 to count do
  80.       result := EvalSeq(body) | fail
  81.    return result
  82. end
  83.  
  84. procedure ATOM_P(arg)
  85.    return (LLIsNotPair(arg),T) | F
  86. end
  87.  
  88. procedure BREAK()
  89.    local result
  90.    BreakLevel +:= 1
  91.    result := ReadEvalPrint((InputPortStack[1].file | &input)\1) | Failure
  92.    BreakLevel -:= 1
  93.    return Failure ~=== result
  94. end
  95.  
  96. procedure BREAK_LEVEL()
  97.    return BreakLevel
  98. end
  99.  
  100. procedure RESUME(value)
  101.    Resume := Value(\value | F)
  102.    fail
  103. end
  104.  
  105. procedure TOP()
  106.    Resume := "top"
  107.    fail
  108. end
  109.  
  110. procedure TRACE(funcs[])
  111.    local fn,result,element
  112.    if *funcs = 0 then {
  113.       result := LLNull
  114.       every result := LLPair((!sort(TraceSet)).name,result)
  115.       return LLInvert(result)
  116.       }
  117.    else every element := !funcs do {
  118.       fn := Eval(element) | fail
  119.       fn.traced := "true"
  120.       insert(TraceSet,fn)
  121.       return NIL
  122.       }
  123. end
  124.  
  125. procedure UNTRACE(funcs[])
  126.    local fn,element
  127.    if *funcs = 0 then {
  128.       FTrace := &null
  129.       every (!TraceSet).traced := &null
  130.       }
  131.    else every element := !funcs do {
  132.       fn := Eval(element) | fail
  133.       fn.traced := &null
  134.       delete(TraceSet,fn)
  135.       }
  136.    return NIL
  137. end
  138.  
  139. procedure ITRACEON()
  140.    return (&trace := -1,T)
  141. end
  142.  
  143. procedure ITRACEOFF()
  144.    return (&trace := 0,F)
  145. end
  146.  
  147. procedure ITRACE(expr)
  148.    local value
  149.    &trace := -1
  150.    value := Eval(expr) | Failure
  151.    &trace := 0
  152.    return Failure ~=== value
  153. end
  154.  
  155. procedure TRACE_ALL()
  156.    return FTrace := T
  157. end
  158.  
  159. procedure DEFINE_MACRO(arg)
  160.    local sym,value
  161.    return Error(DEFINE_MACRO,"Not implemented for now")
  162. ##    return DEFINE(arg,,Macro)
  163. end
  164.  
  165. procedure ADD1(n)
  166.    return n + 1
  167. end
  168.  
  169. procedure SUB1(n)
  170.    return n - 1
  171. end
  172.  
  173. procedure READ_LINE(port)
  174.    local f
  175.    f := (\port | InputPortStack[1]).file
  176.    return String(read(f)) | EOFObject
  177. end
  178.