Commit 6aecc2db authored by Troels Henriksen's avatar Troels Henriksen
Browse files

Yet another big patch:

    * Added Set Package and Set Syntax commands to Lisp syntax.

    * Added Update Attribute List command (and associated functions).

    * Fixed issue in Lisp syntax where deletion of `(in-package)'
      forms was not properly picked up.
parent 5967b19c
......@@ -474,7 +474,9 @@ spaces only."))
(string-equal name "MODE")))
options
:key #'first)))))
(when specified-syntax
(when (and specified-syntax
(not (eq (class-of (syntax buffer))
specified-syntax)))
(setf (syntax buffer)
(make-instance specified-syntax
:buffer buffer))))
......@@ -503,35 +505,79 @@ spaces only."))
(mapcar (lambda (pair) (split-attribute pair #\:))
(split-attribute line #\;)))
(defun get-attribute-line (buffer)
(defun find-attribute-line-position (buffer)
(let ((scan (beginning-of-buffer (clone-mark (point buffer)))))
;; skip the leading whitespace
(loop until (end-of-buffer-p scan)
until (not (whitespacep (syntax buffer) (object-after scan)))
do (forward-object scan))
until (not (whitespacep (syntax buffer) (object-after scan)))
do (forward-object scan))
;; stop looking if we're already 1,000 objects into the buffer
(unless (> (offset scan) 1000)
(let ((start-found
(loop with newlines = 0
when (end-of-buffer-p scan)
do (return nil)
when (eql (object-after scan) #\Newline)
do (incf newlines)
when (> newlines 1)
do (return nil)
do (forward-object scan)
until (looking-at scan "-*-")
finally (return t))))
when (end-of-buffer-p scan)
do (return nil)
when (eql (object-after scan) #\Newline)
do (incf newlines)
when (> newlines 1)
do (return nil)
until (looking-at scan "-*-")
do (forward-object scan)
finally (return t))))
(when start-found
(let ((line (buffer-substring buffer
(offset scan)
(offset (end-of-line (clone-mark scan))))))
(when (>= (length line) 6)
(let ((end (search "-*-" line :from-end t :start2 3)))
(when end
(string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))))
(defun evaluate-attributes-line (buffer)
(let* ((end-scan (clone-mark scan))
(end-found
(loop when (end-of-buffer-p end-scan)
do (return nil)
when (eql (object-after end-scan) #\Newline)
do (return nil)
do (forward-object end-scan)
until (looking-at end-scan "-*-")
finally (return t))))
(when end-found
(values scan
(progn (forward-object end-scan 3)
end-scan)))))))))
(defun get-attribute-line (buffer)
(multiple-value-bind (start-mark end-mark) (find-attribute-line-position buffer)
(let ((line (buffer-substring buffer
(offset start-mark)
(offset end-mark))))
(when (>= (length line) 6)
(let ((end (search "-*-" line :from-end t :start2 3)))
(when end
(string-trim '(#\Space #\Tab) (subseq line 3 end))))))))
(defun replace-attribute-line (buffer new-attribute-line)
(let ((full-attribute-line (concatenate 'string
"-*- "
new-attribute-line
"-*-")))
(multiple-value-bind (start-mark end-mark) (find-attribute-line-position buffer)
(cond ((not (null end-mark))
;; We have an existing attribute line.
(delete-region start-mark end-mark)
(let ((new-line-start (clone-mark start-mark :left)))
(insert-sequence start-mark full-attribute-line)
(comment-region (syntax buffer)
new-line-start
start-mark)))
(t
;; Create a new attribute line at beginning of buffer.
(let* ((mark1 (beginning-of-buffer (clone-mark (point buffer) :left)))
(mark2 (clone-mark mark1 :right)))
(insert-sequence mark2 full-attribute-line)
(insert-object mark2 #\Newline)
(comment-region (syntax buffer)
mark1
mark2)))))))
(defun update-attribute-line (buffer)
(replace-attribute-line buffer
(make-attribute-line (syntax buffer))))
(defun evaluate-attribute-line (buffer)
(evaluate-attributes
buffer
(split-attribute-line (get-attribute-line buffer))))
......@@ -579,6 +625,9 @@ spaces only."))
(setf (syntax buffer) nil)
(setf (offset (point (buffer pane))) (offset (point pane)))
(setf (buffer (current-window)) buffer)
(setf (syntax buffer)
(make-instance (syntax-class-name-for-filepath filepath)
:buffer buffer))
;; Don't want to create the file if it doesn't exist.
(when (probe-file filepath)
(with-open-file (stream filepath :direction :input)
......@@ -586,13 +635,7 @@ spaces only."))
(setf (file-write-time buffer) (file-write-date filepath))
;; A file! That means we may have a local options
;; line to parse.
(evaluate-attributes-line buffer))
;; If the local options line didn't set a syntax, do
;; it now.
(when (null (syntax buffer))
(setf (syntax buffer)
(make-instance (syntax-class-name-for-filepath filepath)
:buffer buffer)))
(evaluate-attribute-line buffer))
(setf (filepath buffer) filepath
(name buffer) (filepath-filename filepath)
(needs-saving buffer) nil
......
......@@ -113,7 +113,8 @@
(values default default-type))
(t (values string 'string)))))
(define-command (com-reparse-attribute-list :name t :command-table buffer-table) ()
(define-command (com-reparse-attribute-list :name t :command-table buffer-table)
()
"Reparse the current buffer's attribute list.
An attribute list is a line of keyword-value pairs, each keyword separated
from the corresponding value by a colon. If another keyword-value pair
......@@ -125,7 +126,30 @@ on the first or second non-blank line of the file.
An example attribute-list is:
;; -*- Syntax: Lisp; Base: 10 -*- "
(evaluate-attributes-line (buffer (current-window))))
(evaluate-attribute-line (buffer (current-window))))
(define-command (com-update-attribute-list :name t :command-table buffer-table)
()
"Update the current buffers attribute list to reflect the
settings of the syntax of the buffer.
After the attribute list has been updated, it will also be
re-evaluated. An attribute list is a line of keyword-value pairs,
each keyword separated from the corresponding value by a
colon. If another keyword-value pair follows, the value should be
terminated by a colon. The attribute list is surrounded by '-*-'
sequences, but the opening '-*-' need not be at the beginning of
the line. Climacs looks for the attribute list on the first or
second non-blank line of the file.
An example attribute-list is:
;; -*- Syntax: Lisp; Base: 10 -*-
This command automatically comments the attribute line as
appropriate for the syntax of the buffer."
(update-attribute-line (buffer (current-window)))
(evaluate-attribute-line (buffer (current-window))))
(define-command (com-find-file :name t :command-table buffer-table)
((filepath 'pathname
......
......@@ -85,6 +85,18 @@ string at point."
syntax
t)))))
(define-command (com-set-base :name t :command-table lisp-table)
((base '(integer 2 36)))
"Set the base for the current buffer."
(setf (base (syntax (current-buffer)))
base))
(define-command (com-set-package :name t :command-table lisp-table)
((package 'package))
"Set the package for the current buffer."
(setf (option-specified-package (syntax (current-buffer)))
package))
(define-command (com-indent-expression :name t :command-table lisp-table)
((count 'integer :prompt "Number of expressions"))
(let* ((pane (current-window))
......
......@@ -113,6 +113,16 @@
(setf (base syntax) integer-base)
(esa:display-message "Invalid base specified: outside the interval 2 to 36.")))))
(defmethod current-attributes-for-syntax append ((syntax lisp-syntax))
(list (cons :package (or (if (packagep (option-specified-package syntax))
(package-name (option-specified-package syntax))
(option-specified-package syntax))
(package-name (package-at-mark
syntax
(or (caar (last (package-list syntax)))
0)))))
(cons :base (format nil "~A" (base syntax)))))
(defmethod initialize-instance :after ((syntax lisp-syntax) &rest args)
(declare (ignore args))
(with-slots (buffer scan) syntax
......@@ -1366,8 +1376,14 @@ invalid, return the CLIM-USER package."
'cl:in-package)))))))
(with-slots (stack-top) syntax
(or (not (slot-boundp syntax 'package-list))
(loop for child in (children stack-top)
(loop
for child in (children stack-top)
when (test child)
do (return t))
(loop
for (offset . nil) in (package-list syntax)
unless (let ((form (form-around syntax offset)))
(and form (typep form 'complete-list-form)))
do (return t)))))))
(defun update-package-list (buffer syntax)
......@@ -1409,9 +1425,9 @@ invalid, return the CLIM-USER package."
(new-state syntax
(parser-state stack-top)
stack-top)))
(loop do (parse-patch syntax))))))
(when (need-to-update-package-list-p buffer syntax)
(update-package-list buffer syntax)))
(loop do (parse-patch syntax)))))
(when (need-to-update-package-list-p buffer syntax)
(update-package-list buffer syntax))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
......
......@@ -122,6 +122,8 @@
(:export #:syntax #:define-syntax
#:eval-option
#:define-option-for-syntax
#:current-attributes-for-syntax
#:make-attribute-line
#:syntax-from-name
#:basic-syntax
#:update-syntax #:update-syntax-for-display
......@@ -399,7 +401,8 @@
#:kill-buffer
#:filepath-filename
#:evaluate-attributes-line
#:update-attribute-line
#:evaluate-attribute-line
#:directory-pathname-p
#:find-file
#:directory-of-buffer
......
......@@ -201,6 +201,19 @@ in the specific syntax.")
,value-symbol)
,@body)))
(defgeneric current-attributes-for-syntax (syntax)
(:method-combination append)
(:method append (syntax)
(list (cons :syntax (name syntax)))))
(defun make-attribute-line (syntax)
(apply #'concatenate 'string
(loop for (name . value) in (current-attributes-for-syntax syntax)
collect (string-downcase (symbol-name name) :start 1)
collect ": "
collect value
collect "; ")))
#+nil
(defmacro define-syntax (class-name (name superclasses) &body body)
`(progn (push '(,name . ,class-name) *syntaxes*)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment