Scribble: SCRibe-like reader extension for Common Lisp
-Copyright (c) 2002-2011 by Fare Rideau < fare at tunes dot org >
+Copyright (c) 2002-2012 by Fare Rideau < fare at tunes dot org >
http://www.cliki.net/Fare%20Rideau
HOME PAGE:
http://www.cliki.net/Scribble
LICENSE:
- http://www.geocities.com/SoHo/Cafe/5947/bugroff.html
+ http://tunes.org/legalese/bugroff.html
You may at your leisure use the LLGPL instead:
http://www.cliki.net/LLGPL
DEPENDENCY:
This package depends on Meta by Jochen Schmidt, version 1.0.0 or later.
http://www.cliki.net/Meta
-Now also: closer-mop meta fare-utils fare-matcher
+Now also: meta fare-utils fare-matcher named-readtables
USAGE:
You can enable Racket-like Scribble behavior for the macro-character #\@ with
(scribble:enable-scribble-at-syntax)
and disable it with
(scribble:disable-scribble-at-syntax)
+You may also use
+ (named-readtables:in-readtable :scribble-racket)
+Or
+ (named-readtables:in-readtable :scribble-both)
+Or
+ (named-readtables:in-readtable :scribble)
For details, see:
http://docs.racket-lang.org/scribble/reader.html
-If you additionally pass the keyword argument :scribe t
+If you additionally pass the keyword argument :skribe t
You will also have Skribe-like syntax.
You can enable only Skribe-like syntax for the macro-character #\[ with
(scribble:enable-scribble-syntax)
and disable it with
(scribble:disable-scribble-syntax)
+You may also use
+ (named-readtables:in-readtable :scribble-skribe)
+Or
+ (named-readtables:in-readtable :scribble-both)
+Or
+ (named-readtables:in-readtable :scribble)
+
Alternatively, you can enable behaviour for the character #\[
under the dispatching macro-character #\# using
(scribble:enable-sub-scribble-syntax)
(scribble:disable-sub-scribble-syntax)
+AT SYNTAX:
+The syntax of text after @ is just like
+Racket's Scribble syntax by Eli Barzilay.
+His Scribble "at-syntax" is described thus:
+ http://barzilay.org/research.html
+ http://barzilay.org/misc/scribble-reader.pdf
+ http://docs.racket-lang.org/scribble/reader.html
+
+
BASIC SYNTAX:
-The syntax of text within brackets is Scribe-like:
+The syntax of text within brackets is Skribe-like:
* Text between brackets will expand to a string containing said text,
unless there are escape forms in the text,
Share and enjoy!
-
-Suggested extensions:
-
-* something to easily get (foo " bar") or (foo "\nbar")
-* something to easily quote stuff with text in it.
- [=====|[this is scribble text] [==| Example stuff |==] |=====]
-* get more ideas from Eli Barzilay who implemented the unrelated Racket Scribble syntax @foo{bar}
+For historical information, see also Daniel Herring's partial implementation:
+http://lists.libcl.com/pipermail/libcl-devel-libcl.com/2010-January/000094.html
-Eli offered to rewrite my whole code base from Scribe-like Scribble syntax
-to his newfangled Racket Scribble syntax if I write the backend.
-His Scribble (he started using the name in 2006, I started using it in 2003 or earlier)
-http://barzilay.org/research.html
-http://barzilay.org/misc/scribble-reader.pdf
-http://docs.racket-lang.org/scribble/reader.html
+NAMING NOTE
-For historical information, see also Daniel Herring's partial implementation:
-http://lists.libcl.com/pipermail/libcl-devel-libcl.com/2010-January/000094.html
+Eli Barzilay started using the name "Scribble" in 2006;
+I started using it in 2003 or earlier for my Scribe-like syntax, now Skribe-like.
(:fullname
"scribble"
:depends-on
- ("package" "scribble-scribe" "scribble")
+ ("package" "utilities" "stream-line-column" "skribe" "racket" "readtables")
:build-depends-on
("meta" "fare-utils" "fare-matcher")
:supersedes-asdf
+++ /dev/null
-;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;; LL(\omega) parser: indefinite lookahead recursive descent parsing.
-
-#+xcvb (module (:depends-on ("package")))
-
-(defpackage :llω
- (:nicknames :ll-omega)
- (:use :closer-common-lisp :closer-mop :pure)
- (:export
- #:accept))
-
-(in-package :ll-omega)
-
-;;; First, a datastructure for buffering from a stream,
-;;; marking positions in the stream with some data
-;;; used for backtracking (e.g. a continuation);
-;;; remembering all characters up to the oldest mark.
-
-(defparameter $buffer-size 1024)
-
-(defun make-ωs-buffer (&key (size $buffer-size) (buffer "") (start 0) (end 0))
- (let* ((fill-pointer (- end start))
- (initial-contents
- (make-array fill-pointer :displaced-to buffer :displaced-index-offset start)))
- (make-array size :element-type 'character
- :adjustable t :fill-pointer fill-pointer
- :initial-contents initial-contents)))
-
-(defclass ωs ()
- ((stream
- :type t #|stream|# :accessor ωs-stream :initarg :stream
- :documentation "underlying unbuffered stream")
- (buffer
- :type string :accessor ωs-buffer :initform (make-ωs-buffer)
- :documentation "buffer for memoized input")
- (position
- :type (integer 0 *) :accessor ωs-position :initform 0
- :documentation "current position or cursor in the stream")
- (offset
- :type (integer 0 *) :accessor ωs-offset :initform 0
- :documentation "position of buffer in the stream")
- (oldest-mark
- :type (integer 0 *) :accessor ωs-oldest-mark :initform 0
- :documentation "position of oldest mark, when there are any, not meaningful otherwise")
- (marks
- :type list :accessor ωs-marks :initform nil
- :documentation "set of markers on the buffer, can easily push, test for emptiness"))
- (:documentation "Omega stream, indefinitely buffered from user-specified marks"))
-
-(defvar *ωs* nil
- "default omega-stream to work on")
-
-(defmethod check-invariant! ((ωs ωs))
- (with-slots (buffer position offset oldest-mark marks) ωs
- (assert (adjustable-array-p buffer))
- (assert (<= 0 (- position offset) (fill-pointer buffer)))
- (dolist (m marks)
- (check-type m (cons (integer 0 *) (or function symbol))))
- (when marks
- (assert (<= offset oldest-mark position))))
- t)
-
-(defmethod print-object ((ωs ωs) s)
- (print-unreadable-object (ωs s :type t)
- (with-slots (stream buffer position offset oldest-mark marks) ωs
- (let ((start (- (if marks oldest-mark position) offset))
- (end (fill-pointer buffer)))
- (format stream "~<~A :stream ~S :buffer ~S ~
- :position ~S :offset ~S :oldest-mark ~S :marks ~S~>"
- (if (ignore-errors (check-invariant! ωs)) "" "(violates invariant) ")
- s (ignore-errors (subseq buffer start end))
- position offset oldest-mark marks))))
- (values))
-
-(defun ωs-mark! (continuation &optional (ωs *ωs*))
- (with-slots (position oldest-mark marks) ωs
- (unless marks
- (setf oldest-mark position))
- (push (cons position continuation) marks)
- position))
-
-(defun ωs-unmark! (&optional (ωs *ωs*))
- (with-slots (marks) ωs
- (unless marks
- (error "Trying to reset an ωs without a mark"))
- (pop marks)))
-
-(defun adjust-ωs-buffer (&optional (ωs *ωs*))
- ;(check-invariant ωs)
- (with-slots (buffer position offset oldest-mark marks) ωs
- (let ((fill-pointer (fill-pointer buffer))
- (total-size (length buffer)))
- (when (= fill-pointer total-size)
- (let* ((start (if marks oldest-mark position))
- (buffer-start (- start offset))
- (useful-size (- fill-pointer buffer-start))
- (new-size (ceiling (* 2 useful-size) $buffer-size)))
- (setf buffer (make-ωs-buffer :size new-size :buffer buffer
- :start buffer-start :end fill-pointer))))))
- (values))
-
-(defun fill-ωs-buffer (&optional (ωs *ωs*))
- (adjust-ωs-buffer ωs)
- (with-slots (stream buffer) ωs
- (let ((start (fill-pointer buffer)))
- (setf (fill-pointer buffer) (length buffer))
- (let ((index (read-sequence buffer stream :start start)))
- (setf (fill-pointer buffer) index)
- (not (zerop (- index start))))))
- (values))
-
-(defun ωs-peek-char (&optional (ωs *ωs*))
- (block nil
- (with-slots (stream buffer position offset) ωs
- (when (= (- position offset) (fill-pointer buffer))
- (unless (fill-ωs-buffer)
- (return nil)))
- (aref buffer (- position offset)))))
-
-(defun ωs-read-char (&optional (ωs *ωs*))
- (let ((c (ωs-peek-char ωs)))
- (when c
- (incf (ωs-position ωs)))
- c))
-
-(defun ωs-peek-n-chars (n &optional (ωs *ωs*))
- (with-slots (stream buffer position offset) ωs
- (loop :until (<= n (- (fill-pointer buffer) (- position offset))) :do
- (unless (fill-ωs-buffer)
- (return-from ωs-peek-n-chars nil)))
- (let* ((start (- position offset))
- (end (+ start n)))
- (subseq buffer start end))))
-
-(defun ωs-read-n-chars (n &optional (ωs *ωs*))
- (let ((s (ωs-peek-n-chars n ωs)))
- (when s
- (incf (ωs-position ωs) n))
- s))
-#+xcvb (module (:depends-on nil))
+#+xcvb (module ())
(cl:defpackage #:scribble
- (:use #:common-lisp #|#:ll-omega|# #:meta :fare-utils :fare-quasiquote)
+ (:use #:common-lisp #:meta :fare-utils :fare-quasiquote :named-readtables)
#+(or clisp sbcl ccl)
(:import-from #+clisp :gray #+sbcl :sb-gray #+ccl :ccl
:stream-line-column)
#:combine-column-modifiers
#:stream-line-column-harder
#:read-stream-to-pos
+
+
))
(in-package :scribble)
-; -----------------------------------------------------------------------------
-;;; Optimization
-(declaim (optimize (speed 2) (safety 3) (debug 3)))
-
-; -----------------------------------------------------------------------------
-;;; stream-line-column
-
-(defparameter $columns-per-tab 8)
-
-(defun to-next-tab (position &optional (columns-per-tab $columns-per-tab))
- (* columns-per-tab (ceiling (1+ position) columns-per-tab)))
-
-(defun string-column-modifier (string)
- "Return multiple values describing the effect of the string on column position.
-1- whether there was a newline found, if no NIL, if yes its position in the string.
-2- if no newline, whether there is a leading tab that further aligns the column.
-3- the number of characters after newline and/or tab."
- ;; TODO: handle double-width characters????
- (loop :with nlpos = (position #\newline string :from-end t)
- :with start = (if nlpos (1+ nlpos) 0)
- :with unaligned = (and (not nlpos) 0)
- :with aligned = (and nlpos 0)
- :for c :across (subseq string start) :do
- (if aligned
- (case c
- ((#\tab) (setf aligned (to-next-tab aligned)))
- ((#\return) (setf unaligned nil aligned 0))
- (t (incf aligned)))
- (case c
- ((#\tab) (setf aligned 0))
- ((#\return) (setf unaligned nil aligned 0))
- (t (incf unaligned))))
- :finally (return (values unaligned aligned nlpos))))
-
-(defun combine-column-modifiers (unaligned1 aligned1
- unaligned2 aligned2)
- (cond
- ((null unaligned2) (values unaligned2 aligned2))
- ((null aligned1) (values (+ unaligned1 unaligned2) aligned2))
- ((null aligned2) (values unaligned1 (+ aligned1 unaligned2)))
- (t (values unaligned1 (+ (to-next-tab (+ aligned1 unaligned2)) aligned2)))))
-
-(defun adjust-stream-forward-to-char (stream)
- (loop :for pos :from (file-position stream)
- :for nil = nil :then (file-position stream pos)
- :for c = (ignore-errors (read-char stream nil t nil))
- :until c
- :finally (progn (when (characterp c) (unread-char c stream)) (return pos))))
-
-(defun read-stream-to-pos (stream endpos)
- (declare (optimize (speed 1) (safety 3) (debug 3)))
- (loop :with startpos = (file-position stream)
- :with maxchar = (- endpos startpos)
- :with buffer = (make-string maxchar :initial-element #\_)
- :with index = 0
- :until (zerop maxchar) :do ;; dichotomy
- (let* ((x (ceiling maxchar 2))
- (i (read-sequence buffer stream :start index :end (+ index x))))
- (if (= i index)
- (setf maxchar 0)
- (let ((p (file-position stream)))
- (if (<= p endpos)
- (setf index i
- startpos p
- maxchar (min (- maxchar x) (- endpos startpos)))
- (progn
- (file-position stream startpos)
- (setf maxchar (1- x)))))))
- :finally (return (subseq buffer 0 index))))
-
-(defun stream-line-column-harder (stream)
- (or (ignore-errors (stream-line-column stream))
- (loop
- :with orig-pos = (file-position stream)
- :for targetpos = orig-pos :then startpos
- :for range = 128 :then (* range 2)
- :for start = (max 0 (- targetpos range))
- :for startpos = (progn (file-position stream start)
- (adjust-stream-forward-to-char stream))
- :for string = (read-stream-to-pos stream targetpos)
- :for unaligned2 = 0 :then unaligned
- :for aligned2 = nil :then aligned
- :for (unaligned1 aligned1) =
- (multiple-value-list (string-column-modifier string))
- :for (unaligned aligned) =
- (multiple-value-list (combine-column-modifiers
- unaligned1 aligned1 unaligned2 aligned2))
- ;;:for nil = (DBG :slch orig-pos targetpos range start startpos string unaligned2 aligned2 unaligned1 aligned1 unaligned aligned)
- :until (or (null unaligned) (zerop start))
- :finally (progn
- (when (zerop start)
- (multiple-value-setq (unaligned aligned) (combine-column-modifiers nil 0 unaligned aligned)))
- (assert (null unaligned))
- (return aligned)))))
-
-; -----------------------------------------------------------------------------
-;;; Markers
-
-(defun mirror-char (x)
- (check-type x (or null character))
- (let* ((s "()[]{}<>pqbd")
- (p (position x s)))
- (if p
- (aref s (logxor p 1))
- x)))
-
-(defun mirror-string (x)
- (check-type x string)
- (map 'string 'mirror-char (reverse x)))
-
-(defun ascii-char-p (x)
- (and (typep x 'base-char)
- (<= (char-code x) 127)))
-
-(defun expected-char-p (c expectation)
- (check-type c (or null character))
- (etypecase expectation
- (null t)
- (character (eql c expectation))
- (sequence (find c expectation))
- (function (funcall expectation c))))
-
-(defvar *lf* (string #\newline))
-
-(fmemo:define-memo-function n-spaces (n)
- (make-string n :initial-element #\space :element-type 'base-char))
-
-(defun expect-char (i &optional expectation)
- (let ((c (peek-char nil i nil nil t)))
- (and (expected-char-p c expectation) (read-char i))))
-
-(defun expect-string (i s)
- (loop :for c :across s :for l :from 0 :do
- (unless (expect-char i c)
- (return (values nil (subseq s l))))
- :finally (return (values t l))))
-
-(defun skip-whitespace-return-column (i &optional (col 0))
- (loop :for c = (expect-char i #.(format nil " ~c" #\tab))
- :while c :do
- (ecase c
- ((#\space) (incf col))
- ((#\tab) (setf col (to-next-tab col))))
- :finally (return col)))
-
-(defun trim-ending-spaces (s)
- (let ((p (position-if #'(lambda (c) (not (member c '(#\space #\tab)))) s :from-end t)))
- (if p (subseq s 0 (1+ p)) nil)))
-
-(defun read-to-char (c &optional (i *standard-input*))
- (with-output-to-string (o)
- (loop :for char = (expect-char i)
- :until (eql c char)
- :do (write-char char o))))
-
(defun parse-at-syntax (i)
;; Parse an @ expression.
(let* ((o (make-string-output-stream)) ; buffered output of "current stuff"
((?@1 () ; what to do after a @
(cond
((expect-char i #.(coerce '(#\space #\tab #\return #\newline) 'base-string))
- (error "Unexpected whitespace after @"))
+ (simple-parse-error "Unexpected whitespace after @"))
((expect-char i #\;)
(?at-comment))
(t
(eof '#:eof))
(multiple-value-bind (s n) (read-from-string r)
(unless (eq eof (ignore-errors (read-from-string r nil eof :start n)))
- (error "Unexpected characters in ~S after position ~D" r n))
+ (simple-parse-error "Unexpected characters in ~S after position ~D" r n))
(setf cmdonly t)
(form! s)
(?end))))
(reverse mrof))))
(?@1))))
-(defun do-enable-scribble-at-syntax (&key (readtable *readtable*) scribe)
+(defun read-at-syntax (stream &optional char)
+ (declare (ignore char))
+ (parse-at-syntax stream))
+(defun forbidden-pipe-macro (stream char)
+ (declare (ignore stream char))
+ (simple-parse-error "| not allowed when at syntax enabled"))
+
+(defun do-enable-scribble-at-syntax (&key (readtable *readtable*) scribe skribe)
(enable-quasiquote :readtable readtable)
- (set-macro-character
- #\[ #'(lambda (stream char)
- (declare (ignore char))
- (read-delimited-list #\] stream t))
- nil readtable)
- (set-macro-character
- #\] #'(lambda (stream char)
- (declare (ignore stream char))
- (error "Unbalanced ]"))
- nil readtable)
- (set-macro-character
- #\{ #'(lambda (stream char)
- (declare (ignore char))
- (read-delimited-list #\] stream t))
- nil readtable)
- (set-macro-character
- #\} #'(lambda (stream char)
- (declare (ignore stream char))
- (error "Unbalanced }"))
- nil readtable)
- (set-macro-character
- #\@ #'(lambda (stream char)
- (declare (ignore char))
- (parse-at-syntax stream))
- nil readtable)
- (when scribe ;; backward compatibility with former scribble?
- (do-enable-scribble-syntax readtable))
- (set-macro-character
- #\| #'(lambda (stream char)
- (declare (ignore stream char))
- (error "| not allowed when at syntax enabled"))
- nil readtable)
+ (flet ((s (char fun) (set-macro-character char fun nil readtable)))
+ (s #\[ #'read-paren-list)
+ (s #\] #'unbalanced-paren)
+ (s #\{ #'read-paren-list)
+ (s #\} #'unbalanced-paren)
+ (s #\@ #'read-at-syntax)
+ (when (or scribe skribe) ;; backward compatibility with former scribble?
+ (do-enable-scribble-syntax readtable))
+ (s #\| #'forbidden-pipe-macro))
t)
(defvar *scribble-at-readtable* nil)
(setf *scribble-at-readtable* (push-readtable readtable))
(do-enable-scribble-at-syntax :readtable *scribble-at-readtable* :scribe scribe)
*scribble-at-readtable*)
-(defun disable-scribble-syntax ()
+(defun disable-scribble-at-syntax ()
(pop-readtable))
(defun reenable-scribble-at-syntax (&key scribe)
(if (readtablep *scribble-at-readtable*)
--- /dev/null
+;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; See README.
+#+xcvb (module (:depends-on ("racket" "skribe")))
+
+(in-package :scribble)
+
+(eval-now
+ (defreadtable :scribble-racket-mixin
+ (:merge :fare-quasiquote-mixin)
+ (:macro-char #\[ #'read-paren-list)
+ (:macro-char #\] #'unbalanced-paren)
+ (:macro-char #\{ #'read-paren-list)
+ (:macro-char #\} #'unbalanced-paren)
+ (:macro-char #\@ #'read-at-syntax)
+ (:macro-char #\| #'forbidden-pipe-macro))
+
+ (defreadtable :scribble-skribe-mixin
+ (:macro-char #\[ #'read-skribe-bracket)
+ (:macro-char #\] #'unbalanced-paren))
+
+ (defreadtable :scribble-both-mixin
+ (:fuze :scribble-racket-mixin :scribble-skribe-mixin))
+
+ (defreadtable :scribble-racket
+ (:fuze :standard :scribble-racket-mixin))
+
+ (defreadtable :scribble-skribe
+ (:fuze :standard :scribble-skribe-mixin))
+
+ (defreadtable :scribble-both
+ (:fuze :standard :scribble-both-mixin))
+
+ (defreadtable :scribble
+ (:merge :scribble-both)))
+
:long-description "Scribble offers two syntax extensions allowing you to very nicely
mix text markup data and Lisp code. One syntax is a port to CL of Racket's Scribble syntax,
and the other is a port to CL of Bigloo's Skribe syntax."
- :depends-on (#|:closer-mop|# :meta :fare-utils :fare-matcher)
- :serial t
+ :depends-on (:meta :fare-utils :fare-matcher
+ :fare-quasiquote-readtable :named-readtables)
:components
- (;;(file "ll")
- (:file "package")
- (:file "scribble-scribe")
- (:file "scribble")))
+ ((:file "package")
+ (:file "utilities" :depends-on ("package"))
+ (:file "stream-line-column" :depends-on ("package"))
+ (:file "racket" :depends-on ("package"))
+ (:file "skribe" :depends-on ("utilities"))
+ (:file "readtables" :depends-on ("racket" "skribe"))))
-#+xcvb (module (:depends-on ("package")))
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; Scribble: SCRibe-like reader extension for Common Lisp
-;;; Copyright (c) 2002-2010 by Fare Rideau < fare at tunes dot org >
;;; See README.
+#+xcvb (module (:depends-on ("utilities")))
(in-package :scribble)
-
-; -----------------------------------------------------------------------------
-;;; Optimization
-;(declaim (optimize (speed 3) (safety 1) (debug 0)))
+(named-readtables:in-readtable :meta)
; -----------------------------------------------------------------------------
;;; Customizing string preprocessing
(cons (ensure-list head) body))
; -----------------------------------------------------------------------------
-;;; Some error handling
-(defun issue-parse-error (fmt &rest r)
- #+sbcl (error 'sb-int:simple-parse-error
- :format-control fmt
- :format-arguments r)
- #-sbcl (apply 'error fmt r))
-
-; -----------------------------------------------------------------------------
;;; The META parser
(deftype spacing-character ()
"spacing character"
'(member #\space #\newline #\tab #\linefeed #\return #\page))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (enable-meta-syntax))
(defun parse-bracket (stream &aux c (s (make-string-output-stream)) (l '()))
(with-stream-meta (st stream)
(labels
(match {[@(spacing-character c) !(skip-spaces)]}))
(body ()
(match
- {[#\[ !(issue-parse-error
+ {[#\[ !(simple-parse-error
"Nested bracket neither after backslash or comma on ~A @ ~A."
stream (file-position stream))]
[#\] !(progn
[#\\ @(character c) !(progn (add-char c) (body))]
[@(character c) !(progn (add-char c) (body))]})))
(head))))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (disable-meta-syntax))
; -----------------------------------------------------------------------------
(setf *scribble-readtable* (push-readtable readtable))
(do-enable-scribble-syntax *scribble-readtable*)
*scribble-readtable*)
+
+(defun read-skribe-bracket (stream char)
+ (declare (ignore char))
+ (parse-bracket stream))
+
(defun do-enable-scribble-syntax (&optional readtable)
- (set-macro-character
- #\] #'(lambda (stream char)
- (declare (ignore char))
- (issue-parse-error "] outside of a [ construct on ~A @ ~A." stream (file-position stream)))
- nil readtable)
- (set-macro-character
- #\[ #'(lambda (stream char)
- (declare (ignore char))
- (parse-bracket stream))
- nil readtable)
+ (set-macro-character #\] #'unbalanced-paren nil readtable)
+ (set-macro-character #\[ #'read-skribe-bracket nil readtable)
t)
(defun disable-scribble-syntax ()
(pop-readtable))
(set-macro-character #\]
#'(lambda (stream char)
(declare (ignore char))
- (issue-parse-error "] outside of a #[ construct on ~A @ ~A." stream (file-position stream))))
+ (simple-parse-error "] outside of a #[ construct on ~A @ ~A." stream (file-position stream))))
(set-dispatch-macro-character #\# #\[
#'(lambda (stream subchar arg)
(declare (ignore subchar arg))
(configure-scribble :default-head (read-from-string "yaclml:yaclml-quote")
:package (find-package '#:it.bese.yaclml)
:cons 'cons))
+
+(named-readtables:in-readtable :standard)
--- /dev/null
+;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; stream-line-column
+
+#+xcvb (module (:depends-on ("package")))
+
+(in-package :scribble)
+
+(defparameter $columns-per-tab 8)
+
+(defun to-next-tab (position &optional (columns-per-tab $columns-per-tab))
+ (* columns-per-tab (ceiling (1+ position) columns-per-tab)))
+
+(defun string-column-modifier (string)
+ "Return multiple values describing the effect of the string on column position.
+1- whether there was a newline found, if no NIL, if yes its position in the string.
+2- if no newline, whether there is a leading tab that further aligns the column.
+3- the number of characters after newline and/or tab."
+ ;; TODO: handle double-width characters????
+ (loop :with nlpos = (position #\newline string :from-end t)
+ :with start = (if nlpos (1+ nlpos) 0)
+ :with unaligned = (and (not nlpos) 0)
+ :with aligned = (and nlpos 0)
+ :for c :across (subseq string start) :do
+ (if aligned
+ (case c
+ ((#\tab) (setf aligned (to-next-tab aligned)))
+ ((#\return) (setf unaligned nil aligned 0))
+ (t (incf aligned)))
+ (case c
+ ((#\tab) (setf aligned 0))
+ ((#\return) (setf unaligned nil aligned 0))
+ (t (incf unaligned))))
+ :finally (return (values unaligned aligned nlpos))))
+
+(defun combine-column-modifiers (unaligned1 aligned1
+ unaligned2 aligned2)
+ (cond
+ ((null unaligned2) (values unaligned2 aligned2))
+ ((null aligned1) (values (+ unaligned1 unaligned2) aligned2))
+ ((null aligned2) (values unaligned1 (+ aligned1 unaligned2)))
+ (t (values unaligned1 (+ (to-next-tab (+ aligned1 unaligned2)) aligned2)))))
+
+(defun adjust-stream-forward-to-char (stream)
+ (loop :for pos :from (file-position stream)
+ :for nil = nil :then (file-position stream pos)
+ :for c = (ignore-errors (read-char stream nil t nil))
+ :until c
+ :finally (progn (when (characterp c) (unread-char c stream)) (return pos))))
+
+(defun read-stream-to-pos (stream endpos)
+ (declare (optimize (speed 1) (safety 3) (debug 3)))
+ (loop :with startpos = (file-position stream)
+ :with maxchar = (- endpos startpos)
+ :with buffer = (make-string maxchar :initial-element #\_)
+ :with index = 0
+ :until (zerop maxchar) :do ;; dichotomy
+ (let* ((x (ceiling maxchar 2))
+ (i (read-sequence buffer stream :start index :end (+ index x))))
+ (if (= i index)
+ (setf maxchar 0)
+ (let ((p (file-position stream)))
+ (if (<= p endpos)
+ (setf index i
+ startpos p
+ maxchar (min (- maxchar x) (- endpos startpos)))
+ (progn
+ (file-position stream startpos)
+ (setf maxchar (1- x)))))))
+ :finally (return (subseq buffer 0 index))))
+
+(defun stream-line-column-harder (stream)
+ (or (ignore-errors (stream-line-column stream))
+ (loop
+ :with orig-pos = (file-position stream)
+ :for targetpos = orig-pos :then startpos
+ :for range = 128 :then (* range 2)
+ :for start = (max 0 (- targetpos range))
+ :for startpos = (progn (file-position stream start)
+ (adjust-stream-forward-to-char stream))
+ :for string = (read-stream-to-pos stream targetpos)
+ :for unaligned2 = 0 :then unaligned
+ :for aligned2 = nil :then aligned
+ :for (unaligned1 aligned1) =
+ (multiple-value-list (string-column-modifier string))
+ :for (unaligned aligned) =
+ (multiple-value-list (combine-column-modifiers
+ unaligned1 aligned1 unaligned2 aligned2))
+ ;;:for nil = (DBG :slch orig-pos targetpos range start startpos string unaligned2 aligned2 unaligned1 aligned1 unaligned aligned)
+ :until (or (null unaligned) (zerop start))
+ :finally (progn
+ (when (zerop start)
+ (multiple-value-setq (unaligned aligned) (combine-column-modifiers nil 0 unaligned aligned)))
+ (assert (null unaligned))
+ (return aligned)))))
--- /dev/null
+;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+#+xcvb (module (:depends-on ("package")))
+
+(in-package :scribble)
+
+(eval-now
+
+(define-condition simple-parse-error (simple-error parse-error)
+ ())
+
+(defun simple-parse-error (format &rest arguments)
+ (error 'simple-parse-error
+ :format-control format :format-arguments arguments))
+
+; -----------------------------------------------------------------------------
+;;; Markers
+
+(defun mirror-char (x)
+ (check-type x (or null character))
+ (let* ((s "()[]{}<>pqbd")
+ (p (position x s)))
+ (if p
+ (aref s (logxor p 1))
+ x)))
+
+(defun mirror-string (x)
+ (check-type x string)
+ (map 'string 'mirror-char (reverse x)))
+
+(defun ascii-char-p (x)
+ (and (typep x 'base-char)
+ (<= (char-code x) 127)))
+
+(defun expected-char-p (c expectation)
+ (check-type c (or null character))
+ (etypecase expectation
+ (null t)
+ (character (eql c expectation))
+ (sequence (find c expectation))
+ (function (funcall expectation c))))
+
+(defvar *lf* (string #\newline))
+
+(fmemo:define-memo-function n-spaces (n)
+ (make-string n :initial-element #\space :element-type 'base-char))
+
+(defun expect-char (i &optional expectation)
+ (let ((c (peek-char nil i nil nil t)))
+ (and (expected-char-p c expectation) (read-char i))))
+
+(defun expect-string (i s)
+ (loop :for c :across s :for l :from 0 :do
+ (unless (expect-char i c)
+ (return (values nil (subseq s l))))
+ :finally (return (values t l))))
+
+(defun skip-whitespace-return-column (i &optional (col 0))
+ (loop :for c = (expect-char i #.(format nil " ~c" #\tab))
+ :while c :do
+ (ecase c
+ ((#\space) (incf col))
+ ((#\tab) (setf col (to-next-tab col))))
+ :finally (return col)))
+
+(defun trim-ending-spaces (s)
+ (let ((p (position-if #'(lambda (c) (not (member c '(#\space #\tab)))) s :from-end t)))
+ (if p (subseq s 0 (1+ p)) nil)))
+
+(defun read-to-char (c &optional (i *standard-input*))
+ (with-output-to-string (o)
+ (loop :for char = (expect-char i)
+ :until (eql c char)
+ :do (write-char char o))))
+
+(defun read-paren-list (stream opening)
+ (let ((closing (mirror-char opening)))
+ (check-type closing character)
+ (read-delimited-list closing stream t)))
+
+(defun unbalanced-paren (stream char)
+ (simple-parse-error "Unbalanced ~A on ~A @ ~A." char stream (file-position stream)))
+
+);eval-now
common-lisp.net / users/frideau/scribble.git / commitdiff
