climacs-cvs January 2008

climacs-cvs@common-lisp.net

2 participants
44 discussions

[climacs-cvs] CVS climacs
by thenriksen 15 Jan '08

15 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1603 Modified Files: climacs-lisp-syntax.lisp Log Message: Also consider macrolet to define local functions. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/10 11:22:03 1.10 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/15 10:43:40 1.11 @@ -342,13 +342,18 @@ 'cl:function) (t t)))) +(defvar *local-function-definers* '(flet labels macrolet) + "A list of macros that define local functions, as per +`find-local-definition.") + (defun find-local-definition (syntax symbol-form) "Return a form locally defining `symbol-form' as a function (explicitly via `flet' or `labels', does not expand macros or similar). If no such form can be found, return NIL." (labels ((locally-binding-p (form) - (or (form-equal syntax (form-operator form) "FLET") - (form-equal syntax (form-operator form) "LABELS"))) + (find-if #'(lambda (symbol) + (form-equal syntax (form-operator form) (string symbol))) + *local-function-definers*)) (match (form-operator) (when form-operator (form-equal syntax form-operator symbol-form)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 13 Jan '08

13 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv8457 Modified Files: io.lisp Log Message: Signal an error when trying to save a buffer that contains a non-character. --- /project/climacs/cvsroot/climacs/io.lisp 2006/09/09 18:21:02 1.8 +++ /project/climacs/cvsroot/climacs/io.lisp 2008/01/13 22:23:00 1.9 @@ -24,9 +24,31 @@ (in-package :climacs-core) +(define-condition buffer-contains-noncharacter (buffer-writing-error) + () + (:report (lambda (condition stream) + (format stream "Buffer ~A contains non-character object" + (name (buffer condition))))) + (:documentation "This error is signalled whenever an attempt is +made to save a buffer that contains a non-character object.")) + +(defun buffer-contains-noncharacter (buffer filepath) + "Signal an error of type `buffer-contains-noncharacter' with +the buffer `buffer' and the filepath `filepath'." + (error 'buffer-contains-noncharacter :buffer buffer :filepath filepath)) + +(defmethod check-buffer-writability ((application-frame climacs) (filepath pathname) + (buffer drei-buffer)) + (do-buffer-region (object offset buffer 0 (size buffer)) + (unless (characterp object) + (buffer-contains-noncharacter buffer filepath))) + (call-next-method)) + (defmethod frame-save-buffer-to-stream ((application-frame climacs) (buffer climacs-buffer) stream) (let ((seq (buffer-sequence buffer 0 (size buffer)))) - (write-sequence seq stream))) + (if (every #'characterp seq) + (write-sequence seq stream) + (display-message "Cannot save to file, buffer contains non-character object")))) (defun input-from-stream (stream buffer offset) (let* ((seq (make-string (file-length stream)))

1 0

[climacs-cvs] CVS climacs/Doc
by thenriksen 13 Jan '08

13 Jan '08

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv14113 Modified Files: climacs-internals.texi Log Message: Removed parts of internals documentation that have been moved to Drei. --- /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/09/14 14:24:01 1.24 +++ /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2008/01/13 08:49:09 1.25 @@ -50,2057 +50,6 @@ detailed description of various Climacs protocols and other internal details. -@chapter Buffer protocol - -@section Introduction - -The Climacs buffer is what holds textual and other objects to be -edited and displayed. Conceptually, the buffer is a potentially -large sequence of objects, most of which are expected to be -characters (the full Unicode character set is supported). However, -Climacs buffers can contain any Common Lisp objects, as long as the -syntax module knows how to render them. - -The Climacs buffer implementation differs from that of a vector, -because it allows for very efficient editing operations, such as -inserting and removing objects at arbitrary offsets. - -In addition, the Climacs buffer protocols defines that concept of a -mark. - -@section General - -@deftp {Protocol Class} buffer - -The base class for all buffers. A buffer conceptually contains a -large array of arbitrary objects. Lines of objects are separated by -newline characters. The last object of the buffer is not -necessarily a newline character. -@end deftp - -@deftp {Class} standard-buffer - -The standard instantiable class for buffers. A subclass of buffer. -@end deftp - -@deftp {Protocol Class} mark - -The base class for all marks. -@end deftp - -@deftp {Initarg} :buffer - -The :buffer initarg is mandatory because no mark can exist without a -buffer. When the :offset initarg is not given, it defaults to zero. -@end deftp - -@deftp {Initarg} :offset - -If an :offset initarg is given that is less than zero or greater than -the size of the buffer, a no-such-offset condition is signaled. -@end deftp - -@deftp {Protocol Class} left-sticky-mark - -A subclass of mark. A mark of this type will "stick" to the object -to the left of it, i.e. when an object is inserted at this mark, the -mark will be positioned to the left of the object. -@end deftp - -@deftp {Protocol Class} right-sticky-mark - -A subclass of mark. A mark of this type will "stick" to the object -to the right of it, i.e. when an object is inserted at this mark, the -mark will be positioned to the right of the object. -@end deftp - -@deffn {Generic Function} {clone-mark} (mark &optional stick-to) - -Clone a mark. By default (when stick-to is NIL) the same type of mark -is returned. Otherwise stick-to is either :left, indicating that a -left-sticky-mark should be created, or :right indicating that a -right-sticky-mark should be created. -@end deffn - -@deffn {Generic Function} {buffer} mark - -Return the buffer that the mark is positioned in. -@end deffn - -@deftp {Error Condition} no-such-offset - -This condition is signaled whenever an attempt is made to access an -object that is before the beginning or after the end of the buffer. -@end deftp - -@deftp {Error Condition} offset-before-beginning - -This condition is signaled whenever an attempt is made to access -buffer contents that is before the beginning of the buffer. -This condition is a subclass of no-such-offset -@end deftp - -@deftp {Error Condition} offset-after-end - -This condition is signaled whenever an attempt is made to access -buffer contents that is after the end of the buffer. -This condition is a subclass of no-such-offset -@end deftp - -@deftp {Error Condition} invalid-motion - -This condition is signaled whenever an attempt is made to move a mark -before the beginning or after the end of the buffer. -@end deftp - -@deftp {Error Condition} motion-before-beginning - -This condition is signaled whenever an attempt is made to move a mark -before the beginning of the buffer. -This condition is a subclass of invalid-motion. -@end deftp - -@deftp {Error Condition} motion-after-end - -This condition is signaled whenever an attempt is made to move a mark -after the end of the buffer. -This condition is a subclass of invalid-motion. -@end deftp - -@deffn {Generic Function} {size} buffer - -Return the number of objects in the buffer. -@end deffn - -@deffn {Generic Function} {number-of-lines} buffer - -Return the number of lines of the buffer, or really the number of -newline characters. -@end deffn - -@section Operations related to the offset of marks - - -@deffn {Generic Function} {offset} mark - -Return the offset of the mark into the buffer. -@end deffn - -@deffn {Generic Function} {(setf offset)} offset mark - -Set the offset of the mark into the buffer. A motion-before-beginning -condition is signaled if the offset is less than zero. A -motion-after-end condition is signaled if the offset is greater than -the size of the buffer. -@end deffn - -@deffn {Generic Function} {forward-object} mark &optional (count 1) - -Move the mark forward the number of positions indicated by count. -This function could be implemented by an incf on the offset of the -mark, but many buffer implementations can implement this function much -more efficiently in a different way. A motion-before-beginning -condition is signaled if the resulting offset of the mark is less than -zero. A motion-after-end condition is signaled if the resulting offset -of the mark is greater than the size of the buffer. -@end deffn - -@deffn {Generic Function} {backward-object} mark &optional (count 1) - -Move the mark backward the number of positions indicated by count. -This function could be implemented by a decf on the offset of the -mark, but many buffer implementations can implement this function much -more efficiently in a different way. A motion-before-beginning -condition is signaled if the resulting offset of the mark is less than -zero. A motion-after-end condition is signaled if the resulting offset -of the mark is greater than the size of the buffer. -@end deffn - -@deffn {Generic Function} {mark<} mark1 mark2 - -Return t if the offset of mark1 is strictly less than that of mark2. -An error is signaled if the two marks are not positioned in the same -buffer. It is acceptable to pass an offset in place of one of the -marks. -@end deffn - -@deffn {Generic Function} {mark<=} mark1 mark2 - -Return t if the offset of mark1 is less than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks. -@end deffn - -@deffn {Generic Function} {mark>} mark1 mark2 - -Return t if the offset of mark1 is strictly greater than that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks. -@end deffn - -@deffn {Generic Function} {mark>=} mark1 mark2 - -Return t if the offset of mark1 is greater than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks. -@end deffn - -@deffn {Generic Function} {mark=} mark1 mark2 - -Return t if the offset of mark1 is equal to that of mark2. An error -is signaled if the two marks are not positioned in the same buffer. -It is acceptable to pass an offset in place of one of the marks. -@end deffn - -@deffn {Generic Function} {beginning-of-buffer} mark - -Move the mark to the beginning of the buffer. This is equivalent to -(setf (offset mark) 0) -@end deffn - -@deffn {Generic Function} {end-of-buffer} mark - -Move the mark to the end of the buffer. -@end deffn - -@deffn {Generic Function} {beginning-of-buffer-p} mark - -Return t if the mark is at the beginning of the buffer, nil -otherwise. -@end deffn - -@deffn {Generic Function} {end-of-buffer-p} mark - -Return t if the mark is at the end of the buffer, nil otherwise. -@end deffn - -@deffn {Generic Function} {beginning-of-line} mark - -Move the mark to the beginning of the line. The mark will be -positioned either immediately after the closest preceding newline -character, or at the beginning of the buffer if no preceding newline -character exists. -@end deffn - -@deffn {Generic Function} {end-of-line} mark - -Move the mark to the end of the line. The mark will be positioned -either immediately before the closest following newline character, or -at the end of the buffer if no following newline character exists. -@end deffn - -@deffn {Generic Function} {beginning-of-line-p} mark - -Return t if the mark is at the beginning of the line (i.e., if the -character preceding the mark is a newline character or if the mark is -at the beginning of the buffer), nil otherwise. -@end deffn - -@deffn {Generic Function} {end-of-line-p} mark - -Return t if the mark is at the end of the line (i.e., if the character -following the mark is a newline character, or if the mark is at the -end of the buffer), nil otherwise. -@end deffn - -@deffn {Generic Function} {buffer-line-number} buffer offset - -Return the line number of the line at offset. Lines are numbered from -zero. -@end deffn - -@deffn {Generic Function} {buffer-column-number} buffer offset - -Return the column number of the line at offset. It is the number of -objects between it and the preceding newline, or between it and the -beginning of the buffer if offset is on the first line of the buffer. -@end deffn - -@deffn {Generic Function} {line-number} mark - -Return the line number of the mark. Lines are numbered from zero. -@end deffn - -@deffn {Generic Function} {column-number} mark - -Return the column number of the mark. The column number of a mark is -the number of objects between it and the preceding newline, or -between it and the beginning of the buffer if the mark is on the -first line of the buffer. -@end deffn - -@section Inserting and deleting objects - -@deffn {Generic Function} {insert-buffer-object} buffer offset object - -Insert the object at the offset in the buffer. Any left-sticky marks -that are placed at the offset will remain positioned before the -inserted object. Any right-sticky marks that are placed at the -offset will be positioned after the inserted object. -@end deffn - -@deffn {Generic Function} {insert-buffer-sequence} buffer offset sequence - -Like calling insert-buffer-object on each of the objects in the -sequence. -@end deffn - -@deffn {Generic Function} {insert-object} mark object - -Insert the object at the mark. This function simply calls -insert-buffer-object with the buffer and the position of the mark. -@end deffn - -@deffn {Generic Function} {insert-sequence} mark sequence - -Insert the objects in the sequence at the mark. This function simply -calls insert-buffer-sequence with the buffer and the position of the -mark. -@end deffn - -@deffn {Generic Function} {delete-buffer-range} buffer offset n - -Delete n objects from the buffer starting at the offset. If offset is -negative, a offset-before-beginning condition is signaled. If -offset+n is greater than the size of the buffer, a offset-after-end -condition is signaled. -@end deffn - -@deffn {Generic Function} {delete-range} mark &optional (n 1) - -Delete n objects after (if n > 0) or before (if n < 0) the mark. -This function eventually calls delete-buffer-range, provided that n -is not zero. -@end deffn - -@deffn {Generic Function} {delete-region} mark1 mark2 - -Delete the objects in the buffer that are between mark1 and mark2. An -error is signaled if the two marks are positioned in different -buffers. It is acceptable to pass an offset in place of one of the -marks. - -This function calls delete-buffer-range with the appropriate arguments. -@end deffn - -@section Getting objects out of the buffer - -@deffn {Generic Function} {buffer-object} buffer offset - -Return the object at the offset in the buffer. The first object -has offset 0. If offset is less than zero, an offset-before-beginning -condition is signaled. If offset is greater than or equal to -the size of the buffer, an offset-after-end condition is signaled. -@end deffn - -@deffn {Generic Function} {buffer-sequence} buffer offset1 offset2 - -Return the contents of the buffer starting at offset1 and ending at -offset2-1 as a sequence. If either of the offsets is less than zero, -an offset-before-beginning condition is signaled. If either of the -offsets is greater than or equal to the size of the buffer, an -offset-after-end condition is signaled. If offset2 is smaller than or -equal to offset1, an empty sequence will be returned. -@end deffn - -@deffn {Generic Function} {object-before} mark - -Return the object that is immediately before the mark. If mark is at -the beginning of the buffer, an offset-before-beginning condition is -signaled. If the mark is at the beginning of a line, but not at the -beginning of the buffer, a newline character is returned. -@end deffn - -@deffn {Generic Function} {object-after} mark - -Return the object that is immediately after the mark. If mark is at -the end of the buffer, an offset-after-end condition is signaled. If -the mark is at the end of a line, but not at the end of the buffer, a -newline character is returned. -@end deffn - -@deffn {Generic Function} {region-to-sequence} mark1 mark2 - -Return a freshly allocated sequence of the objects between mark1 and -mark2. An error is signaled if the two marks are positioned in -different buffers. It is acceptable to pass an offset in place of one -of the marks. - -This function calls buffer-sequence with the appropriate arguments. -@end deffn - -@section Implementation hints - -The buffer is implemented as lines organized in a 2-3-tree. The -leaves of the tree contain the lines, and the internal nodes contain -additional information of the left subtree (if it is a 2-node) or the -left and the middle subtree (if it is a 3-node). Two pieces of -information are stored: The number of lines in up to and including -the subtree and the total number of objects up to an including the -subtree. This organization allows us to determine, the line number -and object position of any mark in O(log N) where N is the number of -lines. - [1660 lines skipped]

1 0

[climacs-cvs] CVS climacs
by thenriksen 12 Jan '08

12 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv9398 Modified Files: gui.lisp packages.lisp Log Message: Added *climacs-text-style* variable for customisation. --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/11 04:08:15 1.251 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/12 11:49:35 1.252 @@ -44,6 +44,9 @@ "A function for creating targets for commands potentially acting over multiple views.") +(defvar *climacs-text-style* (make-text-style nil nil nil) + "The default CLIM text style used in Climacs panes.") + (defclass climacs-buffer (drei-buffer) ((%external-format :initform *default-external-format* :accessor external-format @@ -58,6 +61,7 @@ :view (make-instance 'textual-drei-syntax-view :buffer (make-instance 'climacs-buffer)) :display-time :command-loop + :text-style *climacs-text-style* :width 900 :height 400)) (defmethod command-table ((pane climacs-pane)) --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/11 02:15:08 1.130 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/12 11:49:35 1.131 @@ -34,6 +34,7 @@ :esa-buffer :esa-io :esa-utils) ;;(:import-from :lisp-string) (:export #:climacs ; Frame. + #:*climacs-text-style* #:climacs-buffer #:external-format #:climacs-pane

1 0

[climacs-cvs] CVS climacs
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv6763 Modified Files: gui.lisp Log Message: Made climacs-pane be of metaclass modual-class. --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/06 11:54:45 1.250 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/11 04:08:15 1.251 @@ -53,6 +53,7 @@ (defclass climacs-pane (drei-pane esa-pane-mixin) () + (:metaclass modual-class) (:default-initargs :view (make-instance 'textual-drei-syntax-view :buffer (make-instance 'climacs-buffer))

1 0

[climacs-cvs] CVS climacs
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv18003 Modified Files: structured-editing.lisp packages.lisp Log Message: Moved Structedit's defpackage form into packages.lisp and exported some symbols from it. --- /project/climacs/cvsroot/climacs/structured-editing.lisp 2008/01/09 09:47:15 1.1 +++ /project/climacs/cvsroot/climacs/structured-editing.lisp 2008/01/11 02:15:08 1.2 @@ -30,11 +30,6 @@ ;;; You must do M-x Structedit Mode to enable these commands. -(defpackage :climacs-structedit - (:use :clim-lisp :clim :esa :esa-utils :drei :drei-buffer :drei-base :drei-core - :drei-motion :drei-editing :drei-syntax :drei-lr-syntax :drei-lisp-syntax) - (:shadow clim:form)) - (in-package :climacs-structedit) (define-syntax-mode structedit-mode () --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/10 14:15:51 1.129 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/11 02:15:08 1.130 @@ -167,6 +167,13 @@ :drei-syntax :flexichain :drei :drei-fundamental-syntax) (:export)) +(defpackage :climacs-structedit + (:use :clim-lisp :clim :esa :esa-utils :drei :drei-buffer :drei-base :drei-core + :drei-motion :drei-editing :drei-syntax :drei-lr-syntax :drei-lisp-syntax) + (:shadow clim:form) + (:export #:structedit-mode + #:structedit-table)) + (defpackage :climacs-c-syntax (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base :drei-syntax :drei-fundamental-syntax :flexichain :drei

1 0

[climacs-cvs] CVS climacs
by thenriksen 10 Jan '08

10 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7065 Modified Files: text-syntax.lisp packages.lisp Log Message: Fixed Text syntax. --- /project/climacs/cvsroot/climacs/text-syntax.lisp 2007/12/15 10:17:11 1.15 +++ /project/climacs/cvsroot/climacs/text-syntax.lisp 2008/01/10 14:15:51 1.16 @@ -74,8 +74,8 @@ (:name "Text") (:pathname-types "text" "txt" "README")) -(defmethod update-syntax ((syntax text-syntax) prefix-size suffix-size - &optional begin end) +(defmethod update-syntax values-max-min ((syntax text-syntax) prefix-size suffix-size + &optional begin end) (declare (ignore begin end)) (let* ((buffer (buffer syntax)) (high-mark-offset (- (size buffer) suffix-size)) @@ -154,7 +154,7 @@ (insert* paragraphs pos1 m)) (incf pos1)) (t nil))))))) - (call-next-method)) + (values 0 (size (buffer syntax)))) (defmethod backward-one-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/06 10:26:12 1.128 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/10 14:15:51 1.129 @@ -153,7 +153,8 @@ (defpackage :climacs-text-syntax (:use :clim-lisp :clim :drei-buffer :drei-base - :drei-syntax :flexichain :drei :drei-fundamental-syntax)) + :drei-syntax :flexichain :drei :drei-fundamental-syntax + :esa-utils)) (defpackage :climacs-prolog-syntax (:use :clim-lisp :clim :drei-buffer :drei-base

1 0

[climacs-cvs] CVS climacs
by thenriksen 10 Jan '08

10 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19279 Modified Files: climacs-lisp-syntax.lisp climacs-lisp-syntax-commands.lisp Log Message: Added local-definition finding. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/07 16:59:20 1.9 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/10 11:22:03 1.10 @@ -342,6 +342,26 @@ 'cl:function) (t t)))) +(defun find-local-definition (syntax symbol-form) + "Return a form locally defining `symbol-form' as a +function (explicitly via `flet' or `labels', does not expand +macros or similar). If no such form can be found, return NIL." + (labels ((locally-binding-p (form) + (or (form-equal syntax (form-operator form) "FLET") + (form-equal syntax (form-operator form) "LABELS"))) + (match (form-operator) + (when form-operator + (form-equal syntax form-operator symbol-form))) + (find-local-binding (form) + (or (when (locally-binding-p form) + (loop for binding in (form-children (first (form-operands form))) + when (and (form-list-p binding) + (match (form-operator binding))) + return binding)) + (unless (form-at-top-level-p form) + (find-local-binding (parent form)))))) + (find-local-binding (list-at-mark syntax (start-offset symbol-form))))) + (defun edit-definition (symbol &optional type) (let ((all-definitions (find-definitions-for-drei (get-usable-image (current-syntax)) --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2007/12/11 18:46:53 1.7 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2008/01/10 11:22:03 1.8 @@ -119,7 +119,10 @@ (let* ((token (this-form (current-syntax) (point))) (this-symbol (form-to-object (current-syntax) token))) (when (and this-symbol (symbolp this-symbol)) - (edit-definition this-symbol)))) + (let ((local-definition (find-local-definition (current-syntax) token))) + (if local-definition + (setf (offset (point)) (start-offset local-definition)) + (edit-definition this-symbol)))))) (define-command (com-return-from-definition :name t :command-table climacs-lisp-table) ()

1 0

[climacs-cvs] CVS climacs
by crhodes 10 Jan '08

10 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7575 Modified Files: climacs.asd prolog-syntax.lisp prolog2paiprolog.lisp Log Message: Restore prolog2paiprolog The source isn't clean, but its primary use right now is to check that prolog syntax is vaguely working (since we don't have prolog syntax highlighting). --- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/09 12:56:02 1.68 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/10 10:48:24 1.69 @@ -35,7 +35,7 @@ ;; (:file "cl-syntax" :depends-on ("packages")) ;; (:file "html-syntax" :depends-on ("packages")) (:file "prolog-syntax" :depends-on ("packages")) -;; (:file "prolog2paiprolog" :depends-on ("prolog-syntax")) + (:file "prolog2paiprolog" :depends-on ("prolog-syntax")) ;; (:file "ttcn3-syntax" :depends-on ("packages")) (:file "climacs-lisp-syntax" :depends-on ("core" "groups")) (:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands")) --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/09 18:23:21 1.33 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/10 10:48:24 1.34 @@ -26,13 +26,16 @@ (defclass prolog-parse-tree (parse-tree) ()) +(define-syntax-command-table prolog-table :errorp nil) + (define-syntax prolog-syntax (fundamental-syntax) ((lexer :reader lexer) (valid-parse :initform 1) (parser) (operator-directives :initform nil :accessor operator-directives)) (:name "Prolog") - (:pathname-types "pl")) + (:pathname-types "pl") + (:command-table prolog-table)) (defparameter *prolog-grammar* (grammar)) --- /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2006/11/12 16:06:06 1.3 +++ /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2008/01/10 10:48:24 1.4 @@ -20,6 +20,8 @@ (in-package #:climacs-prolog-syntax) +#+nil +(progn (defclass prolog-buffer (standard-buffer) ((filepath :initform nil :accessor filepath) (syntax :accessor syntax))) @@ -28,9 +30,12 @@ (declare (ignore args)) (with-slots (syntax) buffer (setf syntax (make-instance 'prolog-syntax :buffer buffer)))) +) (defvar *loaded-files* nil "List of files loaded by ensure_loaded directive.") +#+nil +(progn (defun eval-prolog-file (filepath) (setf *loaded-files* nil) (let ((*package* @@ -51,10 +56,12 @@ (update-syntax-for-display buffer (syntax buffer) (low-mark buffer) (high-mark buffer)) buffer)) +) -(defun buffer->paiprolog (buffer) - (let ((lexemes (drei-syntax::lexemes (lexer (syntax buffer)))) +(defun view->paiprolog (view) + (let ((lexemes (drei-syntax::lexemes (lexer (syntax view)))) (expressions '())) + (update-parse (syntax view)) (dotimes (i (flexichain:nb-elements lexemes) (nreverse expressions)) (let ((lexeme (flexichain:element* lexemes i))) (when (typep lexeme 'end-lexeme) @@ -76,12 +83,12 @@ (ensure-loaded (unless (member (cadr dexpr) *loaded-files* :test #'string=) - (dolist (e (buffer->paiprolog + (dolist (e (view->paiprolog (find-prolog-file (cadr dexpr)))) (push e expressions)) (push (cadr dexpr) *loaded-files*))) (include - (dolist (e (buffer->paiprolog + (dolist (e (view->paiprolog (find-prolog-file (cadr dexpr)))) (push e expressions))))) (return)) @@ -403,3 +410,10 @@ (defun intern-paiprolog (name) (intern (string-upcase name) :paiprolog)) + +(define-command (com-export-paiprolog :name t :command-table prolog-table) + ((pathname 'pathname)) + (let ((expressions (view->paiprolog (current-view)))) + (with-open-file (s pathname :direction :output :if-exists :supersede) + (dolist (e expressions) + (prin1 e s)))))

1 0

[climacs-cvs] CVS climacs
by crhodes 09 Jan '08

09 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv23664 Modified Files: prolog-syntax.lisp Log Message: Possibly working incremental prolog parser. (Syntax highlighting would be really nice...) --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/04 13:08:22 1.32 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/09 18:23:21 1.33 @@ -1129,8 +1129,8 @@ (defmethod inter-lexeme-object-p ((lexer prolog-lexer) object) (member object '(#\Space #\Newline #\Tab))) -(defmethod update-syntax ((syntax prolog-syntax) prefix-size suffix-size &optional begin end) - (call-next-method) +(defmethod update-syntax esa-utils:values-max-min ((syntax prolog-syntax) prefix-size suffix-size &optional begin end) + (declare (ignore begin)) (with-slots (lexer valid-parse) syntax (let* ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) (high-mark (make-buffer-mark @@ -1171,8 +1171,8 @@ (loop named relex do (skip-inter-lexeme-objects lexer scan) until (end-of-buffer-p scan) - #+nil #+nil ; FIXME: incremental - until (<= end (start-offset (lexeme lexer (1- valid-lex)))) + until (and (<= end (start-offset (lexeme lexer (1- valid-lex)))) + (typep (lexeme lexer (1- valid-lex)) 'end-lexeme)) do (when (mark> scan high-mark) (do () ((= (nb-lexemes lexer) valid-lex)) @@ -1210,14 +1210,17 @@ ;; thing) can return a delegating buffer. (let ((*this-syntax* syntax)) (loop until (= valid-parse valid-lex) - #+nil #+nil ; FIXME: incremental - until (<= end (start-offset (lexeme lexer (1- valid-parse)))) + until (and (<= end (start-offset (lexeme lexer (1- valid-parse)))) + (typep (lexeme lexer (1- valid-parse)) 'end-lexeme)) do (let ((current-token (lexeme lexer (1- valid-parse))) (next-lexeme (lexeme lexer valid-parse))) (setf (slot-value next-lexeme 'state) (advance-parse parser (list next-lexeme) (slot-value current-token 'state))) - (incf valid-parse))))))) + (incf valid-parse)))) + (values 0 (if (= valid-parse (nb-lexemes lexer)) + (size (buffer syntax)) + (start-offset (lexeme lexer valid-parse))))))) ;;; display #+nil ; old, not based on stroking pumps.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs January 2008