I'm trying to write a macro in racket/scheme that operates like a for loop across some arbitrary code such that the body of the loop is unrolled. For example, the following code
(macro-for ((i '(0 1 2 3))
(another-macro
(with i)
(some (nested i))
(arguments (in (it (a b c i))))))
should have the same result as if the code had been written as
(another-macro
(with 0)
(some (nested 0))
(arguments (in (it (a b c 0))))))
(another-macro
(with 1)
(some (nested 1))
(arguments (in (it (a b c 1))))))
(another-macro
(with 2)
(some (nested 2))
(arguments (in (it (a b c 2))))))
I've made an attempt of implementing it but I'm new to macros and they don't seem to work as I expect them to. Here's my attempt - which doesn't compile because match apparently is not allowed to be used within macros - but hopefully it conveys the idea I'm trying to achieve.
(module test racket
(require (for-syntax syntax/parse))
(begin-for-syntax
(define (my-for-replace search replace elem)
(if (list? elem)
(map (lambda (e) (my-for-replace search replace e)) elem)
(if (equal? elem search)
replace
elem))))
(define-syntax (my-for stx)
(syntax-case stx ()
((my-for args-stx body-stx)
(let ((args (syntax-e #'args-stx)))
(if (list? args)
(map (lambda (arg)
(match arg
((list #'var #'expr)
(my-for-replace #'var #'expr #'body))
(else
(raise-syntax-error #f
"my-for: bad variable clause"
stx
#'args))))
args)
(raise-syntax-error #f
"my-for: bad sequence binding clause"
stx
#'args))))))
(define-syntax (my-func stx)
(syntax-parse stx
((my-func body)
#'body)))
(my-for ((i '(0 1 2)))
(my-func (begin
(display i)
(newline))))
)
Here's how I would write that (if I were going to write something like that):
First, we need a helper function that substitutes in one syntax object wherever an identifier occurs in another syntax object. Note: never use syntax->datum on something that you intend to treat as an expression (or that contains expressions, or definitions, etc). Instead, recursively unwrap using syntax-e and after processing put it back together just like it was before:
(require (for-syntax racket/base))
(begin-for-syntax
;; syntax-substitute : Syntax Identifier Syntax -> Syntax
;; Replace id with replacement everywhere in stx.
(define (syntax-substitute stx id replacement)
(let loop ([stx stx])
(cond [(and (identifier? stx) (bound-identifier=? stx id))
replacement]
[(syntax? stx)
(datum->syntax stx (loop (syntax-e stx)) stx stx)]
;; Unwrapped data cases:
[(pair? stx)
(cons (loop (car stx)) (loop (cdr stx)))]
;; FIXME: also traverse vectors, etc?
[else stx]))))
Use bound-identifier=? when you're implementing a binding-like relationship, like substitution. (This is a rare case; usually free-identifier=? is the right comparison to use.)
Now the macro just interprets the for-clause, does the substitutions, and assembles the results. If you really want the list of terms to substitute to be a compile-time expression, use syntax-local-eval from racket/syntax.
(require (for-syntax racket/syntax))
(define-syntax (macro-for stx)
(syntax-case stx ()
[(_ ([i ct-sequence]) body)
(with-syntax ([(replaced-body ...)
(for/list ([replacement (syntax-local-eval #'ct-sequence)])
(syntax-substitute #'body #'i replacement))])
#'(begin replaced-body ...))]))
Here's an example use:
> (macro-for ([i '(1 2 3)]) (printf "The value of ~s is now ~s.\n" 'i i))
The value of 1 is now 1.
The value of 2 is now 2.
The value of 3 is now 3.
Notice that it replaces the occurrence of i under the quote, so you never see the symbol i in the output. Is that what you expect?
Disclaimer: This is not representative of typical Racket macros. It's generally a bad idea to go searching and replacing in unexpanded forms, and there are usually more idiomatic ways to achieve what you want.
If the for-loop is to be evaluated at compile-time, you can use the builtin for loop.
#lang racket/base
(require (for-syntax syntax/parse
racket/base)) ; for is in racket/base
(define-syntax (print-and-add stx)
(syntax-parse stx
[(_ (a ...))
; this runs at compile time
(for ([x (in-list (syntax->datum #'(a ...)))])
(displayln x))
; the macro expands to this:
#'(+ a ...)]))
(print-and-add (1 2 3 4 5))
Output:
1
2
3
4
5
15
UPDATE
Here is an updated version.
#lang racket
(require (for-syntax syntax/parse racket))
(define-syntax (macro-for stx)
(syntax-parse stx
[(_macro-for ((i (a ...))) body)
(define exprs (for/list ([x (syntax->list #'(a ...))])
#`(let-syntax ([i (λ (_) #'#,x)])
body)))
(with-syntax ([(expr ...) exprs])
#'(begin expr ...))]))
(macro-for ((i (1 2 3 4)))
(displayln i))
Output:
1
2
3
4
Ryan Culpepper's answer only supports use of one induction variable, so here's an extension which supports multiple induction variables:
(begin-for-syntax
;; syntax-substitute : Syntax Identifier Syntax -> Syntax
;; Replace id with replacement everywhere in stx.
(define (instr-syntax-substitute stx id replacement index)
(let loop ([stx stx])
(cond [(and (identifier? stx)
(bound-identifier=? stx id))
replacement]
[(syntax? stx)
(datum->syntax stx (loop (syntax-e stx)) stx stx)]
;; Special handling of (define-instruction id ...) case
[(and (pair? stx)
(syntax? (car stx))
(equal? (syntax-e (car stx)) 'define-instruction))
(let ((id-stx (car (cdr stx))))
(cons (loop (car stx))
(cons (datum->syntax id-stx
(string->symbol
(format "~a_~a"
(symbol->string
(syntax-e id-stx))
index))
id-stx
id-stx)
(loop (cdr (cdr stx))))))]
;; Unwrap list case
[(pair? stx)
(cons (loop (car stx)) (loop (cdr stx)))]
;; Do nothing
[else stx]))))
(begin-for-syntax
(define instr-iter-index 0)
(define (instr-iter-arg body arg argrest)
(let loop ([body body]
[arg arg]
[argrest argrest])
(let ([i (car (syntax-e arg))]
[ct-sequence (cadr (syntax-e arg))]
[replaced-bodies '()])
(for ([replacement (syntax-e ct-sequence)])
(let ([new-body (instr-syntax-substitute body
i
replacement
instr-iter-index)])
(if (null? argrest)
(begin
(set! replaced-bodies
(append replaced-bodies (list new-body)))
(set! instr-iter-index (+ instr-iter-index 1)))
(let* ([new-arg (car argrest)]
[new-argrest (cdr argrest)]
[new-bodies (loop new-body
new-arg
new-argrest)])
(set! replaced-bodies
(append replaced-bodies new-bodies))))))
replaced-bodies))))
(provide instr-for)
(define-syntax (instr-for stx)
(syntax-case stx ()
[(instr-for args body)
(with-syntax ([(replaced-body ...)
(let ([arg (car (syntax-e #'args))]
[argrest (cdr (syntax-e #'args))])
(instr-iter-arg #'body arg argrest))])
#'(begin replaced-body ...))]))
Related
In "The Scheme Programming Language 4th Edition" section 3.3 Continuations the following example is given:
(define product
(lambda (ls)
(call/cc
(lambda (break)
(let f ([ls ls])
(cond
[(null? ls) 1]
[(= (car ls) 0) (break 0)]
[else (* (car ls) (f (cdr ls)))]))))))
I can confirm it works in chezscheme as written:
> (product '(1 2 3 4 5))
120
What is 'f' in the above let? Why is the given ls being assigned to itself? It doesn't seem to match what I understand about (let ...) as described in 4.4 local binding:
syntax: (let ((var expr) ...) body1 body2 ...)
If 'f' is being defined here I would expect it inside parenthesis/square brackets:
(let ([f some-value]) ...)
This is 'named let', and it's a syntactic convenience.
(let f ([x y] ...)
...
(f ...)
...)
is more-or-less equivalent to
(letrec ([f (λ (x ...)
...
(f ...)
...)])
(f y ...))
or, in suitable contexts, to a local define followed by a call:
(define (outer ...)
(let inner ([x y] ...)
...
(inner ...)
...))
is more-or-less equivalent to
(define (outer ...)
(define (inner x ...)
...
(inner ...)
...)
(inner y ...))
The nice thing about named let is that it puts the definition and the initial call of the local function in the same place.
Cavemen like me who use CL sometimes use macros like binding, below, to implement this (note this is not production code: all its error messages are obscure jokes):
(defmacro binding (name/bindings &body bindings/decls/forms)
;; let / named let
(typecase name/bindings
(list
`(let ,name/bindings ,#bindings/decls/forms))
(symbol
(unless (not (null bindings/decls/forms))
(error "a syntax"))
(destructuring-bind (bindings . decls/forms) bindings/decls/forms
(unless (listp bindings)
(error "another syntax"))
(unless (listp decls/forms)
(error "yet another syntax"))
(multiple-value-bind (args inits)
(loop for binding in bindings
do (unless (and (listp binding)
(= (length binding) 2)
(symbolp (first binding)))
(error "a more subtle syntax"))
collect (first binding) into args
collect (second binding) into inits
finally (return (values args inits)))
`(labels ((,name/bindings ,args
,#decls/forms))
(,name/bindings ,#inits)))))
(t
(error "yet a different syntax"))))
f is bound to a procedure that has the body of let as a body and ls as a parameter.
http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-14.html#node_sec_11.16
Think of this procedure:
(define (sum lst)
(define (helper lst acc)
(if (null? lst)
acc
(helper (cdr lst)
(+ (car lst) acc))))
(helper lst 0))
(sum '(1 2 3)) ; ==> 6
We can use named let instead of defining a local procedure and then use it like this:
(define (sum lst-arg)
(let helper ((lst lst-arg) (acc 0))
(if (null? lst)
acc
(helper (cdr lst)
(+ (car lst) acc)))))
Those are the exact same code with the exception of some duplicate naming situations. lst-arg can have the same name lst and it is never the same as lst inside the let.
Named let is easy to grasp. call/ccusually takes some maturing. I didn't get call/cc before I started creating my own implementations.
I would like to write a function that gets and infix expression and changes it to prefix.
at first let's assume we only deal with + operator, so I want to change the expression 1+1+1 into: (+ (+ 1 1) 1)
I want to do it using foldl or foldl-like matter:
taking the second item in the list (which is always the operand) appending it with the first and the third (in that order) then I would like the expression we've just appended to become the first item in the list so I would do the same on the rest of the list recursively.
Iv'e tried the following:
(lambda (lst)
(fold-left (lambda (pmLst)
`(,((cadr pmLst) ,(car pmLst) (caddr pmLst)) ,(cddr pmLst)))
'()
lst))
but then I realized that the lambda given to the fold-left has to have 2 arguments but I would like to deal with the first 3 items of the list.
I hope I've made myself clear cause it got a bit tricky..
A fold wont do what you want. If you imagine the expression (5 + 3 + 2) then using a fold with proc as the procedure do this:
(proc 2 (proc '+ (proc 3 (proc '+ (proc 5 '())))))
A way would be to make a function that returns the odd and even elements in their own list so that '(+ 2 - 3) becomes (+ -) and (2 3) and then you could do it like this:
(define (infix->prefix expr)
(if (pair? expr)
(let-values ([(ops args) (split (cdr expr))])
(fold (lambda (op arg acc)
(list op acc (infix->prefix arg)))
(car expr)
ops
args))
expr))
However the size of both is much greater than just rolling your own recursion:
(define (infix->prefix expr)
(define (aux lst acc)
(if (pair? lst)
(aux (cddr lst)
(list (car lst)
acc
(infix->prefix (cadr lst))))
acc))
(if (pair? expr)
(aux (cdr expr) (infix->prefix (car expr)))
expr))
(infix->prefix '(1 + 2 - 3))
; ==> (- (+ 1 2) 3)
There is no operator precedence here. Everything is strictly left to right.
I'm trying to implement streams for an assignment, and I'm missing something important.
This stream-cons should be creating a pair which is a value and a promise for the cdr (to be evaluated later) ..
(define (str1) (stream-cons 1 2))
However, when then I call (stream-car str1) and it complains "contract violation expected: pair?"
I don't understand why str1 is not a valid pair -- what do I do to make this work?
Rob
#lang racket
(define-syntax delay
(syntax-rules () ((delay expr) (lambda () expr))))
(define (force delayed-obj)
(delayed-obj))
(define-syntax stream-cons
(syntax-rules() ((stream-cons x y)
(cons x (delay y)))))
(define (stream-car stream)
(car stream))
(define (stream-cdr stream)
(force (cdr stream)))
(define the-empty-stream '())
;;;
; TESTS
(define (str1) (stream-cons 1 2))
(stream-car str1)
Your line:
(define (str1) (stream-cons 1 2))
is defining a function called str1 and thus str1 is not a pair. It should read:
(define str1 (stream-cons 1 2))
This seems to work, it's a macro that expands to successive integers depending on how many times it has been expanded.
;; Library (test macro-state)
(library
(test macro-state)
(export get-count incr-count)
(import (rnrs))
(define *count* 0)
(define (get-count) *count*)
(define (incr-count) (set! *count* (+ *count* 1)))
)
;; Program
(import (rnrs) (for (test macro-state) expand))
(define-syntax m
(lambda (x)
(syntax-case x ()
((m) (begin (incr-count) (datum->syntax #'m (get-count)))))))
(write (list (m) (m) (m)))
(newline)
;; prints (1 2 3)
But it's clumsy to me because the macro state *count* and the macro m itself are in different modules. Is there a better way to do this in r6rs, preferably one that doesn't split the implementation over two modules?
EDIT
I should make it clear that although this example is just a single macro, in reality I'm looking for a method that works when multiple macros need to share state.
You can make the state local to the macro transformer:
(define-syntax m
(let ()
(define *count* 0)
(define (get-count) *count*)
(define (incr-count) (set! *count* (+ *count* 1)))
(lambda (x)
(syntax-case x ()
((m) (begin (incr-count) (datum->syntax #'m (get-count))))))))
Edited to add: In Racket, you can also do this:
(begin-for-syntax
(define *count* 0)
(define (get-count) *count*)
(define (incr-count) (set! *count* (+ *count* 1))))
(define-syntax m
(lambda (x)
(syntax-case x ()
((m) (begin (incr-count) (datum->syntax #'m (get-count)))))))
But I don't think R6RS has anything that corresponds to begin-for-syntax.
I have the following scheme function:
(define get-ivars
(λ (ivars num)
(cond ((null? ivars) '())
(else
(append (list (car ivars) `(nth args ,num)) (list (get-ivars (cdr ivars) (+ num 1))))))))
That returns the following in a specific instance:
(x (nth args 1) (y (nth args 2) ()))
The problem is, I need it to return:
((x (nth args1)) (y (nth args 2)) ())
-the two closing parenthesis at the end should be after the (nth statements.
How would I go about getting this to work properly?
get-ivars caller:
(define gen-classes
(λ (classes)
(cond ((null? classes) '())
(else
(let* ((class (car classes)))
(eval
`(define ,(cadr class)
(λ (args)
(let (
,(get-ivars (cdr (cadddr class)) 1)
)
(eval
(let* ,(cdar (cddddr class))
(λ (method . args)
,(get-methods (cdadr (cddddr class)))
))))))))))))
That second (list ...) in your else clause is what's screwing you up. It's nesting each successive call deeper and deeper. The recursion will naturally create the list; you don't need to wrap it again.
Try:
(define get-ivars
(λ (ivars num)
(if (null? ivars) '()
(cons (list (car ivars) `(nth args ,num))
(get-ivars (cdr ivars) (+ num 1))))))
Regarding the get-ivars caller code, the parentheses surrounding the unquoted call to get-ivars are what's giving you the trouble you mention in the comments. With them, this code:
`(define ClassName
(lambda (args)
(let (,(get-ivars '(iVar1 iVar2 iVar3) 1))
;; your method-getting code
)))
Gives you this:
(define ClassName
(lambda (args)
(let (((iVar1 (nth args 1))
(iVar2 (nth args 2))
(iVar3 (nth args 3))))
;; method-getting code
)))
Which, as you can see, gives you an extra set of parentheses around the assignments in the let.
So you want to do this:
`(define ClassName
(lambda (args)
(let ,(get-ivars '(iVar1 iVar2 iVar3) 1)
;; your method-getting code
)))
get-ivars is returning a list of lists, which is exactly what you want for the assignments in the let, so you don't need to wrap or (as I had it earlier) splice it. Just use the unquote on its own, and the result is:
(define ClassName
(lambda (args)
(let ((iVar1 (nth args 1))
(iVar2 (nth args 2))
(iVar3 (nth args 3)))
;; method-getting code
)))
Which should do the trick.
Incidentally, I found it helpful to leave off the eval when I was playing around with this; one can then visually inspect the result to make sure its syntax is okay.
I haven't tried this, but I think this would work:
(define (get-ivars ivars num)
(if (null? ivars)
'()
(list (list (car ivars) `(nth args ,num))
(get-ivars (cdr ivars) (1+ num)))))