A better prototype for clean define (here: cc-define) and destroy (here: destroy-it) shen functions for partial applications' case in Shen. Usage of call graph to maintain a list of callers to force recompilation of kl code in a host language which doesn't support curry.

cl-define+destroy_v2.shen

\* This script is aimed to run on Shen 7.1 on any Common Lisp port *\

(package property-vector-utilities- [delete-properties]

 (define delete-properties
  Ref Properties Vec -> (let Pos (hash Ref (limit Vec))
                             Content (trap-error (<-vector Vec Pos) (/. (protect E) (error "no vector element to retract")))
                             DeprecatedEntries (map (/. X [Ref X]) Properties)
                             NewContent (remove-entries DeprecatedEntries Content)
                             (do (vector-> Vec Pos NewContent)
                                 NewContent)))

 (define remove-entries
  Entries [] -> []
  Entries Table -> (remove-entries-help Entries Table []))

 (define remove-entries-help
  _ [] Acc -> (reverse Acc)
  Entries [[Entry | _] | Others] Acc -> (remove-entries-help Entries Others Acc) where (element? Entry Entries)
  Entries [ Entry+Content | Others ] Acc -> (remove-entries-help Entries Others [Entry+Content | Acc])))

(package call-utilities- [filter-functions]

(define extract-rules
 [] -> []
 Body -> (extract-rules-help (compile shen-<rules> Body) []))

(define extract-rules-help
 [] Acc -> Acc
 [X | Y] Acc -> (extract-rules-help Y [ (hd (tl X)) | Acc]))

(define prepend-function
  [] -> []
  [X | Y] -> (append [function] (prepend-function X) (prepend-function Y))
  X -> [X])

(define filter-functions \* tricky but fast filtering *\
 [] -> []
 [Name | Body] -> (let FList (extract-rules Body)
                       PFList (prepend-function FList)
                       (remove Name (filter-functions-help PFList []))))

(define filter-functions-help
 [] Acc -> Acc
 [function function X | Y] Acc -> (let Name (if (= X function) (hd Y) X)
                                       NewAcc (if (element? Name Acc) Acc [Name | Acc])
                                      (filter-functions-help Y NewAcc))
 [X | Y] Acc -> (filter-functions-help Y Acc)))

(package call-graph- [update-graph get-callers erase-caller delete-properties]

(define update-graph
 Caller Callees -> (let PreviousCallees (get-callees Caller)
                        CommonCallees (intersection Callees PreviousCallees)
                        DeprecatedCallees (difference PreviousCallees CommonCallees)
                        NewCallees (difference Callees CommonCallees)
                        \*Test (output "~A :: ~A :: ~A~%" PreviousCallees DeprecatedCallees NewCallees)*\
                        (do (map (/. Callee (remove-caller Callee Caller)) DeprecatedCallees)
                            (map (/. Callee (add-caller Callee Caller)) NewCallees)
                            (put-callees Callees Caller)
                            Caller)))

(define get-callers
 Callee -> (property Callee shen-calledby))

(define get-callees
 Caller -> (property Caller shen-call))

(define put-callers
 Callers Callee -> (put Callee shen-calledby Callers))

(define put-callees
 Callees Caller -> (put Caller shen-call Callees))

(define erase-caller
 Caller -> (let Callees (get-callees Caller)
                PropertyVector (value shen-*property-vector*)
                (do (map (/. Callee (remove-caller Callee Caller)) Callees)
                    (delete-properties Caller [shen-call] PropertyVector))))

(define add-caller
 Callee Caller -> (let Callers (get-callers Callee)
                       (put-callers [Caller | Callers] Callee)))

(define remove-caller
 Callee Caller -> (let Callers (get-callers Callee)
                       (put-callers (remove Caller Callers) Callee)))
  
(define property
  Function Property -> (trap-error (get Function Property) (/. (protect E) []))))
  
(package compatible-shen-functions- [destroy-it erase-caller delete-properties]

(define destroy-it
  X -> (error "~A is defined as a system function~%" X) where (element? X (value shen-*system*))
  X -> (let Table (value shen-*property-vector*)
            Properties [arity shen-source]
            Lists [shen-*tracking* shen-*signedfuncs*]
            (do
              (trap-error (erase-caller X) (/. (protect E) (output "Unable to erase the call entry in the property vector~%")))
              (trap-error (delete-properties X Properties Table) (/. (protect E) (output "One of the following properties ~A were not found~%" Properties)))
              (map (/. Z (set Z (remove X (value Z)))) Lists) X))))

(defmacro curry-compatible-define
 [cc-define Fn | Body] -> (let (protect PreviousArity) (arity Fn)
                               (protect Callees) (shen-cons_form (filter-functions [Fn | Body]))
                               [do [define Fn | Body]
                                   [update-graph Fn (protect Callees)]
                                   [if [= [arity Fn] (protect PreviousArity)]
                                       Fn
                                       [let (protect Callers) [get-callers Fn]
                                            [do [map [/. (protect C) [do [eval-kl [get (protect C) shen-source]]]] (protect Callers)] Fn]]]]))

\* tests *\
\*

(cc-define toto X -> (titi X))
(get toto shen-call)
(get titi shen-calledby)
(cc-define titi X Y -> (+ X Y))
((toto 2) 5)
(destroy-it titi)
(cc-define titi X Y Z -> (+ X (- Y Z)))
((toto 2) 5 7)

*\

\* expected results *\
\*

toto
[titi]
[toto]
titi
7
titi
titi
0

*\