fork download
copy 
  1. ; destructuring-bind
  2.  
  3. (define-syntax bind (lambda (stx) ; (bind pattern values body ...)
  4.   ; Pattern is a possibly-nested list of symbols, values is a list of items of
  5.   ; the same "shape" as pattern, and body is a non-empty sequence of expressions.
  6.   ; The bind macro executes the body expressions in an environment with each
  7.   ; value let-bound to the corresponding symbol. Writing "& x" at the end of the
  8.   ; pattern list causes the remaining values to be bound to x in a list. Symbol
  9.   ; "_" in the pattern matches the corresponding value but causes no binding.
  10.   ; Extra values are silently ignored, missing values cause an error. Examples:
  11.   ;     (bind (a b c) '(1 2 3) (list c b a)) => (3 2 1)
  12.   ;     (bind (a b c) '(1 2 3 4) (list c b a)) => (3 2 1)
  13.   ;     (bind (a b c) '(1 2) (list c b a)) => causes an error
  14.   ;     (bind (a b (c d)) '(1 2 (3 4)) (list d c b a)) => (4 3 2 1)
  15.   ;     (bind (a b & c) '(1 2 3 4) (list c b a)) => ((3 4) 2 1)
  16.   ;     (bind (a _ c) '(1 2 3) (list c a)) => (3 1)
  17.   ;     (let ((x 3)) (bind (a b c) '(1 (+ 1 1) x) (list c b a))) => (x (+ 1 1) 1)
  18.   ;     (let ((x 3)) (bind (a b c) `(1 ,(+ 1 1) ,x) (list c b a))) => (3 2 1)
  19.   ; As an example, the macro-expression (bind (a b c) '(1 2 3) (list c b a))
  20.   ; expands to (let ((a 1)) (let ((b 2)) (let ((c 3)) (list c b a)))). Similar to
  21.   ; Common Lisp destruturing-bind or many "match" macro libraries in Scheme.
  22.   (define (underscore? x) (and (identifier? x) (free-identifier=? x (syntax _))))
  23.   (syntax-case stx (&)
  24.     ((bind () vals body ...) ; end of pattern, ignore extra values
  25.       (syntax (begin body ...)))
  26.     ((bind (& pat) vals body ...) ; rest pattern, collect remaining values
  27.       (syntax (let ((pat vals)) body ...)))
  28.     ((bind (underscore) vals body ...) ; non-binding pattern at end
  29.       (underscore? (syntax underscore)) (syntax (begin body ...)))
  30.     ((bind (underscore pat ...) vals body ...) ; non-binding pattern not at end
  31.       (underscore? (syntax underscore))
  32.         (syntax (bind (pat ...) (cdr vals) body ...)))
  33.     ((bind ((nest ...) pat ...) vals body ...) ; nested pattern
  34.       (syntax (bind (pat ...) (cdr vals) (bind (nest ...) (car vals) body ...))))
  35.     ((bind (pat) vals body ...) ; last binding in pattern
  36.       (syntax (let ((pat (car vals))) body ...)))
  37.     ((bind (pat1 pat2 ...) vals body ...) ; more bindings in pattern
  38.       (syntax (let ((pat1 (car vals))) (bind (pat2 ...) (cdr vals) body ...)))))))
  39.  
  40.  (define queue list)
  41.  
  42. (define empty (queue '() 0 (delay '()) 0 '()))
  43. (define (empty? q) (bind (_ lenf _ _ _) q (zero? lenf)))
  44.  
  45. (define (checkw q) (bind (w lenf f lenr r) q
  46.   (if (null? w) (queue (force f) lenf f lenr r) q)))
  47. (define (check q) (bind (w lenf f lenr r) q
  48.   (if (< lenr lenf) (checkw q)
  49.     (let ((fprime (force f)))
  50.       (checkw (queue fprime (+ lenf lenr)
  51.                      (delay (append fprime (reverse r))) 0 '()))))))
  52.  
  53. (define (snoc q x) (bind (w lenf f lenr r) q
  54.   (check (queue w lenf f (+ lenr 1) (cons x r)))))
  55.  
  56. (define (head q) (bind (w _ _ _ _) q
  57.   (if (null? w) (error 'head "empty queue") (car w))))
  58. (define (tail q) (bind (w lenf f lenr r) q
  59.   (if (null? w) (error 'tail "empty queue")
  60.     (check (queue (cdr w) (- lenf 1) (delay (cdr (force f))) lenr r)))))
  61.  
  62. (define q empty)
  63. (set! q (snoc q 1))
  64. (set! q (snoc q 2))
  65. (set! q (snoc q 3))
  66. (display (head q)) (newline)
  67. (set! q (tail q))
  68. (display (head q)) (newline)
  69. (set! q (tail q))
  70. (display (head q)) (newline)
  71. (set! q (tail q))
  72. (display (empty? q)) (newline)
Success #stdin #stdout 0.02s 50648KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
1
2
3
#t
https://ideone.com/66284X
language:
Scheme (guile 2.2.4)
created:
5 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!