;;;
;;; Writing src/h/cons.h and src/c/cons.d
;;;

(defun process-file (filename)
  (let* ((filename (merge-pathnames filename))
         (name (pathname-name filename))
         (input (make-pathname :name (concatenate 'string "bak-" name)
                               :type (pathname-type filename)
                               :directory (pathname-directory filename)))
         (output filename))
    (cond ((not (probe-file filename))
           (error "Unable to find ~a" filename))
          ((probe-file input)
           (error "Backup already exists" input))
          (t
           (format t "~%;;; Renaming ~a -> ~a" filename input)
           (rename-file filename input)))
    (with-open-file (in input :direction :input)
      (with-open-file (out output :direction :output :if-exists :supersede)
        (format t "~%;;; Transforming ~a -> ~a" input output)
        (loop with skip = nil
              for l = (read-line in nil nil nil)
              while l
              do (cond (skip
                        (when (search "END-GENERATED" l)
                          (write-line l out)
                          (setf skip nil)))
                       (t
                        (write-line l out)
                        (let ((ndx (search "BEGIN-GENERATED" l)))
                          (when ndx
                            (let* ((*standard-output* out)
                                   (form-text (subseq l (+ ndx 15)))
                                   (form (read-from-string form-text)))
                              (eval form)
                              (setf skip t)))))))))
    (format t "~%;;; Deleting the file ~a" input)
    (delete-file input)))

(defun write-rec (depth list flag &optional (prefix ""))
  (when (plusp depth)
    (write-rec (1- depth) (cons 'a list) flag)
    (write-rec (1- depth) (cons 'd list) flag)
    (return-from write-rec))
  (let* ((string (apply #'concatenate 'string (mapcar #'string-downcase list))))
    (case flag
      (:inline
       (write-rec depth list :unsafe "static ECL_INLINE "))
      (:unsafe-macro
       (format t "~%#define C~AR(x) _ecl_c~ar(x)" (string-upcase string) string))
      (:unsafe
       (format t "~%~acl_object _ecl_c~ar(cl_object x)~%{" prefix string)
       (loop for what in (reverse list)
             for op = (if (eq what 'a) "ECL_CONS_CAR" "ECL_CONS_CDR")
             do (format t "~%  if (Null(x)) return x;~%  x = ~A(x);" op))
       (format t "~%  return x;~%}~%"))
      (:safe
       (format t "~%cl_object ecl_c~ar(cl_object x)~%{" string)
       (loop for what in (reverse list)
             for op = (if (eq what 'a) "ECL_CONS_CAR" "ECL_CONS_CDR")
             do (format t "~%  if (ecl_unlikely(!ECL_LISTP(x))) FEwrong_type_nth_arg(@[car], 1, x, @[list]);")
             do (format t "~%  if (Null(x)) return x;~%  x = ~A(x);" op))
       (format t "~%  return x;~%}~%"))
      (:common-lisp
       (format t "~%cl_object cl_c~ar(cl_object x)~%{~%  return1(ecl_c~ar(x));~%}~%"
               string string))
      (:declare-unsafe
       (format t "~%extern ECL_API cl_object _ecl_c~ar(cl_object);" string))
      (:declare-safe
       (format t "~%extern ECL_API cl_object ecl_c~ar(cl_object);" string))
      (:declare-common-lisp
       (format t "~%extern ECL_API cl_object cl_c~ar(cl_object);" string))
      (:common-lisp-inline
       (format t "~%(def-inline c~ar :always (t) t \"ecl_c~ar(#0)\")" string string)
       (format t "~%(def-inline c~ar :unsafe (t) t \"_ecl_c~ar(#0)\")" string string)
       )
      )))

(defun gen-cons-h ()
  (format t "~%#if ECL_CAN_INLINE")
  (loop for depth from 1 below 5
        do (write-rec depth nil :inline))
  (format t "~%#else")
  (loop for depth from 1 below 5
        do (write-rec depth nil :declare-unsafe))
  (format t "~%#endif /* !ECL_CAN_INLINE */~%")
  (loop for depth from 1 below 5
        do (write-rec depth nil :declare-safe))
  (terpri)
  (gen-cons-legacy-h)
  (loop for depth from 1 below 5
        do (write-rec depth nil :declare-common-lisp))
  (terpri))

(defun gen-cons-d ()
  (format t "~%#if !ECL_CAN_INLINE")
  (loop for depth from 1 below 5
        do (write-rec depth nil :unsafe))
  (format t "~%#endif /* !ECL_CAN_INLINE */~%")
  (loop for depth from 1 below 5
        do (write-rec depth nil :safe))
  (terpri)
  (loop for depth from 1 below 5
        do (write-rec depth nil :common-lisp))
  (terpri))

(defun gen-cons-legacy-h ()
  (loop for depth from 1 below 5
        do (write-rec depth nil :unsafe-macro))
  (terpri))

(defun gen-cons-sysfun ()
  (loop for depth from 1 below 5
        do (write-rec depth nil :common-lisp-inline))
  (terpri))

(process-file "src/c/cons.d")
(process-file "src/h/cons.h")
;(process-file "src/h/legacy.h")
(process-file "src/cmp/sysfun.lsp")
(terpri)
#+ecl
(ext:quit)
