Common Lisp locally shadow function with same name - macros

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
(f arg1 arg2 ...)
to
(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 place1), 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.