;; -*- lexical-binding: t -*-

(require 'treesit)
(require 'project)

(defmacro igccg--define-record (name &rest fields)
  (let* ((constructor (intern (format "igccg--make-%s" name)))
         (conc-name (intern (format "igccg--%s." name)))
         (tag-name (intern (format "igccg--%s" name))))
    `(cl-defstruct (,tag-name
                    (:constructor ,constructor (,@fields))
                    (:constructor nil)
                    (:conc-name ,conc-name)
                    (:predicate nil)
                    (:copier nil)
                    (:noinline))
       ,@(mapcar (lambda (field)
                   `(,field nil :read-only t))
                 fields))))

(igccg--define-record layout name header pvectype tag ctype fields)

(defun igccg--arg-decl (name type)
  (pcase-exhaustive type
    (`(* ,type) (igccg--arg-decl (format "*%s" name) type))
    (`(struct ,s) (format "struct %s %s" s name))
    (`(array ,type) (igccg--arg-decl (format "%s[]" name) type))
    (`vectorlike_header (igccg--arg-decl name `(struct Lisp_Vector)))
    ((guard (symbolp type)) (format "%s %s" type name))))

(defun igccg--type-spec (type)
  (pcase-exhaustive type
    (`(* ,type) (format "%s*" (igccg--type-spec type)))
    (`(struct ,s) (format "struct %s" s))
    (`(array ,type) (format "%s*" (igccg--type-spec type)))
    (`vectorlike_header (igccg--type-spec `(struct Lisp_Vector)))
    ((guard (symbolp type)) (symbol-name type))))

(defvar igccg--indent 0)

(defun igccg--emit-line (string)
  (princ (format "%s%s\n"
                 (make-string igccg--indent ?\s)
                 string)))

(defun igccg--emit-function (rtype name args body)
  (princ (format "static %s\n%s (%s)\n{\n" rtype name (string-join args ", ")))
  (let ((igccg--indent 2))
    (funcall body))
  (princ "}\n\n"))

(defun igccg--emit-block (body)
  (igccg--emit-line "{")
  (let ((igccg--indent (+ 2 igccg--indent)))
    (funcall body))
  (igccg--emit-line "}"))

(defun igccg--emit-switch (exp cases)
  (igccg--emit-line (format "switch (%s)" exp))
  (igccg--emit-block (lambda ()
                       (dolist (c cases)
                         (igccg--emit-line
                          (cond ((equal (car c) "default") "default:")
                                (t (format "case %s:" (car c)))))
                         (let ((igccg--indent (+ 2 igccg--indent)))
                           (funcall (cdr c))
                           (igccg--emit-line "break;"))))))

(defun igccg--emit-\#if (exp body)
  (igccg--emit-line (format "#if %s" exp))
  (funcall body)
  (igccg--emit-line "#endif"))

(defun igccg--ifdef-exp (exp)
  (pcase-exhaustive exp
    ((guard (symbolp exp)) (format "defined %s" exp))
    (`(or . ,exps) (mapconcat #'igccg--ifdef-exp exps " || "))))

(defun igccg--emit-scan-body (body)
  (igccg--emit-line "MPS_SCAN_BEGIN (ss)")
  (igccg--emit-block body)
  (igccg--emit-line "MPS_SCAN_END (ss);")
  (igccg--emit-line "return MPS_RES_OK;"))

(defun igccg--field-addr-exp (var path)
  (pcase-exhaustive path
    ((guard (symbolp path))
     (format "&%s->%s" var path))
    (`(path . ,symbols)
     (format "&%s->%s" var (mapconcat #'symbol-name symbols ".")))
    ((guard (stringp path))
     (format path var))))

(defun igccg--field-value-exp (var path)
  (pcase-exhaustive path
    ((guard (symbolp path))
     (format "%s->%s" var path))
    (`(path . ,symbols)
     (format "%s->%s" var (mapconcat #'symbol-name symbols ".")))
    ((guard (stringp path))
     (format path var))
    ('(pvec-header-size)
     (format "%s->header.size & PSEUDOVECTOR_SIZE_MASK" var))
    ('(igc-header-len)
     (format "((struct igc_header *)client_to_base (%s))->nwords \
- to_words (sizeof (struct igc_header))" var))
    ('(sub-char-table-len)
     (format "(%s->header.size & PSEUDOVECTOR_SIZE_MASK)\
 - SUB_CHAR_TABLE_OFFSET" var))))

(defun igccg--emit-fix-call (ss type var fname)
  (igccg--emit-line
   (format "IGC_FIX_CALL_FN (%s, %s, %s, %s);"
           ss (igccg--type-spec type) var fname)))

(defun igccg--emit-abort ()
  (igccg--emit-line "emacs_abort ();"))

(defun igccg--emit-fix-field-exp (ss obj exp)
  (pcase-exhaustive exp
    (`(tagged ,path)
     (igccg--emit-line (format "IGC_FIX12_OBJ (%s, %s);"
                               ss (igccg--field-addr-exp obj path))))
    (`(untagged ,path)
     (igccg--emit-line (format "IGC_FIX12_RAW (%s, %s);"
                               ss (igccg--field-addr-exp obj path))))
    (`(switch ,path . ,cases)
     (igccg--emit-switch
      (igccg--field-value-exp obj path)
      (mapcar (lambda (case)
                (pcase-exhaustive case
                  (`(,tag . ,fields)
                   (cons (symbol-name tag)
                         (lambda ()
                           (mapc (lambda (field)
                                   (igccg--emit-fix-field-exp ss obj field))
                                 fields))))))
              cases)))
    (`(array tagged ,start ,len)
     (igccg--emit-line
      (format (concat "IGC_FIX12_NOBJS (%s, %s, %s);")
              ss
              (igccg--field-value-exp obj start)
              (igccg--field-value-exp obj len))))
    (`(array untagged ,start ,len)
     (igccg--emit-line
      (format "size_t len = %s;" (igccg--field-value-exp obj len)))
     (igccg--emit-line
      (format "for (void **p = %s, **q = p + len; p < q; p++)"
              (igccg--field-value-exp obj start)))
     (igccg--emit-block (lambda ()
                          (igccg--emit-line
                           (format "IGC_FIX12_RAW (%s, p);" ss)))))
    (`(vectorlike)
     (igccg--emit-line
      (format
       "IGC_FIX12_NOBJS (%s,\
 (Lisp_Object *)(&%s->header + 1),\
 %s->header.size & PSEUDOVECTOR_SIZE_MASK);" ss obj obj)))
    (`(cfg ,test . ,exps)
     (igccg--emit-\#if (igccg--ifdef-exp test)
                      (lambda ()
                        (mapc (lambda (exp)
                                (igccg--emit-fix-field-exp ss obj exp))
                              exps))))
    ('(abort)
     (igccg--emit-abort))
    ('(frame-quirks)
     (igccg--emit-line
      (format "IGC_FIX_CALL_FN (%s, struct frame, %s, fix_frame_quirks);"
              ss obj)))
    ('(window-quirks)
     (igccg--emit-line
      (format "IGC_FIX_CALL_FN (%s, struct window, %s, fix_window_quirks);"
              ss obj)))
    ('(buffer-quirks)
     (igccg--emit-line
      (format "IGC_FIX_CALL_FN (%s, struct buffer, %s, fix_buffer_quirks);"
              ss obj)))
    ('(terminal-quirks)
     (igccg--emit-line
      (format "IGC_FIX_CALL_FN (%s, struct terminal, %s, fix_terminal_quirks);"
              ss obj)))
    ('(font-object-quirks)
     (igccg--emit-line
      (format "IGC_FIX_CALL_FN (%s, struct font, %s, fix_font_object_quirks);"
              ss obj)))))

(defun igccg--fix-method-name (layout)
  (format "fix_%s" (igccg--layout.name layout)))

(defun igccg--scan-vectorlike-method-name (prefix)
  (format "%s_scan_vectorlike" prefix))

(defun igccg--emit-fix-method (layout)
  (igccg--emit-function
   "mps_res_t"
   (igccg--fix-method-name layout)
   (list "mps_ss_t ss" (igccg--arg-decl "o"
                                        `(* ,(igccg--layout.ctype layout))))
   (lambda ()
     (igccg--emit-scan-body
      (lambda ()
        (dolist (exp (igccg--layout.fields layout))
          (igccg--emit-fix-field-exp "ss" "o" exp)))))))

(defun igccg--emit-scan-vectorlike-method (name layouts)
  (igccg--emit-function
   "mps_res_t"
   name
   (list "mps_ss_t ss" "struct Lisp_Vector *v")
   (lambda ()
     (igccg--emit-scan-body
      (lambda ()
        (igccg--emit-switch
         "pseudo_vector_type (v->header)"
         (append
          (mapcar (lambda (l)
                    (cons (symbol-name (igccg--layout.pvectype l))
                          (lambda ()
                            (igccg--emit-fix-call
                             "ss" (igccg--layout.ctype l)
                             "v" (igccg--fix-method-name l)))))
                  layouts)
          (list (cons 'PVEC_FREE (lambda () (igccg--emit-abort)))))))))))

(defun igccg--emit-scan-object-method (prefix layouts)
  (mapc #'igccg--emit-fix-method layouts)
  (let* ((alist (seq-group-by #'igccg--layout.header igccg--layouts ))
         (vectorlike (cdr (assq 'IGC_OBJ_VECTOR alist)))
         (scan-vectorlike (igccg--scan-vectorlike-method-name prefix)))
    (igccg--emit-scan-vectorlike-method scan-vectorlike vectorlike)
    (igccg--emit-function
     "mps_res_t"
     (format "%s_scan_object" prefix)
     (list "mps_ss_t ss" "mps_addr_t base")
     (lambda ()
       (igccg--emit-scan-body
        (lambda ()
          (igccg--emit-line "mps_addr_t client = base_to_client (base);")
          (igccg--emit-line "struct igc_header *header = base;")
          (igccg--emit-switch
           "header->obj_type"
           (append
            (mapcar
             (lambda (p)
               (pcase-exhaustive p
                 (`(,type . (,layout))
                  (cons (symbol-name type)
                        (lambda ()
                          (igccg--emit-fix-call
                           "ss" (igccg--layout.ctype layout)
                           "client" (igccg--fix-method-name layout)))))
                 (`(IGC_OBJ_VECTOR . ,_)
                  (cons "IGC_OBJ_VECTOR"
                        (lambda ()
                          (igccg--emit-fix-call "ss" '(struct Lisp_Vector)
                                                "client" scan-vectorlike))))))
             alist)
            (list
             (cons "IGC_OBJ_FWD" (lambda ()))
             (cons "IGC_OBJ_PAD" (lambda ()))
             (cons "IGC_OBJ_INVALID" (lambda () (igccg--emit-abort))))))))))))

(defvar igccg--layouts
  (list
   (igccg--make-layout
    'cons 'IGC_OBJ_CONS nil 'Lisp_Cons '(struct Lisp_Cons)
    '((tagged (path u s car))
      (tagged (path u s u cdr))))

   (igccg--make-layout
    'symbol 'IGC_OBJ_SYMBOL nil 'Lisp_Symbol '(struct Lisp_Symbol)
    '((tagged (path u s name))
      (tagged (path u s function))
      (tagged (path u s plist))
      (untagged (path u s next))
      (switch
       (path u s redirect)
       (SYMBOL_PLAINVAL (tagged (path u s val value)))
       (SYMBOL_VARALIAS (untagged (path u s val alias)))
       (SYMBOL_LOCALIZED (untagged (path u s val blv)))
       (SYMBOL_FORWARDED
        (switch
         "XFWDTYPE (%s->u.s.val.fwd)"
         (Lisp_Fwd_Int)
         (Lisp_Fwd_Bool)
         (Lisp_Fwd_Kboard_Obj)
         (Lisp_Fwd_Obj
          (tagged "((struct Lisp_Objfwd *)(%s->u.s.val.fwd.fwdptr))->objvar"))
         (Lisp_Fwd_Buffer_Obj
          (tagged
           "&\
((struct Lisp_Buffer_Objfwd *)(%s->u.s.val.fwd.fwdptr))\
->predicate")))))))

   (igccg--make-layout
    'interval 'IGC_OBJ_INTERVAL nil nil '(struct interval)
    '((untagged left)
      (untagged right)
      (switch up_obj
              (default (tagged (path up obj)))
              (false (untagged (path up interval))))
      (tagged plist)))

   (igccg--make-layout
    'string 'IGC_OBJ_STRING nil 'Lisp_String '(struct Lisp_String)
    '((untagged (path u s data))
      (untagged (path u s intervals))))

   (igccg--make-layout
    'string_data 'IGC_OBJ_STRING_DATA nil nil '(array uint8_t) nil)

   (igccg--make-layout
    'itree_tree 'IGC_OBJ_ITREE_TREE nil nil '(struct itree_tree)
    '((untagged root)))

   (igccg--make-layout
    'itree_node 'IGC_OBJ_ITREE_NODE nil nil '(struct itree_node)
    '((untagged parent)
      (untagged left)
      (untagged right)
      (tagged data)))

   (igccg--make-layout
    'image 'IGC_OBJ_IMAGE nil nil '(struct image)
    '((tagged spec)
      (tagged dependencies)
      (tagged lisp_data)
      (untagged next)
      (untagged prev)))

   (igccg--make-layout
    'image_cache 'IGC_OBJ_IMAGE_CACHE nil nil '(struct image_cache)
    '((untagged images)
      (untagged buckets)))

   (igccg--make-layout
    'face 'IGC_OBJ_FACE nil nil '(struct face)
    '((array tagged lface "ARRAYELTS (%s->lface)")
      (untagged font)
      (untagged next)
      (untagged prev)
      (untagged ascii_face)
      (cfg
       (or HAVE_XFT HAVE_FREETYPE)
       (untagged extra))))

   (igccg--make-layout
    'face_cache 'IGC_OBJ_FACE_CACHE nil nil '(struct face_cache)
    '((untagged f)
      (untagged faces_by_id)
      (untagged buckets)))

   (igccg--make-layout
    'float 'IGC_OBJ_FLOAT nil 'Lisp_Float '(struct Lisp_Float)
    '())

   (igccg--make-layout
    'blv 'IGC_OBJ_BLV nil nil '(struct Lisp_Buffer_Local_Value)
    '((tagged where)
      (tagged defcell)
      (tagged valcell)))

   ;; (igccg--make-layout
   ;;  'weak_ref 'IGC_OBJ_WEAK 'Lisp_Vectorlike '(struct Lisp_Weak_Ref)
   ;;  '((tagged ref)))

   (igccg--make-layout
    'ptr_vec 'IGC_OBJ_PTR_VEC nil nil '(* void)
    '((array untagged "%s" (igc-header-len))))

   (igccg--make-layout
    'obj_vec 'IGC_OBJ_OBJ_VEC nil nil 'Lisp_Object
    '((array tagged "%s" (igc-header-len))))

   (igccg--make-layout
    'handler 'IGC_OBJ_HANDLER nil nil '(struct handler)
    '((tagged tag_or_ch)
      (tagged val)
      (untagged next)
      (untagged nextfree)))

   (igccg--make-layout
    'bytes 'IGC_OBJ_BYTES nil nil '(array uint8_t) nil)

   (igccg--make-layout
    'normal_vector 'IGC_OBJ_VECTOR 'PVEC_NORMAL_VECTOR 'Lisp_Vectorlike
    '(struct Lisp_Vector) '((array tagged contents (path header size))))

   (igccg--make-layout
    'bignum 'IGC_OBJ_VECTOR 'PVEC_BIGNUM 'Lisp_Vectorlike
    '(struct Lisp_Bignum) '())

   (igccg--make-layout
    'marker 'IGC_OBJ_VECTOR 'PVEC_MARKER 'Lisp_Vectorlike
    '(struct Lisp_Marker)
    '((untagged buffer)
      ;;(untagged next)
      ))

   (igccg--make-layout
    'overlay 'IGC_OBJ_VECTOR 'PVEC_OVERLAY 'Lisp_Vectorlike
    '(struct Lisp_Overlay)
    '((untagged buffer)
      (tagged plist)
      (untagged interval)))

   (igccg--make-layout
    'finalizer 'IGC_OBJ_VECTOR 'PVEC_FINALIZER 'Lisp_Vectorlike
    '(struct Lisp_Finalizer)
    '((tagged function)
      (untagged next)
      (untagged prev)))

   (igccg--make-layout
    'symbol_with_pos 'IGC_OBJ_VECTOR 'PVEC_SYMBOL_WITH_POS 'Lisp_Vectorlike
    '(struct Lisp_Symbol_With_Pos)
    '((vectorlike)))

   (igccg--make-layout
    'misc_ptr 'IGC_OBJ_VECTOR 'PVEC_MISC_PTR 'Lisp_Vectorlike
    '(struct Lisp_Misc_Ptr)
    '())

   (igccg--make-layout
    'user_ptr 'IGC_OBJ_VECTOR 'PVEC_USER_PTR 'Lisp_Vectorlike
    '(struct Lisp_User_Ptr)
    '())

   (igccg--make-layout
    'process 'IGC_OBJ_VECTOR 'PVEC_PROCESS 'Lisp_Vectorlike
    '(struct Lisp_Process)
    '((vectorlike)))

   (igccg--make-layout
    'frame 'IGC_OBJ_VECTOR 'PVEC_FRAME 'Lisp_Vectorlike
    '(struct frame)
    '((vectorlike)
      (untagged face_cache)
      (untagged terminal)
      (frame-quirks)))

   (igccg--make-layout
    'window 'IGC_OBJ_VECTOR 'PVEC_WINDOW 'Lisp_Vectorlike
    '(struct window)
    '((vectorlike)
      (tagged prev_buffers)
      (tagged next_buffers)
      (window-quirks)))

   (igccg--make-layout
    'bool_vector 'IGC_OBJ_VECTOR 'PVEC_BOOL_VECTOR 'Lisp_Vectorlike
    '(struct Lisp_Bool_Vector)
    '())

   (igccg--make-layout
    'buffer 'IGC_OBJ_VECTOR 'PVEC_BUFFER 'Lisp_Vectorlike
    '(struct buffer)
    '((vectorlike)
      (untagged (path own_text intervals))
      (untagged (path own_text markers))
      (untagged overlays)
      (untagged base_buffer)
      (tagged undo_list_)
      (buffer-quirks)))

   (igccg--make-layout
    'hash_table 'IGC_OBJ_VECTOR 'PVEC_HASH_TABLE 'Lisp_Vectorlike
    '(struct Lisp_Hash_Table)
    '((untagged key)
      (untagged value)
      (untagged hash)
      (untagged next)
      (untagged index)))

   (igccg--make-layout
    'obarray 'IGC_OBJ_VECTOR 'PVEC_OBARRAY 'Lisp_Vectorlike
    '(struct Lisp_Obarray)
    '((untagged buckets)))

   (igccg--make-layout
    'terminal 'IGC_OBJ_VECTOR 'PVEC_TERMINAL 'Lisp_Vectorlike
    '(struct terminal)
    '((vectorlike)
      (untagged next_terminal)
      (cfg HAVE_WINDOW_SYSTEM
           (untagged image_cache))
      (terminal-quirks)))

   (igccg--make-layout
    'window_configuraion 'IGC_OBJ_VECTOR 'PVEC_WINDOW_CONFIGURATION
    'Lisp_Vectorlike
    'vectorlike_header
    '((vectorlike)))

   (igccg--make-layout
    'subr 'IGC_OBJ_VECTOR 'PVEC_SUBR 'Lisp_Vectorlike
    '(struct Lisp_Subr)
    '((tagged command_modes)
      (cfg
       HAVE_NATIVE_COMP
       (tagged (path intspec native))
       (tagged native_comp_u)
       (tagged lambda_list)
       (tagged type))))

   (igccg--make-layout
    'other 'IGC_OBJ_VECTOR 'PVEC_OTHER 'Lisp_Vectorlike
    '(struct scroll_bar)
    '((vectorlike)))

   (igccg--make-layout
    'xwidget 'IGC_OBJ_VECTOR 'PVEC_XWIDGET 'Lisp_Vectorlike
    'vectorlike_header
    '((vectorlike)))

   (igccg--make-layout
    'xwidget_view 'IGC_OBJ_VECTOR 'PVEC_XWIDGET_VIEW 'Lisp_Vectorlike
    'vectorlike_header
    '((vectorlike)))

   (igccg--make-layout
    'thread 'IGC_OBJ_VECTOR 'PVEC_THREAD 'Lisp_Vectorlike
    '(struct thread_state)
    '((vectorlike)
      (untagged m_current_buffer)
      (untagged next_thread)
      (untagged m_handlerlist)))

   (igccg--make-layout
    'mutex 'IGC_OBJ_VECTOR 'PVEC_MUTEX 'Lisp_Vectorlike
    '(struct Lisp_Mutex)
    '((vectorlike)))

   (igccg--make-layout
    'condvar 'IGC_OBJ_VECTOR 'PVEC_CONDVAR 'Lisp_Vectorlike
    '(struct Lisp_CondVar)
    '((vectorlike)))

   (igccg--make-layout
    'module_function 'IGC_OBJ_VECTOR 'PVEC_MODULE_FUNCTION 'Lisp_Vectorlike
    '(struct module_global_reference)
    '((vectorlike)))

   (igccg--make-layout
    'module_global_reference 'IGC_OBJ_VECTOR 'PVEC_MODULE_GLOBAL_REFERENCE
    'Lisp_Vectorlike
    'vectorlike_header
    '((vectorlike)))

   (igccg--make-layout
    'comp_unit 'IGC_OBJ_VECTOR 'PVEC_NATIVE_COMP_UNIT
    'Lisp_Vectorlike
    '(struct Lisp_Native_Comp_Unit)
    '((vectorlike)))

   (igccg--make-layout
    'ts_parser 'IGC_OBJ_VECTOR 'PVEC_TS_PARSER
    'Lisp_Vectorlike
    '(struct Lisp_TS_Parser)
    '((vectorlike)))

   (igccg--make-layout
    'ts_node 'IGC_OBJ_VECTOR 'PVEC_TS_NODE
    'Lisp_Vectorlike
    '(struct Lisp_TS_Node)
    '((vectorlike)))

   (igccg--make-layout
    'ts_query 'IGC_OBJ_VECTOR 'PVEC_TS_COMPILED_QUERY
    'Lisp_Vectorlike
    '(struct Lisp_TS_Query)
    '((vectorlike)))

   (igccg--make-layout
    'sqlite 'IGC_OBJ_VECTOR 'PVEC_SQLITE
    'Lisp_Vectorlike
    '(struct Lisp_Sqlite)
    '((vectorlike)))

   ;; (PVEC_WEAK_REF			(struct Lisp_Weak_Ref))

   (igccg--make-layout
    'closure 'IGC_OBJ_VECTOR 'PVEC_CLOSURE
    'Lisp_Vectorlike
    'vectorlike_header
    '((vectorlike)))

   (igccg--make-layout
    'char_table 'IGC_OBJ_VECTOR 'PVEC_CHAR_TABLE
    'Lisp_Vectorlike
    '(struct Lisp_Char_Table)
    '((vectorlike)))

   (igccg--make-layout
    'sub_char_table 'IGC_OBJ_VECTOR 'PVEC_SUB_CHAR_TABLE
    'Lisp_Vectorlike
    '(struct Lisp_Sub_Char_Table)
    '((array tagged contents (sub-char-table-len))))

   (igccg--make-layout
    'record 'IGC_OBJ_VECTOR 'PVEC_RECORD 'Lisp_Vectorlike
    'vectorlike_header
    '((vectorlike)))

   (igccg--make-layout
    'font 'IGC_OBJ_VECTOR 'PVEC_FONT 'Lisp_Vectorlike
    '(struct Lisp_Vector)
    '((vectorlike)
      (switch (pvec-header-size)
              (FONT_SPEC_MAX)
              (FONT_ENTITY_MAX)
              (FONT_OBJECT_MAX (font-object-quirks))
              (default (abort)))))
   ))

(defun igccg-main ()
  (igccg--emit-line "/* Generated by igc-codegen.el */")
  (igccg--emit-line "#pragma GCC diagnostic push")
  ;;(igccg--emit-line "#pragma GCC diagnostic ignored \"-Wunused-function\"")
  (igccg--emit-scan-object-method "dflt" igccg--layouts)
  (igccg--emit-line "#pragma GCC diagnostic pop"))

;; (igccg-main)