home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / ICON.SCM < prev    next >
Text File  |  1992-06-18  |  2KB  |  68 lines
  1.  
  2. ; For Icon's alternation operator, a | b, we write (either a b).
  3.  
  4. (define-syntax either
  5.   (syntax-rules ()
  6.     ((either x) x)
  7.     ((either x y ...)
  8.      (%either (lambda () x) (lambda () (either y ...))))))
  9.  
  10. (define (%either thunk1 thunk2)        ;Macro axuiliary
  11.   (let ((save *fail*))
  12.     ((call-with-current-continuation
  13.        (lambda (k)
  14.      (set! *fail*
  15.            (lambda ()
  16.          (set! *fail* save)
  17.          (k thunk2)))
  18.      thunk1)))))
  19.  
  20. ; (accumulate a) returns a list of all the possible values of the
  21. ; expression a.  Prolog calls this "bagof"; I forget what Icon calls it.
  22.  
  23. (define-syntax accumulate
  24.   (syntax-rules ()
  25.     ((accumulate x) (%accumulate (lambda () x)))))
  26.  
  27. (define (%accumulate thunk)
  28.   (let ((results '()))
  29.     (either (begin (set! results (cons (thunk) results))
  30.            (fail))
  31.         (reverse results))))
  32.  
  33.  
  34. ; Generate all the members of list l.  E.g.
  35. ;   (accumulate (+ (member-of '(10 20 30)) (member-of '(1 2 3))))
  36. ;     => '(11 12 13 21 22 23 31 32 33)
  37.  
  38. (define (member-of l)
  39.   (if (null? l)
  40.       (fail)
  41.       (either (car l) (member-of (cdr l)))))
  42.  
  43.  
  44. ; Internal variable representing the failure stack.
  45.  
  46. (define (fail) (*fail*))
  47.  
  48. (define *fail* (lambda () (error "You didn't do (init).")))
  49.  
  50.  
  51. ; Crufty initialization hack that allows you to type failing
  52. ; expressions at the R-E-P loop (if there is an R-E-P loop).  E.g. try
  53. ; evaluating the sequence
  54. ;  (either 1 2)
  55. ;  (fail)
  56. ;  (+ (fail) 10)
  57.  
  58. (define (init)
  59.   (call-with-current-continuation
  60.     (lambda (k)
  61.       (set! *fail* (lambda () (k 'failed)))
  62.       'initialized)))
  63.  
  64. (display "Type (init) at the read-eval-print loop.")
  65. (newline)
  66.  
  67.  
  68.