prolog-syntax.lisp 54.2 KB
Newer Older
1
;;; -*- Mode: Lisp; Package: CLIMACS-PROLOG-SYNTAX -*-
2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23

;;;  (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

24
(in-package #:climacs-prolog-syntax)
25 26 27 28

(defclass prolog-parse-tree (parse-tree)
  ())

29 30
(define-syntax-command-table prolog-table :errorp nil)

31
(define-syntax prolog-syntax (fundamental-syntax)
32 33
  ((lexer :reader lexer)
   (valid-parse :initform 1)
34 35
   (parser)
   (operator-directives :initform nil :accessor operator-directives))
36
  (:name "Prolog")
37 38
  (:pathname-types "pl")
  (:command-table prolog-table))
39 40 41

(defparameter *prolog-grammar* (grammar))

42 43 44 45 46 47
;;; *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*)

48 49 50
(defmacro define-prolog-rule ((&rest rule) &body body)
  `(add-rule (grammar-rule (,@rule ,@body)) *prolog-grammar*))

51 52
(defmethod initialize-instance :after ((syntax prolog-syntax) &rest args)
  (declare (ignore args))
53 54 55 56 57 58 59 60 61 62 63 64
  (let ((buffer (buffer syntax)))
    (with-slots (parser lexer) syntax
      (setf parser (make-instance 'parser
                                  :grammar *prolog-grammar*
                                  :target 'prolog-text))
      (setf lexer (make-instance 'prolog-lexer :buffer buffer :syntax syntax))
      (let ((m (make-buffer-mark buffer 0 :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)))))
65 66 67 68 69 70 71

;;; grammar

(defclass prolog-nonterminal (prolog-parse-tree)
  ())

(defclass prolog-token (prolog-parse-tree)
72
  ((ink) (face) (start) (end)))
73 74 75 76 77

;;; lexer

(defclass prolog-lexeme (prolog-token)
  ((state :initarg :state)))
78 79 80
(defmethod print-object ((o prolog-lexeme) s)
  (print-unreadable-object (o s :type t)
    (format s (lexeme-string o))))
81 82 83

(defclass start-lexeme (prolog-lexeme) ())

84
(defgeneric display-parse-tree (entity syntax stream drei))
85 86 87 88 89

(defclass layout-text (prolog-nonterminal)
  ((comment :initarg :comment :accessor comment :initform nil)
   (cont :initarg :cont :accessor cont)))
(defmethod display-parse-tree
90
    ((entity layout-text) (syntax prolog-syntax) (stream extended-output-stream) (drei drei))
91
  (when (cont entity)
92
    (display-parse-tree (cont entity) syntax stream drei))
93
  (when (comment entity)
94 95
    (with-drawing-options (stream :ink (make-rgb-color 0.7 0.0 0.0))
      (display-parse-tree (comment entity) syntax stream drei))))
96 97 98 99 100

(defgeneric syntactic-lexeme (thing))
(defmethod syntactic-lexeme ((lexeme prolog-lexeme))
  lexeme)
(macrolet ((def ((name &optional tokenp) &rest subs)
101
	     (flet ((f (x) (intern (format-sym "~A-~A" x '#:lexeme))))
102 103 104 105 106 107 108 109
	       `(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
110
                            ((entity ,name) (syntax prolog-syntax) (stream extended-output-stream) (drei drei))
111 112
                          (when (layout-text entity)
                            (display-parse-tree
113
                             (layout-text entity) syntax stream drei))
114
                          (display-parse-tree
115
                           (syntactic-lexeme entity) syntax stream drei))
116 117 118 119 120
                        (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)))))
121 122 123 124 125 126
		  ,@(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)
127 128
  (def (integer t) integer-constant character-code-constant binary-constant
                   octal-constant hexadecimal-constant)
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
  (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)))

144 145 146 147 148 149
;;; 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)))
150 151 152
(defmethod display-parse-tree ((entity open-ct) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree (syntactic-lexeme entity) syntax stream drei))
153 154 155
(define-prolog-rule (open-ct -> (open-ct-lexeme))
  (make-instance 'open-ct :syntactic-lexeme open-ct-lexeme))

156
;;; 6.4.1
157
(define-prolog-rule (layout-text -> (layout-text comment-lexeme))
158 159 160
  (make-instance 'layout-text :comment comment-lexeme :cont layout-text))
(define-prolog-rule (layout-text -> ())
  (make-instance 'layout-text :cont nil))
161

162
(defclass prolog-lexer (incremental-lexer)
163 164
  ((valid-lex :initarg :valid-lex :initform 1)
   (syntax :initarg :syntax :reader syntax)))
165 166 167 168 169 170 171 172 173 174

(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))
	   (bo ()
	     (vector-pop string)
	     (backward-object scan)))
175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226
      (macrolet ((read-quoted-char (char)
		   `(block read-quoted-char
		     (let ((o (object-after scan)))
		       (tagbody
			START
			  (cond 
			    ((eql o #\\) (fo) (go ESCAPE))
			    ((eql o ,char) (fo) (go QUOTE))
			    (t (fo) (return-from read-quoted-char t)))
			QUOTE
			  (if (end-of-buffer-p scan)
			      (return-from read-quoted-char nil)
			      (let ((o (object-after scan)))
				(cond
				  ((eql o ,char) (fo) (return-from read-quoted-char t))
				  (t (return-from read-quoted-char nil)))))
			ESCAPE
			  (if (end-of-buffer-p scan)
			      (return (make-instance 'error-lexeme))
			      (let ((o (object-after scan)))
				(cond
				  ;; meta (6.5.5)
				  ((position o "\\'\"`") (fo) (return-from read-quoted-char t))
				  ;; symbolic (6.4.2.1)
				  ((position o "abfnrtv") (fo) (return-from read-quoted-char t))
				  ;; octal
				  ((digit-char-p o 8) (fo)
				   (tagbody
				    LOOP
				      (when (end-of-buffer-p scan)
					(return (make-instance 'error-lexeme)))
				      (let ((o (object-after scan)))
					(cond
					  ((eql o #\\) (fo) (return-from read-quoted-char t))
					  ((digit-char-p o 8) (fo) (go LOOP))
					  (t (return (make-instance 'error-lexeme)))))))
				  ((eql o #\x) (fo)
				   (if (or (end-of-buffer-p scan)
					   (not (digit-char-p (object-after scan) 16)))
				       (return (make-instance 'error-lexeme))
				       (progn 
					 (fo)
					 (tagbody
					  LOOP
					    (when (end-of-buffer-p scan)
					      (return (make-instance 'error-lexeme)))
					    (let ((o (object-after scan)))
					      (cond
						((eql o #\\) (fo) (return-from read-quoted-char t))
						((digit-char-p o 16) (fo) (go LOOP))
						(t (return (make-instance 'error-lexeme)))))))))
				  (t (return (make-instance 'error-lexeme)))))))))))
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
      (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))
243
	       ((eql object #\0) (fo) (go NUMBER-OR-INTEGER))
244 245 246 247
	       ((digit-char-p object) (fo) (go NUMBER))
	       ((eql object #\") (fo) (go CHAR-CODE-LIST))
	       ((eql object #\()
		(if (or (beginning-of-buffer-p scan)
248
			(not (member (object-before scan) '(#\Space #\Tab #\Newline))))
249 250 251 252 253 254 255 256 257 258 259 260 261 262
		    (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)
263 264 265 266
		   while (let ((object (object-after scan)))
			   (or (alphanumericp object)
			       (eql object #\_)))
		   do (fo))
267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309
	     (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
310
		  ((and (string= string ".") 
311
                        (or (whitespacep (syntax lexer)
312
                                         (object-after scan))
313
                            (eql (object-after scan) #\%)))
314 315 316
		   (return (make-instance 'end-lexeme)))
		  (t (return (make-instance 'graphic-lexeme))))))
	   QUOTED-TOKEN
317 318 319 320
	     (loop named #:mu
		   until (end-of-buffer-p scan)
		   while (read-quoted-char #\'))
	     (return (make-instance 'quoted-lexeme))
321 322
	   VARIABLE
	     (if (or (end-of-buffer-p scan)
323 324 325
                     (let ((object (object-after scan)))
                       (not (or (alphanumericp object)
                                (eql object #\_)))))
326 327 328 329
		 (return (make-instance 'anonymous-lexeme))
		 (go NAMED-VARIABLE))
	   NAMED-VARIABLE
	     (loop until (end-of-buffer-p scan)
330 331 332
		while (let ((object (object-after scan)))
                        (or (alphanumericp object)
                            (eql object #\_)))
333 334
		do (fo))
	     (return (make-instance 'named-lexeme))
335 336 337 338 339 340 341 342 343 344
	   NUMBER-OR-INTEGER
	     (if (end-of-buffer-p scan)
		 (return (make-instance 'integer-lexeme))
		 (let ((object (object-after scan)))
		   (cond
		     ((eql object #\') (fo) (go CHARACTER-CODE-CONSTANT))
		     ((eql object #\b) (fo) (go BINARY-CONSTANT))
		     ((eql object #\o) (fo) (go OCTAL-CONSTANT))
		     ((eql object #\x) (fo) (go HEXADECIMAL-CONSTANT))
		     ((digit-char-p object) (fo) (go NUMBER))
345
                     ((eql object #\.) (fo) (go INTEGER-AND-END-OR-FLOAT))
346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365
		     (t (return (make-instance 'integer-lexeme))))))
	   CHARACTER-CODE-CONSTANT
	     (if (read-quoted-char #\')
		 (return (make-instance 'character-code-constant-lexeme))
		 (return (make-instance 'error-lexeme)))
	   BINARY-CONSTANT
	     (loop until (end-of-buffer-p scan)
		   while (digit-char-p (object-after scan) 2)
		   do (fo))
	     (return (make-instance 'binary-constant-lexeme))
	   OCTAL-CONSTANT
	     (loop until (end-of-buffer-p scan)
		   while (digit-char-p (object-after scan) 8)
		   do (fo))
	     (return (make-instance 'octal-constant-lexeme))
	   HEXADECIMAL-CONSTANT
	     (loop until (end-of-buffer-p scan)
		   while (digit-char-p (object-after scan) 16)
		   do (fo))
	     (return (make-instance 'hexadecimal-constant-lexeme))
366 367
	   NUMBER
	     (loop until (end-of-buffer-p scan)
368 369
                   when (eql (object-after scan) #\.) 
                     do (fo) and do (go INTEGER-AND-END-OR-FLOAT)
370 371 372
		   while (digit-char-p (object-after scan))
		   do (fo))
	     (return (make-instance 'integer-constant-lexeme))
373
	   CHAR-CODE-LIST
374 375 376
	     (loop named #:mu
		   until (end-of-buffer-p scan)
		   while (read-quoted-char #\"))
377 378 379 380 381
	     (return (make-instance 'char-code-list-lexeme))
           INTEGER-AND-END-OR-FLOAT
             (when (or (end-of-buffer-p scan)
                       (let ((object (object-after scan)))
                         (or (eql object #\%)
382
                             (whitespacep (syntax lexer)
383
                                          object))))
384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402
               (bo)
               (return (make-instance 'integer-lexeme)))
             (loop until (end-of-buffer-p scan)
                   while (digit-char-p (object-after scan))
                   do (fo))
             (when (or (end-of-buffer-p scan)
                       (not (member (object-after scan) '(#\e #\E))))
               (return (make-instance 'float-number-lexeme)))
             (fo)
             (when (end-of-buffer-p scan)
               (return (make-instance 'error-lexeme)))
             (when (member (object-after scan) '(#\+ #\-))
               (fo)
               (when (end-of-buffer-p scan)
                 (return (make-instance 'error-lexeme))))
             (loop until (end-of-buffer-p scan)
                   while (digit-char-p (object-after scan))
                   do (fo))
             (return (make-instance 'float-number-lexeme)))))))))
403 404 405 406 407 408 409 410 411 412 413 414 415 416 417

;;; 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
418 419 420
    ((entity empty-prolog-text) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (declare (ignore stream drei))
421 422
  nil)
(defmethod display-parse-tree
423 424 425 426
    ((entity clause-prolog-text) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (text-rest entity) syntax stream drei)
  (display-parse-tree (clause entity) syntax stream drei))
427
(defmethod display-parse-tree
428 429 430 431 432
    ((entity directive-prolog-text) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (text-rest entity) syntax stream drei)
  (with-text-face (stream :italic)
    (display-parse-tree (directive entity) syntax stream drei)))
433 434 435 436 437 438 439 440 441 442 443 444

(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)))

445 446 447 448 449
(defmethod display-parse-tree ((entity directive) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (with-text-face (stream :italic)
    (display-parse-tree (directive-term entity) syntax stream drei))
  (display-parse-tree (end entity) syntax stream drei))
450
(defmethod display-parse-tree
451 452 453 454 455 456 457
    ((entity directive-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (term entity) syntax stream drei))
(defmethod display-parse-tree ((entity clause) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree (clause-term entity) syntax stream drei)
  (display-parse-tree (end entity) syntax stream drei))
458
(defmethod display-parse-tree
459 460 461
    ((entity clause-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (term entity) syntax stream drei))
462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482

(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)))
483 484
(defmethod arity ((f functional-compound-term))
  (arg-list-length (arg-list f)))
485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529
(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
530 531
    ((entity constant-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
532 533 534
  ;; FIXME: this is so not the right thing.
  (cond
    ((consp (value entity))
535 536 537
     (display-parse-tree (first (value entity)) syntax stream drei)
     (display-parse-tree (second (value entity)) syntax stream drei))
    (t (display-parse-tree (value entity) syntax stream drei))))
538
(defmethod display-parse-tree 
539 540 541 542
    ((entity variable-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (with-drawing-options (stream :ink (make-rgb-color 0.7 0.7 0.0))
    (display-parse-tree (name entity) syntax stream drei)))
543
(defmethod display-parse-tree 
544 545 546 547 548 549 550
    ((entity functional-compound-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (with-drawing-options (stream :ink (make-rgb-color 0.9 0 0.9))
    (display-parse-tree (functor entity) syntax stream drei))
  (display-parse-tree (open-ct entity) syntax stream drei)
  (display-parse-tree (arg-list entity) syntax stream drei)
  (display-parse-tree (close entity) syntax stream drei))
551
(defmethod display-parse-tree
552 553 554 555 556
    ((entity bracketed-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (open entity) syntax stream drei)
  (display-parse-tree (term entity) syntax stream drei)
  (display-parse-tree (close entity) syntax stream drei))
557
(defmethod display-parse-tree
558 559 560 561 562
    ((entity binary-operator-compound-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (left entity) syntax stream drei)
  (display-parse-tree (operator entity) syntax stream drei)
  (display-parse-tree (right entity) syntax stream drei))
563
(defmethod display-parse-tree
564 565 566 567
    ((entity prefix-operator-compound-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (operator entity) syntax stream drei)
  (display-parse-tree (right entity) syntax stream drei))
568
(defmethod display-parse-tree
569 570 571 572
    ((entity postfix-operator-compound-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (left entity) syntax stream drei)
  (display-parse-tree (operator entity) syntax stream drei))
573
(defmethod display-parse-tree
574 575 576 577 578 579
    ((entity list-compound-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (with-drawing-options (stream :ink (make-rgb-color 0.0 0.0 0.8))
    (display-parse-tree ([ entity) syntax stream drei)
    (display-parse-tree (items entity) syntax stream drei)
    (display-parse-tree (] entity) syntax stream drei)))
580
(defmethod display-parse-tree
581 582 583 584 585
    ((entity curly-compound-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree ({ entity) syntax stream drei)
  (display-parse-tree (term entity) syntax stream drei)
  (display-parse-tree (} entity) syntax stream drei))
586
(defmethod display-parse-tree
587 588 589 590
    ((entity char-code-list-compound-term) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (with-drawing-options (stream :ink (make-rgb-color 0.0 0.6 0.0))
    (display-parse-tree (ccl entity) syntax stream drei)))
591 592 593

(defclass atom (prolog-nonterminal)
  ((value :initarg :value :accessor value)))
594 595 596 597
(defgeneric canonical-name (thing)
  ;; FIXME: is this actually necessary?  There is confusion over the
  ;; FUNCTOR of lists, curly lists and char-code lists.
  (:method ((thing string)) thing))
598 599 600 601 602
(defmethod canonical-name ((thing atom))
  (canonical-name (value thing)))
(defmethod canonical-name ((thing name))
  ;; FIXME: should canonize
  (lexeme-string (syntactic-lexeme thing)))
603 604
(defmethod canonical-name ((thing comma))
  ",")
605 606 607
(defclass empty-list (prolog-nonterminal)
  (([ :initarg :[ :accessor [)
   (] :initarg :] :accessor ])))
608
(defmethod canonical-name ((thing empty-list))
Christophe Rhodes's avatar
Christophe Rhodes committed
609
  ;; FIXME: this clashes with the canonical name for the atom '[]'
610
  "[]")
611 612 613
(defclass curly-brackets (prolog-nonterminal)
  (({ :initarg :{ :accessor {)
   (} :initarg :} :accessor })))
614
(defmethod canonical-name ((thing curly-brackets))
Christophe Rhodes's avatar
Christophe Rhodes committed
615
  ;; FIXME: see comment in CANONICAL-NAME (EMPTY-LIST)
616
  "{}")
617 618 619 620 621 622 623
(defmethod display-parse-tree ((entity atom) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree (value entity) syntax stream drei))
(defmethod display-parse-tree ((entity empty-list) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree ([ entity) syntax stream drei)
  (display-parse-tree (] entity) syntax stream drei))
624
(defmethod display-parse-tree
625 626 627 628
    ((entity curly-brackets) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree ({ entity) syntax stream drei)
  (display-parse-tree (} entity) syntax stream drei))
629 630 631 632 633 634

(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)))
635 636 637 638 639 640 641 642 643 644
(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))))
645

646 647 648
(defmethod display-parse-tree ((entity arg-list) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree (exp entity) syntax stream drei))
649
(defmethod display-parse-tree
650 651 652 653 654
    ((entity arg-list-pair) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (exp entity) syntax stream drei)
  (display-parse-tree (comma entity) syntax stream drei)
  (display-parse-tree (arg-list entity) syntax stream drei))
655 656 657 658 659 660 661

(defclass exp (prolog-nonterminal) ())
(defclass exp-atom (exp)
  ((atom :initarg :atom :accessor atom)))
(defclass exp-term (exp)
  ((term :initarg :term :accessor term)))

662 663 664 665 666 667
(defmethod display-parse-tree ((entity exp-atom) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree (atom entity) syntax stream drei))
(defmethod display-parse-tree ((entity exp-term) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree (term entity) syntax stream drei))
668 669 670 671 672 673 674 675 676 677

(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)))

678 679 680
(defmethod display-parse-tree ((entity lterm) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree (term entity) syntax stream drei))
681

682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704
;;; 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
705 706 707 708 709
    ((entity binary-operator-compound-lterm) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (left entity) syntax stream drei)
  (display-parse-tree (operator entity) syntax stream drei)
  (display-parse-tree (right entity) syntax stream drei))
710
(defmethod display-parse-tree
711 712 713 714
    ((entity prefix-operator-compound-lterm) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (operator entity) syntax stream drei)
  (display-parse-tree (right entity) syntax stream drei))
715
(defmethod display-parse-tree
716 717 718 719
    ((entity postfix-operator-compound-lterm) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (left entity) syntax stream drei)
  (display-parse-tree (operator entity) syntax stream drei))
720

721 722 723 724
(defclass op (prolog-nonterminal)
  ((name :initarg :name :accessor name)
   (priority :initarg :priority :accessor priority)
   (specifier :initarg :specifier :accessor specifier)))
725 726
(defmethod canonical-name ((thing op))
  (canonical-name (name thing)))
727 728 729 730
(defclass prefix-op (op) ())
(defclass binary-op (op) ())
(defclass postfix-op (op) ())

731 732 733
(defmethod display-parse-tree ((entity op) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree (name entity) syntax stream drei))
734 735 736 737 738 739 740 741 742 743

(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)))

744 745 746
(defmethod display-parse-tree ((entity items) (syntax prolog-syntax)
                               (stream extended-output-stream) (drei drei))
  (display-parse-tree (exp entity) syntax stream drei))
747
(defmethod display-parse-tree
748 749 750 751 752
    ((entity items-pair) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (exp entity) syntax stream drei)
  (display-parse-tree (htsep entity) syntax stream drei)
  (display-parse-tree (texp entity) syntax stream drei))
753
(defmethod display-parse-tree
754 755 756 757 758
    ((entity items-list) (syntax prolog-syntax)
     (stream extended-output-stream) (drei drei))
  (display-parse-tree (exp entity) syntax stream drei)
  (display-parse-tree (comma entity) syntax stream drei)
  (display-parse-tree (tlist entity) syntax stream drei))
759

760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779
;;; 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))))

780
;;; 6.2.1
781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821
(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))
822 823 824 825 826 827 828
	       (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))))))))))
829
	   
830
(define-prolog-rule (prolog-text -> (prolog-text directive))
831 832 833 834 835 836
  (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*)))
837
  (make-instance 'directive-prolog-text :directive directive
838
		 :text-rest prolog-text))
839
(define-prolog-rule (prolog-text -> (prolog-text clause))
840 841 842
  (make-instance 'clause-prolog-text :clause clause :text-rest prolog-text))
(define-prolog-rule (prolog-text -> ())
  (make-instance 'empty-prolog-text))
843 844

;;; 6.2.1.1
845 846
(defun term-directive-p (term)
  (and (compound-term-p term)
847
       (string= (canonical-name (functor term)) ":-")
848 849 850 851 852 853
       (= (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))
854 855

;;; 6.2.1.2
856 857 858 859
(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))
860 861

;;; 6.3.1.1
862 863
(define-prolog-rule (term -> (integer))
  (make-instance 'constant-term :priority 0 :value integer))
864 865
(define-prolog-rule (term -> (float-number))
  (make-instance 'constant-term :priority 0 :value float-number))
866

867
;;; 6.3.1.2
868
(define-prolog-rule (term -> ((atom
869
                               (string= (canonical-name atom) "-"))
870 871 872
                              integer))
  ;; FIXME: this doesn't really look right.
  (make-instance 'constant-term :priority 0 :value (list atom integer)))
873 874 875 876 877
(define-prolog-rule (term -> ((atom
                               (string= (canonical-name atom) "-"))
                              float-number))
  ;; FIXME: this doesn't really look right.
  (make-instance 'constant-term :priority 0 :value (list atom float-number)))
878

879
;;; 6.3.1.3
880 881 882 883 884 885 886 887 888 889 890 891 892
(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))
893
(define-prolog-rule (curly-brackets -> (open-curly close-curly))
894
  (make-instance 'curly-brackets :{ open-curly :} close-curly))
895 896

;;; 6.3.2
897 898
(define-prolog-rule (term -> (variable))
  (make-instance 'variable-term :priority 0 :name variable))
899 900

;;; 6.3.3
901
(define-prolog-rule (term -> (atom open-ct arg-list close))
902
  (make-instance 'functional-compound-term :priority 0 :functor atom
903
                 :arg-list arg-list :open-ct open-ct :close close))
904 905 906 907
(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))
908 909

;;; 6.3.3.1
910 911 912 913 914
(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))
915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934

;;; 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.
935 936 937 938
;;;
;;; 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.
939 940 941 942 943 944
(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))
945
(define-prolog-rule (term -> (open-ct
946 947 948
                              (term (<= (priority term) 1201))
                              close))
  (make-instance 'bracketed-term :priority 0
949
                 :open open-ct :term term :close close))
950 951 952 953 954

;;; 6.3.4.2
;;;
;;; NOTE NOTE NOTE
;;;
955
;;; We rely here on the (undocumented?) fact that returning NIL from
956
;;; the body of these rules implies a failure.
957 958 959 960 961
(define-prolog-rule (lterm -> ((left term)
                               (op (eql (specifier op) :xfx))
                               (right term)))
  (when (and (< (priority left) (priority op))
             (< (priority right) (priority op)))
962 963
    (make-instance 'binary-operator-compound-lterm :priority (priority op)
		   :left left :operator op :right right)))
964 965 966 967 968
(define-prolog-rule (lterm -> ((left lterm)
                               (op (eql (specifier op) :yfx))
                               (right term)))
  (when (and (<= (priority left) (priority op))
             (< (priority right) (priority op)))
969 970
    (make-instance 'binary-operator-compound-lterm :priority (priority op)
		   :left left :operator op :right right)))
971 972 973 974 975 976 977 978 979
(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))
980 981
    (make-instance 'postfix-operator-compound-lterm :priority (priority op)
		   :left lterm :operator op)))
982 983
(define-prolog-rule (lterm -> (term (op (eql (specifier op) :xf))))
  (when (< (priority term) (priority op))
984 985
    (make-instance 'postfix-operator-compound-lterm :priority (priority op)
		   :left term :operator op)))
986
(define-prolog-rule (term -> ((op (eql (specifier op) :fy)) term))
987
  (when (and (or (not (string= (canonical-name op) "-"))
988 989 990 991 992 993
                 (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))
994
  (when (and (or (not (string= (canonical-name op) "-"))
995 996 997
                 (not (numeric-constant-p term)))
             (not (typep (first-lexeme term) 'open-ct-lexeme))
             (< (priority term) (priority op)))
998 999
    (make-instance 'prefix-operator-compound-lterm :priority (priority op)
		   :right term :operator op)))
1000 1001

;;; 6.3.4.3
1002
(macrolet ((def (class &rest specifiers)
1003
             `(progn
1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020
               (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))
1021 1022

;;; 6.3.5
1023 1024 1025 1026 1027 1028 1029 1030
(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))
1031 1032
(define-prolog-rule (items -> (exp))
  (make-instance 'items :exp exp))
1033 1034

;;; 6.3.6
1035 1036 1037
(define-prolog-rule (term -> (open-curly term close-curly))
  (make-instance 'curly-compound-term :priority 0
                 :{ open-curly :term term :} close-curly))
1038 1039

;;; 6.3.7
1040 1041 1042
(define-prolog-rule (term -> (char-code-list))
  (make-instance 'char-code-list-compound-term
                 :priority 0 :ccl char-code-list))
1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076

(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)
1077
  (find (canonical-name name)
1078 1079 1080 1081
        (remove-if-not (lambda (x) (member (opspec-specifier x) specifiers))
                       *predefined-operators*)
        :key #'opspec-name :test #'string=))
(defun find-defined-operator (name specifiers)
1082 1083 1084 1085 1086 1087 1088 1089 1090
  (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)))))))))
		       
1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103
(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)
1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117
  (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)))
1118

1119
(defun first-lexeme (thing)
1120 1121 1122 1123 1124 1125 1126 1127 1128 1129
  ;; KLUDGE: it might be "cleaner" to walk the various parsing
  ;; structures, but this will do.
  (let* ((syntax *this-syntax*)
         (lexer (slot-value syntax 'lexer)))
    (do ((i 0 (+ i 1)))
        ((= i (nb-lexemes lexer)) (error "foo"))
      (let ((lexeme (lexeme lexer i)))
        (when (= (start-offset thing) (start-offset lexeme))
          (return lexeme))))))

1130 1131
;;; update syntax

1132 1133 1134
(defmethod inter-lexeme-object-p ((lexer prolog-lexer) object)
  (member object '(#\Space #\Newline #\Tab)))

1135 1136
(defmethod update-syntax esa-utils:values-max-min ((syntax prolog-syntax) prefix-size suffix-size &optional begin end)
  (declare (ignore begin))
1137 1138 1139 1140 1141 1142 1143
  ;; FIXME: this isn't quite right; it's possible that an edit has
  ;; occurred out of view, destroying our parse-up-to-end-lexeme
  ;; invariant.  Actually it also seems to be wrong, maybe because
  ;; there's something weird in views.lisp?  Dunno.
  #+nil
  (when (< end prefix-size)
    (return-from update-syntax (values 0 prefix-size)))
1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172
  (with-slots (lexer valid-parse) syntax
    (let* ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left))
           (high-mark (make-buffer-mark
                       (buffer syntax) (- (size (buffer syntax)) suffix-size) :left)))
      ;; this bit really belongs in a method on a superclass --
      ;; something like incremental-lexer.
      (when (mark<= low-mark high-mark)
	(with-slots (drei-syntax::lexemes valid-lex)
	    lexer
	  (let ((start 1)
		(end (nb-elements drei-syntax::lexemes)))
	    (loop while (< start end)
		  do (let ((middle (floor (+ start end) 2)))
		       (if (mark< (end-offset (element* drei-syntax::lexemes middle))
				  low-mark)
			   (setf start (1+ middle))
			   (setf end middle))))
	    (setf valid-lex 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)))))))
  ;; old update-syntax-for-display
1173
  (with-slots (parser lexer valid-parse) syntax
1174
    (with-slots (drei-syntax::lexemes valid-lex) lexer
1175 1176
      (let ((scan (make-buffer-mark (buffer syntax) prefix-size :left))
	    (high-mark (make-buffer-mark (buffer syntax) (- (size (buffer syntax)) suffix-size) :left)))
1177 1178
        (setf (offset scan)
              (end-offset (lexeme lexer (1- valid-lex))))
1179 1180
	;; this magic belongs in a superclass' method.  (It's not the
	;; same as HTML/Common Lisp relexing, though)
1181 1182
        (loop named relex
	      do (skip-inter-lexeme-objects lexer scan)
1183
              until (end-of-buffer-p scan)
1184 1185
	      until (and (<= end (start-offset (lexeme lexer (1- valid-lex))))
			 (typep (lexeme lexer (1- valid-lex)) 'end-lexeme))
1186
	      do (when (mark> scan high-mark)
1187 1188
		   (do ()
		       ((= (nb-lexemes lexer) valid-lex))
1189
		     (let ((l (lexeme lexer valid-lex)))
1190 1191 1192 1193 1194 1195 1196
		       (cond
			 ((mark< scan (start-offset l))
			  (return nil))
			 ((mark= scan (start-offset l))
			  (setf valid-lex (nb-lexemes lexer))
			  (return-from relex))
			 (t
1197
			  (delete* drei-syntax::lexemes valid-lex))))))
1198 1199 1200
	      do (let* ((start-mark (clone-mark scan))
			(lexeme (next-lexeme lexer scan))
			(size (- (offset scan) (offset start-mark))))
1201 1202
		   (setf (slot-value lexeme 'drei-syntax::start-mark) start-mark
			 (slot-value lexeme 'drei-syntax::size) size)
1203 1204
		   (insert-lexeme lexer valid-lex lexeme)
		   (incf valid-lex)))
1205 1206 1207 1208 1209 1210 1211 1212
	;; remove lexemes which we know to be invalid.
	;;
	;; If we wanted some additional complexity, we could maintain
	;; the possibility of not matching a start lexeme in the
	;; visible region, but possibly elsewhere instead; however,
	;; for now, simply assume that the VALID-LEX from above is
	;; definitive.
	(loop until (= (nb-lexemes lexer) valid-lex)
1213
	      do (delete* drei-syntax::lexemes valid-lex)))
1214
      ;; parse up to the limit of validity imposed by the lexer, or
1215
      ;; the bottom of the visible area, whichever comes sooner
1216 1217 1218 1219 1220 1221 1222
      ;;
      ;; 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)
1223 1224
	      until (and (<= end (start-offset (lexeme lexer (1- valid-parse))))
			 (typep (lexeme lexer (1- valid-parse)) 'end-lexeme))
1225 1226 1227 1228 1229
	      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)))
1230
		   (incf valid-parse))))
1231 1232 1233 1234
      (let ((scan (make-buffer-mark (buffer syntax) 0 :left)))
	(setf (offset scan) (end-offset (lexeme lexer (1- valid-parse))))
	(skip-inter-lexeme-objects lexer scan)
	(values 0 (offset scan))))))
1235 1236

;;; display
1237 1238 1239 1240
(defclass pump-state ()
  ((drawing-options :initarg :drawing-options :accessor drawing-options)
   (lexeme-index :initarg :lexeme-index :accessor lexeme-index)
   (offset :initarg :offset :accessor pump-state-offset)))
1241 1242 1243 1244
(defmethod print-object ((o pump-state) s)
  (print-unreadable-object (o s :type t)
    (with-slots (lexeme-index offset) o
      (format s "~S ~S" lexeme-index offset))))
1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279

(defun make-pump-state (drawing-options lexeme-index offset)
  (make-instance 'pump-state :drawing-options drawing-options 
		 :lexeme-index lexeme-index :offset offset))

(defun %lexeme-index-before-offset (syntax offset)
  (update-parse syntax 0 offset)
  (with-slots (drei-syntax::lexemes valid-lex)
      (lexer syntax)
    ;; FIXME: speed this up.
    (do* ((i (1- valid-lex) (1- i))
	  (lexeme #1=(element* drei-syntax::lexemes i) #1#)
	  (start #2=(start-offset lexeme) #2#))
	 ((<= start offset) i))))

(defun %drawing-options-for-lexeme-index (syntax index)
  (with-slots (drei-syntax::lexemes)
      (lexer syntax)
    (typecase (element* drei-syntax::lexemes index)
      (comment-lexeme *comment-drawing-options*)
      (char-code-list-lexeme *string-drawing-options*)
      (variable-lexeme *special-variable-drawing-options*)
      (t +default-drawing-options+))))

(defmethod pump-state-for-offset-with-syntax 
    ((view textual-drei-syntax-view) (syntax prolog-syntax) (offset cl:integer))
  (let ((index (%lexeme-index-before-offset syntax offset)))
    (make-pump-state (%drawing-options-for-lexeme-index syntax index) index offset)))

(defmethod stroke-pump-with-syntax 
    ((view textual-drei-syntax-view) (syntax prolog-syntax)
     stroke (pump-state pump-state))
  (with-slots (drei-syntax::lexemes) (lexer syntax)
    (let* ((index (lexeme-index pump-state))
	   (offset (pump-state-offset pump-state))
1280
	   (line (line-containing-offset view offset))
1281
           (line-start-offset (start-offset line))
1282
           (line-end-offset (end-offset line))
1283 1284 1285
	   (lexeme (and index (element* drei-syntax::lexemes index))))
      (cond
	((or 
1286
	  ;; in theory, if INDEX is null
1287
	  (null index)
1288 1289 1290
          ;; or if we're actually past the lexeme
          (> line-start-offset (end-offset lexeme))
	  ;; or somehow before the lexeme 
1291
	  (< line-end-offset (start-offset lexeme)))
1292
         ;; then we have blank space
1293
	 (setf (stroke-start-offset stroke) offset
1294
	       (stroke-end-offset stroke) line-end-offset
1295
	       (stroke-drawing-options stroke) +default-drawing-options+)
1296
	 (setf (pump-state-offset pump-state) (1+ line-end-offset))
1297
	 pump-state)
1298
	((< line-end-offset (end-offset lexeme))
1299
	 (setf (stroke-start-offset stroke) offset
1300
	       (stroke-end-offset stroke) line-end-offset
1301
	       (stroke-drawing-options stroke) (drawing-options pump-state))
1302
	 (setf (pump-state-offset pump-state) (1+ line-end-offset))
1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316
	 pump-state)
	(t
	 ;; before deciding what happens next, we need to ensure that
	 ;; we have given the parser a chance to lex and parse beyond
	 ;; the last lexeme.
	 (when (= (1+ index) (slot-value (lexer syntax) 'valid-lex))
	   (let ((next (min (size (buffer syntax))
			    (1+ (drei::prefix-size view)))))
	     (update-parse syntax 0 next)))
	 (cond
	   ((< (1+ index) (nb-lexemes (lexer syntax)))
	    (let* ((new-index (1+ index))
		   (new-lexeme (lexeme (lexer syntax) new-index))
		   (end-offset (min (start-offset new-lexeme) 
1317
				    line-end-offset)))
1318 1319 1320
	      (setf (stroke-start-offset stroke) offset
		    (stroke-end-offset stroke) end-offset
		    (stroke-drawing-options stroke) (drawing-options pump-state))
1321
	      (setf (pump-state-offset pump-state) (if (= end-offset line-end-offset)
1322 1323 1324 1325 1326 1327 1328 1329 1330 1331
						       (1+ end-offset)
						       end-offset)
		    (drawing-options pump-state) (%drawing-options-for-lexeme-index syntax new-index)
		    (lexeme-index pump-state) new-index))
	    pump-state)
	   (t 
	    (let ((end-offset (end-offset lexeme)))
	      (setf (stroke-start-offset stroke) offset
		    (stroke-end-offset stroke) end-offset
		    (stroke-drawing-options stroke) (drawing-options pump-state))
1332
	      (setf (pump-state-offset pump-state) (if (= end-offset line-end-offset)
1333 1334 1335 1336 1337 1338
						       (1+ end-offset)
						       end-offset)
		    (drawing-options pump-state) +default-drawing-options+
		    (lexeme-index pump-state) nil)
	      pump-state))))))))

1339 1340
#|
(climacs-gui::define-named-command com-inspect-lex ()
1341
  (with-slots (lexer) (slot-value (buffer (climacs-gui::current-window)) 'drei-syntax::syntax)
1342 1343 1344 1345 1346
    (let ((*standard-input* *query-io*)
	  (*standard-output* *query-io*))
      (inspect lexer))))

(climacs-gui::define-named-command com-inspect-parse ()
1347
  (with-slots (parser) (slot-value (buffer (climacs-gui::current-window)) 'drei-syntax::syntax)
1348 1349 1350 1351
    (let ((*standard-input* *query-io*)
	  (*standard-output* *query-io*))
      (inspect parser))))
|#