pegutils.lisp

   1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; -*-
   2 ;;;
   3 ;;; pegutils.lisp --- Utility functions for implementing PEG parsers
   4
   5 ;; Copyright (C) 2008 Utz-Uwe Haus <lisp@uuhaus.de>
   6 ;; $Id$
   7 ;;
   8 ;; This code is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the version 2.1 of the GNU Lesser General
  10 ;; Public License as published by the Free Software Foundation, as
  11 ;; clarified by the lisp prequel found in LICENSE.
  12 ;;
  13 ;; This code is distributed in the hope that it will be useful, but
  14 ;; without any warranty; without even the implied warranty of
  15 ;; merchantability or fitness for a particular purpose. See the GNU
  16 ;; Lesser General Public License for more details.
  17 ;;
  18 ;; Version 2.1 of the GNU Lesser General Public License is in the file
  19 ;; LICENSE that was distributed with this file. If it is not
  20 ;; present, you can access it from
  21 ;; http://www.gnu.org/copyleft/lgpl.txt (until superseded by a
  22 ;; newer version) or write to the Free Software Foundation, Inc., 59
  23 ;; Temple Place, Suite 330, Boston, MA 02111-1307 USA
  24 ;;
  25 ;; Commentary:
  26
  27 ;; Some code here is inspired by the metapeg library of John Leuner
  28
  29 ;;; Code:
  30
  31
  32 (eval-when (:load-toplevel :compile-toplevel :execute)
  33   (declaim (optimize (speed 0) (safety 3) (debug 3))))
  34
  35 (in-package #:opossum)
  36 \f
  37 (defparameter *trace* nil "If non-nil, do extensive tracing of the parser functions.")
  38 \f
  39
  40 (defclass context ()
  41   (;; these slots are copied when cloning a context for recursion
  42    (input       :accessor input       :initarg :input       :initform nil
  43                 :type 'string
  44                 :documentation "The input string being parsed.")
  45    (dst-package :accessor dst-package :initarg :dst-package :initform nil
  46                 :type 'package
  47                 :documentation "The package into which symbols generated during the parse are interned.")
  48    (memotab     :accessor memotab     :initarg :memotab     :initform (make-hash-table :test #'equal)
  49                 :type 'hash-table
  50                 :documentation "Hash-table used to memoize parsing result. Keyed on (fun . offset) pairs.")
  51    ;; these slots are shared by all cloned copies of a context -- use only STORE-ACTION to guarantee consistency
  52    (actions     :accessor actions     :initarg :actions     :initform (make-list 1 :initial-element NIL)
  53                 :type 'list
  54                 :documentation "The list of actions accumulated during the parse.")
  55    (action-counter :accessor action-counter :initarg :action-counter :initform '(0)
  56                    :type '(cons (integer 0) null)
  57                    :documentation "The counter of actions.")
  58    ;; these slots are what make a context unique
  59    (parent      :accessor parent      :initarg :parent      :initform nil
  60                 :documentation "Parent context of this context.")
  61    (rule        :accessor rule        :initarg :rule        :initform nil
  62                 :documentation "Rule name in this context.")
  63    (children    :accessor children    :initform nil)
  64    (value       :accessor value       :initarg :value       :initform nil
  65                 :documentation "Accumulated value after successful matching of rule in this context.")
  66    (start-index :accessor start-index :initarg :start-index :initform nil
  67                 :documentation "Position in INPUT where this context starts.")
  68    (end-index   :accessor end-index   :initarg :end-index   :initform nil
  69                 :documentation "Position in INPUT where this context's match ends.")
  70    (depth       :accessor depth       :initarg :depth       :initform 0
  71                 :documentation "How deep in the tree is this context?"))
  72   (:documentation "A parser context object."))
  73
  74 (defmethod print-object ((obj context) stream)
  75   (print-unreadable-object (obj stream :type T :identity NIL)
  76     (format stream "rule ~A (~S) value ~S (~D:~D)"
  77             (rule obj) (children obj) (value obj) (start-index obj) (end-index obj))))
  78
  79 (defmethod store-action ((ctx context) action)
  80   "Store ACTION in context CTX."
  81   (let ((a (actions ctx)))
  82     (rplacd a (cons (car a) (cdr a)))
  83     (rplaca a action)))
  84
  85 (defvar *context* nil "The current parser context.")
  86
  87 (defun clone-ctx (ctx rule)
  88   "Create clone context of CTX for rule RULE."
  89   (make-instance 'context
  90                  :input (input ctx)
  91                  :dst-package (dst-package ctx)
  92                  :memotab (memotab ctx)
  93                  :actions (actions ctx)
  94                  :action-counter (action-counter ctx)
  95                  :parent ctx
  96                  :rule rule
  97                  :start-index (end-index ctx)
  98                  :depth (1+ (depth ctx))))
  99
 100 (defun ctx-failed-p (ctx)
 101   "Check whether CTX failed to match."
 102   (null (end-index ctx)))
 103
 104 (defun succeed (ctx value start-index end-index)
 105   "Mark CTX as successful: set VALUE and matched region START-INDEX:END-INDEX."
 106   (setf (value ctx) value)
 107   (setf (start-index ctx) start-index)
 108   (setf (end-index ctx) end-index)
 109   ;; (when *trace*
 110   ;;     (format *trace-output* "Matched: ~A (~D:~D)~%"
 111   ;;        (rule ctx) (start-index ctx) (end-index ctx)))
 112   ctx)
 113
 114 (defun fail ()
 115   "Return a failure context generate from *CONTEXT*."
 116   (let ((ctx (make-instance 'context
 117                             :input (input *context*)
 118                             :rule ':fail
 119                             :value (rule *context*)
 120                             :start-index (start-index *context*)
 121                             :end-index (end-index *context*)
 122                             ;; probably some of these copies can be saved
 123                             :dst-package (dst-package *context*)
 124                             :actions (actions *context*)
 125                             :action-counter (action-counter *context*)
 126                             :depth (1+ (depth *context*)))))
 127     ;; (when *trace*
 128     ;;       (format *trace-output* "(failed: ~A ~A ~A)~%"
 129     ;;        (value ctx) (start-index ctx) (end-index ctx)))
 130     ctx))
 131
 132 (defun find-memoized-value (name offset &optional (ctx *context*))
 133   "Return a memoized value for FUN at OFFSET, or NIL."
 134   (let ((res (gethash `(,name . ,offset) (memotab ctx))))
 135     (when *trace*
 136       (format *trace-output* "~vT~A memoized result.~%" (depth ctx) (if res "Found" "No")))
 137     res))
 138
 139 (defun memoizing (name offset result-ctx &optional (ctx *context*))
 140   (when *trace*
 141     (format *trace-output* "~vT(memoizing for ~A/~D)~%" (depth ctx) name offset))
 142   (setf (gethash `(,name . ,offset) (memotab ctx))
 143         result-ctx)
 144   result-ctx)
 145 \f
 146 ;;
 147 (defun make-name (rule-string)
 148   "Create a symbol suitable for naming the parser function for rule RULE-STRING."
 149   (intern (concatenate 'string "parse-" rule-string)
 150           (dst-package *context*)))
 151
 152 (defun make-action-name (&key ctx)
 153   "Return a symbol suitable to name the next action in the current *CONTEXT*."
 154   (incf (car (action-counter *context*)))
 155   (let ((aname (if ctx
 156                    (format nil "opossum-action-~D-srcpos-~D-~D"
 157                            (car (action-counter *context*))
 158                            (start-index ctx)
 159                            (end-index ctx))
 160                    (format nil "opossum-action-~D"
 161                            (car (action-counter *context*)))) ))
 162     (intern aname (dst-package *context*))))
 163
 164 (defun char-list-to-string (char-list)
 165   (coerce char-list 'string))
 166
 167 (defmacro build-parser-function (name parser)
 168   "Return a function of 1 argument, the offset in *CONTEXT*, parsing using the given PARSER."
 169   `(lambda (offset)
 170     ,(format nil "Parse a ~A at the given OFFSET." name)
 171     (let ((indent (depth *context*)))
 172       (when *trace* (format *trace-output* "~vTTrying to parse a ~A at pos ~D~%" indent ,name offset))
 173       (or (find-memoized-value ,name offset)
 174           (let* ((*context* (clone-ctx *context* ,name))
 175                  (result (funcall ,parser offset)))
 176             (unless result
 177               (error "Parser function ~A did not return a value" ,parser))
 178             (if (ctx-failed-p result)
 179                 (progn
 180                   (when *trace* (format *trace-output* "~vT... no ~A at pos ~D~%" indent ,name offset))
 181                   (memoizing ,name offset (fail)))
 182                 (progn
 183                   (when *trace* (format *trace-output* "~vT... found ~A at ~D:~D~%"
 184                                         indent
 185                                         ,name (start-index result) (end-index result)))
 186                   (memoizing ,name offset (succeed *context* (value result) (start-index result) (end-index result))))))))))
 187
 188
 189 \f
 190 (defun match-string (string)
 191   "Return a function of 1 argument, the offset in *CONTEXT*, that tries to match STRING at that position."
 192   #'(lambda (offset)
 193       (let ((input (input *context*))
 194             (len (length string)))
 195         (if (and (>= (length input) (+ offset len))
 196                  (string= string input :start2 offset :end2 (+ offset len)))
 197             (succeed (clone-ctx *context* 'opossum-string) string offset (+ offset (length string)))
 198             (fail)))))
 199
 200 (defun match-char (char-list)
 201   #'(lambda (offset)
 202       (let ((input (input *context*)))
 203 ;;      (when *trace*
 204 ;;        (format *trace-output* "match-char: looking for one of `~{~A~}'~%" char-list))
 205         (if (and (> (length input) offset)
 206                  (member (char input offset)
 207                          char-list :test #'char=))
 208             (succeed (clone-ctx *context* 'opossum-char) (char input offset) offset (+ offset 1))
 209             (fail)))))
 210
 211 (defun match-octal-char-code (i1 i2 i3)
 212   "Compare the character given by i3 + 8*i2 + 64*i1 to the next input character."
 213   (let ((c (+ i3 (* 8 i2) (* 64 i1))))
 214     #'(lambda (offset)
 215         (let ((input (input *context*)))
 216 ;;        (when *trace*
 217 ;;          (format *trace-output* "match-octal-char-code: looking for ~D~%" c))
 218           (if (and (> (length input) offset)
 219                    (= (char-int (char input offset)) c))
 220               (succeed (clone-ctx *context* 'opossum-char) (char input offset) offset (+ offset 1))
 221               (fail))))))
 222
 223 (defun match-char-range (lower-char upper-char)
 224   "Match characters in the range between LOWER-CHAR and UPPER-CHAR (inclusive) as decided by CL:CHAR-CODE."
 225   #'(lambda (offset)
 226       (let ((input (input *context*)))
 227 ;;      (when *trace*
 228 ;;        (format *trace-output* "match-char-range: looking for ~A-~A~%" lower-char upper-char))
 229         (if (and (> (length input) offset)
 230                  (let ((x (char-code (char input offset))))
 231                    (and (>= x (char-code lower-char))
 232                         (<= x (char-code upper-char)))))
 233             (succeed (clone-ctx *context* 'opossum-char-range) (char input offset) offset (+ offset 1))
 234             (fail)))))
 235
 236 (defun match-any-char (&optional ignored)
 237   (declare (ignore ignored))
 238   #'(lambda (offset)
 239       "Match any character at OFFSET, fail only on EOF."
 240       (let ((input (input *context*)))
 241 ;;      (when *trace*
 242 ;;        (format *trace-output* "match-any-char~%"))
 243         (if (< (1+ offset) (length input))
 244             (succeed (clone-ctx *context* 'opossum-anychar) (char input offset) offset (+ offset 1))
 245             (fail)))))
 246
 247 (defun match-char-class (char-class)
 248   "Regexp matching of next input character against [CHAR-CLASS] using cl-ppcre:scan."
 249   (declare (type string char-class))
 250   ;; FIXME: could use a pre-computed scanner
 251   (let ((cc (format nil "[~A]" char-class)))
 252     #'(lambda (offset)
 253         "Match next character at OFFSET against the characters in CHAR-CLASS."
 254         (let ((input (input *context*)))
 255 ;;        (when *trace*
 256 ;;          (format *trace-output* "match-char-class on ~A~%"))
 257           (if (and (< (1+ offset) (length input))
 258                    (let ((c (char input offset)))
 259                      (cl-ppcre:scan cc (make-string 1 :initial-element c))))
 260               (succeed (clone-ctx *context* 'opossum-charclass)
 261                        (char input offset) offset (+ offset 1))
 262               (fail))))))
 263
 264 (defun fix-escape-sequences (char-list)
 265   "Iterate over the list CHAR-LIST, glueing adjacent #\\ #\n and #\\ #\t chars into
 266 #\Newline and #\Tab."
 267   (cond
 268     ((null char-list) char-list)
 269     ((null (cdr char-list)) char-list)
 270     (T
 271      (loop :with drop := nil
 272            :for (c1 c2) :on char-list
 273            :if drop
 274            :do (setf drop nil)
 275            :else
 276            :collect (if (char= c1 #\\)
 277                         (case c2
 278                           ((#\n) (setf drop T) #\Newline)
 279                           ((#\t) (setf drop T) #\Tab)
 280                           ((#\r) (setf drop T) #\Linefeed)
 281                           (otherwise c1))
 282                         c1)
 283            :end))))
 284 \f
 285 ;;
 286 ;; parsing combinator functions cribbed from libmetapeg
 287 ;;
 288 (defun either (&rest parsers)
 289   "Produce a function that tries each of the functions in PARSERS sequentially until one succeeds and
 290 returns the result of that function, or a failure context if none succeeded."
 291   #'(lambda (offset)
 292       (let ((*context* (clone-ctx *context* 'opossum-either)))
 293         ;; (when *trace*
 294         ;;        (format *trace-output* "either: ~A ~A~%" *context* parsers))
 295         (loop :for p :in parsers
 296               :as result = (funcall p offset)
 297               :when (not (ctx-failed-p result))
 298               :return (succeed *context* (value result) offset (end-index result))
 299               :finally (return (fail))))))
 300
 301
 302 (defun optional (parser)
 303   #'(lambda (offset)
 304       (let ((*context* (clone-ctx *context* 'opossum-optional)))
 305 ;;      (when *trace*
 306 ;;        (format *trace-output* "optional: ~A ~A~%" *context* parser))
 307         (let ((result (funcall parser offset)))
 308           (if (ctx-failed-p result)
 309               (succeed *context* 'optional offset offset)
 310               (succeed *context* (value result) offset (end-index result)))))))
 311
 312 (defun follow (parser)
 313   #'(lambda (offset)
 314       (let ((*context* (clone-ctx *context* 'opossum-follow)))
 315 ;;      (when *trace*
 316 ;;        (format *trace-output* "follow: ~A ~A~%" *context* parser))
 317         (let ((result (funcall parser offset)))
 318           (if (ctx-failed-p result)
 319               (fail)
 320               (succeed *context* (value result)
 321                        ;; don't consume input
 322                        offset offset))))))
 323
 324 (defun many (parser)
 325   #'(lambda (offset)
 326       (let ((*context* (clone-ctx *context* 'opossum-many))
 327             (start-offset offset)
 328             children)
 329 ;;      (when *trace*
 330 ;;        (format *trace-output* "many: ~A ~A~%" *context* parser))
 331         (loop :as result := (funcall parser offset)
 332               :while (not (ctx-failed-p result))
 333               :do (progn (push (value result) children)
 334                          (setf offset (end-index result)))
 335               :finally (return (succeed *context* (nreverse children) start-offset offset))))))
 336
 337
 338 (defun many1 (parser)
 339   #'(lambda (offset)
 340       (let* ((*context* (clone-ctx *context* 'opossum-many1))
 341              (result (funcall parser offset)))
 342 ;;      (when *trace*
 343 ;;        (format *trace-output* "many1: ~A ~A~%" *context* parser))
 344         (if (not (ctx-failed-p result))
 345             (let ((result2 (funcall (many parser) (end-index result))))
 346               (if (end-index result2)
 347                   (succeed *context* (cons (value result) (value result2)) offset (end-index result2))
 348                   (succeed *context* (value result) offset (end-index result))))
 349             (fail)))))
 350
 351
 352 (defun seq (&rest parsers)
 353   #'(lambda (offset)
 354       (assert (> (length parsers) 0))
 355       (let ((*context* (clone-ctx *context* 'opossum-seq))
 356             (start-offset offset)
 357             child-values
 358             child-nodes)
 359 ;;      (when *trace*
 360 ;;        (format *trace-output* "seq: ~A ~A~%" *context* parsers))
 361         ;; run the parsers
 362         (loop :for p :in parsers
 363 ;;            :do (when *trace* (format *trace-output* " (seq ~A) trying ~A~%" *context* p))
 364               :do (cond
 365                     ((consp p)
 366                      (push (succeed (clone-ctx *context* 'action) nil offset offset)  child-nodes)
 367                      (push p child-values)
 368                      (setf (children *context*) (reverse child-nodes)))
 369                     (T
 370                      (let ((result (funcall p offset)))
 371                        (if (end-index result)
 372                            (progn
 373                              (push result child-nodes)
 374                              (push (value result) child-values)
 375                              (setf offset (end-index result))
 376                              (setf (children *context*) (reverse child-nodes)))
 377                            (return (fail))))))
 378               :finally (return (succeed *context* (reverse child-values) start-offset offset))))))
 379
 380 (defun negate (parser)
 381   #'(lambda (offset)
 382       "Return a successful context at OFFSET if PARSER succeeds, without advancing input position."
 383       (let ((*context* (clone-ctx *context* 'opossum-negate)))
 384         (let ((result (funcall parser offset)))
 385           (if (ctx-failed-p result)
 386               (succeed *context* 'negate offset offset)
 387               (fail))))))
 388
 389 \f
 390 ;;
 391 (defun read-stream (stream)
 392   "Read STREAM and return a string of all its contents."
 393   (let ((s ""))
 394     (loop :as line := (read-line stream nil nil)
 395           :while line
 396           :do (setq s (concatenate 'string s line)))
 397     s))
 398
 399 (defun read-file (file)
 400   "Read FILE and return a string of all its contents."
 401   (with-open-file (f file :direction :input)
 402     (let ((len (file-length f)))
 403       (if len
 404           (let ((s (make-string len)))
 405             (read-sequence s f)
 406             s)
 407           (read-stream f)))))
 408 \f
 409 (defun make-default-dst-package (grammarfile)
 410   (make-package (gensym "opossum-parser")
 411                 :documentation (format T "Opossum parser for grammar ~A" grammarfile)))
 412
 413 (defun get-iso-time ()
 414   "Return a string in ISO format for the current time"
 415   (multiple-value-bind (second minute hour date month year day daylight-p zone)
 416       (get-decoded-time)
 417     (declare (ignore day))
 418     (format nil "~4D-~2,'0D-~2,'0D-~2,'0D:~2,'0D:~2,'0D (UCT~@D)"
 419             year month date
 420             hour minute second
 421             (if daylight-p (1+ (- zone)) (- zone)))))
 422
 423 (defun cleanup-action-code (code)
 424   "Remove trailing newlines  so that the string CODE can be printed nicely."
 425   (subseq code 0
 426           (when (char= #\Newline (char code (1- (length code))))
 427             (1+ (position #\Newline code :from-end T :test #'char/=)))))
 428
 429 (defmacro checking-parse (grammarfile parse-file-fun)
 430   (let ((res (gensym "resultctx")))
 431     `(let ((,res (funcall ,parse-file-fun ,grammarfile *package*)))
 432       (cond
 433         ((ctx-failed-p ,res)
 434          (format *error-output* "Failed to parse PEG grammar ~A~%" ,grammarfile)
 435          (error "Parsing ~A failed: ~A" ,grammarfile ,res))
 436         ((< (end-index ,res) (length (input ,res)))
 437          (format *error-output* "Parsed only ~D characters of grammar ~A~%" (end-index ,res) ,grammarfile)
 438          ,res)
 439         (T ,res)))))
 440
 441 (defun generate-parser-file (grammarfile dst-package dst-file &key start-rule (parse-file-fun #'opossum:parse-file))
 442   "Create lisp code in DST-FILE that can be loaded to yield functions to parse using GRAMMARFILE in DST-PACKAGE.
 443 DST-PACKAGE will contain the 3 functions PARSE-STRING, PARSE-FILE and PARSE-STREAM as exported entrypoints."
 444   (let* ((*package* dst-package)
 445          (result (checking-parse grammarfile parse-file-fun))
 446          ;; FIXME: check for complete parse
 447          (*context* result)  ;; routines in pegutils.lisp expect *context* to be bound properly
 448          (dpkg (intern (package-name dst-package) :keyword)))
 449     (let ((forms (transform (value result)))
 450           (actions (actions result)))
 451       (with-open-file (s dst-file :direction :output :if-exists :supersede)
 452         (let ((*print-readably* T)
 453               (*print-pretty* T)
 454               (*print-circle* NIL))
 455           (format s ";; This is a Common Lisp peg parser automatically generated by OPOSSUM -*- mode:lisp -*-~%")
 456           (format s ";; generated from ~A on ~A~%" grammarfile (get-iso-time))
 457           (prin1 `(eval-when (:load-toplevel :compile-toplevel :execute)
 458                    (declaim (optimize (speed 0) (safety 3) (debug 3))))
 459                  s)
 460           (terpri s)
 461           (prin1 `(defpackage ,dpkg
 462                    (:use :cl :opossum)
 463                    (:export :parse-string :parse-file :parse-stream :*trace*))
 464                  s)
 465           (terpri s)
 466           (prin1 `(in-package ,dpkg) s) (terpri s)
 467           ;; First form is taken to be the start rule
 468           (let ((entryrule (or (and start-rule (make-name start-rule))
 469                                (and forms (cadr (first forms))))))
 470             (if (not entryrule)
 471                 (format *error-output* "Cannot find entry rule for parser")
 472                 (progn
 473                   (when *trace*
 474                     (format *trace-output* "Inserting definitions for parser entry points through ~A~%"
 475                             entryrule))
 476                   (terpri s)
 477                   (prin1 `(defun parse-string (,(intern :s dst-package) dst-package)
 478                            ,(format nil "Parse S using grammar ~A starting at ~A" grammarfile entryrule)
 479                            (let ((*context* (make-instance 'opossum:context
 480                                                            :dst-package dst-package
 481                                                            :input ,(intern :s dst-package))))
 482                              (funcall (,entryrule) 0)))
 483                          s)
 484                   (terpri s)
 485                   (prin1 `(defun parse-file (,(intern :f dst-package) dst-package)
 486                            ,(format nil "Parse file F using grammar ~A starting at ~A" grammarfile entryrule)
 487                            (parse-string (opossum:read-file ,(intern :f dst-package)) dst-package))
 488                          s)
 489                   (terpri s)
 490                   (prin1 `(defun parse-stream (,(intern :stream dst-package) dst-package)
 491                            ,(format nil "Parse stream F using grammar ~A starting at ~A" grammarfile entryrule)
 492                            (parse-string (opossum:read-stream ,(intern :stream dst-package)) dst-package))
 493                          s)
 494                   (fresh-line s))))
 495           (loop :for aform :in forms
 496                 :do (when *trace* (format *trace-output* "Inserting form ~A~%" aform))
 497                 :do (terpri s)
 498                 :do (prin1 aform s)
 499                 :do (fresh-line s))
 500           (terpri s)
 501           (prin1
 502            `(defparameter ,(intern "*trace*" dst-package) nil
 503              "When non-nil, the generated parser function log to cl:*trace-output*.")
 504            s)
 505           (terpri s)
 506
 507           (loop :for (sym code) :in actions
 508                 :when sym ;; the final action is named NIL because we push a
 509                 ;; NIL ahead of us in store-actions
 510                 :do (when *trace* (format *trace-output* "Inserting defun for ~A~%" sym))
 511                 :and :do (format s "~%(defun ~S (data)~% (declare (ignorable data) (type list data))~% ~A)~%"
 512                                  sym (cleanup-action-code code))))))))
 513
 514 (defun generate-parser-package (grammarfile &key (dst-package (make-package (gensym "opossum-parser-")))
 515                                 start-rule (parse-file-fun #'opossum:parse-file))
 516   "Create functions to parse using GRAMMARFILE in DST-PACKAGE, starting ar rule named HEAD.
 517 DST-PACKAGE will contain the 3 functions PARSE-STRING, PARSE-FILE and PARSE-STREAM as exported entrypoints."
 518   (let* ((*package* dst-package)
 519          (result (checking-parse grammarfile parse-file-fun))
 520          ;; FIXME: check for complete parse
 521          (*context* result)) ;; routines in pegutils.lisp expect *context* to be bound properly)
 522     (let ((forms (transform (value result)))
 523           (actions (actions result)))
 524       (format *trace-output* "Injecting parser functions into ~A~%" dst-package)
 525       (break "~A, ~A" forms actions)
 526       (use-package '(:cl :opossum) dst-package)
 527       (let ((entryrule (or (and start-rule (make-name start-rule))
 528                            (and forms (cadr (first forms))))))
 529         (if (not entryrule)
 530             (format *error-output* "Cannot find entry rule for parser")
 531             (progn
 532               (when *trace*
 533                 (format *trace-output* "Inserting definitions for parser entry points through ~A~%"
 534                         entryrule))
 535               (intern (compile 'parse-string
 536                                `(lambda (,(intern :s dst-package))
 537                                  ,(format nil "Parse S using grammar ~A starting at ~A" grammarfile entryrule)
 538                                  (let ((*context* (make-instance 'opossum:context
 539                                                                  :dst-package ,dst-package
 540                                                                  :input ,(intern :s dst-package))))
 541                                    (funcall (,entryrule) 0))))
 542                       dst-package)
 543               (intern (compile 'parse-file
 544                                `(lambda (,(intern :f dst-package))
 545                                  ,(format nil "Parse file F using grammar ~A starting at ~A" grammarfile entryrule)
 546                                  (parse-string (opossum:read-file ,(intern :f dst-package)))))
 547                       dst-package)
 548
 549               (intern (compile 'parse-stream
 550                                `(lambda (,(intern :stream dst-package))
 551                                  ,(format nil "Parse stream F using grammar ~A starting at ~A" grammarfile entryrule)
 552                                  (parse-string (opossum:read-stream ,(intern :stream dst-package)))))
 553                       dst-package))))
 554       (intern '*trace* dst-package)
 555       (setf (documentation '*trace* 'cl:variable)
 556             "When non-nil, the generated parser function log to cl:*trace-output*.")
 557       (export '(:parse-string :parse-file :parse-stream :*trace*) dst-package)
 558
 559       (loop :for aform :in forms
 560             :do (when *trace*
 561                   (format *trace-output* "Injecting form ~A~%" aform))
 562             :do (destructuring-bind (defun-sym name args &rest body)
 563                     aform
 564                   (declare (ignore defun-sym))
 565                   (intern (compile name `(lambda ,args ,@body)) dst-package)))
 566       (loop :for (sym code) :in actions
 567             :when sym
 568             :do (when *trace* (format *trace-output* "Injecting definition for ~A~%" sym))
 569             :and :do (intern (compile sym `(lambda (data) (declare (ignorable data)) ,code)) dst-package)))))
 570
 571
 572
 573 (defun transform (tree &optional (depth 0))
 574   (if (and tree
 575            (consp tree))
 576       (if (eq (first tree) ':action)
 577           (progn
 578             (when *trace*
 579               (format *trace-output* "~AFound action ~A~%"  (make-string depth :initial-element #\Space) tree))
 580             tree)
 581           (let ((data (mapcar #'(lambda (tr) (transform tr (1+ depth)))
 582                               tree)))
 583             (loop :for el :in data
 584                   :when (and (listp el)
 585                              (eq (first el) ':action)
 586                              (symbolp (third el)))
 587                   :do (let ((*package* (dst-package *context*))
 588                             (action (third el)))
 589                         (when *trace*
 590                           (format *trace-output* "~&Applying action ~A to ~A~%" action data))
 591                         (handler-case
 592                             (return-from transform
 593                               (funcall (symbol-function action) data))
 594                           (undefined-function (x)
 595                             (progn
 596                               (format *error-output* "missing definition for ~A: ~A~%" action x)
 597                               ;                       (break "~A in ~A" action *package*)
 598                                     tree)))))
 599             data))
 600       tree))