Common Lisp locally shadow function with same name

Question

I've had this question more than once before.

Generic Question

Is it possible to transparently locally shadow a function f with a wrapper of it with the same name f?

I.e., how to locally have (f wrapped-args...) expand to (f args...)?

Flet seems to let us do so, but has limitations, namely, the resulting wrapper is not setf-able. Is it possible to do so without resorting to flet?

Ideally there would be a macro that lets us write the "wrapped" f calls and it expands the code to the original "non-wrapped" f call.

At first I believed macrolet could be that, for it says in the documentation that it first expands the macro and then applies setf on the expanded form, but I'm not being able to use it (keep reading below).

Motivation

This is useful in contexts where some paremeters are implicit and should not be repeated over and over, for more DRY code.

In my previous question (let-curry) there's a particular example of that. Attempting to "automatically" assign some of the parameters of the functions (let-curry).

Caveats of flet

I got some excellent answers there, however, I hit some limitations. By resorting to flet to accomplish such local "shadowing" of the function name to a wrapper over it, such wrappers are not setf-able, thus, such wrappers cannot be used as flexibly as the original function, only to read values, not write.

Concrete question

With the link above, how can one write the macro flet-curry and have the wrapper functions be setf-able?

Bonus: Can that macro expand the wrapped calls to the original ones with 0 runtime overhead?

I tried taking the selected answer in that post and using macrolet instead of flet to no avail.

Thank you!

---

UPDATE

I was asked to give a concrete example for this generic question.

Comments of wishes in the code:

(locally (declare (optimize safety))
  (defclass scanner ()
    ((source
      :initarg :source
      :accessor source
      :type string)
     (tokens
      :initform nil
      :accessor tokens
      :type list)
     (start
      :initform 0
      :accessor start
      :type integer)
     (current
      :initform 0
      :accessor current
      :type integer)
     (line
      :initform 1
      :accessor line
      :type integer))
    (:metaclass checked-class)))

(defun lox-string (scanner)
  "Parse string into a token and add it to tokens"
  ;; Any function / defmethod / accessor can be passed to let-curry

  ;; 1. I'd like to add the accessor `line` to this list of curried methods:
  (let-curry scanner (peek at-end-p advance source start current)
    (loop while (and (char/= #\" (peek))
                     (not (at-end-p)))
          do
             ;; 2. but cannot due to the incf call which calls setf:
             (if (char= #\Newline (peek)) (incf (line scanner))
                 (advance)))
    (when (at-end-p)
      (lox.error::lox-error (line scanner) "Unterminated string.")
      (return-from lox-string nil))
    (advance) ;; consume closing \"
    (add-token scanner 'STRING (subseq (source)
                                       (1+ (start))
                                       (1- (current))))))

Meaning I'd like let-curry to transform any call of the curried functions in that block from

1. (f arg1 arg2 ...) to
2. (f scanner arg1 arg2 ...)

in place, as if I'd written the latter form and not the former in the source code. If that were the case with some ?macro?, then it would be setf-able by design.

It seems a macro would be the right tool for this but I don't know how.

Thanks again :)

P.S.: If you need access to the full code it's here: https://github.com/AlbertoEAF/cl-lox (scanner.lisp)

Answer 1

Binding with macrolet is not trivial since:

• Once you bind f in a macrolet, if it expands as (f ...), you are going to have infinite macroexpansion.

• Also, you could expand the macrolet as (apply #'f ...) (which is great, since APPLY can be a SETF place¹), but then you have errors because #'f is bound to a local macro, not the original function. If, however, you first evaluate #'f, bind it to a hidden variable, then define a macro that applies the variable's value, SETF APPLY complains (at least in SBCL) that the function must not be a symbol (ie. dynamically computed).

  ^{1: For example (let ((x (list 0 1 2))) (prog1 x (setf (apply #'second list ()) 9)))}

But you don't need macrolet, since you can bind SETF functions in FLET; here is what you could write manually if you wanted to redefine some functions locally:

(defun lox-string (scanner)
  (flet 
    ((peek        ()  (peek scanner))
     (at-end-p    ()  (at-end-p scanner))
     (advance     ()  (advance scanner))
     (line        ()  (line scanner))
     ((setf line) (n) (setf (line scanner) n))
     (source      ()  (source scanner))
     (start       ()  (start scanner))
     (current     ()  (current scanner)))
    (loop 
       while (and (char/= #\" (peek))
                  (not (at-end-p)))
       do
         (if (char= #\Newline (peek)) 
         (incf (line))
             (advance)))
    (when (at-end-p)
      (error "Unterminated string at line ~a" (line)))
    (advance)
    (add-token scanner 'STRING (subseq (source)
                                       (1+ (start))
                                       (1- (current))))))

Expand as FLET

The following macro expands as inlinable flets and handles SETF functions in a special way, since the first argument is always the value being set:

(defmacro with-curry ((&rest fn-specs) prefix &body body)
  (loop 
     with args = (gensym)
     and n = (gensym)
     and prefix = (alexandria:ensure-list prefix)
     for f in fn-specs
     collect (if (and (consp f) (eq 'setf (first f)))
                 `(,f (,n &rest ,args) (apply #',f ,n ,@prefix ,args))
                 `(,f (&rest ,args) (apply #',f ,@prefix ,args))) 
     into flets
     finally (return
               `(flet ,flets
                  (declare (inline ,@fn-specs))
                  ,@body))))

For example:

(let ((scanner (make-instance 'scanner)))
  (with-curry (start (setf start)) scanner
    (setf (start) (+ (start) 10))))

This macroexpands as:

(LET ((SCANNER (MAKE-INSTANCE 'SCANNER)))
  (FLET ((START (&REST #:G849)
           (APPLY #'START SCANNER #:G849))
         ((SETF START) (#:G850 &REST #:G849)
           (APPLY #'(SETF START) #:G850 SCANNER #:G849)))
    (DECLARE (INLINE START (SETF START)))
    (LET* ((#:NEW1 (+ (START) 10)))
      (FUNCALL #'(SETF START) #:NEW1))))

Inlining FLET

The inline declaration is a request (the compiler may ignore it) to replace each calls to the function by its body (parameters are substituted by the function call arguments; it looks like β-reduction in lambda-calculus).

When the compiler recognizes it, it is as-if you defined the code as a macrolet, removing the need to call a function. When inlining is in effect, apply will see during compilation both the function object to call and all the arguments, so the compiler can emit code as-if you wrote directly all parameters.

Let's test that with SBCL, first with a notinline declaration to explicitly prevent inlining:

(disassemble
 (lambda ()
   (declare (optimize (debug 0) (safety 0)))
   (flet ((p (&rest args) (apply #'print args)))
     (declare (notinline p))
     (p 0) (p 1))))

The output of the disassembler is a bit long, and I won't claim I understand what happens exactly; there is a first segment that apparently allocates memory (for the local function?):

; disassembly for (LAMBDA ())
; Size: 187 bytes. Origin: #x53F0A5B6 (segment 1 of 2)        ; (LAMBDA ())
; 5B6:       49896D28         MOV [R13+40], RBP               ; thread.pseudo-atomic-bits
; 5BA:       4D8B5D68         MOV R11, [R13+104]              ; thread.alloc-region
; 5BE:       498D4B10         LEA RCX, [R11+16]
; 5C2:       493B4D70         CMP RCX, [R13+112]
; 5C6:       0F878C000000     JNBE L8
; 5CC:       49894D68         MOV [R13+104], RCX              ; thread.alloc-region
; 5D0: L0:   498D4B07         LEA RCX, [R11+7]
; 5D4:       49316D28         XOR [R13+40], RBP               ; thread.pseudo-atomic-bits
; 5D8:       7402             JEQ L1
; 5DA:       CC09             INT3 9                          ; pending interrupt trap
; 5DC: L1:   C7410117001050   MOV DWORD PTR [RCX+1], #x50100017  ; NIL
; 5E3:       488BDD           MOV RBX, RBP
; 5E6:       488D5424F0       LEA RDX, [RSP-16]
; 5EB:       4883EC10         SUB RSP, 16
; 5EF:       48891A           MOV [RDX], RBX
; 5F2:       488BEA           MOV RBP, RDX
; 5F5:       E82F000000       CALL L4
; 5FA:       49896D28         MOV [R13+40], RBP               ; thread.pseudo-atomic-bits
; 5FE:       4D8B5D68         MOV R11, [R13+104]              ; thread.alloc-region
; 602:       498D4B10         LEA RCX, [R11+16]
; 606:       493B4D70         CMP RCX, [R13+112]
; 60A:       775A             JNBE L9
; 60C:       49894D68         MOV [R13+104], RCX              ; thread.alloc-region
; 610: L2:   498D4B07         LEA RCX, [R11+7]
; 614:       49316D28         XOR [R13+40], RBP               ; thread.pseudo-atomic-bits
; 618:       7402             JEQ L3
; 61A:       CC09             INT3 9                          ; pending interrupt trap
; 61C: L3:   C641F902         MOV BYTE PTR [RCX-7], 2
; 620:       C7410117001050   MOV DWORD PTR [RCX+1], #x50100017  ; NIL
; 627:       EB03             JMP L5
; 629: L4:   8F4508           POP QWORD PTR [RBP+8]

... followed by a second segment which looks like it actually defines and call the local function (?):

; Origin #x53F0A62C (segment 2 of 2)                          ; (FLET P)
; 62C: L5:   488BF4           MOV RSI, RSP
; 62F: L6:   4881F917001050   CMP RCX, #x50100017             ; NIL
; 636:       7412             JEQ L7
; 638:       FF71F9           PUSH QWORD PTR [RCX-7]
; 63B:       488B4901         MOV RCX, [RCX+1]
; 63F:       8D41F9           LEA EAX, [RCX-7]
; 642:       A80F             TEST AL, 15
; 644:       74E9             JEQ L6
; 646:       CC0A             INT3 10                         ; cerror trap
; 648:       06               BYTE #X06                       ; BOGUS-ARG-TO-VALUES-LIST-ERROR
; 649:       04               BYTE #X04                       ; RCX
; 64A: L7:   488B053FFFFFFF   MOV RAX, [RIP-193]              ; #<FUNCTION PRINT>
; 651:       FF2425A8000052   JMP QWORD PTR [#x520000A8]      ; TAIL-CALL-VARIABLE
; 658: L8:   6A11             PUSH 17
; 65A:       FF142550000052   CALL QWORD PTR [#x52000050]     ; CONS->R11
; 661:       E96AFFFFFF       JMP L0
; 666: L9:   6A11             PUSH 17
; 668:       FF142550000052   CALL QWORD PTR [#x52000050]     ; CONS->R11
; 66F:       EB9F             JMP L2

Anyway, it is very different from the disassembly output of the inline case:

(disassemble
 (lambda ()
   (declare (optimize (debug 0) (safety 0)))
   (flet ((p (&rest args) (apply #'print args)))
     (declare (inline p))
     (p 0) (p 1))))

This prints:

; disassembly for (LAMBDA ())
; Size: 45 bytes. Origin: #x540D3CF6                          ; (LAMBDA ())
; CF6:       4883EC10         SUB RSP, 16
; CFA:       31D2             XOR EDX, EDX
; CFC:       B902000000       MOV ECX, 2
; D01:       48892C24         MOV [RSP], RBP
; D05:       488BEC           MOV RBP, RSP
; D08:       B8C2283950       MOV EAX, #x503928C2             ; #<FDEFN PRINT>
; D0D:       FFD0             CALL RAX
; D0F:       BA02000000       MOV EDX, 2
; D14:       B902000000       MOV ECX, 2
; D19:       FF7508           PUSH QWORD PTR [RBP+8]
; D1C:       B8C2283950       MOV EAX, #x503928C2             ; #<FDEFN PRINT>
; D21:       FFE0             JMP RAX

The above is shorter, and directly calls print. It is equivalent to the disassembly where inlining is done by hand:

(disassemble (lambda ()
               (declare (optimize (debug 0) (safety 0)))
               (print 0) (print 1)))

; disassembly for (LAMBDA ())
; Size: 45 bytes. Origin: #x540D4066                          ; (LAMBDA ())
; 66:       4883EC10         SUB RSP, 16
; 6A:       31D2             XOR EDX, EDX
; 6C:       B902000000       MOV ECX, 2
; 71:       48892C24         MOV [RSP], RBP
; 75:       488BEC           MOV RBP, RSP
; 78:       B8C2283950       MOV EAX, #x503928C2              ; #<FDEFN PRINT>
; 7D:       FFD0             CALL RAX
; 7F:       BA02000000       MOV EDX, 2
; 84:       B902000000       MOV ECX, 2
; 89:       FF7508           PUSH QWORD PTR [RBP+8]
; 8C:       B8C2283950       MOV EAX, #x503928C2              ; #<FDEFN PRINT>
; 91:       FFE0             JMP RAX

Answer 2

While I have not been following this in detail, note that setf does not have to be a problem here.

Consider this:

(defclass grunga-object ()
  ;; grunga objects have grungas, but they may be unbound
  ((grunga :accessor object-grunga :initarg :grunga)))

(defgeneric object-has-valid-grunga-p (o)
  ;; Does some object have a valid grunga?
  (:method (o)
   nil))

(defmethod object-has-valid-grunga-p ((o grunga-object))
  ;; grunga object's grungas are valid if they are bound
  (slot-boundp o 'grunga))


(defun grunga (object &optional (default 'grunga))
  ;; get the grunga of a thing
  (if (object-has-valid-grunga-p object)
      (object-grunga object)
    default))

(defun (setf grunga) (new object)
  ;; set the grunga of a thing
  (setf (object-grunga object) new))

Now this will work fine:

(defun foo (o)
  (flet ((grunga (object)
           (grunga object 3)))
    (setf (grunga o) (grunga o))
    o))

and (grunga (foo (make-instance 'grunga-object))) will return 3. In this case the local grunga function calls the global one, while (setf grunga) – a different function – is called directly.

If you want to override the (setf grunga) function you can do that as well:

(defun bar (o &optional (exploded-value 'exploded))
  (flet ((grunga (object)
           (grunga object 3))
         ((setf grunga) (new object &optional (exploding t))
           (setf (grunga object) (if exploding (cons exploded-value new) new))))
    (setf (grunga o t) (grunga o))
    o))

And now (grunga (bar (make-instance 'grunga-object) 'crunched)) is (cruched . 3). In this case both grunga and (setf grunga) are local functions which call their global counterparts.

Note that this may be more complicated with setf forms defined by define-setf-*: I never use those if I can possibly avoid it.