[climacs-cvs] CVS update: climacs/prolog-syntax.lisp
Christophe Rhodes
crhodes at common-lisp.net
Thu May 26 13:22:35 UTC 2005
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 (, at rule , at 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
More information about the Climacs-cvs
mailing list