home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / icon / dos / src / tests / pdco.icn < prev    next >
Text File  |  1992-02-09  |  4KB  |  180 lines
  1. #
  2. #          D E F I N E D   C O N T R O L   O P E R A T I O N S
  3. #
  4.  
  5. #  This program illustrates how programmer-control operations can be
  6. #  implemented in Icon using co-expressions and the p{ ... }
  7. #  syntax that facilitates their use.
  8.  
  9. procedure main()
  10.    if not(&features == "co-expressions") then
  11.       stop("co-expressions not supported")
  12.    write(Seqimage{1 to 10})
  13.    write(Seqimage{&fail})
  14.    write(Seqimage{(1 to 10 by 2) | (10 to 1 by -2)})
  15.    write(Seqimage{!"abc" || !"xy"})
  16.    write(Seqimage{Seqimage | main})
  17.    every write(Galt{1 to 10,!"abcd",1 to 10})
  18.    write(Seqimage{star("abc") \ 10})
  19.    write(Seqimage{1 to 50,5})
  20.    write("---")
  21.    every write(Limit{1 to 100,3})
  22.    write("---")
  23.    every write(Ranseq{!"abcd",1 to 10})
  24.    every Parallel{|write,!"abcd",1 to 10}
  25.    every Allpar{|write,!"abcd",1 to 10} \ 20
  26.    every Rotate{|write,!"abcd",1 to 10} \ 20
  27. end
  28.  
  29. procedure star(s)
  30.    suspend "" | (star(s) || !s)
  31. end
  32.  
  33. procedure Galt(a)
  34.    local e
  35.    every e := !a do suspend |@e
  36. end
  37.  
  38. procedure Limit(a)
  39.    local i, x
  40.    while i := @a[2] do {
  41.       a[1] := ^a[1]
  42.       every 1 to i do
  43.          if x := @a[1] then suspend x
  44.          else break
  45.       }
  46. end
  47.  
  48. procedure Ranseq(a)
  49.    local x
  50.    while x := @?a do suspend x
  51. end
  52.  
  53. procedure Seqimage(L)
  54.    local s
  55.    s := ""
  56.    while s ||:= ", " || image(@L[1])
  57.    return "{" || s[3:0] || "}" | "{}"
  58. end
  59.  
  60. procedure Allpar(a)
  61.    local i, x, done
  62.    x := list(*a)
  63.    done := list(*a,1)
  64.    every i := 1 to *a do x[i] := @a[i] | fail
  65.    repeat {
  66.       suspend Call(x)
  67.       every i := 1 to *a do
  68.          if done[i] = 1 then ((x[i] := @a[i]) | (done[i] := 0))
  69.       if not(!done = 1) then fail
  70.        }
  71. end
  72.  
  73. procedure Call(a)
  74.    suspend case *a of {
  75.       1 : a[1]()
  76.       2 : a[1](a[2])
  77.       3 : a[1](a[2],a[3])
  78.       4 : a[1](a[2],a[3],a[4])
  79.       5 : a[1](a[2],a[3],a[4],a[5])
  80.       6 : a[1](a[2],a[3],a[4],a[5],a[6])
  81.       7 : a[1](a[2],a[3],a[4],a[5],a[6],a[7])
  82.       8 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8])
  83.       9 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9])
  84.       10 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],a[10])
  85.       default :  stop("Call : too many args.")
  86.       }
  87. end
  88.  
  89. procedure Extract(a)
  90.    local i, j, n, x
  91.    x := list(*a/2)
  92.    repeat {
  93.       i := 1
  94.       while i < *a do {
  95.          n := @a[i] | fail
  96.          every 1 to n do
  97.             x[(i + 1)/2] := @a[i + 1] | fail
  98.          a[i + 1] := ^a[i + 1]
  99.          i +:= 2
  100.          }
  101.       suspend Call(x)
  102.       }
  103. end
  104.  
  105. procedure Lifo(a)
  106.    local i, x, ptr
  107.    x := list(*a)
  108.    ptr := 1
  109.    repeat {
  110.       repeat
  111.          if x[ptr] := @a[ptr]
  112.          then {
  113.             ptr +:= 1
  114.             (a[ptr] := ^a[ptr]) |
  115.             break
  116.             }
  117.          else if (ptr -:=  1) = 0
  118.               then fail
  119.       suspend Call(x)
  120.       ptr := *a
  121.       }
  122. end
  123.  
  124. procedure Parallel(a)
  125.    local i, x
  126.    x := list(*a)
  127.    repeat {
  128.       every i := 1 to *a do
  129.          x[i] := @a[i] | fail
  130.       suspend Call(x)
  131.       }
  132. end
  133.  
  134. procedure Reverse(a)
  135.    local i, x, ptr
  136.    x := list(*a)
  137.    ptr := *a
  138.    repeat {
  139.       repeat
  140.          if x[ptr] := @a[ptr]
  141.          then {
  142.             ptr -:= 1
  143.             (a[ptr] := ^a[ptr]) |
  144.             break
  145.             }
  146.          else if (ptr +:= 1) > *a
  147.               then fail
  148.       suspend Call(x)
  149.       ptr := 1
  150.       }
  151. end
  152.  
  153. procedure Rotate(a)
  154.    local i, x, done
  155.    x := list(*a)
  156.    done := list(*a,1)
  157.    every i := 1 to *a do x[i] := @a[i] | fail
  158.    repeat {
  159.       suspend Call(x)
  160.       every i := 1 to *a do
  161.          if not(x[i] := @a[i]) then {
  162.             done[i] := 0
  163.             if !done = 1 then {
  164.                a[i] := ^a[i]
  165.                x[i] := @a[i] | fail
  166.                }
  167.             else fail
  168.             }
  169.         }
  170. end
  171.  
  172. procedure Simple(a)
  173.    local i, x
  174.    x := list(*a)
  175.    every i := 1 to *a do
  176.       x[i] := @a[i] | fail
  177.    return Call(x)
  178. end
  179.  
  180.