| In arc.arc, there's a bunch of repetitive crap looking like this: (defset cadr (x)
(w/uniq g
(list (list g x)
`(cadr ,g)
`(fn (val) (scar (cdr ,g) val)))))
(defset cddr (x)
(w/uniq g
(list (list g x)
`(cddr ,g)
`(fn (val) (scdr (cdr ,g) val)))))
Not only are there 5 of these expressions looking exactly the same and taking up space (car, cdr, cadr, caar, cddr; not cdar), but there are only 5 of these (no cdar, and I recently wanted to use (= cadar)). It would be nice if you could write a macro to generate these things. This macro turns out to be kind of hard/ridiculous to write, and perhaps that's why PG/RTM wrote that crap out manually. But I've written it now, and you can all rejoice. ; (prepare-cxr-setter a d) --> cadr
(mac prepare-cxr-setter args
(withs (crify [symb 'c _ 'r]
name (crify args))
`(defset ,name (x)
(w/uniq g
(list (list g x)
`(,',name ,g)
`(fn (val)
(,',(symb 'sc car.args 'r)
;Ridiculous quasiquoting stuff
,,(xloop (rx (rev cdr.args) xs ',g)
(if no.rx
(list 'quasiquote xs)
(next cdr.rx (list (crify car.rx) xs))))
val)))))))
It works. (Does anyone know how to rewrite (list 'quasiquote xs)? `(quasiquote ,xs) doesn't work; `(,'quasiquote ,xs) works but isn't much better. Here I'm defining a macro whose output is defset, which defines another macro; quasiquote doesn't handle this all that well. Oh well, it works as is.)I wrote some more macros: 'prepare-cxr-func, which will define cadr for you; 'prepare-cxr, which defines the setter and the function; and 'prepare-cxrs, which takes, say, 3 and prepares caaar, caadr, cadar, caddr, cdaar, cdadr, cddar, cdddr for you. Note that you do not want to execute (prepare-cxr-func a) [or d], because that will expand to (def car (x) (car x)) and make Arc die. I took that into account when writing 'prepare-cxrs, which I intend to be the user frontend. Usage: arc> (prepare-cxrs 5)
#<procedure>
arc> (= xs '(a b c d e f))
(a b c d e f)
arc> caddddr.xs
e
arc> (= caddddr.xs 'hell-yeah)
hell-yeah
arc> xs
(a b c d hell-yeah f)
Implementation: (With the utilities, this works in plain arc3.1.) ;Utilities used (I have to put these first,
; since xloop is a macro used in the bodies of cxr stuff)
(= symb sym:string)
(mac xloop (varvals . body)
`((rfn next ,(map car pair.varvals)
,@body)
,@(map cadr pair.varvals)))
(def num->digs (n (o base 10) (o digs nil))
(let u (xloop (n n xs nil)
(if (is n 0)
xs
(next (trunc:/ n base)
(cons (mod n base) xs))))
(if no.digs
u
(join (n-of (- digs len.u) 0) u))))
;The code.
; (prepare-cxr a d d) -> caddr
(mac prepare-cxr args
`(do (prepare-cxr-func ,@args)
(prepare-cxr-setter ,@args)))
(mac prepare-cxr-func args
(withs (crify [symb 'c _ 'r]
name (crify args))
`(def ,name (x)
,(xloop (rx rev.args xs 'x)
(if no.rx
xs
(next cdr.rx (list (crify car.rx) xs)))))))
(mac prepare-cxr-setter args
(withs (crify [symb 'c _ 'r]
name (crify args))
`(defset ,name (x)
(w/uniq g
(list (list g x)
`(,',name ,g)
`(fn (val)
(,',(symb 'sc car.args 'r)
;Ridiculous quasiquoting stuff
,,(xloop (rx (rev cdr.args) xs ',g)
(if no.rx
(list 'quasiquote xs)
(next cdr.rx (list (crify car.rx) xs))))
val)))))))
; (prepare-cxrs 2) -> caar, cadr, cdar, cddr
(mac prepare-cxrs (n)
;Now we really don't want to (def car (x) (car x)),
; which makes the entire Arc REPL die. Likewise cdr.
;So I hard-code the n=1 case.
(case n
1 '(do (prepare-cxr-setter a)
(prepare-cxr-setter d))
`(do ,@(map (fn (xs) `(prepare-cxr ,@xs))
(map [map [case _
0 'a
1 'd]
(num->digs _ 2 n)]
(range 0 (- (expt 2 n) 1)))))))
|
