#! /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 --------------------------------------------------