May 2005 - climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[climacs-cvs] CVS update: climacs/lisp-syntax.lisp
by rstrandh＠common-lisp.net 30 May '05

30 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4197 Modified Files: lisp-syntax.lisp Log Message: prettified keyword symbols. Date: Mon May 30 15:47:21 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.3 climacs/lisp-syntax.lisp:1.4 --- climacs/lisp-syntax.lisp:1.3 Mon May 30 11:33:39 2005 +++ climacs/lisp-syntax.lisp Mon May 30 15:47:21 2005 @@ -806,6 +806,13 @@ (with-drawing-options (pane :ink +red+) (call-next-method))) +(defmethod display-parse-tree ((parse-symbol token-lexeme) (syntax lisp-syntax) pane) + (if (and (> (end-offset parse-symbol) (start-offset parse-symbol)) + (eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:)) + (with-drawing-options (pane :ink +dark-violet+) + (call-next-method)) + (call-next-method))) + (defmethod display-parse-tree ((parser-symbol lisp-lexeme) (syntax lisp-syntax) pane) (flet ((cache-test (t1 t2) (and (eq t1 t2)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/lisp-syntax.lisp climacs/packages.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 30 May '05

30 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21260 Modified Files: gui.lisp lisp-syntax.lisp packages.lisp syntax.lisp Log Message: New command `eval-defun' bound to C-M-x Date: Mon May 30 11:33:39 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.142 climacs/gui.lisp:1.143 --- climacs/gui.lisp:1.142 Mon May 30 09:51:32 2005 +++ climacs/gui.lisp Mon May 30 11:33:39 2005 @@ -1406,6 +1406,12 @@ (syntax (syntax (buffer pane)))) (forward-expression point syntax))) +(define-named-command com-eval-defun () + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (eval-defun point syntax))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Global and dead-escape command tables @@ -1495,6 +1501,7 @@ (global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*)) (global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*)) +(global-set-key '(#\x :control :meta) '(com-eval-defun)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.2 climacs/lisp-syntax.lisp:1.3 --- climacs/lisp-syntax.lisp:1.2 Mon May 30 11:00:35 2005 +++ climacs/lisp-syntax.lisp Mon May 30 11:33:39 2005 @@ -415,14 +415,14 @@ (define-parser-state |form* | (lexer-toplevel-state parser-state) ()) (define-parser-state form-may-follow (lexer-toplevel-state parser-state) ()) -(define-parser-state initial-state (form-may-follow) ()) +(define-parser-state |initial-state | (form-may-follow) ()) -(define-new-lisp-state (initial-state form) initial-state) +(define-new-lisp-state (|initial-state | form) |initial-state |) -(define-lisp-action (initial-state (eql nil)) +(define-lisp-action (|initial-state | (eql nil)) (make-instance 'form* :children (pop-all syntax))) -(define-new-lisp-state (initial-state form*) |form* | ) +(define-new-lisp-state (|initial-state | form*) |form* | ) (define-lisp-action (|form* | (eql nil)) (throw 'done nil)) @@ -742,7 +742,7 @@ (setf stack-top (find-last-valid-lexeme stack-top (offset low-mark))) (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top)) current-state (if (null stack-top) - initial-state + |initial-state | (new-state syntax (parser-state stack-top) stack-top))) @@ -958,3 +958,14 @@ (if potential-form (setf (offset mark) (end-offset potential-form)) (error 'no-expression)))) + +(defmethod eval-defun (mark (syntax lisp-syntax)) + (with-slots (stack-top) syntax + (loop for form in (children stack-top) + when (and (mark<= (start-offset form) mark) + (mark<= mark (end-offset form))) + do (return (eval (read-from-string + (coerce (buffer-sequence (buffer syntax) + (start-offset form) + (end-offset form)) + 'string))))))) \ No newline at end of file Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.63 climacs/packages.lisp:1.64 --- climacs/packages.lisp:1.63 Mon May 30 09:25:13 2005 +++ climacs/packages.lisp Mon May 30 11:33:39 2005 @@ -106,6 +106,7 @@ #:no-such-operation #:no-expression #:syntax-line-indentation #:forward-expression #:backward-expression + #:eval-defun #:redisplay-pane-with-syntax #:beginning-of-paragraph #:end-of-paragraph)) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.51 climacs/syntax.lisp:1.52 --- climacs/syntax.lisp:1.51 Mon May 30 09:25:13 2005 +++ climacs/syntax.lisp Mon May 30 11:33:39 2005 @@ -28,6 +28,7 @@ (define-condition no-such-operation (simple-error) () (:report (lambda (condition stream) + (declare (ignore condition)) (format stream "Operation unavailable for this syntax"))) (:documentation "This condition is signaled whenever an attempt is made to execute an operation that is unavailable for the particular syntax" )) @@ -35,6 +36,7 @@ (define-condition no-expression (simple-error) () (:report (lambda (condition stream) + (declare (ignore condition)) (format stream "No expression at point"))) (:documentation "This condition is signaled whenever an attempt is made to execute a by-experssion motion command and no expression is available." )) @@ -51,6 +53,8 @@ (defgeneric backward-expression (mark syntax)) +(defgeneric eval-defun (mark syntax)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax completion @@ -147,6 +151,9 @@ (error 'no-such-operation)) (defmethod backward-expression (mark syntax) + (error 'no-such-operation)) + +(defmethod eval-defun (mark syntax) (error 'no-such-operation)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[climacs-cvs] CVS update: climacs/base.lisp
by rstrandh＠common-lisp.net 30 May '05

30 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19477 Modified Files: base.lisp Log Message: patches to constituentp and whitespacep (thanks to Splittist) Date: Mon May 30 11:09:49 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.38 climacs/base.lisp:1.39 --- climacs/base.lisp:1.38 Sun Mar 13 21:51:48 2005 +++ climacs/base.lisp Mon May 30 11:09:48 2005 @@ -177,13 +177,16 @@ "A predicate to ensure that an object is a constituent character." (and (characterp obj) #+sbcl (sb-impl::constituentp obj) - #-sbcl (alphanumericp obj))) + #-sbcl (or (alphanumericp obj) + (member obj '(#\! #\$ #\% #\& #\* #\+ #\- #\. #\/ + #\: #\< #\= #\> #\? #\@ #\^ #\~ #\_ + #\{ #\} #\[ #\] ))))) (defun whitespacep (obj) "A predicate to ensure that an object is a whitespace character." (and (characterp obj) #+sbcl (sb-impl::whitespacep obj) - #-sbcl (member obj '(#\Space #\Tab)))) + #-sbcl (member obj '(#\Space #\Tab #\Newline)))) (defun forward-to-word-boundary (mark) "Move the mark forward to the beginning of the next word."

1 0

[climacs-cvs] CVS update: climacs/lisp-syntax.lisp
by rstrandh＠common-lisp.net 30 May '05

30 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18572 Modified Files: lisp-syntax.lisp Log Message: Add parsing rules for `#:' so that prolog-syntax.lisp parses OK. Date: Mon May 30 11:00:35 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.1 climacs/lisp-syntax.lisp:1.2 --- climacs/lisp-syntax.lisp:1.1 Mon May 30 09:25:13 2005 +++ climacs/lisp-syntax.lisp Mon May 30 11:00:35 2005 @@ -179,6 +179,7 @@ (defclass text-lexeme (lisp-lexeme) ()) (defclass reader-conditional-positive-lexeme (lisp-lexeme) ()) (defclass reader-conditional-negative-lexeme (lisp-lexeme) ()) +(defclass uninterned-symbol-lexeme (lisp-lexeme) ()) (defmethod skip-inter ((syntax lisp-syntax) state scan) (macrolet ((fo () `(forward-object scan))) @@ -236,6 +237,8 @@ (make-instance 'reader-conditional-positive-lexeme)) (#\- (fo) (make-instance 'reader-conditional-negative-lexeme)) + (#\: (fo) + (make-instance 'uninterned-symbol-lexeme)) (t (fo) (make-instance 'error-lexeme))))) (t (cond ((constituentp object) (loop until (end-of-buffer-p scan) @@ -605,6 +608,22 @@ (define-lisp-action (|#- form form | t) (reduce-rule reader-conditional-negative-form 3)) + +;;;;;;;;;;;;;;;; uninterned symbol + +;;; parse trees +(defclass uninterned-symbol-form (form) ()) + +(define-parser-state |#: | (form-may-follow) ()) +(define-parser-state |#: form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow uninterned-symbol-lexeme) |' |) +(define-new-lisp-state (|#: | form) |#: form |) + +;;; reduce according to the rule form -> #: form +(define-lisp-action (|#: form | t) + (reduce-rule uninterned-symbol-form 2)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 30 May '05

30 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv15020 Modified Files: gui.lisp Log Message: added reader conditionals around calls to sb-profile:xxx Date: Mon May 30 09:51:32 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.141 climacs/gui.lisp:1.142 --- climacs/gui.lisp:1.141 Mon May 30 09:25:13 2005 +++ climacs/gui.lisp Mon May 30 09:51:32 2005 @@ -1382,10 +1382,12 @@ ;;; For testing purposes (define-named-command com-reset-profile () - (sb-profile:reset)) + #+sbcl (sb-profile:reset) + #-sbcl nil) (define-named-command com-report-profile () - (sb-profile:report)) + #+sbcl (sb-profile:report) + #-sbcl nil) (define-named-command com-recompile () (asdf:operate 'asdf:load-op :climacs))

1 0

[climacs-cvs] CVS update: climacs/lisp-syntax.lisp climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 30 May '05

30 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12579 Modified Files: climacs.asd gui.lisp packages.lisp syntax.lisp Added Files: lisp-syntax.lisp Log Message: Alternative syntax for editing common lisp (called "Lisp"). I have not completely lost hope of making the Earley-based syntax module fast enough, but as of now I don't know how. This syntax module provides an incremental resynchronizing LR parser for Common Lisp. It is fast enough the parse tree for the entire buffer is kept updated, as opposed to just for what is visible in the CLIM pane. Ultimately, I hope to factor out the parts that are not specific to Lisp into a different module, perhaps the existing syntax.lisp file. I'll be interested in your opinions. Date: Mon May 30 09:25:14 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.29 climacs/climacs.asd:1.30 --- climacs/climacs.asd:1.29 Mon May 23 03:00:24 2005 +++ climacs/climacs.asd Mon May 30 09:25:13 2005 @@ -65,6 +65,7 @@ "html-syntax" "prolog-syntax" "ttcn3-syntax" + "lisp-syntax" "gui" ;;---- optional ---- "testing/rt" Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.140 climacs/gui.lisp:1.141 --- climacs/gui.lisp:1.140 Thu May 26 10:31:53 2005 +++ climacs/gui.lisp Mon May 30 09:25:13 2005 @@ -270,7 +270,11 @@ (motion-before-beginning () (beep) (display-message "Beginning of buffer")) (motion-after-end () - (beep) (display-message "End of buffer"))) + (beep) (display-message "End of buffer")) + (no-expression () + (beep) (display-message "No expression around point")) + (no-such-operation () + (beep) (display-message "Operation unavailable for syntax"))) (setf (previous-command *standard-output*) (if (consp command) (car command) @@ -1375,6 +1379,33 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; For testing purposes + +(define-named-command com-reset-profile () + (sb-profile:reset)) + +(define-named-command com-report-profile () + (sb-profile:report)) + +(define-named-command com-recompile () + (asdf:operate 'asdf:load-op :climacs)) + +(define-named-command com-backward-expression ((count 'integer :prompt "Number of expressions")) + (declare (ignore count)) + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (backward-expression point syntax))) + +(define-named-command com-forward-expression ((count 'integer :prompt "Number of expresssions")) + (declare (ignore count)) + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (forward-expression point syntax))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Global and dead-escape command tables (make-command-table 'global-climacs-table :errorp nil) @@ -1459,6 +1490,9 @@ (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*)) (global-set-key '(:insert) 'com-toggle-overwrite-mode) + +(global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*)) +(global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.62 climacs/packages.lisp:1.63 --- climacs/packages.lisp:1.62 Sat May 7 00:32:28 2005 +++ climacs/packages.lisp Mon May 30 09:25:13 2005 @@ -103,7 +103,9 @@ #:parse-stack-top #:target-parse-tree #:parse-state-empty-p #:parse-stack-next #:parse-stack-symbol #:parse-stack-parse-trees #:map-over-parse-trees + #:no-such-operation #:no-expression #:syntax-line-indentation + #:forward-expression #:backward-expression #:redisplay-pane-with-syntax #:beginning-of-paragraph #:end-of-paragraph)) @@ -149,6 +151,11 @@ (:shadow "ATOM" "CLOSE" "EXP" "INTEGER" "OPEN" "VARIABLE")) (defpackage :climacs-cl-syntax + (:use :clim-lisp :clim :climacs-buffer :climacs-base + :climacs-syntax :flexichain :climacs-pane) + (:export)) + +(defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-syntax :flexichain :climacs-pane) (:export)) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.50 climacs/syntax.lisp:1.51 --- climacs/syntax.lisp:1.50 Thu May 26 10:31:53 2005 +++ climacs/syntax.lisp Mon May 30 09:25:13 2005 @@ -25,6 +25,20 @@ (defclass syntax (name-mixin) ((buffer :initarg :buffer :reader buffer))) +(define-condition no-such-operation (simple-error) + () + (:report (lambda (condition stream) + (format stream "Operation unavailable for this syntax"))) + (:documentation "This condition is signaled whenever an attempt is +made to execute an operation that is unavailable for the particular syntax" )) + +(define-condition no-expression (simple-error) + () + (:report (lambda (condition stream) + (format stream "No expression at point"))) + (:documentation "This condition is signaled whenever an attempt is +made to execute a by-experssion motion command and no expression is available." )) + (defgeneric update-syntax (buffer syntax)) (defgeneric update-syntax-for-display (buffer syntax from to)) @@ -33,6 +47,10 @@ (:documentation "Return the correct indentation for the line containing the mark, according to the specified syntax.")) +(defgeneric forward-expression (mark syntax)) + +(defgeneric backward-expression (mark syntax)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax completion @@ -124,6 +142,12 @@ (defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax)) (declare (ignore mark tab-width)) 0) + +(defmethod forward-expression (mark syntax) + (error 'no-such-operation)) + +(defmethod backward-expression (mark syntax) + (error 'no-such-operation)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS update: climacs/climacs.html
by rstrandh＠common-lisp.net 30 May '05

30 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12519 Modified Files: climacs.html Log Message: fixed a spelling error. Date: Mon May 30 09:19:53 2005 Author: rstrandh Index: climacs/climacs.html diff -u climacs/climacs.html:1.6 climacs/climacs.html:1.7 --- climacs/climacs.html:1.6 Mon Apr 11 07:28:51 2005 +++ climacs/climacs.html Mon May 30 09:19:53 2005 @@ -15,7 +15,7 @@ <ul> <li>Emacs Lisp est un langage spécialement conçu pour implémenter Emacs. Depuis la conception de GNU Emacs et du langage Emacs - LIsp, Common Lisp a été normalisé et propose à la fois une + Lisp, Common Lisp a été normalisé et propose à la fois une efficacité bien supérieure à celle de Emacs Lisp (car Emacs Lisp est implémenté sous la forme d'un interpréteur écrit en C) et des fonctionnalités plus sophistiqués (macros, CLOS, etc). Le choix

1 0

[climacs-cvs] CVS update: climacs/prolog-syntax.lisp
by crhodes＠common-lisp.net 27 May '05

27 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3987 Modified Files: prolog-syntax.lisp Log Message: Fix for multiple op/3 directives with the same operator. Date: Fri May 27 15:25:01 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.20 climacs/prolog-syntax.lisp:1.21 --- climacs/prolog-syntax.lisp:1.20 Thu May 26 15:22:33 2005 +++ climacs/prolog-syntax.lisp Fri May 27 15:25:01 2005 @@ -747,11 +747,13 @@ (with-slots (term) directive-term (with-slots (right) term (let* ((a (arg-list right)) - (exp (arg-list-nth 2 a)) - (term (term exp))) - (let ((value (slot-value term 'value))) - (when (typep value 'atom) - (canonical-name value)))))))) + (exp (arg-list-nth 2 a))) + (etypecase exp + (exp-atom (canonical-name (atom exp))) + (exp-term (let* ((term (term exp)) + (value (slot-value term 'value))) + (when (typep value 'atom) + (canonical-name value)))))))))) (define-prolog-rule (prolog-text -> (prolog-text directive)) (when (and (op/3-directive-p directive)

1 0

[climacs-cvs] CVS update: climacs/prolog-syntax.lisp
by crhodes＠common-lisp.net 26 May '05

26 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14358 Modified Files: prolog-syntax.lisp Log Message: Support op/3 directives in Prolog syntax. * *THIS-SYNTAX* bound in UPDATE-SYNTAX-FOR-DISPLAY so that parser rules can modify the syntax state; * SLOT-MISSING bandage for encapsulating LTERM; * Fragile OP/3-DIRECTIVE-FOO stuff to walk the parse-tree. Despite those caveats, it seems to work. Date: Thu May 26 15:22:34 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.19 climacs/prolog-syntax.lisp:1.20 --- climacs/prolog-syntax.lisp:1.19 Thu May 26 10:31:53 2005 +++ climacs/prolog-syntax.lisp Thu May 26 15:22:33 2005 @@ -29,12 +29,19 @@ (define-syntax prolog-syntax (basic-syntax) ((lexer :reader lexer) (valid-parse :initform 1) - (parser)) + (parser) + (operator-directives :initform nil :accessor operator-directives)) (:name "Prolog") (:pathname-types "pl")) (defparameter *prolog-grammar* (grammar)) +;;; *THIS-SYNTAX* is bound around calls to the parser, so that the +;;; parser rules can update the operator directive table. Possibly +;;; this functionality ought to be offered by the syntax module +;;; itself? +(defvar *this-syntax*) + (defmacro define-prolog-rule ((&rest rule) &body body) `(add-rule (grammar-rule (,@rule ,@body)) *prolog-grammar*)) @@ -431,6 +438,8 @@ (open-ct :initarg :open-ct :accessor open-ct) (arg-list :initarg :arg-list :accessor arg-list) (close :initarg :close :accessor close))) +(defmethod arity ((f functional-compound-term)) + (arg-list-length (arg-list f))) (defclass bracketed-term (term) ((open :initarg :open :accessor open) (term :initarg :term :accessor term) @@ -563,6 +572,16 @@ (defclass arg-list-pair (arg-list) ((comma :initarg :comma :accessor comma) (arg-list :initarg :arg-list :accessor arg-list))) +(defmethod arg-list-length ((a arg-list)) + 1) +(defmethod arg-list-length ((a arg-list-pair)) + ;; Hoho. See also Felleisen (ECOOP 2004) about TRE and OO. + (1+ (arg-list-length (arg-list a)))) + +(defmethod arg-list-nth (n (a arg-list)) + (if (= n 0) + (exp a) + (arg-list-nth (1- n) (arg-list a)))) (defmethod display-parse-tree ((entity arg-list) (syntax prolog-syntax) pane) (display-parse-tree (exp entity) syntax pane)) @@ -666,10 +685,83 @@ (display-parse-tree (comma entity) syntax pane) (display-parse-tree (tlist entity) syntax pane)) +;;; FIXME FIXME FIXME!!! +;;; +;;; This is a band-aid for not having taken the time to sort out an +;;; LTERM "protocol". I think the proper solution is to +;;; +;;; * make an "encapsulating-lterm" subclass of lterm, and use it in +;;; the lterm -> term rule; +;;; +;;; * for all the relevant questions we can ask of terms +;;; (COMPOUND-TERM-P, ARITY, FUNCTOR, NUMERIC-CONSTANT-P, and so on) +;;; implement methods which do the right thing for this +;;; encapsulating-lterm class, and also for bracketed-term. +;;; +;;; this SLOT-MISSING hack will cause pain later. Please FIXME. +;;; +;;; CSR, 2005-05-26. +(defmethod slot-missing (class (lterm lterm) name operation &optional value) + (case operation + (slot-value (slot-value (term lterm) name)))) + ;;; 6.2.1 +(defun op/3-directive-p (directive) + (with-slots (directive-term) directive + (with-slots (term) directive-term + (with-slots (right) term + (and (compound-term-p right) + (string= (canonical-name (functor right)) "op") + (= (arity right) 3)))))) + +(defun op/3-directive-priority (directive) + (with-slots (directive-term) directive + (with-slots (term) directive-term + (with-slots (right) term + (let* ((a (arg-list right)) + ;; FIXME: error-checking + (exp (arg-list-nth 0 a)) + (term (term exp))) + (when (numeric-constant-p term) + (let ((value (numeric-constant-value term))) + (and (<= 0 value 1200) value)))))))) + +(defun op/3-directive-specifier (directive) + (with-slots (directive-term) directive + (with-slots (term) directive-term + (with-slots (right) term + (let* ((a (arg-list right)) + (exp (arg-list-nth 1 a)) + (term (term exp))) + (let ((string (coerce (buffer-sequence (buffer term) + (start-offset term) + (end-offset term)) + 'string))) + (cdr (assoc string '(("fx" . :fx) ("fy" . :fy) + ("xfx" . :xfx) ("xfy" . :xfy) ("yfx" . :yfx) + ("xf" . :xf) ("yf" . :yf)) + :test #'string=)))))))) + +(defun op/3-directive-operator (directive) + (with-slots (directive-term) directive + (with-slots (term) directive-term + (with-slots (right) term + (let* ((a (arg-list right)) + (exp (arg-list-nth 2 a)) + (term (term exp))) + (let ((value (slot-value term 'value))) + (when (typep value 'atom) + (canonical-name value)))))))) + (define-prolog-rule (prolog-text -> (prolog-text directive)) + (when (and (op/3-directive-p directive) + (op/3-directive-priority directive) + (op/3-directive-specifier directive) + (op/3-directive-operator directive)) + ;; FIXME: argh. + (push directive (operator-directives *this-syntax*))) (make-instance 'directive-prolog-text :directive directive - :text-rest prolog-text)) + :text-rest prolog-text)) (define-prolog-rule (prolog-text -> (prolog-text clause)) (make-instance 'clause-prolog-text :clause clause :text-rest prolog-text)) (define-prolog-rule (prolog-text -> ()) @@ -906,8 +998,15 @@ *predefined-operators*) :key #'opspec-name :test #'string=)) (defun find-defined-operator (name specifiers) - (declare (ignore name specifiers)) - nil) + (let ((operator-directives (operator-directives *this-syntax*))) + (dolist (d operator-directives) + (when (> (start-offset name) (end-offset d)) + (when (string= (canonical-name name) (op/3-directive-operator d)) + (when (member (op/3-directive-specifier d) specifiers) + (return (make-opspec :name (op/3-directive-operator d) + :priority (op/3-directive-priority d) + :specifier (op/3-directive-specifier d))))))))) + (defun operatorp (name) (or (find-predefined-operator name '(:xf :yf :fx :fx :xfx :xfy :yfx)) (find-defined-operator name '(:xf :yf :fx :fx :xfx :xfy :yfx)))) @@ -921,12 +1020,20 @@ 'string)) (defun numeric-constant-p (thing) - (and (typep thing 'constant-term) - (let ((value (value thing))) - (or (typep value 'integer) - (and (consp value) - (typep (car value) 'atom) - (typep (cadr value) 'integer)))))) + (if (typep thing 'lterm) + (numeric-constant-p (term thing)) + (and (typep thing 'constant-term) + (let ((value (value thing))) + (or (typep value 'integer) + (and (consp value) + (typep (car value) 'atom) + (typep (cadr value) 'integer))))))) + +(defun numeric-constant-value (thing) + (parse-integer + (coerce + (buffer-sequence (buffer thing) (start-offset thing) (end-offset thing)) + 'string))) (defun first-lexeme (thing) ;; FIXME: we'll need to implement this. @@ -942,6 +1049,8 @@ (high-mark (high-mark buffer))) (setf (offset scan) (end-offset (lexeme lexer (1- valid-lex)))) + ;; this magic belongs in a superclass' method. (It's not the + ;; same as HTML/Common Lisp relexing, though) (loop named relex do (skip-inter-lexeme-objects lexer scan) until (end-of-buffer-p scan) @@ -976,15 +1085,21 @@ do (delete* climacs-syntax::lexemes valid-lex))) ;; parse up to the limit of validity imposed by the lexer, or ;; the bottom of the visible area, whichever comes sooner - (loop until (= valid-parse valid-lex) - until (mark<= bot (start-offset (lexeme lexer (1- valid-parse)))) - 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)))))) - + ;; + ;; This is ugly, but apparently necessary to be able to refer to + ;; the syntax in question: (syntax (buffer thing)) doesn't work, + ;; because SYNTAX isn't part of the buffer protocol, and (buffer + ;; thing) can return a delegating buffer. + (let ((*this-syntax* syntax)) + (loop until (= valid-parse valid-lex) + until (mark<= bot (start-offset (lexeme lexer (1- valid-parse)))) + 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))))))) + (defmethod inter-lexeme-object-p ((lexer prolog-lexer) object) (member object '(#\Space #\Newline #\Tab))) @@ -992,6 +1107,8 @@ (with-slots (lexer valid-parse) syntax (let* ((low-mark (low-mark buffer)) (high-mark (high-mark buffer))) + ;; this bit really belongs in a method on a superclass -- + ;; something like incremental-lexer. (when (mark<= low-mark high-mark) (with-slots (climacs-syntax::lexemes valid-lex) lexer @@ -1004,7 +1121,16 @@ (setf start (1+ middle)) (setf end middle)))) (setf valid-lex start) - (setf valid-parse start))))))) + (setf valid-parse start)))) + ;; this bit is truly prolog-syntax specific. + (when (mark<= low-mark high-mark) + (with-slots (operator-directives) syntax + (do ((directives operator-directives (cdr directives))) + ((null directives) (setf operator-directives nil)) + (when (< (end-offset (car directives)) + (offset low-mark)) + (setf operator-directives directives) + (return nil)))))))) ;;; display

1 0

[climacs-cvs] CVS update: climacs/cl-syntax.lisp climacs/gui.lisp climacs/html-syntax.lisp climacs/prolog-syntax.lisp climacs/syntax.lisp climacs/text-syntax.lisp climacs/ttcn3-syntax.lisp
by crhodes＠common-lisp.net 26 May '05

26 May '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29479 Modified Files: cl-syntax.lisp gui.lisp html-syntax.lisp prolog-syntax.lisp syntax.lisp text-syntax.lisp ttcn3-syntax.lisp Log Message: OK, no-one complained too much, so I'm going ahead with the syntax file-type changes discussed in <sqmzqrhbma.fsf(a)cam.ac.uk>: DEFINE-SYNTAX's syntax is changed incompatibly. Date: Thu May 26 10:31:53 2005 Author: crhodes Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.13 climacs/cl-syntax.lisp:1.14 --- climacs/cl-syntax.lisp:1.13 Mon May 9 16:09:30 2005 +++ climacs/cl-syntax.lisp Thu May 26 10:31:53 2005 @@ -111,10 +111,12 @@ (make-instance 'other-entry)))))))) -(define-syntax cl-syntax ("Common-lisp" (basic-syntax)) +(define-syntax cl-syntax (basic-syntax) ((lexer :reader lexer) (valid-parse :initform 1) - (parser))) + (parser)) + (:name "Common Lisp") + (:pathname-types "lisp" "lsp" "cl")) (defun neutralcharp (var) (and (characterp var) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.139 climacs/gui.lisp:1.140 --- climacs/gui.lisp:1.139 Thu May 19 11:04:26 2005 +++ climacs/gui.lisp Thu May 26 10:31:53 2005 @@ -699,6 +699,16 @@ (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) +(defun syntax-class-name-for-filepath (filepath) + (or (climacs-syntax::syntax-description-class-name + (find (or (pathname-type filepath) + (pathname-name filepath)) + climacs-syntax::*syntaxes* + :test (lambda (x y) + (member x y :test #'string=)) + :key #'climacs-syntax::syntax-description-pathname-types)) + 'basic-syntax)) + (define-named-command com-find-file () (let ((filepath (accept 'completable-pathname :prompt "Find File")) @@ -707,8 +717,10 @@ (setf (point (buffer pane)) (clone-mark (point pane))) (push buffer (buffers *application-frame*)) (setf (buffer (current-window)) buffer) - (setf (syntax buffer) (make-instance - 'basic-syntax :buffer (buffer (point pane)))) + (setf (syntax buffer) + (make-instance + (syntax-class-name-for-filepath filepath) + :buffer (buffer (point pane)))) ;; Don't want to create the file if it doesn't exist. (when (probe-file filepath) (with-open-file (stream filepath :direction :input) Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.30 climacs/html-syntax.lisp:1.31 --- climacs/html-syntax.lisp:1.30 Mon May 9 15:12:47 2005 +++ climacs/html-syntax.lisp Thu May 26 10:31:53 2005 @@ -22,10 +22,12 @@ (in-package :climacs-html-syntax) -(define-syntax html-syntax ("HTML" (basic-syntax)) +(define-syntax html-syntax (basic-syntax) ((lexer :reader lexer) (valid-parse :initform 1) - (parser))) + (parser)) + (:name "HTML") + (:pathname-types "html" "htm")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.18 climacs/prolog-syntax.lisp:1.19 --- climacs/prolog-syntax.lisp:1.18 Sat May 7 18:41:03 2005 +++ climacs/prolog-syntax.lisp Thu May 26 10:31:53 2005 @@ -26,10 +26,12 @@ (defclass prolog-parse-tree (parse-tree) ()) -(define-syntax prolog-syntax ("Prolog" (basic-syntax)) +(define-syntax prolog-syntax (basic-syntax) ((lexer :reader lexer) (valid-parse :initform 1) - (parser))) + (parser)) + (:name "Prolog") + (:pathname-types "pl")) (defparameter *prolog-grammar* (grammar)) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.49 climacs/syntax.lisp:1.50 --- climacs/syntax.lisp:1.49 Mon May 9 15:12:47 2005 +++ climacs/syntax.lisp Thu May 26 10:31:53 2005 @@ -39,6 +39,50 @@ (defparameter *syntaxes* '()) +(defstruct (syntax-description (:type list)) + (name (error "required argument") :type string) + (class-name (error "required argument") :type symbol) + (pathname-types nil :type list)) + +(defmacro define-syntax (class-name superclasses slots &rest options) + (let ((defclass-options nil) + (default-initargs nil) + (name nil) + (pathname-types nil)) + (dolist (option options) + (case (car option) + ((:name) + (if name + (error "More than one ~S option provided to ~S" + ':name 'define-syntax) + (setf name (cadr option)))) + ((:pathname-types) + (if pathname-types + (error "More than one ~S option provided to ~S" + ':pathname-types 'define-syntax) + (setf pathname-types (cdr option)))) + ((:default-initargs) + (if default-initargs + (error "More than one ~S option provided to ~S" + ':default-initargs 'define-syntax) + (setf default-initargs (cdr option)))) + (t (push (cdr option) defclass-options)))) + (unless name + (error "~S not supplied to ~S" ':name 'define-syntax)) + ;; FIXME: the :NAME initarg looks, well, a bit generic, and could + ;; collide with user-defined syntax initargs. Use + ;; CLIMACS-SYNTAX::%NAME instead. + (setf default-initargs (list* :name name default-initargs)) + `(progn + (push (make-syntax-description + :name ,name :class-name ',class-name + :pathname-types ',pathname-types) + *syntaxes*) + (defclass ,class-name ,superclasses ,slots + (:default-initargs ,@default-initargs) + ,@defclass-options)))) + +#+nil (defmacro define-syntax (class-name (name superclasses) &body body) `(progn (push '(,name . ,class-name) *syntaxes*) (defclass ,class-name ,superclasses @@ -52,8 +96,8 @@ (lambda (so-far action) (complete-from-possibilities so-far *syntaxes* '() :action action - :name-key #'car - :value-key #'cdr)) + :name-key #'syntax-description-name + :value-key #'syntax-description-class-name)) :partial-completers '(#\Space) :allow-any-input t) (declare (ignore success string)) @@ -63,8 +107,11 @@ ;;; ;;; Basic syntax -(define-syntax basic-syntax ("Basic" (syntax)) - ()) +;;; FIXME: this is a really bad name. It's even worse if it's +;;; case-insensitive. Emacs' "Fundamental" isn't too bad. +(define-syntax basic-syntax (syntax) + () + (:name "Basic")) (defmethod update-syntax (buffer (syntax basic-syntax)) (declare (ignore buffer)) Index: climacs/text-syntax.lisp diff -u climacs/text-syntax.lisp:1.6 climacs/text-syntax.lisp:1.7 --- climacs/text-syntax.lisp:1.6 Sun Mar 13 21:51:48 2005 +++ climacs/text-syntax.lisp Thu May 26 10:31:53 2005 @@ -57,8 +57,10 @@ (setf low-position (floor (+ low-position 1 high-position) 2))) finally (return low-position))) -(define-syntax text-syntax ("Text" (basic-syntax)) - ((paragraphs :initform (make-instance 'standard-flexichain)))) +(define-syntax text-syntax (basic-syntax) + ((paragraphs :initform (make-instance 'standard-flexichain))) + (:name "Text") + (:pathname-types "text" "txt" "README")) (defmethod update-syntax (buffer (syntax text-syntax)) (let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer))) Index: climacs/ttcn3-syntax.lisp diff -u climacs/ttcn3-syntax.lisp:1.1 climacs/ttcn3-syntax.lisp:1.2 --- climacs/ttcn3-syntax.lisp:1.1 Mon May 23 03:00:24 2005 +++ climacs/ttcn3-syntax.lisp Thu May 26 10:31:53 2005 @@ -119,10 +119,12 @@ (make-instance 'identifier)) (t (fo) (make-instance 'other-entry))))))))) -(define-syntax ttcn3-syntax ("TTCN3" (basic-syntax)) +(define-syntax ttcn3-syntax (basic-syntax) ((lexer :reader lexer) (valid-parse :initform 1) - (parser))) + (parser)) + (:name "TTCN3") + (:pathname-types "ttcn" "ttcn3")) (defparameter *ttcn3-grammar* (grammar))

1 0