--- /dev/null
+#! /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 --------------------------------------------------
~mdw / sod / commitdiff