chiark - git - mdw - sod/blob - doc/progfmt

   1 #! /bin/sh
   2 ":"; ### -*-lisp-*-
   3 ":"; CL_SOURCE_REGISTRY=$(pwd)/build/src/:
   4 ":"; ASDF_OUTPUT_TRANSLATIONS=$(pwd)/src:$(pwd)/build/src
   5 ":"; export CL_SOURCE_REGISTRY ASDF_OUTPUT_TRANSLATIONS
   6 ":"; exec cl-launch -X -l "sbcl cmucl" -s asdf -i "(main)" -- "$0" "$@" || exit 1
   7
   8 ;;;--------------------------------------------------------------------------
   9 ;;; Random utilities.
  10
  11 (defun whitespace-char-p (char)
  12   (case char
  13     (#.(loop for i below char-code-limit
  14              for ch = (code-char i)
  15              unless (with-input-from-string (in (string ch))
  16                       (peek-char t in nil))
  17              collect ch) t)
  18     (t nil)))
  19
  20 (defun slurp-file (pathname)
  21   (with-open-file (stream pathname)
  22     (let* ((length (file-length stream))
  23            (string (make-string length))
  24            (n (read-sequence string stream))
  25            (ch (read-char stream nil)))
  26       (unless (and (= n length) (null ch))
  27         (error "File `~A' unexpectedly changed size when reading" pathname))
  28       string)))
  29
  30 (defun update-hash-table (map alist)
  31   (dolist (item alist map)
  32     (let ((key (car item))
  33           (value (cdr item)))
  34       (if value (setf (gethash key map) value)
  35           (remhash key map)))))
  36
  37 (defun copy-hash-table (map)
  38   (let ((new (make-hash-table :test (hash-table-test map))))
  39     (maphash (lambda (key value)
  40                (setf (gethash key new) value))
  41              map)
  42     new))
  43
  44 (defun build-hash-table (alist &key (test #'eql))
  45   (update-hash-table (make-hash-table :test test) alist))
  46
  47 (defun modified-hash-table (map alist)
  48   (update-hash-table (copy-hash-table map) alist))
  49
  50 (defun binary-search (item-key vector lessp &key (key #'identity))
  51   (let ((len (length vector)))
  52     (if (or (zerop len)
  53             (funcall lessp item-key (funcall key (aref vector 0))))
  54         (values 0 nil)
  55         (let ((lo 0) (hi len))
  56           (loop (let ((gap (- hi lo)))
  57                   (when (< gap 2) (return))
  58                   (let ((mid (+ lo (floor gap 2))))
  59                     (if (funcall lessp item-key
  60                                        (funcall key (aref vector mid)))
  61                         (setf hi mid)
  62                         (setf lo mid)))))
  63           (cond (( = lo hi) (values 0 nil))
  64                 ((funcall lessp (funcall key (aref vector lo))
  65                           item-key)
  66                  (values (1+ lo) nil))
  67                 (t (values lo t)))))))
  68
  69 (defun add-to-sorted-vector (item vector lessp &key (key #'identity))
  70   (multiple-value-bind (index foundp)
  71       (binary-search (funcall key item) vector lessp)
  72     (unless foundp
  73       (let ((len (fill-pointer vector))
  74             (size (array-dimension vector 0)))
  75         (when (= len size)
  76           (setf vector (adjust-array vector (* 2 size))))
  77         (setf (fill-pointer vector) (1+ len))
  78         (replace vector vector
  79                  :start1 (1+ index) :end1 (1+ len)
  80                  :start2 index :end2 len)
  81         (setf (aref vector index) item)))
  82     vector))
  83
  84 (defmacro sorted-vector-push (item vector-place lessp &key key
  85                               &environment env)
  86   (let ((item-var (gensym "ITEM-")))
  87     (multiple-value-bind (vars values temps store-form load-form)
  88         (get-setf-expansion vector-place env)
  89     `(let* ((,item-var ,item)
  90             ,@(mapcar #'list vars values)
  91             (,(car temps) (add-to-sorted-vector ,item-var ,load-form ,lessp
  92                                                 ,@(and key `(:key ,key)))))
  93        ,store-form))))
  94
  95 (defparameter *char-latex-map*
  96   (build-hash-table '((#\\ . "\\textbackslash{}")
  97                       (#\{ . "\\{")
  98                       (#\} . "\\}")
  99                       (#\% . "\\%")
 100                       (#\$ . "\\$")
 101                       (#\# . "\\#")
 102                       (#\& . "\\&")
 103                       (#\^ . "\\textasciicircum{}")
 104                       (#\~ . "\\textasciitilde{}")
 105                       (#\` . "\\textasciigrave{}")
 106                       (#\' . "\\textquotesingle{}")
 107                       (#\- . "\\fakeminus{}")
 108                       (#\< . "{<}")
 109                       (#\> . "{>}"))))
 110
 111 (defun string-latex (string &optional (map *char-latex-map*))
 112   (with-output-to-string (out)
 113     (dotimes (i (length string))
 114       (let ((char (char string i)))
 115         (multiple-value-bind (latex foundp) (gethash char map)
 116           (if foundp (write-string latex out)
 117               (write-char char out)))))))
 118
 119 ;;;--------------------------------------------------------------------------
 120 ;;; Tokens.
 121
 122 (defclass token ()
 123   ((string :type string :initarg :string :reader token-string)
 124    (line :type fixnum :initarg :line :reader token-line)
 125    (start-column :type fixnum :initarg :start-column :reader token-start-column)
 126    (end-column :type fixnum :initarg :end-column :reader token-end-column)
 127    (active-alignment-points :type list
 128                             :initform (make-array 4
 129                                                   :element-type
 130                                                     '(unsigned-byte 16)
 131                                                   :fill-pointer 0)
 132                             :accessor token-active-alignment-points)))
 133
 134 (defmethod print-object ((token token) stream)
 135   (print-unreadable-object (token stream :type t)
 136     (prin1 (token-string token) stream)))
 137
 138 (defclass whitespace (token)
 139   ())
 140
 141 (defclass tabulation (whitespace)
 142   ())
 143
 144 (defclass indentation (whitespace)
 145   ())
 146
 147 (defclass operator (token)
 148   ((latex :type string :initarg :latex :reader token-latex)))
 149
 150 (defmethod shared-initialize :after ((token operator) slot-names &key)
 151   (when (and (not (slot-boundp token 'latex))
 152              (or (eq slot-names t) (member 'latex slot-names)))
 153     (setf (slot-value token 'latex)
 154           (slot-value token 'string))))
 155
 156 (defclass identifier (token)
 157   ())
 158
 159 (defclass reserved (token)
 160   ())
 161
 162 (defclass numeric (token)
 163   ())
 164
 165 (defclass literal (token)
 166   ())
 167
 168 (defclass comment-delimiter (operator)
 169   ())
 170
 171 (defclass comment-body (token)
 172   ())
 173
 174 (defgeneric token-width (token)
 175   (:method ((token token)) (length (token-string token))))
 176 (defgeneric token-alignment-points (token)
 177   (:method ((token token)) nil))
 178 (defgeneric activate-token-alignment-point (token offset)
 179   (:method ((token token) offset)
 180     (let* ((vec (active-alignment-points token))
 181            (len (fill-pointer vec)))
 182 (defgeneric format-token (token stream)
 183   (:method ((token token) stream)
 184     (princ (string-latex (token-string token)) stream)))
 185
 186 (defclass alignment-point ()
 187   ())
 188
 189 (defclass relative-alignment-point (alignment-point)
 190   ())
 191
 192 (defclass absolute-alignment-point (alignment-point)
 193   ())
 194
 195 (defun tokenize-whitespace (line pos end emit &key force-indent)
 196   (when (whitespace-char-p (char line pos))
 197     (let ((next (or (position-if-not #'whitespace-char-p line
 198                                      :start pos :end end)
 199                     end)))
 200       (funcall emit
 201                (cond ((or (zerop pos) force-indent) 'indentation)
 202                      ((find #\tab line :start pos :end next) 'tabulation)
 203                      (t 'whitespace))
 204                pos next))))
 205
 206 (defun move-over (line pos end string)
 207   (let ((next (+ pos (length string))))
 208     (if (and (<= next end)
 209              (string= string line :start2 pos :end2 next))
 210         next
 211         nil)))
 212
 213 (defun try-tokenize (line pos end emit class alist)
 214   (dolist (item alist)
 215     (multiple-value-bind (string initargs)
 216         (if (consp item) (values (car item) (cdr item))
 217             (values item nil))
 218       (let ((next (move-over line pos end string)))
 219         (when next
 220           (return (apply emit class pos next initargs)))))))
 221
 222 ;;;--------------------------------------------------------------------------
 223 ;;; Language definitions.
 224
 225 (defparameter *language-matchers* nil)
 226
 227 (defmacro deflanguage (name (pathname) &body body)
 228   `(progn
 229      (pushnew (cons ',name (lambda (,pathname) ,@body))
 230               *language-matchers*
 231               :key #'car)
 232      ',name))
 233
 234 (let ((templates (mapcar (lambda (type)
 235                            (make-pathname :type type :case :common))
 236                          '("C" "CC" "CPP" "C++" "CXX"
 237                            "H" "HH" "HPP" "H++" "HXX"
 238                            "SOD"))))
 239   (deflanguage c-language (pathname)
 240     (find pathname templates :test #'pathname-match-p)))
 241
 242 (let ((templates (mapcar (lambda (type)
 243                            (make-pathname :type type :case :common))
 244                          '("LISP" "EL" "SCM"))))
 245   (deflanguage lisp-language (pathname)
 246     (find pathname templates :test #'pathname-match-p)))
 247
 248 (deflanguage make-language (pathname)
 249   (pathname-match-p pathname
 250                     (make-pathname :name "MAKEFILE" :case :common)))
 251
 252 (defun guess-language (pathname)
 253   (car (or (find-if (lambda (item)
 254                       (funcall (cdr item) pathname))
 255                     *language-matchers*)
 256            (error "No language found for `~A'." pathname))))
 257
 258 (defclass base-language ()
 259   ())
 260
 261 ;;;--------------------------------------------------------------------------
 262 ;;; C(-ish) language scanner.
 263
 264 (defclass c-language (base-language)
 265   ((state :type (member :toplevel :comment)
 266           :initform :toplevel :accessor lang-state)))
 267
 268 (defparameter *c-keywords*
 269   (build-hash-table '(("alignas" . t)
 270                       ("alignof" . t)
 271                       ("and" . t)
 272                       ("and_eq" . t)
 273                       ("asm" . t)
 274                       ("atomic" . t)
 275                       ("auto" . t)
 276                       ("bitand" . t)
 277                       ("bitor" . t)
 278                       ("bool" . t)
 279                       ("break" . t)
 280                       ("case" . t)
 281                       ("catch" . t)
 282                       ("char" . t)
 283                       ("char16_t" . t)
 284                       ("char32_t" . t)
 285                       ("class" . t)
 286                       ("complex" . t)
 287                       ("compl" . t)
 288                       ("const" . t)
 289                       ("constexpr" . t)
 290                       ("const_cast" . t)
 291                       ("continue" . t)
 292                       ("decltype" . t)
 293                       ("defined" . t)
 294                       ("default" . t)
 295                       ("delete" . t)
 296                       ("do" . t)
 297                       ("double" . t)
 298                       ("dynamic_cast" . t)
 299                       ("else" . t)
 300                       ("enum" . t)
 301                       ("explicit" . t)
 302                       ("export" . t)
 303                       ("extern" . t)
 304                       ("float" . t)
 305                       ("for" . t)
 306                       ("friend" . t)
 307                       ("goto" . t)
 308                       ("if" . t)
 309                       ("imaginary" . t)
 310                       ("inline" . t)
 311                       ("int" . t)
 312                       ("long" . t)
 313                       ("mutable" . t)
 314                       ("namespace" . t)
 315                       ("new" . t)
 316                       ("noexcept" . t)
 317                       ("noreturn" . t)
 318                       ("not" . t)
 319                       ("not_eq" . t)
 320                       ("nullptr" . t)
 321                       ("operator" . t)
 322                       ("or" . t)
 323                       ("or_eq" . t)
 324                       ("private" . t)
 325                       ("protected" . t)
 326                       ("public" . t)
 327                       ("register" . t)
 328                       ("reinterpret_cast" . t)
 329                       ("restrict" . t)
 330                       ("return" . t)
 331                       ("short" . t)
 332                       ("signed" . t)
 333                       ("sizeof" . t)
 334                       ("static" . t)
 335                       ("static_assert" . t)
 336                       ("static_cast" . t)
 337                       ("struct" . t)
 338                       ("switch" . t)
 339                       ("template" . t)
 340                       ("throw" . t)
 341                       ("try" . t)
 342                       ("thread_local" . t)
 343                       ("typedef" . t)
 344                       ("typeid" . t)
 345                       ("typeof" . t)
 346                       ("typename" . t)
 347                       ("union" . t)
 348                       ("unsigned" . t)
 349                       ("using" . t)
 350                       ("virtual" . t)
 351                       ("void" . t)
 352                       ("volatile" . t)
 353                       ("wchar_t" . t)
 354                       ("while" . t)
 355                       ("xor" . t)
 356                       ("xor_eq" . t)
 357                       ("_Alignas" . t)
 358                       ("_Alignof" . t)
 359                       ("_Atomic" . t)
 360                       ("_Bool" . t)
 361                       ("_Complex" . t)
 362                       ("_Generic" . t)
 363                       ("_Imaginary" . t)
 364                       ("_Noreturn" . t)
 365                       ("_Pragma" . t)
 366                       ("_Static_assert" . t)
 367                       ("_Thread_local" . t)
 368                       ("__alignof__" . t)
 369                       ("__asm__" . t)
 370                       ("__attribute__" . t)
 371                       ("__complex__" . t)
 372                       ("__const__" . t)
 373                       ("__extension__" . t)
 374                       ("__imag__" . t)
 375                       ("__inline__" . t)
 376                       ("__label__" . t)
 377                       ("__real__" . t)
 378                       ("__signed__" . t)
 379                       ("__typeof__" . t)
 380                       ("__volatile__" . t))
 381                     :test #'equal))
 382
 383 (defparameter *c-preprocessor-keywords*
 384   (build-hash-table '(("define" . :toplevel)
 385                       ("elif" . :toplevel)
 386                       ("else" . :toplevel)
 387                       ("endif" . :toplevel)
 388                       ("error" . :toplevel)
 389                       ("if" . :toplevel)
 390                       ("ifdef" . :toplevel)
 391                       ("ifndef" . :toplevel)
 392                       ("include" . :include)
 393                       ("line" . :toplevel)
 394                       ("pragma" . :toplevel)
 395                       ("undef" . :toplevel))))
 396
 397 (defun scan-c-identifier (line pos end)
 398   (if (and (< pos end)
 399            (let ((char (char line pos)))
 400              (or (char= char #\_) (alpha-char-p char))))
 401       (let ((next (or (position-if-not (lambda (char)
 402                                          (or (char= char #\_)
 403                                              (alphanumericp char)))
 404                                        line
 405                                        :start (1+ pos) :end end)
 406                       end)))
 407         (values (subseq line pos next) next))
 408       (values nil nil)))
 409
 410 (defun tokenize-c-comment (lang line pos end emit)
 411   (and (>= (- end pos) 2)
 412        (char= (char line pos) #\/)
 413        (let ((body-start (+ pos 2))
 414              (ch (char line (1+ pos))))
 415          (or (and (char= ch  #\/)
 416                   (setf (lang-state lang) :toplevel)
 417                   (funcall emit 'comment-delimiter pos body-start)
 418                   (when (< body-start end)
 419                     (funcall emit 'comment-body body-start end))
 420                   end)
 421              (and (char= ch #\*)
 422                   (funcall emit 'comment-delimiter pos body-start)
 423                   (let* ((end-delim (search "*/" line
 424                                             :start2 body-start :end2 end))
 425                          (body-end (or end-delim end))
 426                          (next (if end-delim (+ end-delim 2) end)))
 427                     (when (< body-start body-end)
 428                       (funcall emit 'comment-body body-start body-end))
 429                     (cond (end-delim
 430                            (setf (lang-state lang) :toplevel)
 431                            (funcall emit 'comment-delimiter end-delim next))
 432                           (t
 433                            (setf (lang-state lang) :comment)
 434                            next))))))))
 435
 436 (defmethod next-token ((lang c-language) line pos end emit)
 437   (let ((state (lang-state lang))
 438         (char (char line pos)))
 439     (ecase state
 440       (:toplevel
 441        (or (and (zerop pos)
 442                 (let ((next (or (tokenize-whitespace line pos end emit)
 443                                 pos)))
 444                   (cond ((and (< next end)
 445                               (char= (char line next) #\#))
 446                          (setf (lang-state lang) :preproc-keyword)
 447                          (funcall emit 'operator next (1+ next)))
 448                         ((> next pos)
 449                          next))))
 450
 451            (tokenize-whitespace line pos end emit)
 452
 453            (multiple-value-bind (ident next) (scan-c-identifier line pos end)
 454              (and ident
 455                   (funcall emit
 456                            (if (gethash ident *c-keywords*)
 457                                'reserved
 458                                'identifier)
 459                            pos next)))
 460
 461            (let ((i (cond ((digit-char-p char)
 462                            (1+ pos))
 463                           ((and (char= char #\.)
 464                                 (>= (- end pos) 2)
 465                                 (digit-char-p (char line (1+ pos))))
 466                            (+ pos 2))
 467                           (t
 468                            nil))))
 469              (when i
 470                (loop (when (>= i end) (return))
 471                  (let ((char (char line i)))
 472                    (cond ((or (char= char #\e)
 473                               (char= char #\E)
 474                               (char= char #\p)
 475                               (char= char #\P))
 476                           (if (and (>= (- end i) 2)
 477                                    (let ((ch (char line (1+ i))))
 478                                      (or (char= ch #\+)
 479                                          (char= ch #\-))))
 480                               (incf i 2)
 481                               (incf i 1)))
 482                          ((or (char= char #\_)
 483                               (char= char #\.)
 484                               (alphanumericp char))
 485                           (incf i))
 486                          (t
 487                           (return)))))
 488                (funcall emit 'numeric pos i)))
 489
 490            (and (or (char= char #\")
 491                     (char= char #\'))
 492                 (let ((i (1+ pos)))
 493                   (loop (when (>= i end)
 494                           (error "Missing `~A'." char))
 495                         (let ((ch (char line i)))
 496                           (cond ((char= ch char) (return))
 497                                 ((char= ch #\\) (incf i 2))
 498                                 (t (incf i)))))
 499                   (funcall emit 'literal pos (1+ i))))
 500
 501            (tokenize-c-comment lang line pos end emit)
 502
 503            (try-tokenize line pos end emit 'operator
 504                          '("->" "++" ("--" :latex "{--}\\,{--}")
 505                            "<<" ">>" "<=" ">=" "==" "!=" "&&" "||"
 506                            "*=" "/=" "%=" "+=" "-=" "<<=" ">>="
 507                            "&=" "^=" "|=" "##"
 508                            "<:" ":>" "<%" "%>" "%:" "%:%:"))
 509
 510            (funcall emit 'operator pos (1+ pos))))
 511
 512       (:comment
 513        (assert (zerop pos))
 514        (let ((next (tokenize-whitespace line pos end emit)))
 515          (when next (setf pos next)))
 516        (when (and (< pos end)
 517                   (char= (char line pos) #\*))
 518          (setf pos (funcall emit 'comment-delimiter pos (1+ pos))))
 519        (let* ((end-delim (search "*/" line :start2 pos :end2 end))
 520               (body-end (or end-delim end))
 521               (next (if end-delim (+ end-delim 2) end)))
 522          (when (< pos body-end)
 523            (funcall emit 'comment-body pos body-end))
 524          (cond (end-delim
 525                 (setf (lang-state lang) :toplevel)
 526                 (funcall emit 'comment-delimiter body-end next))
 527                (t
 528                 next))))
 529
 530       (:preproc-keyword
 531        (or (tokenize-whitespace line pos end emit)
 532            (tokenize-c-comment lang line pos end emit)
 533
 534            (multiple-value-bind (ident next) (scan-c-identifier line pos end)
 535              (let ((next-state (gethash ident *c-preprocessor-keywords*)))
 536                (funcall emit (if next-state 'reserved 'identifier) pos next)
 537                (setf (lang-state lang) (or next-state :toplevel))))
 538
 539            (progn (setf (lang-state lang) :toplevel) pos))))))
 540
 541 (defun tokenize-line (lang line)
 542   (let ((tokens nil) (pos 0) (end (length line)))
 543     (loop (if (>= pos end) (return (nreverse tokens))
 544               (next-token lang line pos end
 545                           (lambda (class start end &rest initargs)
 546                             (assert (= start pos))
 547                             (push (apply #'make-instance class
 548                                          :string (subseq line start end)
 549                                          initargs)
 550                                   tokens)
 551                             (setf pos end)))))))
 552
 553
 554 (defgeneric scan-line ((lang c-language) line)
 555   (let* ((i 0)
 556          (spaces 0)
 557          (last 0)
 558          (end (length line))
 559          (state (lang-state lang))
 560          (markers nil)
 561          (comment (if (eq state :comment) :trad nil))
 562          (comment-begin (if (eq state :comment) :star nil)
 563          (escape nil)
 564          (frags nil))
 565     (loop
 566       (when (>= i end) (return))
 567       (let ((ch (char line i))
 568             (align-next nil))
 569         (cond ((char= ch #\tab) (setf space 8))
 570               ((whitespace-char-p ch) (incf space))
 571               (t
 572                (when (and (plusp start) (>= space 2))
 573                  (push (cons i :align) markers))
 574                (case ch
 575                  ((#\, #\;) (setf space 1))
 576                  ((#\( #\[ #\{) (push (cons (1+ i) :align) markers)))))
 577         (ecase state
 578           (:toplevel
 579            (case ch
 580              (#\" (push (cons (1+ i) :align) merkers)
 581                   (setf state :string))
 582              (#\' (setf state :char))
 583              (#\/ (when (< (1+ i) end)
 584                     (let ((nch (char line (1+ i))))
 585                       (case nch
 586                         (#\/ (push (cons i :comment-start) markers)
 587                              (push (cons (+ i 2) :comment-body) markers)
 588                              (setf state :comment
 589                                    comment :line
 590                                    comment-begin t)
 591                              (incf i))
 592                         (#\* (push (cons i :comment-start) markers)
 593                              (push (cons (1+ i) :align) markers)
 594                              (push (cons (+ i 2) :comment-body) markers)
 595                              (setf state :comment
 596                                    comment :trad
 597                                    comment-begin t)
 598                              (incf i))))))))
 599           (:string
 600            (cond (escape (setf escape nil))
 601                  ((char= ch #\") (setf state :toplevel))
 602                  ((char= ch #\\) (setf escape t))))
 603           (:char
 604            (cond (escape (setf escape nil))
 605                  ((char= ch #\') (setf state :toplevel))
 606                  ((char= ch #\\) (setf escape t))))
 607           (:comment
 608            (when (and comment-begin (not (whitespace-char-p ch)))
 609              (cond ((char= ch #\*)-
 610                (push (cons i :comment-mid) markers)
 611                (push (cons (1+ i) :comment-body) markers))
 612              (setf comment-
 613
 614           (case ch
 615             (#\space (incf space))
 616             (#\tab)
 617             (
 618         (ecase state
 619           (:top
 620
 621 ;;;--------------------------------------------------------------------------
 622 ;;; The indentation algorithm.
 623
 624 (defvar *indent-high-water-mark* 0)
 625
 626 (defclass offset ()
 627   ((position :type fixnum :initarg :position :reader offset-position)
 628    (livep :type boolean :initarg :livep :initform nil
 629           :accessor offset-live-p)))
 630
 631 (defclass line ()
 632   ((text :type string :initarg :text :reader line-text)
 633    (offsets :type list :initarg :offsets :initform nil
 634             :reader line-offsets)))
 635
 636
 637
 638 ;;;--------------------------------------------------------------------------
 639 ;;; Main program.
 640
 641 (defun main ()
 642   (format t "Hello, world!~%"))
 643
 644 #+interactive (main)
 645
 646 ;;;----- That's all, folks --------------------------------------------------