@@@ progfmt wip

[sod] / doc / progfmt

#! /bin/sh
":"; ### -*-lisp-*-
":"; CL_SOURCE_REGISTRY=$(pwd)/build/src/:
":"; ASDF_OUTPUT_TRANSLATIONS=$(pwd)/src:$(pwd)/build/src
":"; export CL_SOURCE_REGISTRY ASDF_OUTPUT_TRANSLATIONS
":"; exec cl-launch -X -l "sbcl cmucl" -s asdf -i "(main)" -- "$0" "$@" || exit 1

;;;--------------------------------------------------------------------------
;;; Random utilities.

(defun whitespace-char-p (char)
  (case char
    (#.(loop for i below char-code-limit
             for ch = (code-char i)
             unless (with-input-from-string (in (string ch))
                      (peek-char t in nil))
             collect ch) t)
    (t nil)))

(defun slurp-file (pathname)
  (with-open-file (stream pathname)
    (let* ((length (file-length stream))
           (string (make-string length))
           (n (read-sequence string stream))
           (ch (read-char stream nil)))
      (unless (and (= n length) (null ch))
        (error "File `~A' unexpectedly changed size when reading" pathname))
      string)))

(defun update-hash-table (map alist)
  (dolist (item alist map)
    (let ((key (car item))
          (value (cdr item)))
      (if value (setf (gethash key map) value)
          (remhash key map)))))

(defun copy-hash-table (map)
  (let ((new (make-hash-table :test (hash-table-test map))))
    (maphash (lambda (key value)
               (setf (gethash key new) value))
             map)
    new))

(defun build-hash-table (alist &key (test #'eql))
  (update-hash-table (make-hash-table :test test) alist))

(defun modified-hash-table (map alist)
  (update-hash-table (copy-hash-table map) alist))

(defun binary-search (item-key vector lessp &key (key #'identity))
  (let ((len (length vector)))
    (if (or (zerop len)
            (funcall lessp item-key (funcall key (aref vector 0))))
        (values 0 nil)
        (let ((lo 0) (hi len))
          (loop (let ((gap (- hi lo)))
                  (when (< gap 2) (return))
                  (let ((mid (+ lo (floor gap 2))))
                    (if (funcall lessp item-key
                                       (funcall key (aref vector mid)))
                        (setf hi mid)
                        (setf lo mid)))))
          (cond (( = lo hi) (values 0 nil))
                ((funcall lessp (funcall key (aref vector lo))
                          item-key)
                 (values (1+ lo) nil))
                (t (values lo t)))))))

(defun add-to-sorted-vector (item vector lessp &key (key #'identity))
  (multiple-value-bind (index foundp)
      (binary-search (funcall key item) vector lessp)
    (unless foundp
      (let ((len (fill-pointer vector))
            (size (array-dimension vector 0)))
        (when (= len size)
          (setf vector (adjust-array vector (* 2 size))))
        (setf (fill-pointer vector) (1+ len))
        (replace vector vector
                 :start1 (1+ index) :end1 (1+ len)
                 :start2 index :end2 len)
        (setf (aref vector index) item)))
    vector))

(defmacro sorted-vector-push (item vector-place lessp &key key
                              &environment env)
  (let ((item-var (gensym "ITEM-")))
    (multiple-value-bind (vars values temps store-form load-form)
        (get-setf-expansion vector-place env)
    `(let* ((,item-var ,item)
            ,@(mapcar #'list vars values)
            (,(car temps) (add-to-sorted-vector ,item-var ,load-form ,lessp
                                                ,@(and key `(:key ,key)))))
       ,store-form))))

(defparameter *char-latex-map*
  (build-hash-table '((#\\ . "\\textbackslash{}")
                      (#\{ . "\\{")
                      (#\} . "\\}")
                      (#\% . "\\%")
                      (#\$ . "\\$")
                      (#\# . "\\#")
                      (#\& . "\\&")
                      (#\^ . "\\textasciicircum{}")
                      (#\~ . "\\textasciitilde{}")
                      (#\` . "\\textasciigrave{}")
                      (#\' . "\\textquotesingle{}")
                      (#\- . "\\fakeminus{}")
                      (#\< . "{<}")
                      (#\> . "{>}"))))

(defun string-latex (string &optional (map *char-latex-map*))
  (with-output-to-string (out)
    (dotimes (i (length string))
      (let ((char (char string i)))
        (multiple-value-bind (latex foundp) (gethash char map)
          (if foundp (write-string latex out)
              (write-char char out)))))))

;;;--------------------------------------------------------------------------
;;; Tokens.

(defclass token ()
  ((string :type string :initarg :string :reader token-string)
   (line :type fixnum :initarg :line :reader token-line)
   (start-column :type fixnum :initarg :start-column :reader token-start-column)
   (end-column :type fixnum :initarg :end-column :reader token-end-column)
   (active-alignment-points :type list
                            :initform (make-array 4
                                                  :element-type
                                                    '(unsigned-byte 16)
                                                  :fill-pointer 0)
                            :accessor token-active-alignment-points)))

(defmethod print-object ((token token) stream)
  (print-unreadable-object (token stream :type t)
    (prin1 (token-string token) stream)))

(defclass whitespace (token)
  ())

(defclass tabulation (whitespace)
  ())

(defclass indentation (whitespace)
  ())

(defclass operator (token)
  ((latex :type string :initarg :latex :reader token-latex)))

(defmethod shared-initialize :after ((token operator) slot-names &key)
  (when (and (not (slot-boundp token 'latex))
             (or (eq slot-names t) (member 'latex slot-names)))
    (setf (slot-value token 'latex)
          (slot-value token 'string))))

(defclass identifier (token)
  ())

(defclass reserved (token)
  ())

(defclass numeric (token)
  ())

(defclass literal (token)
  ())

(defclass comment-delimiter (operator)
  ())

(defclass comment-body (token)
  ())

(defgeneric token-width (token)
  (:method ((token token)) (length (token-string token))))
(defgeneric token-alignment-points (token)
  (:method ((token token)) nil))
(defgeneric activate-token-alignment-point (token offset)
  (:method ((token token) offset)
    (let* ((vec (active-alignment-points token))
           (len (fill-pointer vec)))
(defgeneric format-token (token stream)
  (:method ((token token) stream)
    (princ (string-latex (token-string token)) stream)))

(defclass alignment-point ()
  ())

(defclass relative-alignment-point (alignment-point)
  ())

(defclass absolute-alignment-point (alignment-point)
  ())

(defun tokenize-whitespace (line pos end emit &key force-indent)
  (when (whitespace-char-p (char line pos))
    (let ((next (or (position-if-not #'whitespace-char-p line
                                     :start pos :end end)
                    end)))
      (funcall emit
               (cond ((or (zerop pos) force-indent) 'indentation)
                     ((find #\tab line :start pos :end next) 'tabulation)
                     (t 'whitespace))
               pos next))))

(defun move-over (line pos end string)
  (let ((next (+ pos (length string))))
    (if (and (<= next end)
             (string= string line :start2 pos :end2 next))
        next
        nil)))

(defun try-tokenize (line pos end emit class alist)
  (dolist (item alist)
    (multiple-value-bind (string initargs)
        (if (consp item) (values (car item) (cdr item))
            (values item nil))
      (let ((next (move-over line pos end string)))
        (when next
          (return (apply emit class pos next initargs)))))))

;;;--------------------------------------------------------------------------
;;; Language definitions.

(defparameter *language-matchers* nil)

(defmacro deflanguage (name (pathname) &body body)
  `(progn
     (pushnew (cons ',name (lambda (,pathname) ,@body))
              *language-matchers*
              :key #'car)
     ',name))

(let ((templates (mapcar (lambda (type)
                           (make-pathname :type type :case :common))
                         '("C" "CC" "CPP" "C++" "CXX"
                           "H" "HH" "HPP" "H++" "HXX"
                           "SOD"))))
  (deflanguage c-language (pathname)
    (find pathname templates :test #'pathname-match-p)))

(let ((templates (mapcar (lambda (type)
                           (make-pathname :type type :case :common))
                         '("LISP" "EL" "SCM"))))
  (deflanguage lisp-language (pathname)
    (find pathname templates :test #'pathname-match-p)))

(deflanguage make-language (pathname)
  (pathname-match-p pathname
                    (make-pathname :name "MAKEFILE" :case :common)))

(defun guess-language (pathname)
  (car (or (find-if (lambda (item)
                      (funcall (cdr item) pathname))
                    *language-matchers*)
           (error "No language found for `~A'." pathname))))

(defclass base-language ()
  ())

;;;--------------------------------------------------------------------------
;;; C(-ish) language scanner.

(defclass c-language (base-language)
  ((state :type (member :toplevel :comment)
          :initform :toplevel :accessor lang-state)))

(defparameter *c-keywords*
  (build-hash-table '(("alignas" . t)
                      ("alignof" . t)
                      ("and" . t)
                      ("and_eq" . t)
                      ("asm" . t)
                      ("atomic" . t)
                      ("auto" . t)
                      ("bitand" . t)
                      ("bitor" . t)
                      ("bool" . t)
                      ("break" . t)
                      ("case" . t)
                      ("catch" . t)
                      ("char" . t)
                      ("char16_t" . t)
                      ("char32_t" . t)
                      ("class" . t)
                      ("complex" . t)
                      ("compl" . t)
                      ("const" . t)
                      ("constexpr" . t)
                      ("const_cast" . t)
                      ("continue" . t)
                      ("decltype" . t)
                      ("defined" . t)
                      ("default" . t)
                      ("delete" . t)
                      ("do" . t)
                      ("double" . t)
                      ("dynamic_cast" . t)
                      ("else" . t)
                      ("enum" . t)
                      ("explicit" . t)
                      ("export" . t)
                      ("extern" . t)
                      ("float" . t)
                      ("for" . t)
                      ("friend" . t)
                      ("goto" . t)
                      ("if" . t)
                      ("imaginary" . t)
                      ("inline" . t)
                      ("int" . t)
                      ("long" . t)
                      ("mutable" . t)
                      ("namespace" . t)
                      ("new" . t)
                      ("noexcept" . t)
                      ("noreturn" . t)
                      ("not" . t)
                      ("not_eq" . t)
                      ("nullptr" . t)
                      ("operator" . t)
                      ("or" . t)
                      ("or_eq" . t)
                      ("private" . t)
                      ("protected" . t)
                      ("public" . t)
                      ("register" . t)
                      ("reinterpret_cast" . t)
                      ("restrict" . t)
                      ("return" . t)
                      ("short" . t)
                      ("signed" . t)
                      ("sizeof" . t)
                      ("static" . t)
                      ("static_assert" . t)
                      ("static_cast" . t)
                      ("struct" . t)
                      ("switch" . t)
                      ("template" . t)
                      ("throw" . t)
                      ("try" . t)
                      ("thread_local" . t)
                      ("typedef" . t)
                      ("typeid" . t)
                      ("typeof" . t)
                      ("typename" . t)
                      ("union" . t)
                      ("unsigned" . t)
                      ("using" . t)
                      ("virtual" . t)
                      ("void" . t)
                      ("volatile" . t)
                      ("wchar_t" . t)
                      ("while" . t)
                      ("xor" . t)
                      ("xor_eq" . t)
                      ("_Alignas" . t)
                      ("_Alignof" . t)
                      ("_Atomic" . t)
                      ("_Bool" . t)
                      ("_Complex" . t)
                      ("_Generic" . t)
                      ("_Imaginary" . t)
                      ("_Noreturn" . t)
                      ("_Pragma" . t)
                      ("_Static_assert" . t)
                      ("_Thread_local" . t)
                      ("__alignof__" . t)
                      ("__asm__" . t)
                      ("__attribute__" . t)
                      ("__complex__" . t)
                      ("__const__" . t)
                      ("__extension__" . t)
                      ("__imag__" . t)
                      ("__inline__" . t)
                      ("__label__" . t)
                      ("__real__" . t)
                      ("__signed__" . t)
                      ("__typeof__" . t)
                      ("__volatile__" . t))
                    :test #'equal))

(defparameter *c-preprocessor-keywords*
  (build-hash-table '(("define" . :toplevel)
                      ("elif" . :toplevel)
                      ("else" . :toplevel)
                      ("endif" . :toplevel)
                      ("error" . :toplevel)
                      ("if" . :toplevel)
                      ("ifdef" . :toplevel)
                      ("ifndef" . :toplevel)
                      ("include" . :include)
                      ("line" . :toplevel)
                      ("pragma" . :toplevel)
                      ("undef" . :toplevel))))

(defun scan-c-identifier (line pos end)
  (if (and (< pos end)
           (let ((char (char line pos)))
             (or (char= char #\_) (alpha-char-p char))))
      (let ((next (or (position-if-not (lambda (char)
                                         (or (char= char #\_)
                                             (alphanumericp char)))
                                       line
                                       :start (1+ pos) :end end)
                      end)))
        (values (subseq line pos next) next))
      (values nil nil)))

(defun tokenize-c-comment (lang line pos end emit)
  (and (>= (- end pos) 2)
       (char= (char line pos) #\/)
       (let ((body-start (+ pos 2))
             (ch (char line (1+ pos))))
         (or (and (char= ch  #\/)
                  (setf (lang-state lang) :toplevel)
                  (funcall emit 'comment-delimiter pos body-start)
                  (when (< body-start end)
                    (funcall emit 'comment-body body-start end))
                  end)
             (and (char= ch #\*)
                  (funcall emit 'comment-delimiter pos body-start)
                  (let* ((end-delim (search "*/" line
                                            :start2 body-start :end2 end))
                         (body-end (or end-delim end))
                         (next (if end-delim (+ end-delim 2) end)))
                    (when (< body-start body-end)
                      (funcall emit 'comment-body body-start body-end))
                    (cond (end-delim
                           (setf (lang-state lang) :toplevel)
                           (funcall emit 'comment-delimiter end-delim next))
                          (t
                           (setf (lang-state lang) :comment)
                           next))))))))

(defmethod next-token ((lang c-language) line pos end emit)
  (let ((state (lang-state lang))
        (char (char line pos)))
    (ecase state
      (:toplevel
       (or (and (zerop pos)
                (let ((next (or (tokenize-whitespace line pos end emit)
                                pos)))
                  (cond ((and (< next end)
                              (char= (char line next) #\#))
                         (setf (lang-state lang) :preproc-keyword)
                         (funcall emit 'operator next (1+ next)))
                        ((> next pos)
                         next))))

           (tokenize-whitespace line pos end emit)

           (multiple-value-bind (ident next) (scan-c-identifier line pos end)
             (and ident
                  (funcall emit
                           (if (gethash ident *c-keywords*)
                               'reserved
                               'identifier)
                           pos next)))

           (let ((i (cond ((digit-char-p char)
                           (1+ pos))
                          ((and (char= char #\.)
                                (>= (- end pos) 2)
                                (digit-char-p (char line (1+ pos))))
                           (+ pos 2))
                          (t
                           nil))))
             (when i
               (loop (when (>= i end) (return))
                 (let ((char (char line i)))
                   (cond ((or (char= char #\e)
                              (char= char #\E)
                              (char= char #\p)
                              (char= char #\P))
                          (if (and (>= (- end i) 2)
                                   (let ((ch (char line (1+ i))))
                                     (or (char= ch #\+)
                                         (char= ch #\-))))
                              (incf i 2)
                              (incf i 1)))
                         ((or (char= char #\_)
                              (char= char #\.)
                              (alphanumericp char))
                          (incf i))
                         (t
                          (return)))))
               (funcall emit 'numeric pos i)))

           (and (or (char= char #\")
                    (char= char #\'))
                (let ((i (1+ pos)))
                  (loop (when (>= i end)
                          (error "Missing `~A'." char))
                        (let ((ch (char line i)))
                          (cond ((char= ch char) (return))
                                ((char= ch #\\) (incf i 2))
                                (t (incf i)))))
                  (funcall emit 'literal pos (1+ i))))

           (tokenize-c-comment lang line pos end emit)

           (try-tokenize line pos end emit 'operator
                         '("->" "++" ("--" :latex "{--}\\,{--}")
                           "<<" ">>" "<=" ">=" "==" "!=" "&&" "||"
                           "*=" "/=" "%=" "+=" "-=" "<<=" ">>="
                           "&=" "^=" "|=" "##"
                           "<:" ":>" "<%" "%>" "%:" "%:%:"))

           (funcall emit 'operator pos (1+ pos))))

      (:comment
       (assert (zerop pos))
       (let ((next (tokenize-whitespace line pos end emit)))
         (when next (setf pos next)))
       (when (and (< pos end)
                  (char= (char line pos) #\*))
         (setf pos (funcall emit 'comment-delimiter pos (1+ pos))))
       (let* ((end-delim (search "*/" line :start2 pos :end2 end))
              (body-end (or end-delim end))
              (next (if end-delim (+ end-delim 2) end)))
         (when (< pos body-end)
           (funcall emit 'comment-body pos body-end))
         (cond (end-delim
                (setf (lang-state lang) :toplevel)
                (funcall emit 'comment-delimiter body-end next))
               (t
                next))))

      (:preproc-keyword
       (or (tokenize-whitespace line pos end emit)
           (tokenize-c-comment lang line pos end emit)

           (multiple-value-bind (ident next) (scan-c-identifier line pos end)
             (let ((next-state (gethash ident *c-preprocessor-keywords*)))
               (funcall emit (if next-state 'reserved 'identifier) pos next)
               (setf (lang-state lang) (or next-state :toplevel))))

           (progn (setf (lang-state lang) :toplevel) pos))))))

(defun tokenize-line (lang line)
  (let ((tokens nil) (pos 0) (end (length line)))
    (loop (if (>= pos end) (return (nreverse tokens))
              (next-token lang line pos end
                          (lambda (class start end &rest initargs)
                            (assert (= start pos))
                            (push (apply #'make-instance class
                                         :string (subseq line start end)
                                         initargs)
                                  tokens)
                            (setf pos end)))))))


(defgeneric scan-line ((lang c-language) line)
  (let* ((i 0)
         (spaces 0)
         (last 0)
         (end (length line))
         (state (lang-state lang))
         (markers nil)
         (comment (if (eq state :comment) :trad nil))
         (comment-begin (if (eq state :comment) :star nil)
         (escape nil)
         (frags nil))
    (loop
      (when (>= i end) (return))
      (let ((ch (char line i))
            (align-next nil))
        (cond ((char= ch #\tab) (setf space 8))
              ((whitespace-char-p ch) (incf space))
              (t
               (when (and (plusp start) (>= space 2))
                 (push (cons i :align) markers))
               (case ch
                 ((#\, #\;) (setf space 1))
                 ((#\( #\[ #\{) (push (cons (1+ i) :align) markers)))))
        (ecase state
          (:toplevel
           (case ch
             (#\" (push (cons (1+ i) :align) merkers)
                  (setf state :string))
             (#\' (setf state :char))
             (#\/ (when (< (1+ i) end)
                    (let ((nch (char line (1+ i))))
                      (case nch
                        (#\/ (push (cons i :comment-start) markers)
                             (push (cons (+ i 2) :comment-body) markers)
                             (setf state :comment
                                   comment :line
                                   comment-begin t)
                             (incf i))
                        (#\* (push (cons i :comment-start) markers)
                             (push (cons (1+ i) :align) markers)
                             (push (cons (+ i 2) :comment-body) markers)
                             (setf state :comment
                                   comment :trad
                                   comment-begin t)
                             (incf i))))))))
          (:string
           (cond (escape (setf escape nil))
                 ((char= ch #\") (setf state :toplevel))
                 ((char= ch #\\) (setf escape t))))
          (:char
           (cond (escape (setf escape nil))
                 ((char= ch #\') (setf state :toplevel))
                 ((char= ch #\\) (setf escape t))))
          (:comment
           (when (and comment-begin (not (whitespace-char-p ch)))
             (cond ((char= ch #\*)-
               (push (cons i :comment-mid) markers)
               (push (cons (1+ i) :comment-body) markers))
             (setf comment-

          (case ch
            (#\space (incf space))
            (#\tab)
            (
        (ecase state
          (:top

;;;--------------------------------------------------------------------------
;;; The indentation algorithm.

(defvar *indent-high-water-mark* 0)

(defclass offset ()
  ((position :type fixnum :initarg :position :reader offset-position)
   (livep :type boolean :initarg :livep :initform nil
          :accessor offset-live-p)))

(defclass line ()
  ((text :type string :initarg :text :reader line-text)
   (offsets :type list :initarg :offsets :initform nil
            :reader line-offsets)))



;;;--------------------------------------------------------------------------
;;; Main program.

(defun main ()
  (format t "Hello, world!~%"))

#+interactive (main)

;;;----- That's all, folks --------------------------------------------------