diff options
| -rw-r--r-- | artima/scheme/scheme15.ss | 28 | ||||
| -rw-r--r-- | scheme/aps/list-utils.sls | 44 |
2 files changed, 34 insertions, 38 deletions
diff --git a/artima/scheme/scheme15.ss b/artima/scheme/scheme15.ss index 10dbe00..136feb2 100644 --- a/artima/scheme/scheme15.ss +++ b/artima/scheme/scheme15.ss @@ -125,20 +125,20 @@ It is not difficult to understand how the macro works by performing a few experiments ``syntax-expand``; for instance, ``let+`` with a single argument expands as follows:: - > (syntax-expand (let+ (x) '(1) x)) + > (syntax-expand (let+ ((x) '(1)) x)) (let ((ls '(1))) (if (null? ls) (apply error 'let+ "Not enough elements" '(x)) - (let+ x (car ls) (let+ () (cdr ls) x)))) + (let+ (x (car ls)) (let+ (() (cdr ls)) x)))) whereas ``let+`` with a required argument and a variadic list of arguments expands as follows:: - > (syntax-expand (let+ (x . rest) '(1) (cons x rest))) + > (syntax-expand (let+ ((x . rest) '(1)) (cons x rest))) (let ((ls '(1))) (if (null? ls) (apply error 'let+ "Not enough elements" '(x)) - (let+ x (car ls) (let+ rest (cdr ls) (cons x rest))))) + (let+ (x (car ls)) (let+ (rest (cdr ls)) (cons x rest))))) Notice that in this case the template ``(arg2 ... . rest)`` has been replaced by ``rest``, since there are no arguments. This is the @@ -146,7 +146,7 @@ magic of the dots! Finally, let us see what happens when we try to match a too short list:: - > (let+ (x y) '(1) x) + > (let+ ((x y) '(1)) x) Unhandled exception Condition components: 1. &error @@ -157,7 +157,7 @@ Finally, let us see what happens when we try to match a too short list:: or a too long list:: - > (let+ (x y) '(1 2 3) x) + > (let+ ((x y) '(1 2 3)) x) Unhandled exception Condition components: 1. &error @@ -170,7 +170,7 @@ element; in the second case, there is an element ``(3)`` in excess, not matched by any argument. The implementation also checks (at compile time) that the passed arguments are valid identifiers:: - > (let+ (x y 3) '(1 2 3) x) + > (let+ ((x y 3) '(1 2 3)) x) Unhandled exception Condition components: 1. &who: let+ @@ -184,7 +184,7 @@ As I said, Scheme pattern matching is not polymorphic: you cannot exchange a vector for a list of viceversa:: - > (let+ (x (y z)) (list 1 (vector 2 3)) (list x y z)) + > (let+ ((x (y z)) (list 1 (vector 2 3))) (list x y z)) Unhandled exception: Condition components: 1. &assertion @@ -215,27 +215,27 @@ will make clear why it is so useful. See you next time! ;;TESTS (test "no args" - (let+ () '() 1); no bindings; return 1 + (let+ 1); no bindings; return 1 1) (test "name value" - (let+ x 1 x); locally bind the name x to the value 1 and return it + (let+ (x 1) x); locally bind the name x to the value 1 and return it 1) (test "one arg" - (let+ (x) '(1) x); locally bind the name x to the value 1 and return it + (let+ ((x) '(1)) x); locally bind the name x to the value 1 and return it 1) (test "two args" - (let+ (x y) (list 1 2) (list x y)); locally bind the names x and y + (let+ ((x y) (list 1 2)) (list x y)); locally bind the names x and y '(1 2)) (test "pair" - (let+ (x . y) '(1 2) y) + (let+ ((x . y) '(1 2)) y) '(2)) (test "nested" - (let+ (x (y z)) '(1 (2 3)) (list x y z)); bind x, y and z + (let+ ((x (y z)) '(1 (2 3))) (list x y z)); bind x, y and z '(1 2 3)) ;;END ) diff --git a/scheme/aps/list-utils.sls b/scheme/aps/list-utils.sls index 0398992..3aa9d8b 100644 --- a/scheme/aps/list-utils.sls +++ b/scheme/aps/list-utils.sls @@ -13,19 +13,23 @@ ;;LET+ (def-syntax let+ (syntax-match () - (sub (let+ () lst body1 body2 ...) - #'(if (null? lst) (let () body1 body2 ...) + (sub (let+ expr) + #'expr) + (sub (let+ (() lst) expr) + #'(if (null? lst) expr (apply error 'let+ "Too many elements" lst))) - (sub (let+ (arg1 arg2 ... . rest) lst body1 body2 ...) + (sub (let+ ((arg1 arg2 ... . rest) lst) expr) #'(let ((ls lst)) (if (null? ls) (apply error 'let+ "Missing arguments" '(arg1 arg2 ...)) - (let+ arg1 (car ls) - (let+ (arg2 ... . rest) (cdr ls) body1 body2 ...))))) - (sub (let+ name value body1 body2 ...) - #'(let ((name value)) body1 body2 ...) + (let+ (arg1 (car ls)) + (let+ ((arg2 ... . rest) (cdr ls)) expr))))) + (sub (let+ (name value) expr) + #'(let ((name value)) expr) (identifier? #'name) (syntax-violation 'let+ "Argument is not an identifier" #'name)) + (sub (let+ (name value) (n v) ... expr) + #'(let+ (name value) (let+ (n v) ... expr))) )) ;;END @@ -40,11 +44,11 @@ (sub (list-of-aux expr acc (var in lst) rest ...) #'(let loop ((ls lst)) (if (null? ls) acc - (let+ var (car ls) + (let+ (var (car ls)) (list-of-aux expr (loop (cdr ls)) rest ...))))) (sub (list-of-aux expr acc (var is exp) rest ...) - #'(let+ var exp (list-of-aux expr acc rest ...))) + #'(let+ (var exp) (list-of-aux expr acc rest ...))) (sub (list-of-aux expr acc pred? rest ...) #'(if pred? (list-of-aux expr acc rest ...) acc)) @@ -94,7 +98,7 @@ ;; check if the elements of a list are distinct according to eq? (define (distinct? eq? items) (if (null? items) #t ; no items - (let+ (first . rest) items + (let+ ((first . rest) items) (cond ((null? rest) #t); single item ((exists (cut eq? first <>) rest) #f); duplicate @@ -119,33 +123,25 @@ (define (append-unique eq? . lists) (remove-dupl eq? (apply append lists))) ;;END - + ;;FOLD (def-syntax fold (syntax-match (left right is in) - (sub (fold left (acc is seed) (x in lst) then pred? else) + (sub (fold left (acc is seed) (x in lst) expr) #'(fold-left - (lambda (acc a) (let+ x a (if pred? then else))) + (lambda (acc a) (let+ (x a) expr)) seed lst)) - (sub (fold right (acc is seed) (x in lst) then pred? else) + (sub (fold right (acc is seed) (x in lst) expr) #'(fold-right - (lambda (a acc) (let+ x a (if pred? then else))) + (lambda (a acc) (let+ (x a) expr)) seed lst)) - (sub (fold left (acc is seed) (x in lst) then pred?) - #'(fold left (acc is seed) (x in lst) then pred? acc)) - (sub (fold right (acc is seed) (x in lst) then pred?) - #'(fold right (acc is seed) (x in lst) then pred? acc)) - (sub (fold left (acc is seed) (x in lst) then) - #'(fold left (acc is seed) (x in lst) then #t)) - (sub (fold right (acc is seed) (x in lst) then) - #'(fold right (acc is seed) (x in lst) then #t)) )) ;;END ;;FLATTEN (define (flatten lst) (fold right (a is '()) (x in lst) - (append (flatten x) a) (list? x) (cons x a))) + (if (list? x) (append (flatten x) a) (cons x a)))) ;;END ;;PERM |