Arc Forumnew | comments | leaders | submitlogin
3 points by rocketnia 5058 days ago | link | parent

Looks like conanite beat me to it, but I whipped up a solution too:

  (def proper (lst)
    (accum acc
      (while acons.lst
        (do.acc pop.lst))
      only.acc.lst))
  
  (def o-flat (lst)
    (mappend [if (caris _ 'o)  (list cadr._)  ; optional
                 alist._       flat._         ; destructuring
                               list._]        ; normal
             proper.lst))  ; turn rest into normal
  
  ; This returns a two-element list containing a list of all the cars of
  ; the list and the final cdr of the list. For instance,
  ; (iso (split-end '(a b . c)) '((a b) c)). For proper lists, it's the
  ; same as (split lst len.lst).
  (def split-end (lst)
    (let onset (accum acc
                 (while acons.lst
                   (do.acc pop.lst)))
      (list onset lst)))
  
  (def antidestruct (struct)
    (treewise (fn _ `(cons ,@_)) idfn struct))
  
  (def recreate-call (name arglist)
    (withs ((nonrest rest) split-end.arglist
            recreated-nonrest
              (map [if (caris _ 'o)  cadr._
                       alist._       antidestruct._
                                     _]
                   nonrest))
      `(apply ,name ,@recreated-nonrest ,rest)))
Then this should do the trick:

   (unless (bound 'unsafe-def)
     (assign unsafe-def def)
     (mac def (name args . body)
       `(unsafe-def ,name ,args
          (on-err (fn (ex) (err:string "error in "
                                       ',name
  -                                    (tostring:pr:list ,@(flat args))
  +                                    (tostring:pr:list ,@o-flat.args)
                                       "\n"
                                       (details   ex)))
                  (fn ()   ,@body)))))
   
   (mac deftimed(name args . body)
     `(do
        (def ,(symize (stringify name) "_core") ,args
           ,@body)
        (def ,name ,args
         (let t0 (msec)
  -        (ret ans ,(cons (symize (stringify name) "_core") args)
  +        (ret ans ,(recreate-call (sym:string name '_core) args)
             (update-time ,(stringify name) t0))))))
There are really two cases here, and none of the utility functions are used for both. The error message could be modified to use 'recreate-call too (in which case 'o-flat and 'proper would be orphaned), but that would change its behavior with regards to rest args and destructuring args, which already work. (Incidentally, I think conanite and I gave equivalent solutions for the error message case.)