;;; -*- Mode: Lisp; Package: CLIMACS-HTML-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; Robert Strandh (strandh@labri.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Syntax for analysing ISO Prolog (in-package "CLIMACS-PROLOG-SYNTAX") (defclass prolog-parse-tree (parse-tree) ()) (define-syntax prolog-syntax ("Prolog" (basic-syntax)) ((lexer :reader lexer) (valid-parse :initform 1) (parser))) (defparameter *prolog-grammar* (grammar)) (defmacro define-prolog-rule ((&rest rule) &body body) `(add-rule (grammar-rule (,@rule ,@body)) *prolog-grammar*)) (defmethod initialize-instance :after ((syntax prolog-syntax) &rest args) (declare (ignore args)) (with-slots (parser lexer buffer) syntax (setf parser (make-instance 'parser :grammar *prolog-grammar* :target 'prolog-text)) (setf lexer (make-instance 'prolog-lexer :buffer (buffer syntax))) (let ((m (clone-mark (low-mark buffer) :left)) (lexeme (make-instance 'start-lexeme :state (initial-state parser)))) (setf (offset m) 0) (setf (start-offset lexeme) m (end-offset lexeme) 0) (insert-lexeme lexer 0 lexeme)))) ;;; grammar (defclass prolog-nonterminal (prolog-parse-tree) ()) (defclass prolog-token (prolog-parse-tree) ()) (defclass prolog-operator (prolog-token) ()) ;;; lexer (defclass prolog-lexeme (prolog-token) ((state :initarg :state))) (defmethod print-object ((o prolog-lexeme) s) (print-unreadable-object (o s :type t) (format s (lexeme-string o)))) (defclass start-lexeme (prolog-lexeme) ()) (defgeneric display-parse-tree (entity syntax pane)) (defclass layout-text (prolog-nonterminal) ((comment :initarg :comment :accessor comment :initform nil) (cont :initarg :cont :accessor cont))) (defmethod display-parse-tree ((entity layout-text) (syntax prolog-syntax) pane) (when (comment entity) (with-drawing-options (pane :ink (make-rgb-color 0.7 0.0 0.0)) (display-parse-tree (comment entity) syntax pane))) (when (cont entity) (display-parse-tree (cont entity) syntax pane))) (defgeneric syntactic-lexeme (thing)) (defmethod syntactic-lexeme ((lexeme prolog-lexeme)) lexeme) (macrolet ((def ((name &optional tokenp) &rest subs) (flet ((f (x) (intern (format nil "~A-LEXEME" x)))) `(progn (defclass ,(f name) (prolog-lexeme) ()) ,@(when tokenp `((defclass ,name (prolog-nonterminal) ((layout-text :initarg :layout-text :accessor layout-text :initform nil) (syntactic-lexeme :initarg :syntactic-lexeme :accessor syntactic-lexeme))) (defmethod display-parse-tree ((entity ,name) (syntax prolog-syntax) pane) (when (layout-text entity) (display-parse-tree (layout-text entity) syntax pane)) (display-parse-tree (syntactic-lexeme entity) syntax pane)) (define-prolog-rule (,name -> (,(f name))) (make-instance ',name :syntactic-lexeme ,(f name))) (define-prolog-rule (,name -> (layout-text ,(f name))) (make-instance ',name :layout-text layout-text :syntactic-lexeme ,(f name))))) ,@(loop for sub in subs collect `(defclass ,(f sub) (,(f name)) ())))))) (def (comment) single-line-comment bracketed-comment) (def (name t) identifier graphic quoted semicolon cut) (def (variable t) anonymous named) (def (integer t)) (def (float-number t)) (def (char-code-list t)) (def (open-ct)) (def (open t)) (def (close t)) (def (open-list t)) (def (close-list t)) (def (open-curly t)) (def (close-curly t)) (def (head-tail-separator t)) (def (comma t)) (def (end t)) (def (error))) ;;; open-ct is a special case: by 6.5.1 it cannot be preceded by ;;; layout text. We could elide this and its grammar rules, but this ;;; way we get a clearer relationship between the standard and its ;;; expression here. (defclass open-ct (prolog-nonterminal) ((syntactic-lexeme :initarg :syntactic-lexeme :accessor syntactic-lexeme))) (defmethod display-parse-tree ((entity open-ct) (syntax prolog-syntax) pane) (display-parse-tree (syntactic-lexeme entity) syntax pane)) (define-prolog-rule (open-ct -> (open-ct-lexeme)) (make-instance 'open-ct :syntactic-lexeme open-ct-lexeme)) ;;; 6.4.1 (define-prolog-rule (layout-text -> (comment-lexeme layout-text)) (make-instance 'layout-text :comment comment-lexeme :cont layout-text)) (define-prolog-rule (layout-text -> ()) (make-instance 'layout-text :cont nil)) (defclass prolog-lexer (incremental-lexer) ((valid-lex :initarg :valid-lex :accessor valid-lex :initform 1))) (defmethod next-lexeme ((lexer prolog-lexer) scan) (let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))) (flet ((fo () (vector-push-extend (object-after scan) string) (forward-object scan)) #+nil ; we might need this later for float-number tokens (bo () (vector-pop string) (backward-object scan))) (let ((object (object-after scan))) (block nil (tagbody START (cond ((lower-case-p object) (fo) (go IDENTIFIER)) ((eql object #\/) (fo) (go COMMENT-OR-GRAPHIC)) ((eql object #\%) (fo) (go LINE-COMMENT)) ((position object "#$&*+-./:<=>?@^~\\") (fo) (go GRAPHIC-TOKEN)) ((eql object #\') (fo) (go QUOTED-TOKEN)) ((eql object #\;) (fo) (return (make-instance 'semicolon-lexeme))) ((eql object #\!) (fo) (return (make-instance 'cut-lexeme))) ((eql object #\_) (fo) (go VARIABLE)) ((upper-case-p object) (fo) (go NAMED-VARIABLE)) ((digit-char-p object) (fo) (go NUMBER)) ((eql object #\") (fo) (go CHAR-CODE-LIST)) ((eql object #\() (if (or (beginning-of-buffer-p scan) (not (member (object-before scan) '(#\Space #\Newline)))) (progn (fo) (return (make-instance 'open-ct-lexeme))) (progn (fo) (return (make-instance 'open-lexeme))))) ((eql object #\)) (fo) (return (make-instance 'close-lexeme))) ((eql object #\[) (fo) (return (make-instance 'open-list-lexeme))) ((eql object #\]) (fo) (return (make-instance 'close-list-lexeme))) ((eql object #\{) (fo) (return (make-instance 'open-curly-lexeme))) ((eql object #\}) (fo) (return (make-instance 'close-curly-lexeme))) ((eql object #\|) (fo) (return (make-instance 'head-tail-separator-lexeme))) ((eql object #\,) (fo) (return (make-instance 'comma-lexeme))) ((eql object #\.) (error "shouldn't get here")) (t (fo) (return (make-instance 'error-lexeme)))) IDENTIFIER (loop until (end-of-buffer-p scan) while (let ((object (object-after scan))) (or (alphanumericp object) (eql object #\_))) do (fo)) (return (make-instance 'identifier-lexeme)) LINE-COMMENT (loop until (end-of-buffer-p scan) until (eql (object-after scan) #\Newline) do (fo)) (if (end-of-buffer-p scan) (return (make-instance 'error-lexeme)) (return (make-instance 'single-line-comment-lexeme))) COMMENT-OR-GRAPHIC (if (end-of-buffer-p scan) (return (make-instance 'graphic-lexeme)) (let ((object (object-after scan))) (cond ((eql object #\*) (fo) (go COMMENT)) ((not (position object "#$&*+-./:<=>?@^~\\")) (return (make-instance 'graphic-lexeme))) (t (fo) (go GRAPHIC-TOKEN))))) COMMENT (cond ((end-of-buffer-p scan) (return (make-instance 'error-lexeme))) ((eql (object-after scan) #\*) (fo) (cond ((end-of-buffer-p scan) (return (make-instance 'error-lexeme))) ((eql (object-after scan) #\/) (fo) (return (make-instance 'bracketed-comment-lexeme))) (t (fo) (go COMMENT)))) (t (fo) (go COMMENT))) GRAPHIC-TOKEN (loop until (end-of-buffer-p scan) while (position (object-after scan) "#$&*+-./:<=>?@^~\\") do (fo)) (cond ((end-of-buffer-p scan) (cond ((string= string ".") (return (make-instance 'end-lexeme))) (t (return (make-instance 'graphic-lexeme))))) (t (cond ((and (string= string ".") (whitespacep (object-after scan))) (return (make-instance 'end-lexeme))) (t (return (make-instance 'graphic-lexeme)))))) QUOTED-TOKEN (loop until (end-of-buffer-p scan) ;; FIXME until (eql (object-after scan) #\') do (fo)) (if (end-of-buffer-p scan) (return (make-instance 'error-lexeme)) (progn (fo) (return (make-instance 'quoted-lexeme)))) VARIABLE (if (or (end-of-buffer-p scan) (let ((object (object-after scan))) (not (or (alphanumericp object) (eql object #\_))))) (return (make-instance 'anonymous-lexeme)) (go NAMED-VARIABLE)) NAMED-VARIABLE (loop until (end-of-buffer-p scan) while (let ((object (object-after scan))) (or (alphanumericp object) (eql object #\_))) do (fo)) (return (make-instance 'named-lexeme)) NUMBER (loop until (end-of-buffer-p scan) while (digit-char-p (object-after scan)) do (fo)) (return (make-instance 'integer-lexeme)) CHAR-CODE-LIST (loop until (end-of-buffer-p scan) ;; FIXME until (eql (object-after scan) #\") do (fo)) (if (end-of-buffer-p scan) (return (make-instance 'error-lexeme)) (return (make-instance 'char-code-list-lexeme))))))))) ;;; parser (defclass prolog-text (prolog-nonterminal) ()) (defclass empty-prolog-text (prolog-text) ()) (defclass clause-prolog-text (prolog-text) ((clause :initarg :clause :accessor clause) (text-rest :initarg :text-rest :accessor text-rest))) (defclass directive-prolog-text (prolog-text) ((directive :initarg :directive :accessor directive) (text-rest :initarg :text-rest :accessor text-rest))) (defmethod display-parse-tree ((entity empty-prolog-text) (syntax prolog-syntax) pane) (declare (ignore pane)) nil) (defmethod display-parse-tree ((entity clause-prolog-text) (syntax prolog-syntax) pane) (display-parse-tree (clause entity) syntax pane) (display-parse-tree (text-rest entity) syntax pane)) (defmethod display-parse-tree ((entity directive-prolog-text) (syntax prolog-syntax) pane) (with-text-face (pane :italic) (display-parse-tree (directive entity) syntax pane)) (display-parse-tree (text-rest entity) syntax pane)) (defclass directive (prolog-nonterminal) ((directive-term :initarg :directive-term :accessor directive-term) (end :initarg :end :accessor end))) (defclass directive-term (prolog-nonterminal) ((term :initarg :term :accessor term))) (defclass clause (prolog-nonterminal) ((clause-term :initarg :clause-term :accessor clause-term) (end :initarg :end :accessor end))) (defclass clause-term (prolog-nonterminal) ((term :initarg :term :accessor term))) (defmethod display-parse-tree ((entity directive) (syntax prolog-syntax) pane) (with-text-face (pane :italic) (display-parse-tree (directive-term entity) syntax pane)) (display-parse-tree (end entity) syntax pane)) (defmethod display-parse-tree ((entity directive-term) (syntax prolog-syntax) pane) (display-parse-tree (term entity) syntax pane)) (defmethod display-parse-tree ((entity clause) (syntax prolog-syntax) pane) (display-parse-tree (clause-term entity) syntax pane) (display-parse-tree (end entity) syntax pane)) (defmethod display-parse-tree ((entity clause-term) (syntax prolog-syntax) pane) (display-parse-tree (term entity) syntax pane)) (defgeneric functor (term)) (defgeneric arity (term)) (defclass term (prolog-nonterminal) ((priority :initarg :priority :accessor priority))) (defclass constant-term (term) ((value :initarg :value :accessor value))) (defclass variable-term (term) ((name :initarg :name :accessor name))) (defclass compound-term (term) ()) (defgeneric compound-term-p (term)) (defmethod compound-term-p ((term term)) nil) (defmethod compound-term-p ((c compound-term)) t) (defclass functional-compound-term (compound-term) ((functor :initarg :functor :accessor functor) (open-ct :initarg :open-ct :accessor open-ct) (arg-list :initarg :arg-list :accessor arg-list) (close :initarg :close :accessor close))) (defclass bracketed-term (term) ((open :initarg :open :accessor open) (term :initarg :term :accessor term) (close :initarg :close :accessor close))) (defclass operator-compound-term (compound-term) ((operator :initarg :operator :accessor operator))) (defmethod functor ((o operator-compound-term)) (operator o)) (defclass binary-operator-compound-term (operator-compound-term) ((left :initarg :left :accessor left) (right :initarg :right :accessor right))) (defmethod arity ((b binary-operator-compound-term)) 2) (defclass prefix-operator-compound-term (operator-compound-term) ((right :initarg :right :accessor right))) (defmethod arity ((p prefix-operator-compound-term)) 1) (defclass postfix-operator-compound-term (operator-compound-term) ((left :initarg :left :accessor left))) (defmethod arity ((p postfix-operator-compound-term)) 1) (defclass list-compound-term (compound-term) (([ :initarg :[ :accessor [) (items :initarg :items :accessor items) (] :initarg :] :accessor ]))) (defmethod functor ((l list-compound-term)) ".") (defmethod arity ((l list-compound-term)) 2) (defclass curly-compound-term (compound-term) (({ :initarg :{ :accessor {) (term :initarg :term :accessor term) (} :initarg :} :accessor }))) (defmethod functor ((c curly-compound-term)) "{}") (defmethod arity ((c curly-compound-term)) 1) (defclass char-code-list-compound-term (compound-term) ((ccl :initarg :ccl :accessor ccl))) (defmethod functor ((c char-code-list-compound-term)) ".") (defmethod arity ((l char-code-list-compound-term)) 2) (defmethod display-parse-tree ((entity constant-term) (syntax prolog-syntax) pane) (display-parse-tree (value entity) syntax pane)) (defmethod display-parse-tree ((entity variable-term) (syntax prolog-syntax) pane) (display-parse-tree (name entity) syntax pane)) (defmethod display-parse-tree ((entity functional-compound-term) (syntax prolog-syntax) pane) (with-drawing-options (pane :ink (make-rgb-color 0.9 0 0.9)) (display-parse-tree (functor entity) syntax pane)) (display-parse-tree (open-ct entity) syntax pane) (display-parse-tree (arg-list entity) syntax pane) (display-parse-tree (close entity) syntax pane)) (defmethod display-parse-tree ((entity bracketed-term) (syntax prolog-syntax) pane) (display-parse-tree (open entity) syntax pane) (display-parse-tree (term entity) syntax pane) (display-parse-tree (close entity) syntax pane)) (defmethod display-parse-tree ((entity binary-operator-compound-term) (syntax prolog-syntax) pane) (display-parse-tree (left entity) syntax pane) (display-parse-tree (operator entity) syntax pane) (display-parse-tree (right entity) syntax pane)) (defmethod display-parse-tree ((entity prefix-operator-compound-term) (syntax prolog-syntax) pane) (display-parse-tree (operator entity) syntax pane) (display-parse-tree (right entity) syntax pane)) (defmethod display-parse-tree ((entity postfix-operator-compound-term) (syntax prolog-syntax) pane) (display-parse-tree (left entity) syntax pane) (display-parse-tree (operator entity) syntax pane)) (defmethod display-parse-tree ((entity list-compound-term) (syntax prolog-syntax) pane) (with-drawing-options (pane :ink (make-rgb-color 0.0 0.0 0.8)) (display-parse-tree ([ entity) syntax pane) (display-parse-tree (items entity) syntax pane) (display-parse-tree (] entity) syntax pane))) (defmethod display-parse-tree ((entity curly-compound-term) (syntax prolog-syntax) pane) (display-parse-tree ({ entity) syntax pane) (display-parse-tree (term entity) syntax pane) (display-parse-tree (} entity) syntax pane)) (defclass atom (prolog-nonterminal) ((value :initarg :value :accessor value))) (defmethod canonical-name ((thing atom)) (canonical-name (value thing))) (defmethod canonical-name ((thing name)) ;; FIXME: should canonize (lexeme-string (syntactic-lexeme thing))) (defclass empty-list (prolog-nonterminal) (([ :initarg :[ :accessor [) (] :initarg :] :accessor ]))) (defmethod canonical-name ((thing empty-list)) ;; FIXME: this clashes with the canonical name for the atom '[]' "[]") (defclass curly-brackets (prolog-nonterminal) (({ :initarg :{ :accessor {) (} :initarg :} :accessor }))) (defmethod canonical-name ((thing curly-brackets)) ;; FIXME: see comment in CANONICAL-NAME (EMPTY-LIST) "{}") (defmethod display-parse-tree ((entity atom) (syntax prolog-syntax) pane) (display-parse-tree (value entity) syntax pane)) (defmethod display-parse-tree ((entity empty-list) (syntax prolog-syntax) pane) (display-parse-tree ([ entity) syntax pane) (display-parse-tree (] entity) syntax pane)) (defmethod display-parse-tree ((entity curly-brackets) (syntax prolog-syntax) pane) (display-parse-tree ({ entity) syntax pane) (display-parse-tree (} entity) syntax pane)) (defclass arg-list (prolog-nonterminal) ((exp :initarg :exp :accessor exp))) (defclass arg-list-pair (arg-list) ((comma :initarg :comma :accessor comma) (arg-list :initarg :arg-list :accessor arg-list))) (defmethod display-parse-tree ((entity arg-list) (syntax prolog-syntax) pane) (display-parse-tree (exp entity) syntax pane)) (defmethod display-parse-tree ((entity arg-list-pair) (syntax prolog-syntax) pane) (display-parse-tree (exp entity) syntax pane) (display-parse-tree (comma entity) syntax pane) (display-parse-tree (arg-list entity) syntax pane)) (defclass exp (prolog-nonterminal) ()) (defclass exp-atom (exp) ((atom :initarg :atom :accessor atom))) (defclass exp-term (exp) ((term :initarg :term :accessor term))) (defmethod display-parse-tree ((entity exp-atom) (syntax prolog-syntax) pane) (display-parse-tree (atom entity) syntax pane)) (defmethod display-parse-tree ((entity exp-term) (syntax prolog-syntax) pane) (display-parse-tree (term entity) syntax pane)) (defclass lterm (term) ((term :initarg :term :accessor term))) (defmethod compound-term-p ((l lterm)) (compound-term-p (term l))) (defmethod functor ((l lterm)) (functor (term l))) (defmethod arity ((l lterm)) (arity (term l))) (defmethod display-parse-tree ((entity lterm) (syntax prolog-syntax) pane) (display-parse-tree (term entity) syntax pane)) ;;; FIXME: the need for these is because it is a protocol violation to ;;; create nested nonterminals from one rule. (defclass operator-compound-lterm (lterm) ((operator :initarg :operator :accessor operator))) (defmethod compound-term-p ((l operator-compound-lterm)) t) (defmethod functor ((l operator-compound-lterm)) (operator l)) (defclass binary-operator-compound-lterm (operator-compound-lterm) ((left :initarg :left :accessor left) (right :initarg :right :accessor right))) (defmethod arity ((l binary-operator-compound-lterm)) 2) (defclass prefix-operator-compound-lterm (operator-compound-lterm) ((right :initarg :right :accessor right))) (defmethod arity ((l prefix-operator-compound-lterm)) 1) (defclass postfix-operator-compound-lterm (operator-compound-lterm) ((left :initarg :left :accessor left))) (defmethod arity ((l postfix-operator-compound-lterm)) 1) (defmethod display-parse-tree ((entity binary-operator-compound-lterm) (syntax prolog-syntax) pane) (display-parse-tree (left entity) syntax pane) (display-parse-tree (operator entity) syntax pane) (display-parse-tree (right entity) syntax pane)) (defmethod display-parse-tree ((entity prefix-operator-compound-lterm) (syntax prolog-syntax) pane) (display-parse-tree (operator entity) syntax pane) (display-parse-tree (right entity) syntax pane)) (defmethod display-parse-tree ((entity postfix-operator-compound-lterm) (syntax prolog-syntax) pane) (display-parse-tree (left entity) syntax pane) (display-parse-tree (operator entity) syntax pane)) (defclass op (prolog-nonterminal) ((name :initarg :name :accessor name) (priority :initarg :priority :accessor priority) (specifier :initarg :specifier :accessor specifier))) (defmethod canonical-name ((thing op)) (canonical-name (name thing))) (defclass prefix-op (op) ()) (defclass binary-op (op) ()) (defclass postfix-op (op) ()) (defmethod display-parse-tree ((entity op) (syntax prolog-syntax) pane) (display-parse-tree (name entity) syntax pane)) (defclass items (prolog-nonterminal) ((exp :initarg :exp :accessor exp))) (defclass items-pair (items) ((htsep :initarg :htsep :accessor htsep) (texp :initarg :texp :accessor texp))) (defclass items-list (items) ((comma :initarg :comma :accessor comma) (tlist :initarg :tlist :accessor tlist))) (defmethod display-parse-tree ((entity items) (syntax prolog-syntax) pane) (display-parse-tree (exp entity) syntax pane)) (defmethod display-parse-tree ((entity items-pair) (syntax prolog-syntax) pane) (display-parse-tree (exp entity) syntax pane) (display-parse-tree (htsep entity) syntax pane) (display-parse-tree (texp entity) syntax pane)) (defmethod display-parse-tree ((entity items-list) (syntax prolog-syntax) pane) (display-parse-tree (exp entity) syntax pane) (display-parse-tree (comma entity) syntax pane) (display-parse-tree (tlist entity) syntax pane)) ;;; 6.2.1 (define-prolog-rule (prolog-text -> (directive prolog-text)) (make-instance 'directive-prolog-text :directive directive :text-rest prolog-text)) (define-prolog-rule (prolog-text -> (clause prolog-text)) (make-instance 'clause-prolog-text :clause clause :text-rest prolog-text)) (define-prolog-rule (prolog-text -> ()) (make-instance 'empty-prolog-text)) ;;; 6.2.1.1 (defun term-directive-p (term) (and (compound-term-p term) (string= (canonical-name (functor term)) ":-") (= (arity term) 1))) (define-prolog-rule (directive -> (directive-term end)) (make-instance 'directive :directive-term directive-term :end end)) (define-prolog-rule (directive-term -> ((term (term-directive-p term)))) (make-instance 'directive-term :term term)) ;;; 6.2.1.2 (define-prolog-rule (clause -> (clause-term end)) (make-instance 'clause :clause-term clause-term :end end)) (define-prolog-rule (clause-term -> ((term (not (term-directive-p term))))) (make-instance 'clause-term :term term)) ;;; 6.3.1.1 (define-prolog-rule (term -> (integer)) (make-instance 'constant-term :priority 0 :value integer)) ;;; 6.3.1.2 (define-prolog-rule (term -> ((atom (string= (canonical-name atom) "-")) integer)) ;; FIXME: this doesn't really look right. (make-instance 'constant-term :priority 0 :value (list atom integer))) ;;; 6.3.1.3 (define-prolog-rule (term -> ((atom (not (operatorp atom))))) (make-instance 'constant-term :priority 0 :value atom)) (define-prolog-rule (term -> ((atom (operatorp atom)))) (make-instance 'constant-term :priority 1201 :value atom)) (define-prolog-rule (atom -> (name)) (make-instance 'atom :value name)) (define-prolog-rule (atom -> (empty-list)) (make-instance 'atom :value empty-list)) (define-prolog-rule (atom -> (curly-brackets)) (make-instance 'atom :value curly-brackets)) (define-prolog-rule (empty-list -> (open-list close-list)) (make-instance 'empty-list :[ open-list :] close-list)) (define-prolog-rule (curly-brackets -> (open-curly close-curly)) (make-instance 'curly-brackets :{ open-curly :} close-curly)) ;;; 6.3.2 (define-prolog-rule (term -> (variable)) (make-instance 'variable-term :priority 0 :name variable)) ;;; 6.3.3 (define-prolog-rule (term -> (atom open-ct arg-list close)) (make-instance 'functional-compound-term :priority 0 :functor atom :arg-list arg-list :open-ct open-ct :close close)) (define-prolog-rule (arg-list -> (exp)) (make-instance 'arg-list :exp exp)) (define-prolog-rule (arg-list -> (exp comma arg-list)) (make-instance 'arg-list-pair :exp exp :comma comma :arg-list arg-list)) ;;; 6.3.3.1 (define-prolog-rule (exp -> ((atom (and (operatorp atom) (not (typep (value atom) 'comma)))))) (make-instance 'exp-atom :atom atom)) (define-prolog-rule (exp -> ((term (<= (priority term) 999)))) (make-instance 'exp-term :term term)) ;;; 6.3.4.1 ;;; NOTE NOTE NOTE ;;; ;;; Handling the production rules ;;; ;;; term -> lterm ;;; n n ;;; ;;; and ;;; ;;; lterm -> term ;;; n n-1 ;;; ;;; is done by making LTERM a subclass of TERM (for the first) so that ;;; any LTERM produced by operator rules is acceptable where a regular ;;; term would be, by explicitly writing the second production rule ;;; out here, and by using inegality tests rather than equalities for ;;; priorities elsewhere. LTERMs act as containers for terms. ;;; ;;; FIXME: why on earth doesn't this cause infinite recursion? If ;;; LTERM is a subtype of TERM, as it is, this rule should surely be ;;; always applicable. (define-prolog-rule (lterm -> (term)) (make-instance 'lterm :term term :priority (1+ (priority term)))) (define-prolog-rule (term -> (open (term (<= (priority term) 1201)) close)) (make-instance 'bracketed-term :priority 0 :open open :term term :close close)) (define-prolog-rule (term -> (open-ct (term (<= (priority term) 1201)) close)) (make-instance 'bracketed-term :priority 0 :open open-ct :term term :close close)) ;;; 6.3.4.2 ;;; ;;; NOTE NOTE NOTE ;;; ;;; We rely here on the (undocumented?) fact that returning NIL from ;;; the body of these rules implies a failure. (define-prolog-rule (lterm -> ((left term) (op (eql (specifier op) :xfx)) (right term))) (when (and (< (priority left) (priority op)) (< (priority right) (priority op))) (make-instance 'binary-operator-compound-lterm :priority (priority op) :left left :operator op :right right))) (define-prolog-rule (lterm -> ((left lterm) (op (eql (specifier op) :yfx)) (right term))) (when (and (<= (priority left) (priority op)) (< (priority right) (priority op))) (make-instance 'binary-operator-compound-lterm :priority (priority op) :left left :operator op :right right))) (define-prolog-rule (term -> ((left term) (op (eql (specifier op) :xfy)) (right term))) (when (and (< (priority left) (priority op)) (<= (priority right) (priority op))) (make-instance 'binary-operator-compound-term :priority (priority op) :left left :operator op :right right))) (define-prolog-rule (lterm -> (lterm (op (eql (specifier op) :yf)))) (when (<= (priority lterm) (priority op)) (make-instance 'postfix-operator-compound-lterm :priority (priority op) :left lterm :operator op))) (define-prolog-rule (lterm -> (term (op (eql (specifier op) :xf)))) (when (< (priority term) (priority op)) (make-instance 'postfix-operator-compound-lterm :priority (priority op) :left term :operator op))) (define-prolog-rule (term -> ((op (eql (specifier op) :fy)) term)) (when (and (or (not (string= (canonical-name op) "-")) (not (numeric-constant-p term))) (not (typep (first-lexeme term) 'open-ct-lexeme)) (<= (priority term) (priority op))) (make-instance 'prefix-operator-compound-term :right term :operator op :priority (priority op)))) (define-prolog-rule (lterm -> ((op (eql (specifier op) :fx)) term)) (when (and (or (not (string= (canonical-name op) "-")) (not (numeric-constant-p term))) (not (typep (first-lexeme term) 'open-ct-lexeme)) (< (priority term) (priority op))) (make-instance 'prefix-operator-compound-lterm :priority (priority op) :right term :operator op))) ;;; 6.3.4.3 (macrolet ((def (class &rest specifiers) `(progn (define-prolog-rule (,class -> (name)) (let ((opspec (find-predefined-operator name ',specifiers))) (when opspec (make-instance ',class :name name :priority (opspec-priority opspec) :specifier (opspec-specifier opspec))))) (define-prolog-rule (,class -> (name)) (let ((opspec (find-defined-operator name ',specifiers))) (when opspec (make-instance ',class :name name :priority (opspec-priority opspec) :specifier (opspec-specifier opspec)))))))) (def prefix-op :fx :fy) (def binary-op :xfx :xfy :yfx) (def postfix-op :xf :yf)) (define-prolog-rule (op -> (comma)) (make-instance 'op :name comma :priority 1000 :specifier :xfy)) ;;; 6.3.5 (define-prolog-rule (term -> (open-list items close-list)) (make-instance 'list-compound-term :priority 0 :[ open-list :items items :] close-list)) (define-prolog-rule (items -> (exp comma items)) (make-instance 'items-list :exp exp :comma comma :tlist items)) (define-prolog-rule (items -> ((left exp) head-tail-separator (right exp))) (make-instance 'items-pair :exp left :htsep head-tail-separator :texp right)) (define-prolog-rule (items -> (exp)) (make-instance 'items :exp exp)) ;;; 6.3.6 (define-prolog-rule (term -> (open-curly term close-curly)) (make-instance 'curly-compound-term :priority 0 :{ open-curly :term term :} close-curly)) ;;; 6.3.7 (define-prolog-rule (term -> (char-code-list)) (make-instance 'char-code-list-compound-term :priority 0 :ccl char-code-list)) (defparameter *predefined-operators* nil) (defstruct (opspec (:type list)) name priority specifier) (macrolet ((def (priority specifier &rest names) (let (result) (dolist (name names `(progn ,@(nreverse result))) (push `(push (make-opspec :name ',name :priority ,priority :specifier ,specifier) *predefined-operators*) result))))) ;; Table 5 -- The predefined operators (def 1200 :xfx ":-" "-->") (def 1200 :fx ":-" "?-") (def 1100 :xfy ";") (def 1050 :xfy "->") #+nil ; handled specially (FIXME: is this the right way?) (def 1000 :xfy ",") (def 700 :xfx "=" "\\=") (def 700 :xfx "==" "\\==" "@<" "@=<" "@>" "@>=") (def 700 :xfx "=..") (def 700 :xfx "is" "=:=" "=\\=" "<" "=<" ">" ">=") (def 500 :yfx "+" "-" "/\\" "\\/") (def 400 :yfx "*" "/" "//" "rem" "mod" "<<" ">>") (def 200 :xfx "**") (def 200 :xfy "^") (def 200 :fy "-" "\\") (def 100 :xfx "@") (def 50 :xfx ":")) (defun find-predefined-operator (name specifiers) (find (canonical-name name) (remove-if-not (lambda (x) (member (opspec-specifier x) specifiers)) *predefined-operators*) :key #'opspec-name :test #'string=)) (defun find-defined-operator (name specifiers) (declare (ignore name specifiers)) nil) (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)))) (defun lexeme-string (thing) (check-type thing prolog-lexeme) (coerce (buffer-sequence (buffer thing) (start-offset thing) (end-offset thing)) '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)))))) (defun first-lexeme (thing) ;; FIXME: we'll need to implement this. (declare (ignore thing)) nil) ;;; update syntax (defmethod update-syntax-for-display (buffer (syntax prolog-syntax) top bot) (with-slots (parser lexer valid-parse) syntax (with-slots (climacs-syntax::lexemes valid-lex) lexer (let ((scan (clone-mark (low-mark buffer) :left))) (setf (offset scan) (end-offset (lexeme lexer (1- valid-lex)))) ;; lex as far as we need. We actually win quite a lot if we ;; can implement the splicing described in the FIXME note, ;; below, because there's then a good chance that CLIM's ;; incremental redisplay will Do The Right Thing (on the EQ ;; lexemes) (loop do (skip-inter-lexeme-objects lexer scan) until (end-of-buffer-p scan) until (mark<= bot (start-offset (lexeme lexer (1- valid-lex)))) ;; FIXME: a further criterion is when scan matches the ;; start-offset of an element in lexemes, at which point ;; we know that the entirety of the rest of the old lex ;; is valid without doing any further work. do (let* ((start-mark (clone-mark scan)) (lexeme (next-lexeme lexer scan)) (size (- (offset scan) (offset start-mark)))) (setf (slot-value lexeme 'climacs-syntax::start-mark) start-mark (slot-value lexeme 'climacs-syntax::size) size) (insert-lexeme lexer valid-lex lexeme) (incf valid-lex))) ;; remove lexemes which we know to be invalid (let ((end (end-offset (lexeme lexer (1- valid-lex))))) (loop until (= (nb-lexemes lexer) valid-lex) while (< (start-offset (lexeme lexer valid-lex)) end) 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 (loop until (= valid-parse valid-lex) ;; NOTE: this ceases being the same condition as the above ;; as soon as the FIXME note above is implemented. 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))) (defmethod update-syntax (buffer (syntax prolog-syntax)) (with-slots (lexer valid-parse) syntax (let* ((low-mark (low-mark buffer)) (high-mark (high-mark buffer))) (when (mark<= low-mark high-mark) (with-slots (climacs-syntax::lexemes valid-lex) lexer (let ((start 1) (end (nb-elements climacs-syntax::lexemes))) (loop while (< start end) do (let ((middle (floor (+ start end) 2))) (if (mark< (end-offset (element* climacs-syntax::lexemes middle)) low-mark) (setf start (1+ middle)) (setf end middle)))) (setf valid-lex start) (setf valid-parse start))))))) ;;; display (defvar *white-space-start* nil) (defvar *cursor-positions* nil) (defvar *current-line* 0) (defun handle-whitespace (pane buffer start end) (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (< start end) do (ecase (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) (multiple-value-bind (x y) (stream-cursor-position pane) (declare (ignore x)) y))) (#\Space (stream-increment-cursor-position pane space-width 0)) (#\Tab (let ((x (stream-cursor-position pane))) (stream-increment-cursor-position pane (- tab-width (mod x tab-width)) 0)))) (incf start)))) (defmethod display-parse-tree :around ((entity prolog-parse-tree) syntax pane) (with-slots (top bot) pane (when (and (end-offset entity) (mark> (end-offset entity) top)) (call-next-method)))) (defmethod display-parse-tree ((entity prolog-token) (syntax prolog-syntax) pane) (flet ((cache-test (t1 t2) (and (eq t1 t2) #+nil (eq (slot-value t1 'ink) (medium-ink (sheet-medium pane))) #+nil (eq (slot-value t1 'face) (text-style-face (medium-text-style (sheet-medium pane))))))) #| (updating-output (pane :unique-id entity :id-test #'eq :cache-value entity :cache-test #'cache-test)|# (with-slots (#|ink face|#) entity #+nil (setf ink (medium-ink (sheet-medium pane)) face (text-style-face (medium-text-style (sheet-medium pane)))) (let ((string (coerce (buffer-sequence (buffer syntax) (start-offset entity) (end-offset entity)) 'string))) (with-slots (top bot) pane (let (start end) (setf start (max 0 (- (offset top) (start-offset entity)))) (setf end (- (length string) (max 0 (- (end-offset entity) (offset bot))))) (loop (when (>= start end) (return)) (let ((nl (position #\Newline string :start start :end end))) (unless nl (present (subseq string start end) 'string :stream pane) (return)) (present (subseq string start nl) 'string :stream pane) (handle-whitespace pane (buffer pane) (+ (start-offset entity) nl) (+ (start-offset entity) nl 1)) (setf start (+ nl 1)))))))))) (defmethod display-parse-tree :before ((entity prolog-lexeme) (syntax prolog-syntax) pane) (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity)) (setf *white-space-start* (end-offset entity))) (defgeneric display-parse-stack (symbol stack syntax pane)) (defmethod display-parse-stack (symbol stack (syntax prolog-syntax) pane) (let ((next (parse-stack-next stack))) (unless (null next) (display-parse-stack (parse-stack-symbol next) next syntax pane)) (loop for parse-tree in (reverse (parse-stack-parse-trees stack)) do (display-parse-tree parse-tree syntax pane)))) (defun display-parse-state (state syntax pane) (let ((top (parse-stack-top state))) (if (not (null top)) (display-parse-stack (parse-stack-symbol top) top syntax pane) (display-parse-tree (target-parse-tree state) syntax pane)))) (defun nb-valid-lexemes (lexer) (slot-value lexer 'valid-lex)) (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax prolog-syntax) current-p) (with-slots (top bot) pane (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot))) *current-line* 0 (aref *cursor-positions* 0) (stream-cursor-position pane)) (with-slots (lexer) syntax (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-valid-lexemes lexer))) 1.0))) ;; find the last token before bot (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1))) ;; go back to a token before bot (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot) do (decf end-token-index)) ;; go forward to the last token before bot (loop until (or (= end-token-index (nb-valid-lexemes lexer)) (mark> (start-offset (lexeme lexer end-token-index)) bot)) do (incf end-token-index)) (let ((start-token-index end-token-index)) ;; go back to the first token after top, or until the previous token ;; contains a valid parser state (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top) (not (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state)))) do (decf start-token-index)) (let ((*white-space-start* (offset top))) ;; display the parse tree if any (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state)) (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state) syntax pane)) ;; display the lexemes (with-drawing-options (pane :ink +red+) (loop while (< start-token-index end-token-index) do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) (let* ((cursor-line (number-of-lines-in-region top (point pane))) (height (text-style-height (medium-text-style pane) pane)) (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) (cursor-column (column-number (point pane))) (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) (updating-output (pane :unique-id -1) (draw-rectangle* pane (1- cursor-x) (- cursor-y (* 0.2 height)) (+ cursor-x 2) (+ cursor-y (* 0.8 height)) :ink (if current-p +red+ +blue+)))))) #| (climacs-gui::define-named-command com-inspect-lex () (with-slots (lexer) (slot-value (buffer (climacs-gui::current-window)) 'climacs-syntax::syntax) (let ((*standard-input* *query-io*) (*standard-output* *query-io*)) (inspect lexer)))) (climacs-gui::define-named-command com-inspect-parse () (with-slots (parser) (slot-value (buffer (climacs-gui::current-window)) 'climacs-syntax::syntax) (let ((*standard-input* *query-io*) (*standard-output* *query-io*)) (inspect parser)))) |#