#| Copyright (C) 2025 Peter McGoron
 |
 | Permission is hereby granted, free of charge, to any person obtaining a
 | copy of this software and associated documentation files (the
 | "Software"), to deal in the Software without restriction, including
 | without limitation the rights to use, copy, modify, merge, publish,
 | distribute, sublicense, and/or sell copies of the Software, and to
 | permit persons to whom the Software is furnished to do so, subject to
 | the following conditions:
 |
 | The above copyright notice and this permission notice (including the
 | next paragraph) shall be included in all copies or substantial portions
 | of the Software.
 |
 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 |#

;;; This is the low-level Chicken code that implements tagged procedures.
;;; The standard `extend-procedure` cannot be used because it is mutating
;;; by default, while SRFI-259 is persistent.
;;; 
;;; The code works by having a "signifier pair", whose car is a unique
;;; (in the sense of eqv) symbol and whose cdr is a integer map to the
;;; tag values.
;;; 
;;; The code is similar to `extend-procedure`.

(define unique-id
  ;; Generate a fixnum, which will serve as the ID for each tagged
  ;; procedure constructor. This number is always positive.
  (let ((i 0))
    (lambda ()
      (set! i (fx+ i 1))
      i)))

(define unique-symbol
  ;; This uninterned symbol is guaranteed to be a unique memory location
  ;; and is used to pick out the procedure tag mapping from the closure
  ;; data.
  (string->uninterned-symbol "srfi-259"))

(define create/signifier-pair
  ;; Given a procedure that does not have tags associated with it, create
  ;; a new procedure object, with the same underlying procedure and closed
  ;; over variables, with `sig` as the signifier pair.
  (foreign-primitive scheme-object ((scheme-object proc)
                                    (scheme-object sig))
                     "
int old_size = C_header_size(proc);
C_word closure[C_SIZEOF_CLOSURE(old_size + 1)];
int i;

closure[0] = C_CLOSURE_TYPE | (old_size + 1);
for (i = 0; i < old_size; i++)
    C_block_item(closure, i) = C_block_item(proc, i);
C_block_item(closure, old_size) = sig;

C_return(closure);"))

(define set-signifier-pair
  ;; Given a procedure that has tags associated with it, create a new
  ;; procedure object, with the same underlying procedure and closure,
  ;; with `sig` as the signifier pair.
  (foreign-primitive scheme-object ((scheme-object proc)
                                    (scheme-object unique_symbol)
                                    (scheme-object sig))
                     "
int size = C_header_size(proc);
C_word item;
int i;
C_word closure[C_SIZEOF_CLOSURE(size)];
closure[0] = C_CLOSURE_TYPE | size;

for (i = 0; i < size; i++) {
    item = C_block_item(proc, i);
    if (C_i_pairp(item) == C_SCHEME_TRUE && C_eqp(unique_symbol, C_u_i_car(item)) == C_SCHEME_TRUE) {
        C_block_item(closure, i) = sig;
    } else {
        C_block_item(closure, i) = item;
    }
}

C_return(closure);
"))

(define (decoration-is-tag? x)
  ;; Return true if a decoration is a tagged procedure.
  (and (pair? x)
       (eq? (car x) unique-symbol)))

(define (get-mapping proc)
  ;; Return the mapping in a tagged procedure if it exists, or `#f` if it
  ;; does not exist. This relies on an undocumented internal function,
  ;; although it could be implemented with documented functions.
  (cond
    ((not (procedure? proc)) (abort
                              (make-property-condition 'type
                                                       'message
                                                       "not a procedure")))
    ((##sys#lambda-decoration proc decoration-is-tag?) => cdr)
    (else #f)))

(define (make-signifier fxmap)
  ;; Create a signifier pair that can be inserted into the closure.
  (cons unique-symbol fxmap))