;;;; JSON-BUT - gensym-lookup prototype

(defpackage #:json-but
  (:use #:cl)
  (:local-nicknames (#:a #:alexandria))
  (:shadow #:get))

(in-package #:json-but)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Pseudo-package

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *pseudo-package* (make-hash-table :test #'equal :weakness :value)))

(defun pseudo-intern (thing)
  (etypecase thing
    (symbol (pseudo-intern (string thing)))
    (character (pseudo-intern (string thing)))
    (string (multiple-value-bind (value foundp) (gethash thing *pseudo-package*)
              (cond (foundp value)
                    (t (setf (gethash thing *pseudo-package*)
                             (make-symbol thing))))))))

(define-compiler-macro pseudo-intern (&whole whole thing &environment env)
  (if (and (constantp thing env) (stringp thing))
      (a:with-gensyms (value foundp)
        `(load-time-value
          (multiple-value-bind (,value ,foundp)
              (gethash ,thing *pseudo-package*)
            (cond (,foundp ,value)
                  (t (setf (gethash ,thing *pseudo-package*)
                           (make-symbol ,thing)))))))
      whole))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Getter

(defun get (object name)
  (gethash (pseudo-intern name) object))

(define-compiler-macro get (&whole whole object name &environment env)
  (if (constantp name env)
      `(gethash (pseudo-intern ,name) ,object)
      whole))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Test

(defun make-test-object ()
  (let ((keys (map 'vector #'pseudo-intern '("foo" "bar" "fooBar")))
        (values #(123 (1 2 3) "123"))
        (result (make-hash-table :test #'eq)))
    (map nil (lambda (x y) (setf (gethash x result) y)) keys values)
    result))

(defun test ()
  (declare (optimize speed))
  (let* ((object (make-test-object)))
    (list (get object "foo")
          (get object "bar")
          (get object "fooBar"))))


JSON-BUT> (test)
(123 (1 2 3) "123")

JSON-BUT> (disassemble #'test)
; disassembly for TEST
; Size: 248 bytes. Origin: #x53070650                         ; TEST
; 650:       4883EC10         SUB RSP, 16
; 654:       31C9             XOR ECX, ECX
; 656:       48892C24         MOV [RSP], RBP
; 65A:       488BEC           MOV RBP, RSP
; 65D:       E8C0803DFD       CALL #x50448722                 ; #<FDEFN MAKE-TEST-OBJECT>
; 662:       480F42E3         CMOVB RSP, RBX
; 666:       488955F8         MOV [RBP-8], RDX
; 66A:       488B7DF8         MOV RDI, [RBP-8]
; 66E:       488B159BFFFFFF   MOV RDX, [RIP-101]              ; '#:|foo|
; 675:       4883EC10         SUB RSP, 16
; 679:       BE17011050       MOV ESI, #x50100117             ; NIL
; 67E:       B906000000       MOV ECX, 6
; 683:       48892C24         MOV [RSP], RBP
; 687:       488BEC           MOV RBP, RSP
; 68A:       E893162DFD       CALL #x50341D22                 ; #<FDEFN SB-IMPL::GETHASH3>
; 68F:       488955F0         MOV [RBP-16], RDX
; 693:       488B157EFFFFFF   MOV RDX, [RIP-130]              ; '#:|bar|
; 69A:       4883EC10         SUB RSP, 16
; 69E:       488B7DF8         MOV RDI, [RBP-8]
; 6A2:       BE17011050       MOV ESI, #x50100117             ; NIL
; 6A7:       B906000000       MOV ECX, 6
; 6AC:       48892C24         MOV [RSP], RBP
; 6B0:       488BEC           MOV RBP, RSP
; 6B3:       E86A162DFD       CALL #x50341D22                 ; #<FDEFN SB-IMPL::GETHASH3>
; 6B8:       4C8BCA           MOV R9, RDX
; 6BB:       4C894DE8         MOV [RBP-24], R9
; 6BF:       488B155AFFFFFF   MOV RDX, [RIP-166]              ; '#:|fooBar|
; 6C6:       4883EC10         SUB RSP, 16
; 6CA:       488B7DF8         MOV RDI, [RBP-8]
; 6CE:       BE17011050       MOV ESI, #x50100117             ; NIL
; 6D3:       B906000000       MOV ECX, 6
; 6D8:       48892C24         MOV [RSP], RBP
; 6DC:       488BEC           MOV RBP, RSP
; 6DF:       E83E162DFD       CALL #x50341D22                 ; #<FDEFN SB-IMPL::GETHASH3>
; 6E4:       4C8B4DE8         MOV R9, [RBP-24]
; 6E8:       488BF2           MOV RSI, RDX
; 6EB:       488B4DF0         MOV RCX, [RBP-16]
; 6EF:       49896D28         MOV [R13+40], RBP               ; thread.pseudo-atomic-bits
; 6F3:       4D8B5D68         MOV R11, [R13+104]              ; thread.alloc-region
; 6F7:       498D5330         LEA RDX, [R11+48]
; 6FB:       493B5570         CMP RDX, [R13+112]
; 6FF:       773E             JNBE L2
; 701:       49895568         MOV [R13+104], RDX              ; thread.alloc-region
; 705: L0:   498D5307         LEA RDX, [R11+7]
; 709:       488BC2           MOV RAX, RDX
; 70C:       488948F9         MOV [RAX-7], RCX
; 710:       4883C010         ADD RAX, 16
; 714:       488940F1         MOV [RAX-15], RAX
; 718:       4C8948F9         MOV [RAX-7], R9
; 71C:       4883C010         ADD RAX, 16
; 720:       488940F1         MOV [RAX-15], RAX
; 724:       488970F9         MOV [RAX-7], RSI
; 728:       C7400117011050   MOV DWORD PTR [RAX+1], #x50100117  ; NIL
; 72F:       49316D28         XOR [R13+40], RBP               ; thread.pseudo-atomic-bits
; 733:       7402             JEQ L1
; 735:       CC09             INT3 9                          ; pending interrupt trap
; 737: L1:   488BE5           MOV RSP, RBP
; 73A:       F8               CLC
; 73B:       5D               POP RBP
; 73C:       C3               RET
; 73D:       CC10             INT3 16                         ; Invalid argument count trap
; 73F: L2:   6A30             PUSH 48
; 741:       E83FFEF8FE       CALL #x52000585                 ; CONS->R11
; 746:       EBBD             JMP L0
NIL