Common Lisp локально затеняет функцию с таким же именем

У меня уже не раз задавался этот вопрос.

Общий вопрос

Можно ли прозрачно локально затенять функцию f с помощью оболочки с тем же именем f?

То есть, как локально (f wrapped-args ...) расширяться до (f args ...)?

Кажется, что Flet позволяет нам это делать, но имеет ограничения, а именно, получившуюся оболочку нельзя установить. Можно ли сделать это, не прибегая к флету?

В идеале был бы макрос, который позволяет нам писать обернутые f вызовы и расширяет код до исходного не обернутого f вызова.

Сначала я полагал, что макролет может быть таким, поскольку в документации говорится, что он сначала расширяет макрос, а затем применяет setf к развернутой форме, но я не могу его использовать (продолжайте читать ниже).

Мотивация

Это полезно в контекстах, где некоторые параметры являются неявными и не должны повторяться снова и снова, для большего количества СУХОГО кода.

В моем предыдущем вопросе (let-curry) есть конкретный пример что. Попытка автоматически назначить некоторые параметры функций (let-curry).

Предостережения флета

Я получил там отличные ответы, однако я столкнулся с некоторыми ограничениями. При обращении к flet для выполнения такого локального затенения имени функции в оболочке над ней такие оболочки не могут быть установлены, поэтому такие оболочки не могут использоваться так же гибко, как исходная функция, только для чтения значений, а не для записи.

Конкретный вопрос

По приведенной выше ссылке, как можно написать макрос flet-curry и настроить функции оболочки?

Бонус: может ли этот макрос расширить обернутые вызовы до исходных с нулевыми издержками времени выполнения?

Я попытался взять выбранный ответ в этом посте и использовать макролет вместо флета, но безрезультатно.

Спасибо!


ОБНОВИТЬ

Меня попросили привести конкретный пример для этого общего вопроса.

Комментарии желаний в коде:

(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))))))

Это означает, что я бы хотел let-curry преобразовать любой вызов каррированных функций в этом блоке из

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

на месте, как если бы я написал вторую форму, а не первую в исходном коде. Если бы это было в случае с каким-то «макросом», то он был бы настроен по дизайну.

Кажется, макрос был бы правильным инструментом для этого, но я не знаю, как это сделать.

Спасибо еще раз :)

PS: Если вам нужен доступ к полному коду, он находится здесь: https://github.com/AlbertoEAF/cl-lox (scanner.lisp)


person Alberto    schedule 24.05.2020    source источник
comment
Как вы ожидаете setf это? У вас есть пример без flet-curry?   -  person Sylwester    schedule 24.05.2020
comment
Обратите внимание, что получившаяся функция вполне может быть setfable - см. Мой ответ ниже.   -  person    schedule 26.05.2020


Ответы (2)


Связывание с macrolet нетривиально, поскольку:

  • После того, как вы привяжете f в макролете, если он расширится как (f ...), у вас будет бесконечное расширение макроса.
  • Кроме того, вы можете развернуть макрос как (apply #'f ...) (что замечательно, поскольку APPLY может быть местом SETF 1), но тогда у вас будут ошибки, потому что #'f привязан к локальному макрос, а не исходную функцию. Если, однако, вы сначала оцените #'f, привяжете его к скрытой переменной, а затем определите макрос, который применяет значение переменной, SETF APPLY жалуется (по крайней мере, в SBCL), что функция не должна быть символом (т. Е. Динамически вычисляться).

    1: например, (let ((x (list 0 1 2))) (prog1 x (setf (apply #'second list ()) 9)))

Но вам не нужен макроллет, так как вы можете связывать SETF функции в FLET; вот что вы можете написать вручную, если хотите переопределить некоторые функции локально:

(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))))))

Развернуть как FLET

Следующий макрос расширяется как встраиваемые флеты и особым образом обрабатывает SETF функции, поскольку первым аргументом всегда является устанавливаемое значение:

(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))))

Например:

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

Этот макрос расширяется как:

(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))))

Встраивание FLET

Встроенное объявление - это запрос (компилятор может игнорировать его) на замену каждого вызова функции ее телом (параметры заменяются аргументами вызова функции; это выглядит как β-редукция в лямбда-исчислении).

Когда компилятор распознает это, это как если бы вы определили код как маклет, устраняя необходимость в вызове функции. Когда действует встраивание, apply во время компиляции будет видеть как вызываемый объект функции, так и все аргументы, поэтому компилятор может выдать код, как если бы вы написали напрямую все параметры.

Давайте проверим это с помощью SBCL, сначала с объявлением notinline, чтобы явно предотвратить встраивание:

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

Вывод дизассемблера немного длинноват, и я не буду утверждать, что понимаю, что именно происходит; есть первый сегмент, который, по-видимому, выделяет память (для локальной функции?):

; 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]

... за которым следует второй сегмент, который выглядит так, будто он действительно определяет и вызывает локальную функцию (?):

; 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

Во всяком случае, он сильно отличается от вывода разборки случая inline:

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

Это печатает:

; 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

Вышеупомянутое короче и напрямую вызывает печать. Это эквивалентно разборке, когда встраивание выполняется вручную:

(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
person coredump    schedule 24.05.2020
comment
Ого! Потрясающе, уже проверено, и это работает !! Спасибо! (Я еще не все понимаю, но прочитаю еще раз :)) Кстати, у вас возникли проблемы с использованием встроенного объявления бонуса :), что это будет делать в этом контексте? И в связи с этим есть идея, есть ли у этого много накладных расходов по сравнению с написанием кода без with-curry? (нуб здесь, не знаю, стоят ли операции flet и extra funcall) Спасибо @coredump! - person Alberto; 25.05.2020
comment
@Alberto См. Правку о встраивании. Накладные расходы при использовании встраивания должны быть равны нулю с хорошим компилятором. - person coredump; 25.05.2020
comment
Ух ты! Я просто поражен гибкостью и эффективностью Lisp, а также вашими знаниями, спасибо большое! - person Alberto; 25.05.2020
comment
Кстати, а где ты все про этот @coredump узнал? Какие-нибудь советы? У вас есть блог или что-то еще, где я могу следить за вашими материалами? Спасибо - person Alberto; 25.05.2020
comment
@Alberto большое спасибо; У меня нет блога или чего-то подобного; Я знаю это по сочетанию университетских курсов (компиляторы, языки), самообучения (практический Common Lisp, PAIP и т. Д., Чтения блогов, статей, всего, что движет любопытством), а также небольшого опыта работы. Удачи ! - person coredump; 25.05.2020

Хотя я не следил за этим подробно, обратите внимание, что setf не должно быть здесь проблемой.

Учти это:

(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))

Теперь это будет работать нормально:

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

и (grunga (foo (make-instance 'grunga-object))) вернет 3. В этом случае локальная функция grunga вызывает глобальную, а (setf grunga) - другую функцию - вызывается напрямую.

Если вы хотите переопределить функцию (setf grunga), вы также можете это сделать:

(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))

А теперь (grunga (bar (make-instance 'grunga-object) 'crunched)) это (cruched . 3). В этом случае и grunga, и (setf grunga) являются локальными функциями, вызывающими свои глобальные аналоги.

Обратите внимание, что это может быть более сложным с setf формами, определенными define-setf-*: я никогда не использую их, если я могу этого избежать.

person Community    schedule 26.05.2020