From ctian at common-lisp.net Tue Oct 16 19:53:59 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Tue, 16 Oct 2007 15:53:59 -0400 (EDT) Subject: [cl-net-snmp-cvs] r67 - in trunk: . mib smi snmp Message-ID: <20071016195359.11BE570D4@common-lisp.net> Author: ctian Date: Tue Oct 16 15:53:58 2007 New Revision: 67 Added: trunk/fli-templates.lisp Modified: trunk/deliver.lisp trunk/mib/build.lisp trunk/smi/message.lisp trunk/smi/pdu.lisp trunk/snmp/package.lisp trunk/snmp/session.lisp trunk/snmp/snmp-get.lisp trunk/snmp/snmp-walk.lisp Log: SNMP Walk fixed Modified: trunk/deliver.lisp ============================================================================== --- trunk/deliver.lisp (original) +++ trunk/deliver.lisp Tue Oct 16 15:53:58 2007 @@ -4,14 +4,14 @@ ;;; Where we are going to deliver the image. -(defvar *delivered-image-name* "mbrowse") +(defvar *delivered-image-name* "~/mbrowse") ;;; Load the "application". (clc:clc-require :net-snmp) -(mib:build-mib-tree) +(mib:build-tree) ;; Deliver. -(deliver 'mib:browser *delivered-image-name* 5 :interface :capi) +(deliver 'mib:browser *delivered-image-name* 0 :interface :capi) Added: trunk/fli-templates.lisp ============================================================================== Modified: trunk/mib/build.lisp ============================================================================== --- trunk/mib/build.lisp (original) +++ trunk/mib/build.lisp Tue Oct 16 15:53:58 2007 @@ -114,3 +114,6 @@ (format t "Parsing ~A" i) (read-mib (mib-pathname i)) (format t ".~%"))) + +(eval-when (:load-toplevel :execute) + (build-tree)) Modified: trunk/smi/message.lisp ============================================================================== --- trunk/smi/message.lisp (original) +++ trunk/smi/message.lisp Tue Oct 16 15:53:58 2007 @@ -8,7 +8,7 @@ :initarg :community :reader message-comminity) (data :initarg :data - :reader message-data))) + :accessor message-data))) (defmethod ber-encode ((value message)) (with-slots (version community data) value Modified: trunk/smi/pdu.lisp ============================================================================== --- trunk/smi/pdu.lisp (original) +++ trunk/smi/pdu.lisp Tue Oct 16 15:53:58 2007 @@ -2,11 +2,11 @@ (defclass base-pdu () ((request-id :type (unsigned-byte 32) - :reader request-id + :accessor request-id :initform 0 :initarg :request-id) (variable-bindings :type list - :reader variable-bindings + :accessor variable-bindings :initform nil :initarg :variable-bindings))) Modified: trunk/snmp/package.lisp ============================================================================== --- trunk/snmp/package.lisp (original) +++ trunk/snmp/package.lisp Tue Oct 16 15:53:58 2007 @@ -3,7 +3,8 @@ (defpackage :com.netease.snmp (:nicknames snmp) (:use :common-lisp :smi :asn.1 :mib #-win32 :net.sockets #-win32 :io.streams) - (:export v1-session v2c-session v3-session + (:export v1-session v2c-session v3-session make-session + *default-version* *default-community* *default-port* snmp-get snmp-walk)) (in-package :snmp) Modified: trunk/snmp/session.lisp ============================================================================== --- trunk/snmp/session.lisp (original) +++ trunk/snmp/session.lisp Tue Oct 16 15:53:58 2007 @@ -1,5 +1,10 @@ (in-package :snmp) +(defvar *default-version* +snmp-version-1+) +(defvar *default-port* 161) +(defvar *default-community* "public") +(defvar *default-class* 'v1-session) + #-win32 (defclass session () ((socket :reader socket @@ -8,20 +13,20 @@ (version :reader version :initarg :version :type integer - :initform +snmp-version-1+))) + :initform *default-version*))) #+win32 (defclass session () ((version :reader version :initarg :version :type integer - :initform +snmp-version-1+))) + :initform *default-version*))) (defclass v1-session (session) ((community :reader community :initarg :community :type string - :initform "public")) + :initform *default-community*)) (:documentation "SNMP v1 session, community based")) (defmethod initialize-instance :after ((instance v1-session) @@ -57,3 +62,13 @@ &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (setf (slot-value instance 'version) +snmp-version-3+)) + +(defun make-session (host &key (class *default-class*) + (port *default-port*) + (community *default-community*)) + (let ((socket (make-socket :remote-host host + :remote-port port + :type :datagram + :ipv6 nil))) + (set-socket-option socket :receive-timeout :timeval '(1 0)) + (make-instance class :socket socket :community community))) Modified: trunk/snmp/snmp-get.lisp ============================================================================== --- trunk/snmp/snmp-get.lisp (original) +++ trunk/snmp/snmp-get.lisp Tue Oct 16 15:53:58 2007 @@ -4,15 +4,7 @@ (:documentation "SNMP Get")) (defmethod snmp-get ((host string) &rest vars) - (let ((socket (make-socket :remote-host host - :remote-port 161 - :type :datagram - :ipv6 nil))) - (let ((session (make-instance 'v2c-session - :socket socket - :community "public"))) - (values (apply #'snmp-get session vars) - session)))) + (apply #'snmp-get (make-session host) vars)) #-win32 (defmethod snmp-get ((session v1-session) &rest vars) Modified: trunk/snmp/snmp-walk.lisp ============================================================================== --- trunk/snmp/snmp-walk.lisp (original) +++ trunk/snmp/snmp-walk.lisp Tue Oct 16 15:53:58 2007 @@ -3,48 +3,21 @@ (defgeneric snmp-walk (object var) (:documentation "SNMP Walk")) -#-win32 (defmethod snmp-walk ((host string) var) - (let ((socket (make-socket :remote-host host - :remote-port 161 - :type :datagram - :ipv6 nil))) - (let ((session (make-instance 'v1-session - :socket socket - :community "public"))) - (values (snmp-walk session var) session)))) + (apply #'snmp-walk (make-session host) var)) #-win32 (defmethod snmp-walk ((session v1-session) (var object-id)) - (labels ((iter (acc) - (let ((message (make-instance 'message - :version (version session) - :community (community session) - :data (make-instance 'get-next-request-pdu - :request-id 0 - :variable-bindings (list (list var nil)))))) - (let ((data (ber-encode message))) - (socket-send (make-array (length data) - :element-type '(unsigned-byte 8) - :adjustable nil - :initial-contents data - #+lispworks :allocation #+lispworks :static) - (socket session)) - (let ((result (decode-message (socket session)))) - (if (= (error-status (message-data result)) +snmp-err-nosuchname+) - (nreverse acc) - (iter (cons (car (variable-bindings (message-data result))) acc)))))))) - (iter nil))) - -#-win32 -(defmethod snmp-walk ((session v2c-session) (var object-id)) - (labels ((iter (acc) - (let ((message (make-instance 'message - :version (version session) - :community (community session) - :data (make-instance 'get-next-request-pdu - :request-id 0 - :variable-bindings (list (list var nil)))))) + "SNMP Walk for v1 and v2c" + (let ((message (make-instance 'message + :version (version session) + :community (community session) + :data (make-instance 'get-next-request-pdu + :request-id 0 + :variable-bindings (list nil))))) + (labels ((iter (v id acc) + (setf (car (variable-bindings (message-data message))) (list v nil) + (request-id (message-data message)) id) (let ((data (ber-encode message))) (socket-send (make-array (length data) :element-type '(unsigned-byte 8) @@ -54,10 +27,10 @@ (socket session)) (let ((result (decode-message (socket session)))) (let ((vb (car (variable-bindings (message-data result))))) - (if (null (second vb)) - (nreverse acc) - (iter (cons vb acc))))))))) - (iter nil))) + (if (not (oid-< (car vb) var)) + (nreverse acc) + (iter (first vb) (1+ id) (cons vb acc)))))))) + (iter var 0 nil)))) (defmethod snmp-walk ((session v1-session) (var string)) (let ((oid (resolve var))) From ctian at common-lisp.net Tue Oct 16 19:58:56 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Tue, 16 Oct 2007 15:58:56 -0400 (EDT) Subject: [cl-net-snmp-cvs] r68 - trunk/snmp Message-ID: <20071016195856.A42AC1B045@common-lisp.net> Author: ctian Date: Tue Oct 16 15:58:56 2007 New Revision: 68 Modified: trunk/snmp/snmp-walk.lisp Log: Fix trivial snmp-walk string bug Modified: trunk/snmp/snmp-walk.lisp ============================================================================== --- trunk/snmp/snmp-walk.lisp (original) +++ trunk/snmp/snmp-walk.lisp Tue Oct 16 15:58:56 2007 @@ -4,7 +4,7 @@ (:documentation "SNMP Walk")) (defmethod snmp-walk ((host string) var) - (apply #'snmp-walk (make-session host) var)) + (snmp-walk (make-session host) var)) #-win32 (defmethod snmp-walk ((session v1-session) (var object-id)) From ctian at common-lisp.net Wed Oct 17 06:22:07 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 02:22:07 -0400 (EDT) Subject: [cl-net-snmp-cvs] r69 - in trunk: . asn.1 mib smi snmp Message-ID: <20071017062207.D078D49115@common-lisp.net> Author: ctian Date: Wed Oct 17 02:22:06 2007 New Revision: 69 Added: trunk/smi/counter.lisp trunk/smi/gauge.lisp trunk/smi/opaque.lisp Modified: trunk/asn.1/package.lisp trunk/asn.1/syntax.lisp trunk/deliver.lisp trunk/mib/package.lisp trunk/net-snmp.asd trunk/smi/integer.lisp trunk/smi/package.lisp trunk/snmp/package.lisp Log: Add support for counter, gauge, opaque(float) type Modified: trunk/asn.1/package.lisp ============================================================================== --- trunk/asn.1/package.lisp (original) +++ trunk/asn.1/package.lisp Wed Oct 17 02:22:06 2007 @@ -32,3 +32,5 @@ Object-Identifier-Value-value)) (in-package :asn.1) + +(defparameter *version* 1) Modified: trunk/asn.1/syntax.lisp ============================================================================== --- trunk/asn.1/syntax.lisp (original) +++ trunk/asn.1/syntax.lisp Wed Oct 17 02:22:06 2007 @@ -12,9 +12,9 @@ :directory '(:relative "asn.1")) (asdf:component-pathname (asdf:find-system :net-snmp)))) -(defun generate-print-function (ITEM STREAM LEVEL) - (DECLARE (IGNORE LEVEL)) - (FORMAT STREAM "")) +(defun generate-print-function (item stream level) + (declare (ignore item level)) + (format stream "")) (eval-when (:load-toplevel :execute) (zebu-load-file *asn.1-syntax*)) Modified: trunk/deliver.lisp ============================================================================== --- trunk/deliver.lisp (original) +++ trunk/deliver.lisp Wed Oct 17 02:22:06 2007 @@ -10,8 +10,6 @@ (clc:clc-require :net-snmp) -(mib:build-tree) - ;; Deliver. (deliver 'mib:browser *delivered-image-name* 0 :interface :capi) Modified: trunk/mib/package.lisp ============================================================================== --- trunk/mib/package.lisp (original) +++ trunk/mib/package.lisp Wed Oct 17 02:22:06 2007 @@ -12,3 +12,5 @@ #+lispworks browser)) (in-package :mib) + +(defparameter *version* 1) Modified: trunk/net-snmp.asd ============================================================================== --- trunk/net-snmp.asd (original) +++ trunk/net-snmp.asd Wed Oct 17 02:22:06 2007 @@ -36,7 +36,10 @@ (:file "timeticks" :depends-on ("package")) (:file "pdu" :depends-on ("package")) (:file "bulk-pdu" :depends-on ("pdu")) - (:file "message" :depends-on ("package"))) + (:file "message" :depends-on ("package")) + (:file "opaque" :depends-on ("integer")) + (:file "counter" :depends-on ("integer")) + (:file "gauge" :depends-on ("integer"))) :depends-on (asn.1)) ;; MIB (:module mib Added: trunk/smi/counter.lisp ============================================================================== --- (empty file) +++ trunk/smi/counter.lisp Wed Oct 17 02:22:06 2007 @@ -0,0 +1,31 @@ +(in-package :smi) + +(defclass counter (general-type) ()) + +(defclass counter32 (counter) ()) + +(defun counter (v) + (make-instance 'counter :value v)) + +(defun counter32 (v) + (make-instance 'counter32 :value v)) + +(defmethod print-object ((obj counter) stream) + (print-unreadable-object (obj stream :type t) + (format stream "~A" (value-of obj)))) + +(defmethod ber-encode ((value counter)) + (assert (<= 0 value 4294967295)) + (multiple-value-bind (v l) (ber-encode-integer value) + (nconc (ber-encode-type 1 0 1) + (ber-encode-length l) + v))) + +(defmethod ber-decode-value ((stream stream) (type (eql :counter)) length) + (declare (type stream stream) + (type fixnum length) + (ignore type)) + (make-instance 'counter :value (ber-decode-integer-value stream length))) + +(eval-when (:load-toplevel :execute) + (install-asn.1-type :counter 1 0 1)) Added: trunk/smi/gauge.lisp ============================================================================== --- (empty file) +++ trunk/smi/gauge.lisp Wed Oct 17 02:22:06 2007 @@ -0,0 +1,32 @@ +(in-package :smi) + +(defclass gauge (general-type) ()) + +(defclass gauge32 (gauge) ()) + +(defun gauge (v) + (make-instance 'gauge :value v)) + +(defun gauge32 (v) + (make-instance 'gauge32 :value v)) + +(defmethod print-object ((obj gauge) stream) + (with-slots (value) obj + (print-unreadable-object (obj stream :type t) + (format stream "~A" value)))) + +(defmethod ber-encode ((value gauge)) + (assert (<= 0 value 4294967295)) + (multiple-value-bind (v l) (ber-encode-integer value) + (nconc (ber-encode-type 1 0 2) + (ber-encode-length l) + v))) + +(defmethod ber-decode-value ((stream stream) (type (eql :gauge)) length) + (declare (type stream stream) + (type fixnum length) + (ignore type)) + (make-instance 'gauge :value (ber-decode-integer-value stream length))) + +(eval-when (:load-toplevel :execute) + (install-asn.1-type :gauge 1 0 2)) Modified: trunk/smi/integer.lisp ============================================================================== --- trunk/smi/integer.lisp (original) +++ trunk/smi/integer.lisp Wed Oct 17 02:22:06 2007 @@ -1,26 +1,35 @@ (in-package :smi) -(defmethod ber-encode ((value integer)) - (assert (<= 0 value)) +(defun ber-encode-integer (value) + (declare (type integer value)) (labels ((iter (n acc l) (if (zerop n) (values acc l) (multiple-value-bind (q r) (floor n 256) (iter q (cons r acc) (1+ l)))))) - (multiple-value-bind (v l) (if (zerop value) - (values (list 0) 1) - (iter value nil 0)) - (nconc (ber-encode-type 0 0 2) - (ber-encode-length l) - v)))) + (if (zerop value) + (values (list 0) 1) + (iter value nil 0)))) -(defmethod ber-decode-value ((stream stream) (type (eql :integer)) length) +(defmethod ber-encode ((value integer)) + (assert (<= 0 value)) + (multiple-value-bind (v l) (ber-encode-integer value) + (nconc (ber-encode-type 0 0 2) + (ber-encode-length l) + v))) + +(defun ber-decode-integer-value (stream length) (declare (type stream stream) - (type fixnum length) - (ignore type)) + (type fixnum length)) (labels ((iter (i acc) (if (= i length) acc (iter (1+ i) (logior (ash acc 8) (read-byte stream)))))) (iter 0 0))) +(defmethod ber-decode-value ((stream stream) (type (eql :integer)) length) + (declare (type stream stream) + (type fixnum length) + (ignore type)) + (ber-decode-integer-value stream length)) + (eval-when (:load-toplevel :execute) (install-asn.1-type :integer 0 0 2)) Added: trunk/smi/opaque.lisp ============================================================================== --- (empty file) +++ trunk/smi/opaque.lisp Wed Oct 17 02:22:06 2007 @@ -0,0 +1,68 @@ +(in-package :smi) + +(defclass opaque (general-type) ()) + +(defun opaque (v) + (make-instance 'opaque :value v)) + +(defmethod print-object ((obj opaque) stream) + (with-slots (value) obj + (print-unreadable-object (obj stream :type t) + (format stream "~A: ~A" + (type-of value) value)))) + +(defgeneric opaque-length (instance)) + +(defmethod opaque-length ((o opaque)) + (opaque-length (value-of o))) + +(defmethod opaque-length ((f single-float)) + (the fixnum 7)) + +(defmethod encode-opaque ((o single-float)) + (nconc (list #x9f #x78 #x04) + (let ((f (cffi:foreign-alloc :float :initial-element o))) + (unwind-protect + (list (cffi:mem-aref f :uint8 3) + (cffi:mem-aref f :uint8 2) + (cffi:mem-aref f :uint8 1) + (cffi:mem-aref f :uint8 0)) + (cffi:foreign-free f))))) + +(defmethod ber-encode ((value opaque)) + (nconc (ber-encode-type 1 0 4) + (ber-encode-length (opaque-length value)) + (encode-opaque (value-of value)))) + +(defmethod ber-decode-value ((stream stream) (type (eql :opaque)) length) + (declare (type stream stream) + (type fixnum length) + (ignore type)) + (assert (= 7 length)) + (let ((b-1 (read-byte stream)) + (b-2 (read-byte stream)) + (b-3 (read-byte stream))) + (if (= b-3 4) + (ber-decode-value stream :float 4) + (make-instance 'opaque :value nil)))) + +(defmethod ber-decode-value ((stream stream) (type (eql :float)) length) + (let ((f-0 (read-byte stream)) + (f-1 (read-byte stream)) + (f-2 (read-byte stream)) + (f-3 (read-byte stream))) + (let ((f (cffi:foreign-alloc :float :initial-element 0.0))) + (unwind-protect + (progn + (setf (cffi:mem-aref f :uint8 3) f-0 + (cffi:mem-aref f :uint8 2) f-1 + (cffi:mem-aref f :uint8 1) f-2 + (cffi:mem-aref f :uint8 0) f-3) + (make-instance 'opaque :value (cffi:mem-ref f :float))) + (cffi:foreign-free f))))) + +(defmethod ber-encode ((value single-float)) + (ber-encode (make-instance 'opaque :value value))) + +(eval-when (:load-toplevel :execute) + (install-asn.1-type :opaque 1 0 4)) Modified: trunk/smi/package.lisp ============================================================================== --- trunk/smi/package.lisp (original) +++ trunk/smi/package.lisp Wed Oct 17 02:22:06 2007 @@ -23,6 +23,14 @@ message-data request-id ;; timeticks - timeticks ticks hours minutes seconds s/100)) + timeticks ticks hours minutes seconds s/100 + ;; other + opaque gauge counter value-of)) (in-package :smi) + +;;; used by counter, gauge and opaque +(defclass general-type () + ((value :accessor value-of :initarg :value))) + +(defparameter *version* 2) Modified: trunk/snmp/package.lisp ============================================================================== --- trunk/snmp/package.lisp (original) +++ trunk/snmp/package.lisp Wed Oct 17 02:22:06 2007 @@ -8,3 +8,5 @@ snmp-get snmp-walk)) (in-package :snmp) + +(defparameter *version* 1) From ctian at common-lisp.net Wed Oct 17 10:09:31 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 06:09:31 -0400 (EDT) Subject: [cl-net-snmp-cvs] r70 - in trunk: . debian smi Message-ID: <20071017100931.6D06F7437C@common-lisp.net> Author: ctian Date: Wed Oct 17 06:09:30 2007 New Revision: 70 Added: trunk/LICENSE trunk/README trunk/smi/ipaddress.lisp - copied unchanged from r61, trunk/smi/ipaddr.lisp Removed: trunk/smi/ipaddr.lisp Modified: trunk/debian/changelog trunk/debian/docs trunk/net-snmp.asd trunk/smi/counter.lisp trunk/smi/gauge.lisp trunk/smi/package.lisp Log: Add license note. Added: trunk/LICENSE ============================================================================== --- (empty file) +++ trunk/LICENSE Wed Oct 17 06:09:30 2007 @@ -0,0 +1,21 @@ +Copyright (c) 2007, Chun Tian (binghe) + +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * Neither the name of the NetEase.com, Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: trunk/README ============================================================================== --- (empty file) +++ trunk/README Wed Oct 17 06:09:30 2007 @@ -0,0 +1 @@ +^_^ Modified: trunk/debian/changelog ============================================================================== --- trunk/debian/changelog (original) +++ trunk/debian/changelog Wed Oct 17 06:09:30 2007 @@ -1,3 +1,10 @@ +cl-net-snmp (1.1) unstable; urgency=low + + * [fix] snmp-walk + * [new] counter, gauge, opaque + + -- Chun Tian (binghe) Wed, 17 Oct 2007 18:06:37 +0800 + cl-net-snmp (0.6) unstable; urgency=low * Initial release. Modified: trunk/debian/docs ============================================================================== --- trunk/debian/docs (original) +++ trunk/debian/docs Wed Oct 17 06:09:30 2007 @@ -1,3 +1,3 @@ README -copyright +LICENSE Modified: trunk/net-snmp.asd ============================================================================== --- trunk/net-snmp.asd (original) +++ trunk/net-snmp.asd Wed Oct 17 06:09:30 2007 @@ -11,7 +11,7 @@ (defsystem net-snmp :description "Simple Network Manangement Protocol" - :version "1.0" + :version "1.1" :author "Chun Tian (binghe) " :depends-on (:cl-fad ; for directory and file :cl-ppcre ; for oid resolve @@ -31,7 +31,7 @@ (:file "integer" :depends-on ("package")) (:file "string" :depends-on ("package")) (:file "sequence" :depends-on ("package")) - (:file "ipaddr" :depends-on ("package")) + (:file "ipaddress" :depends-on ("package")) (:file "oid" :depends-on ("package")) (:file "timeticks" :depends-on ("package")) (:file "pdu" :depends-on ("package")) Modified: trunk/smi/counter.lisp ============================================================================== --- trunk/smi/counter.lisp (original) +++ trunk/smi/counter.lisp Wed Oct 17 06:09:30 2007 @@ -1,31 +1,45 @@ (in-package :smi) (defclass counter (general-type) ()) - (defclass counter32 (counter) ()) +(defclass counter64 (counter) ()) (defun counter (v) - (make-instance 'counter :value v)) + (make-instance 'counter32 :value v)) (defun counter32 (v) (make-instance 'counter32 :value v)) -(defmethod print-object ((obj counter) stream) - (print-unreadable-object (obj stream :type t) - (format stream "~A" (value-of obj)))) +(defun counter64 (v) + (make-instance 'counter64 :value v)) -(defmethod ber-encode ((value counter)) +(defmethod ber-encode ((value counter32)) (assert (<= 0 value 4294967295)) (multiple-value-bind (v l) (ber-encode-integer value) (nconc (ber-encode-type 1 0 1) (ber-encode-length l) v))) -(defmethod ber-decode-value ((stream stream) (type (eql :counter)) length) +(defmethod ber-encode ((value counter64)) + (assert (<= 0 value)) + (multiple-value-bind (v l) (ber-encode-integer value) + (nconc (ber-encode-type 1 0 6) + (ber-encode-length l) + v))) + +(defmethod ber-decode-value ((stream stream) (type (eql :counter32)) length) (declare (type stream stream) (type fixnum length) (ignore type)) - (make-instance 'counter :value (ber-decode-integer-value stream length))) + (make-instance 'counter32 :value (ber-decode-integer-value stream length))) + +(defmethod ber-decode-value ((stream stream) (type (eql :counter64)) length) + (declare (type stream stream) + (type fixnum length) + (ignore type)) + (make-instance 'counter64 :value (ber-decode-integer-value stream length))) (eval-when (:load-toplevel :execute) - (install-asn.1-type :counter 1 0 1)) + (install-asn.1-type :counter32 1 0 1) + (install-asn.1-type :counter64 1 0 6)) + Modified: trunk/smi/gauge.lisp ============================================================================== --- trunk/smi/gauge.lisp (original) +++ trunk/smi/gauge.lisp Wed Oct 17 06:09:30 2007 @@ -2,21 +2,10 @@ (defclass gauge (general-type) ()) -(defclass gauge32 (gauge) ()) - (defun gauge (v) (make-instance 'gauge :value v)) -(defun gauge32 (v) - (make-instance 'gauge32 :value v)) - -(defmethod print-object ((obj gauge) stream) - (with-slots (value) obj - (print-unreadable-object (obj stream :type t) - (format stream "~A" value)))) - (defmethod ber-encode ((value gauge)) - (assert (<= 0 value 4294967295)) (multiple-value-bind (v l) (ber-encode-integer value) (nconc (ber-encode-type 1 0 2) (ber-encode-length l) Modified: trunk/smi/package.lisp ============================================================================== --- trunk/smi/package.lisp (original) +++ trunk/smi/package.lisp Wed Oct 17 06:09:30 2007 @@ -3,7 +3,9 @@ (defpackage com.netease.smi (:nicknames smi) (:use :common-lisp :asn.1 #-(and lispworks win32) :net.sockets) - (:export ;; object-id + (:export ;; general + value-of general-type + ;; object-id object-id oid make-object-id rev-ids rev-names oid-< ;; pdu @@ -25,7 +27,7 @@ ;; timeticks timeticks ticks hours minutes seconds s/100 ;; other - opaque gauge counter value-of)) + opaque gauge counter counter32 counter64)) (in-package :smi) @@ -33,4 +35,8 @@ (defclass general-type () ((value :accessor value-of :initarg :value))) +(defmethod print-object ((obj general-type) stream) + (print-unreadable-object (obj stream :type t) + (format stream "~A" (value-of obj)))) + (defparameter *version* 2) From ctian at common-lisp.net Wed Oct 17 12:25:00 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 08:25:00 -0400 (EDT) Subject: [cl-net-snmp-cvs] r71 - in trunk: smi snmp Message-ID: <20071017122500.B3D386A032@common-lisp.net> Author: ctian Date: Wed Oct 17 08:25:00 2007 New Revision: 71 Modified: trunk/smi/opaque.lisp trunk/snmp/session.lisp trunk/snmp/snmp-get.lisp trunk/snmp/snmp-walk.lisp Log: fix sbcl run and (set-socket-option s :receive-timeout :sec 1 :usec 0) is correct. Modified: trunk/smi/opaque.lisp ============================================================================== --- trunk/smi/opaque.lisp (original) +++ trunk/smi/opaque.lisp Wed Oct 17 08:25:00 2007 @@ -42,6 +42,7 @@ (let ((b-1 (read-byte stream)) (b-2 (read-byte stream)) (b-3 (read-byte stream))) + (declare (ignore b-1 b-2)) (if (= b-3 4) (ber-decode-value stream :float 4) (make-instance 'opaque :value nil)))) Modified: trunk/snmp/session.lisp ============================================================================== --- trunk/snmp/session.lisp (original) +++ trunk/snmp/session.lisp Wed Oct 17 08:25:00 2007 @@ -7,23 +7,23 @@ #-win32 (defclass session () - ((socket :reader socket + ((socket :reader socket-of :initarg :socket :type socket) - (version :reader version + (version :reader version-of :initarg :version :type integer :initform *default-version*))) #+win32 (defclass session () - ((version :reader version + ((version :reader version-of :initarg :version :type integer :initform *default-version*))) (defclass v1-session (session) - ((community :reader community + ((community :reader community-of :initarg :community :type string :initform *default-community*)) @@ -66,9 +66,9 @@ (defun make-session (host &key (class *default-class*) (port *default-port*) (community *default-community*)) - (let ((socket (make-socket :remote-host host + (let ((s (make-socket :remote-host host :remote-port port :type :datagram :ipv6 nil))) - (set-socket-option socket :receive-timeout :timeval '(1 0)) - (make-instance class :socket socket :community community))) + (set-socket-option s :receive-timeout :sec 1 :usec 0) + (make-instance class :socket s :community community))) Modified: trunk/snmp/snmp-get.lisp ============================================================================== --- trunk/snmp/snmp-get.lisp (original) +++ trunk/snmp/snmp-get.lisp Wed Oct 17 08:25:00 2007 @@ -4,7 +4,10 @@ (:documentation "SNMP Get")) (defmethod snmp-get ((host string) &rest vars) - (apply #'snmp-get (make-session host) vars)) + (let ((session (make-session host))) + (unwind-protect + (apply #'snmp-get session vars) + (close (socket-of session))))) #-win32 (defmethod snmp-get ((session v1-session) &rest vars) @@ -12,19 +15,20 @@ (object-id x) (string (resolve x))) nil)) vars))) (let ((message (make-instance 'message - :version (version session) - :community (community session) + :version (version-of session) + :community (community-of session) :data (make-instance 'get-request-pdu :request-id 0 :variable-bindings vb)))) - (let ((data (ber-encode message))) + (let ((data (ber-encode message)) + (socket (socket-of session))) (socket-send (make-array (length data) :element-type '(unsigned-byte 8) :adjustable nil :initial-contents data #+lispworks :allocation #+lispworks :static) - (socket session)) - (let ((message (decode-message (socket session)))) + socket) + (let ((message (decode-message socket))) (mapcar #'second (variable-bindings (message-data message)))))))) Modified: trunk/snmp/snmp-walk.lisp ============================================================================== --- trunk/snmp/snmp-walk.lisp (original) +++ trunk/snmp/snmp-walk.lisp Wed Oct 17 08:25:00 2007 @@ -4,28 +4,32 @@ (:documentation "SNMP Walk")) (defmethod snmp-walk ((host string) var) - (snmp-walk (make-session host) var)) + (let ((session (make-session host))) + (unwind-protect + (snmp-walk (make-session host) var) + (close (socket-of session))))) #-win32 (defmethod snmp-walk ((session v1-session) (var object-id)) "SNMP Walk for v1 and v2c" (let ((message (make-instance 'message - :version (version session) - :community (community session) + :version (version-of session) + :community (community-of session) :data (make-instance 'get-next-request-pdu :request-id 0 :variable-bindings (list nil))))) (labels ((iter (v id acc) (setf (car (variable-bindings (message-data message))) (list v nil) (request-id (message-data message)) id) - (let ((data (ber-encode message))) + (let ((data (ber-encode message)) + (socket (socket-of session))) (socket-send (make-array (length data) :element-type '(unsigned-byte 8) :adjustable nil :initial-contents data #+lispworks :allocation #+lispworks :static) - (socket session)) - (let ((result (decode-message (socket session)))) + socket) + (let ((result (decode-message socket))) (let ((vb (car (variable-bindings (message-data result))))) (if (not (oid-< (car vb) var)) (nreverse acc) From ctian at common-lisp.net Wed Oct 17 12:46:55 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 08:46:55 -0400 (EDT) Subject: [cl-net-snmp-cvs] r72 - in trunk: asn.1 smi snmp Message-ID: <20071017124655.5E9D674016@common-lisp.net> Author: ctian Date: Wed Oct 17 08:46:55 2007 New Revision: 72 Modified: trunk/asn.1/asn.1-domain.lisp trunk/asn.1/asn.1.tab trunk/smi/counter.lisp trunk/smi/integer.lisp trunk/smi/null.lisp trunk/smi/oid.lisp trunk/smi/package.lisp trunk/smi/sequence.lisp trunk/smi/string.lisp trunk/smi/timeticks.lisp trunk/snmp/session.lisp Log: Add a plain-value function, and update syntax Modified: trunk/asn.1/asn.1-domain.lisp ============================================================================== --- trunk/asn.1/asn.1-domain.lisp (original) +++ trunk/asn.1/asn.1-domain.lisp Wed Oct 17 08:46:55 2007 @@ -138,57 +138,57 @@ IDENTIFIER BODY) -(DEFUN ASSIGNMENT*5 (ASSIGNMENT ASSIGNMENT*) +(DEFUN ASSIGNMENT*0 (ASSIGNMENT ASSIGNMENT*) (MAKE-KB-SEQUENCE :FIRST ASSIGNMENT :REST ASSIGNMENT*)) -(DEFUN SYMBOL*\,1$6 (SYMBOL |Rest-SYMBOL*,1$|) +(DEFUN SYMBOL*\,1$1 (SYMBOL |Rest-SYMBOL*,1$|) (MAKE-KB-SEQUENCE :FIRST SYMBOL :REST |Rest-SYMBOL*,1$|)) -(DEFUN |Rest-SYMBOL*,1$7| (DUMMY SYMBOL |Rest-SYMBOL*,1$|) +(DEFUN |Rest-SYMBOL*,1$2| (DUMMY SYMBOL |Rest-SYMBOL*,1$|) (DECLARE (IGNORE DUMMY)) (MAKE-KB-SEQUENCE :FIRST SYMBOL :REST |Rest-SYMBOL*,1$|)) -(DEFUN SYMBOLS-FROM-MODULE*8 (SYMBOLS-FROM-MODULE SYMBOLS-FROM-MODULE*) +(DEFUN SYMBOLS-FROM-MODULE*3 (SYMBOLS-FROM-MODULE SYMBOLS-FROM-MODULE*) (MAKE-KB-SEQUENCE :FIRST SYMBOLS-FROM-MODULE :REST SYMBOLS-FROM-MODULE*)) -(DEFUN SYMBOL+\,1$9 (SYMBOL) (MAKE-KB-SEQUENCE :FIRST SYMBOL)) +(DEFUN SYMBOL+\,1$4 (SYMBOL) (MAKE-KB-SEQUENCE :FIRST SYMBOL)) -(DEFUN SYMBOL+\,1$10 (SYMBOL DUMMY SYMBOL+\,1$) +(DEFUN SYMBOL+\,1$5 (SYMBOL DUMMY SYMBOL+\,1$) (DECLARE (IGNORE DUMMY)) (MAKE-KB-SEQUENCE :FIRST SYMBOL :REST SYMBOL+\,1$)) -(DEFUN GARBAGE+11 (GARBAGE) (MAKE-KB-SEQUENCE :FIRST GARBAGE)) +(DEFUN GARBAGE+6 (GARBAGE) (MAKE-KB-SEQUENCE :FIRST GARBAGE)) -(DEFUN GARBAGE+12 (GARBAGE GARBAGE+) +(DEFUN GARBAGE+7 (GARBAGE GARBAGE+) (MAKE-KB-SEQUENCE :FIRST GARBAGE :REST GARBAGE+)) -(DEFUN MODULE-REVISION*13 (MODULE-REVISION MODULE-REVISION*) +(DEFUN MODULE-REVISION*8 (MODULE-REVISION MODULE-REVISION*) (MAKE-KB-SEQUENCE :FIRST MODULE-REVISION :REST MODULE-REVISION*)) -(DEFUN IDENTIFIER+\,1$14 (IDENTIFIER) +(DEFUN IDENTIFIER+\,1$9 (IDENTIFIER) (MAKE-KB-SEQUENCE :FIRST IDENTIFIER)) -(DEFUN IDENTIFIER+\,1$15 (IDENTIFIER DUMMY IDENTIFIER+\,1$) +(DEFUN IDENTIFIER+\,1$10 (IDENTIFIER DUMMY IDENTIFIER+\,1$) (DECLARE (IGNORE DUMMY)) (MAKE-KB-SEQUENCE :FIRST IDENTIFIER :REST IDENTIFIER+\,1$)) -(DEFUN MODULE-COMPLIANCE-BODY+16 (MODULE-COMPLIANCE-BODY) +(DEFUN MODULE-COMPLIANCE-BODY+11 (MODULE-COMPLIANCE-BODY) (MAKE-KB-SEQUENCE :FIRST MODULE-COMPLIANCE-BODY)) -(DEFUN MODULE-COMPLIANCE-BODY+17 +(DEFUN MODULE-COMPLIANCE-BODY+12 (MODULE-COMPLIANCE-BODY MODULE-COMPLIANCE-BODY+) (MAKE-KB-SEQUENCE :FIRST MODULE-COMPLIANCE-BODY :REST MODULE-COMPLIANCE-BODY+)) -(DEFUN OBJECT-TYPE-INDEX-VALUE+\,1$18 (OBJECT-TYPE-INDEX-VALUE) +(DEFUN OBJECT-TYPE-INDEX-VALUE+\,1$13 (OBJECT-TYPE-INDEX-VALUE) (MAKE-KB-SEQUENCE :FIRST OBJECT-TYPE-INDEX-VALUE)) -(DEFUN OBJECT-TYPE-INDEX-VALUE+\,1$19 +(DEFUN OBJECT-TYPE-INDEX-VALUE+\,1$14 (OBJECT-TYPE-INDEX-VALUE DUMMY OBJECT-TYPE-INDEX-VALUE+\,1$) (DECLARE (IGNORE DUMMY)) (MAKE-KB-SEQUENCE :FIRST @@ -196,63 +196,63 @@ :REST OBJECT-TYPE-INDEX-VALUE+\,1$)) -(DEFUN IDENTIFIER*\,1$20 (IDENTIFIER |Rest-IDENTIFIER*,1$|) +(DEFUN IDENTIFIER*\,1$15 (IDENTIFIER |Rest-IDENTIFIER*,1$|) (MAKE-KB-SEQUENCE :FIRST IDENTIFIER :REST |Rest-IDENTIFIER*,1$|)) -(DEFUN |Rest-IDENTIFIER*,1$21| (DUMMY IDENTIFIER |Rest-IDENTIFIER*,1$|) +(DEFUN |Rest-IDENTIFIER*,1$16| (DUMMY IDENTIFIER |Rest-IDENTIFIER*,1$|) (DECLARE (IGNORE DUMMY)) (MAKE-KB-SEQUENCE :FIRST IDENTIFIER :REST |Rest-IDENTIFIER*,1$|)) -(DEFUN MODULE-COMPLIANCE-ITEM*22 +(DEFUN MODULE-COMPLIANCE-ITEM*17 (MODULE-COMPLIANCE-ITEM MODULE-COMPLIANCE-ITEM*) (MAKE-KB-SEQUENCE :FIRST MODULE-COMPLIANCE-ITEM :REST MODULE-COMPLIANCE-ITEM*)) -(DEFUN OBJ-ID-COMPONENT+23 (OBJ-ID-COMPONENT) +(DEFUN OBJ-ID-COMPONENT+18 (OBJ-ID-COMPONENT) (MAKE-KB-SEQUENCE :FIRST OBJ-ID-COMPONENT)) -(DEFUN OBJ-ID-COMPONENT+24 (OBJ-ID-COMPONENT OBJ-ID-COMPONENT+) +(DEFUN OBJ-ID-COMPONENT+19 (OBJ-ID-COMPONENT OBJ-ID-COMPONENT+) (MAKE-KB-SEQUENCE :FIRST OBJ-ID-COMPONENT :REST OBJ-ID-COMPONENT+)) -(DEFUN NUMBERS+\|1$25 (NUMBERS) (MAKE-KB-SEQUENCE :FIRST NUMBERS)) +(DEFUN NUMBERS+\|1$20 (NUMBERS) (MAKE-KB-SEQUENCE :FIRST NUMBERS)) -(DEFUN NUMBERS+\|1$26 (NUMBERS DUMMY NUMBERS+\|1$) +(DEFUN NUMBERS+\|1$21 (NUMBERS DUMMY NUMBERS+\|1$) (DECLARE (IGNORE DUMMY)) (MAKE-KB-SEQUENCE :FIRST NUMBERS :REST NUMBERS+\|1$)) -(DEFUN SPLITED-NUMBERS+\|1$27 (SPLITED-NUMBERS) +(DEFUN SPLITED-NUMBERS+\|1$22 (SPLITED-NUMBERS) (MAKE-KB-SEQUENCE :FIRST SPLITED-NUMBERS)) -(DEFUN SPLITED-NUMBERS+\|1$28 +(DEFUN SPLITED-NUMBERS+\|1$23 (SPLITED-NUMBERS DUMMY SPLITED-NUMBERS+\|1$) (DECLARE (IGNORE DUMMY)) (MAKE-KB-SEQUENCE :FIRST SPLITED-NUMBERS :REST SPLITED-NUMBERS+\|1$)) -(DEFUN NAMED-NUMBER+\,1$29 (NAMED-NUMBER) +(DEFUN NAMED-NUMBER+\,1$24 (NAMED-NUMBER) (MAKE-KB-SEQUENCE :FIRST NAMED-NUMBER)) -(DEFUN NAMED-NUMBER+\,1$30 (NAMED-NUMBER DUMMY NAMED-NUMBER+\,1$) +(DEFUN NAMED-NUMBER+\,1$25 (NAMED-NUMBER DUMMY NAMED-NUMBER+\,1$) (DECLARE (IGNORE DUMMY)) (MAKE-KB-SEQUENCE :FIRST NAMED-NUMBER :REST NAMED-NUMBER+\,1$)) -(DEFUN GARBAGE*31 (GARBAGE GARBAGE*) +(DEFUN GARBAGE*26 (GARBAGE GARBAGE*) (MAKE-KB-SEQUENCE :FIRST GARBAGE :REST GARBAGE*)) -(DEFUN NAME-AND-NUMBER-FORM32 (IDENTIFIER DUMMY NUMBER-FORM DUMMY1) +(DEFUN NAME-AND-NUMBER-FORM27 (IDENTIFIER DUMMY NUMBER-FORM DUMMY1) (DECLARE (IGNORE DUMMY1 DUMMY)) (MAKE-OBJ-ID-COMPONENT :NAME IDENTIFIER :VALUE NUMBER-FORM)) -(DEFUN OBJECT-IDENTIFIER-VALUE33 (DUMMY OBJ-ID-COMPONENT+ DUMMY1) +(DEFUN OBJECT-IDENTIFIER-VALUE28 (DUMMY OBJ-ID-COMPONENT+ DUMMY1) (DECLARE (IGNORE DUMMY1 DUMMY)) (MAKE-OBJECT-IDENTIFIER-VALUE :VALUE OBJ-ID-COMPONENT+)) -(DEFUN VALUE-ASSIGNMENT34 (IDENTIFIER TYPE DUMMY VALUE) +(DEFUN VALUE-ASSIGNMENT29 (IDENTIFIER TYPE DUMMY VALUE) (DECLARE (IGNORE DUMMY)) (MAKE-VALUE-ASSIGNMENT :NAME IDENTIFIER :TYPE TYPE :VALUE VALUE)) -(DEFUN VALUE-ASSIGNMENT35 +(DEFUN VALUE-ASSIGNMENT30 (IDENTIFIER DUMMY DUMMY1 STATUS DUMMY2 DESCRIPTION OBJECT-IDENTITY-REFERENCE DUMMY3 OBJECT-IDENTIFIER-VALUE) (DECLARE (IGNORE DUMMY3 DUMMY2 DUMMY1 DUMMY)) @@ -263,7 +263,7 @@ :VALUE OBJECT-IDENTIFIER-VALUE)) -(DEFUN VALUE-ASSIGNMENT36 +(DEFUN VALUE-ASSIGNMENT31 (IDENTIFIER DUMMY DUMMY1 LAST-UPDATED DUMMY2 ORGANIZATION DUMMY3 CONTACT-INFO DUMMY4 DESCRIPTION MODULE-REVISION* DUMMY5 OBJECT-IDENTIFIER-VALUE) @@ -275,7 +275,7 @@ :VALUE OBJECT-IDENTIFIER-VALUE)) -(DEFUN VALUE-ASSIGNMENT45 +(DEFUN VALUE-ASSIGNMENT32 (IDENTIFIER DUMMY DUMMY1 TYPE OBJECT-TYPE-UNITS OBJECT-TYPE-ACCESS DUMMY2 STATUS DUMMY3 DESCRIPTION OBJECT-TYPE-INDEX OBJECT-TYPE-AUGMENTS OBJECT-TYPE-REFERENCE @@ -288,7 +288,7 @@ :VALUE OBJECT-IDENTIFIER-VALUE)) -(DEFUN VALUE-ASSIGNMENT46 +(DEFUN VALUE-ASSIGNMENT33 (IDENTIFIER DUMMY NOTIFICATION-TYPE-OBJECTS DUMMY1 STATUS DUMMY2 DESCRIPTION DUMMY3 OBJECT-IDENTIFIER-VALUE) (DECLARE (IGNORE DUMMY3 DUMMY2 DUMMY1 DUMMY)) @@ -299,7 +299,7 @@ :VALUE OBJECT-IDENTIFIER-VALUE)) -(DEFUN VALUE-ASSIGNMENT47 +(DEFUN VALUE-ASSIGNMENT37 (IDENTIFIER DUMMY DUMMY1 DUMMY2 IDENTIFIER+\,1$ DUMMY3 DUMMY4 STATUS DUMMY5 DESCRIPTION DUMMY6 OBJECT-IDENTIFIER-VALUE) (DECLARE (IGNORE DUMMY6 DUMMY5 DUMMY4 DUMMY3 DUMMY2 DUMMY1 DUMMY)) @@ -310,7 +310,7 @@ :VALUE OBJECT-IDENTIFIER-VALUE)) -(DEFUN VALUE-ASSIGNMENT48 +(DEFUN VALUE-ASSIGNMENT38 (IDENTIFIER DUMMY DUMMY1 STATUS DUMMY2 DESCRIPTION MODULE-COMPLIANCE-BODY+ DUMMY3 OBJECT-IDENTIFIER-VALUE) (DECLARE (IGNORE DUMMY3 DUMMY2 DUMMY1 DUMMY)) @@ -321,7 +321,7 @@ :VALUE OBJECT-IDENTIFIER-VALUE)) -(DEFUN VALUE-ASSIGNMENT49 +(DEFUN VALUE-ASSIGNMENT39 (IDENTIFIER DUMMY DUMMY1 DUMMY2 IDENTIFIER+\,1$ DUMMY3 DUMMY4 STATUS DUMMY5 DESCRIPTION DUMMY6 OBJECT-IDENTIFIER-VALUE) (DECLARE (IGNORE DUMMY6 DUMMY5 DUMMY4 DUMMY3 DUMMY2 DUMMY1 DUMMY)) @@ -332,13 +332,13 @@ :VALUE OBJECT-IDENTIFIER-VALUE)) -(DEFUN ASSIGNMENT50 (TYPE-ASSIGNMENT) +(DEFUN ASSIGNMENT40 (TYPE-ASSIGNMENT) (MAKE-ASSIGNMENT :TYPE :TYPE :VALUE TYPE-ASSIGNMENT)) -(DEFUN ASSIGNMENT51 (VALUE-ASSIGNMENT) +(DEFUN ASSIGNMENT41 (VALUE-ASSIGNMENT) (MAKE-ASSIGNMENT :TYPE :VALUE :VALUE VALUE-ASSIGNMENT)) -(DEFUN SYMBOLS-FROM-MODULE52 +(DEFUN SYMBOLS-FROM-MODULE42 (SYMBOL+\,1$ DUMMY GLOBAL-MODULE-REFERENCE) (DECLARE (IGNORE DUMMY)) (MAKE-SYMBOLS-FROM-MODULE :SYMBOLS @@ -346,19 +346,19 @@ :GLOBAL-MODULE-REFERENCE GLOBAL-MODULE-REFERENCE)) -(DEFUN IMPORTS53 (DUMMY SYMBOLS-FROM-MODULE* DUMMY1) +(DEFUN IMPORTS43 (DUMMY SYMBOLS-FROM-MODULE* DUMMY1) (DECLARE (IGNORE DUMMY1 DUMMY)) (MAKE-IMPORTS :VALID T :LIST SYMBOLS-FROM-MODULE*)) -(DEFUN EXPORTS54 (DUMMY SYMBOL*\,1$ DUMMY1) +(DEFUN EXPORTS44 (DUMMY SYMBOL*\,1$ DUMMY1) (DECLARE (IGNORE DUMMY1 DUMMY)) (MAKE-EXPORTS :LIST SYMBOL*\,1$)) -(DEFUN EXPORTS55 (DUMMY DUMMY1 DUMMY2) +(DEFUN EXPORTS45 (DUMMY DUMMY1 DUMMY2) (DECLARE (IGNORE DUMMY2 DUMMY1 DUMMY)) (MAKE-EXPORTS :ALL-EXPORTS T)) -(DEFUN MODULE-BODY56 (EXPORTS IMPORTS ASSIGNMENT*) +(DEFUN MODULE-BODY46 (EXPORTS IMPORTS ASSIGNMENT*) (MAKE-MODULE-BODY :ASSIGNMENT-LIST ASSIGNMENT* :EXPORTS @@ -366,7 +366,7 @@ :IMPORTS IMPORTS)) -(DEFUN MODULE-DEFINITION57 +(DEFUN MODULE-DEFINITION47 (MODULE-IDENTIFIER DUMMY DUMMY1 DUMMY2 MODULE-BODY DUMMY3) (DECLARE (IGNORE DUMMY3 DUMMY2 DUMMY1 DUMMY)) (MAKE-MODULE-DEFINITION :IDENTIFIER Modified: trunk/asn.1/asn.1.tab ============================================================================== --- trunk/asn.1/asn.1.tab (original) +++ trunk/asn.1/asn.1.tab Wed Oct 17 08:46:55 2007 @@ -698,20 +698,20 @@ 2 -#88((MODULE-DEFINITION . #S(ZEBU::ZB-RULE :-NAME MODULE-DEFINITION :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-IDENTIFIER "DEFINITIONS" "::=" "BEGIN" MODULE-BODY "END") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE MODULE-DEFINITION :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL IDENTIFIER :-VALUE MODULE-IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL BODY :-VALUE MODULE-BODY))) :-BUILD-FN MODULE-DEFINITION57)))) +#88((MODULE-DEFINITION . #S(ZEBU::ZB-RULE :-NAME MODULE-DEFINITION :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-IDENTIFIER "DEFINITIONS" "::=" "BEGIN" MODULE-BODY "END") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE MODULE-DEFINITION :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL IDENTIFIER :-VALUE MODULE-IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL BODY :-VALUE MODULE-BODY))) :-BUILD-FN MODULE-DEFINITION47)))) (MODULE-IDENTIFIER . #S(ZEBU::ZB-RULE :-NAME MODULE-IDENTIFIER :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-REFERENCE) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) (MODULE-REFERENCE . #S(ZEBU::ZB-RULE :-NAME MODULE-REFERENCE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (TYPE-REFERENCE) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) -(MODULE-BODY . #S(ZEBU::ZB-RULE :-NAME MODULE-BODY :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (EXPORTS IMPORTS ASSIGNMENT*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE MODULE-BODY :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL ASSIGNMENT-LIST :-VALUE ASSIGNMENT*) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL EXPORTS :-VALUE EXPORTS) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL IMPORTS :-VALUE IMPORTS))) :-BUILD-FN MODULE-BODY56) #S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) -(EXPORTS . #S(ZEBU::ZB-RULE :-NAME EXPORTS :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("EXPORTS" SYMBOL*\,1$ ";") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE EXPORTS :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL LIST :-VALUE SYMBOL*\,1$))) :-BUILD-FN EXPORTS54) #S(ZEBU::PRODUCTION-RHS :-SYNTAX ("EXPORTS" "ALL" ";") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE EXPORTS :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL ALL-EXPORTS :-VALUE T))) :-BUILD-FN EXPORTS55) #S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) +(MODULE-BODY . #S(ZEBU::ZB-RULE :-NAME MODULE-BODY :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (EXPORTS IMPORTS ASSIGNMENT*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE MODULE-BODY :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL ASSIGNMENT-LIST :-VALUE ASSIGNMENT*) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL EXPORTS :-VALUE EXPORTS) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL IMPORTS :-VALUE IMPORTS))) :-BUILD-FN MODULE-BODY46) #S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) +(EXPORTS . #S(ZEBU::ZB-RULE :-NAME EXPORTS :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("EXPORTS" SYMBOL*\,1$ ";") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE EXPORTS :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL LIST :-VALUE SYMBOL*\,1$))) :-BUILD-FN EXPORTS44) #S(ZEBU::PRODUCTION-RHS :-SYNTAX ("EXPORTS" "ALL" ";") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE EXPORTS :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL ALL-EXPORTS :-VALUE T))) :-BUILD-FN EXPORTS45) #S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) (SYMBOL . #S(ZEBU::ZB-RULE :-NAME SYMBOL :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (REFERENCE) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) -(IMPORTS . #S(ZEBU::ZB-RULE :-NAME IMPORTS :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("IMPORTS" SYMBOLS-FROM-MODULE* ";") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE IMPORTS :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALID :-VALUE T) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL LIST :-VALUE SYMBOLS-FROM-MODULE*))) :-BUILD-FN IMPORTS53) #S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) -(SYMBOLS-FROM-MODULE . #S(ZEBU::ZB-RULE :-NAME SYMBOLS-FROM-MODULE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOL+\,1$ "FROM" GLOBAL-MODULE-REFERENCE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE SYMBOLS-FROM-MODULE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL SYMBOLS :-VALUE SYMBOL+\,1$) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL GLOBAL-MODULE-REFERENCE :-VALUE GLOBAL-MODULE-REFERENCE))) :-BUILD-FN SYMBOLS-FROM-MODULE52)))) +(IMPORTS . #S(ZEBU::ZB-RULE :-NAME IMPORTS :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("IMPORTS" SYMBOLS-FROM-MODULE* ";") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE IMPORTS :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALID :-VALUE T) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL LIST :-VALUE SYMBOLS-FROM-MODULE*))) :-BUILD-FN IMPORTS43) #S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) +(SYMBOLS-FROM-MODULE . #S(ZEBU::ZB-RULE :-NAME SYMBOLS-FROM-MODULE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOL+\,1$ "FROM" GLOBAL-MODULE-REFERENCE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE SYMBOLS-FROM-MODULE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL SYMBOLS :-VALUE SYMBOL+\,1$) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL GLOBAL-MODULE-REFERENCE :-VALUE GLOBAL-MODULE-REFERENCE))) :-BUILD-FN SYMBOLS-FROM-MODULE42)))) (GLOBAL-MODULE-REFERENCE . #S(ZEBU::ZB-RULE :-NAME GLOBAL-MODULE-REFERENCE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-REFERENCE) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) (REFERENCE . #S(ZEBU::ZB-RULE :-NAME REFERENCE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (TYPE-REFERENCE) :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) -(ASSIGNMENT . #S(ZEBU::ZB-RULE :-NAME ASSIGNMENT :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (TYPE-ASSIGNMENT) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :TYPE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE TYPE-ASSIGNMENT))) :-BUILD-FN ASSIGNMENT50) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (VALUE-ASSIGNMENT) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :VALUE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE VALUE-ASSIGNMENT))) :-BUILD-FN ASSIGNMENT51)))) +(ASSIGNMENT . #S(ZEBU::ZB-RULE :-NAME ASSIGNMENT :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (TYPE-ASSIGNMENT) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :TYPE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE TYPE-ASSIGNMENT))) :-BUILD-FN ASSIGNMENT40) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (VALUE-ASSIGNMENT) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :VALUE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE VALUE-ASSIGNMENT))) :-BUILD-FN ASSIGNMENT41)))) (TYPE-ASSIGNMENT . #S(ZEBU::ZB-RULE :-NAME TYPE-ASSIGNMENT :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (TYPE-REFERENCE "::=" TYPE) :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (TYPE-REFERENCE "MACRO" "::=" "BEGIN" GARBAGE+ "END") :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) (GARBAGE . #S(ZEBU::ZB-RULE :-NAME GARBAGE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (ANYTHING) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) -(VALUE-ASSIGNMENT . #S(ZEBU::ZB-RULE :-NAME VALUE-ASSIGNMENT :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER TYPE "::=" VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE TYPE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE VALUE))) :-BUILD-FN VALUE-ASSIGNMENT34) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "OBJECT-IDENTITY" "STATUS" STATUS "DESCRIPTION" DESCRIPTION OBJECT-IDENTITY-REFERENCE "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :OBJECT-IDENTITY) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT35) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "MODULE-IDENTITY" "LAST-UPDATED" LAST-UPDATED "ORGANIZATION" ORGANIZATION "CONTACT-INFO" CONTACT-INFO "DESCRIPTION" DESCRIPTION MODULE-REVISION* "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :MODULE-IDENTITY) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT36) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "OBJECT-TYPE" "SYNTAX" TYPE OBJECT-TYPE-UNITS OBJECT-TYPE-ACCESS "STATUS" STATUS "DESCRIPTION" DESCRIPTION OBJECT-TYPE-INDEX OBJECT-TYPE-AUGMENTS OBJECT-TYPE-REFERENCE OBJECT-TYPE-DEFVAL "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :OBJECT-TYPE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT45) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "NOTIFICATION-TYPE" NOTIFICATION-TYPE-OBJECTS "STATUS" STATUS "DESCRIPTION" DESCRIPTION "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :NOTIFICATION-TYPE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT46) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "NOTIFICATION-GROUP" "NOTIFICATIONS" "{" IDENTIFIER+\,1$ "}" "STATUS" STATUS "DESCRIPTION" DESCRIPTION "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :NOTIFICATION-GROUP) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT47) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "MODULE-COMPLIANCE" "STATUS" STATUS "DESCRIPTION" DESCRIPTION MODULE-COMPLIANCE-BODY+ "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :MODULE-COMPLIANCE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT48) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "OBJECT-GROUP" "OBJECTS" "{" IDENTIFIER+\,1$ "}" "STATUS" STATUS "DESCRIPTION" DESCRIPTION "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :OBJECT-GROUP) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT49)))) +(VALUE-ASSIGNMENT . #S(ZEBU::ZB-RULE :-NAME VALUE-ASSIGNMENT :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER TYPE "::=" VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE TYPE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE VALUE))) :-BUILD-FN VALUE-ASSIGNMENT29) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "OBJECT-IDENTITY" "STATUS" STATUS "DESCRIPTION" DESCRIPTION OBJECT-IDENTITY-REFERENCE "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :OBJECT-IDENTITY) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT30) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "MODULE-IDENTITY" "LAST-UPDATED" LAST-UPDATED "ORGANIZATION" ORGANIZATION "CONTACT-INFO" CONTACT-INFO "DESCRIPTION" DESCRIPTION MODULE-REVISION* "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :MODULE-IDENTITY) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT31) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "OBJECT-TYPE" "SYNTAX" TYPE OBJECT-TYPE-UNITS OBJECT-TYPE-ACCESS "STATUS" STATUS "DESCRIPTION" DESCRIPTION OBJECT-TYPE-INDEX OBJECT-TYPE-AUGMENTS OBJECT-TYPE-REFERENCE OBJECT-TYPE-DEFVAL "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :OBJECT-TYPE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT32) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "NOTIFICATION-TYPE" NOTIFICATION-TYPE-OBJECTS "STATUS" STATUS "DESCRIPTION" DESCRIPTION "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :NOTIFICATION-TYPE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT33) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "NOTIFICATION-GROUP" "NOTIFICATIONS" "{" IDENTIFIER+\,1$ "}" "STATUS" STATUS "DESCRIPTION" DESCRIPTION "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :NOTIFICATION-GROUP) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT37) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "MODULE-COMPLIANCE" "STATUS" STATUS "DESCRIPTION" DESCRIPTION MODULE-COMPLIANCE-BODY+ "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :MODULE-COMPLIANCE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT38) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "OBJECT-GROUP" "OBJECTS" "{" IDENTIFIER+\,1$ "}" "STATUS" STATUS "DESCRIPTION" DESCRIPTION "::=" OBJECT-IDENTIFIER-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE VALUE-ASSIGNMENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL TYPE :-VALUE :OBJECT-GROUP) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJECT-IDENTIFIER-VALUE))) :-BUILD-FN VALUE-ASSIGNMENT39)))) (STATUS . #S(ZEBU::ZB-RULE :-NAME STATUS :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) (DESCRIPTION . #S(ZEBU::ZB-RULE :-NAME DESCRIPTION :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (STRING) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) (LAST-UPDATED . #S(ZEBU::ZB-RULE :-NAME LAST-UPDATED :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (STRING) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) @@ -747,9 +747,9 @@ (OBJECT-IDENTIFIER-TYPE . #S(ZEBU::ZB-RULE :-NAME OBJECT-IDENTIFIER-TYPE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("OBJECT" "IDENTIFIER") :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) (VALUE . #S(ZEBU::ZB-RULE :-NAME VALUE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (BUILTIN-VALUE) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) (BUILTIN-VALUE . #S(ZEBU::ZB-RULE :-NAME BUILTIN-VALUE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (OBJECT-IDENTIFIER-VALUE) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) -(OBJECT-IDENTIFIER-VALUE . #S(ZEBU::ZB-RULE :-NAME OBJECT-IDENTIFIER-VALUE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("{" OBJ-ID-COMPONENT+ "}") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE OBJECT-IDENTIFIER-VALUE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJ-ID-COMPONENT+))) :-BUILD-FN OBJECT-IDENTIFIER-VALUE33)))) +(OBJECT-IDENTIFIER-VALUE . #S(ZEBU::ZB-RULE :-NAME OBJECT-IDENTIFIER-VALUE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("{" OBJ-ID-COMPONENT+ "}") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE OBJECT-IDENTIFIER-VALUE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE OBJ-ID-COMPONENT+))) :-BUILD-FN OBJECT-IDENTIFIER-VALUE28)))) (OBJ-ID-COMPONENT . #S(ZEBU::ZB-RULE :-NAME OBJ-ID-COMPONENT :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (NAME-AND-NUMBER-FORM) :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (NAME-FORM) :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (NUMBER-FORM) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) -(NAME-AND-NUMBER-FORM . #S(ZEBU::ZB-RULE :-NAME NAME-AND-NUMBER-FORM :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "(" NUMBER-FORM ")") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE OBJ-ID-COMPONENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE NUMBER-FORM))) :-BUILD-FN NAME-AND-NUMBER-FORM32)))) +(NAME-AND-NUMBER-FORM . #S(ZEBU::ZB-RULE :-NAME NAME-AND-NUMBER-FORM :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "(" NUMBER-FORM ")") :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE OBJ-ID-COMPONENT :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL NAME :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL VALUE :-VALUE NUMBER-FORM))) :-BUILD-FN NAME-AND-NUMBER-FORM27)))) (NAME-FORM . #S(ZEBU::ZB-RULE :-NAME NAME-FORM :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) (NUMBER-FORM . #S(ZEBU::ZB-RULE :-NAME NUMBER-FORM :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (NUMBER) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) (CHOICE-TYPE . #S(ZEBU::ZB-RULE :-NAME CHOICE-TYPE :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("CHOICE" "{" GARBAGE+ "}") :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) @@ -768,22 +768,22 @@ (TAG . #S(ZEBU::ZB-RULE :-NAME TAG :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("[" CLASS CLASS-NUMBER "]") :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) (CLASS-NUMBER . #S(ZEBU::ZB-RULE :-NAME CLASS-NUMBER :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (SIGNED-NUMBER) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) (CLASS . #S(ZEBU::ZB-RULE :-NAME CLASS :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX ("UNIVERSAL") :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(ZEBU::PRODUCTION-RHS :-SYNTAX ("APPLICATION") :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(ZEBU::PRODUCTION-RHS :-SYNTAX ("PRIVATE") :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) -(GARBAGE* . #S(ZEBU::ZB-RULE :-NAME GARBAGE* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (GARBAGE GARBAGE*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE GARBAGE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE GARBAGE*))) :-BUILD-FN GARBAGE*31)))) -(NAMED-NUMBER+\,1$ . #S(ZEBU::ZB-RULE :-NAME NAMED-NUMBER+\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (NAMED-NUMBER) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE NAMED-NUMBER))) :-BUILD-FN NAMED-NUMBER+\,1$29) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (NAMED-NUMBER "," NAMED-NUMBER+\,1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE NAMED-NUMBER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE NAMED-NUMBER+\,1$))) :-BUILD-FN NAMED-NUMBER+\,1$30)))) -(SPLITED-NUMBERS+\|1$ . #S(ZEBU::ZB-RULE :-NAME SPLITED-NUMBERS+\|1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (SPLITED-NUMBERS) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SPLITED-NUMBERS))) :-BUILD-FN SPLITED-NUMBERS+\|1$27) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (SPLITED-NUMBERS "|" SPLITED-NUMBERS+\|1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SPLITED-NUMBERS) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE SPLITED-NUMBERS+\|1$))) :-BUILD-FN SPLITED-NUMBERS+\|1$28)))) -(NUMBERS+\|1$ . #S(ZEBU::ZB-RULE :-NAME NUMBERS+\|1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (NUMBERS) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE NUMBERS))) :-BUILD-FN NUMBERS+\|1$25) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (NUMBERS "|" NUMBERS+\|1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE NUMBERS) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE NUMBERS+\|1$))) :-BUILD-FN NUMBERS+\|1$26)))) -(OBJ-ID-COMPONENT+ . #S(ZEBU::ZB-RULE :-NAME OBJ-ID-COMPONENT+ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (OBJ-ID-COMPONENT) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE OBJ-ID-COMPONENT))) :-BUILD-FN OBJ-ID-COMPONENT+23) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (OBJ-ID-COMPONENT OBJ-ID-COMPONENT+) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE OBJ-ID-COMPONENT) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE OBJ-ID-COMPONENT+))) :-BUILD-FN OBJ-ID-COMPONENT+24)))) -(MODULE-COMPLIANCE-ITEM* . #S(ZEBU::ZB-RULE :-NAME MODULE-COMPLIANCE-ITEM* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-COMPLIANCE-ITEM MODULE-COMPLIANCE-ITEM*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE MODULE-COMPLIANCE-ITEM) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE MODULE-COMPLIANCE-ITEM*))) :-BUILD-FN MODULE-COMPLIANCE-ITEM*22)))) -(|Rest-IDENTIFIER*,1$| . #S(ZEBU::ZB-RULE :-NAME |Rest-IDENTIFIER*,1$| :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX ("," IDENTIFIER |Rest-IDENTIFIER*,1$|) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE |Rest-IDENTIFIER*,1$|))) :-BUILD-FN |Rest-IDENTIFIER*,1$21|)))) -(IDENTIFIER*\,1$ . #S(ZEBU::ZB-RULE :-NAME IDENTIFIER*\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER |Rest-IDENTIFIER*,1$|) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE |Rest-IDENTIFIER*,1$|))) :-BUILD-FN IDENTIFIER*\,1$20)))) -(OBJECT-TYPE-INDEX-VALUE+\,1$ . #S(ZEBU::ZB-RULE :-NAME OBJECT-TYPE-INDEX-VALUE+\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (OBJECT-TYPE-INDEX-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE OBJECT-TYPE-INDEX-VALUE))) :-BUILD-FN OBJECT-TYPE-INDEX-VALUE+\,1$18) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (OBJECT-TYPE-INDEX-VALUE "," OBJECT-TYPE-INDEX-VALUE+\,1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE OBJECT-TYPE-INDEX-VALUE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE OBJECT-TYPE-INDEX-VALUE+\,1$))) :-BUILD-FN OBJECT-TYPE-INDEX-VALUE+\,1$19)))) -(MODULE-COMPLIANCE-BODY+ . #S(ZEBU::ZB-RULE :-NAME MODULE-COMPLIANCE-BODY+ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-COMPLIANCE-BODY) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE MODULE-COMPLIANCE-BODY))) :-BUILD-FN MODULE-COMPLIANCE-BODY+16) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-COMPLIANCE-BODY MODULE-COMPLIANCE-BODY+) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE MODULE-COMPLIANCE-BODY) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE MODULE-COMPLIANCE-BODY+))) :-BUILD-FN MODULE-COMPLIANCE-BODY+17)))) -(IDENTIFIER+\,1$ . #S(ZEBU::ZB-RULE :-NAME IDENTIFIER+\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE IDENTIFIER))) :-BUILD-FN IDENTIFIER+\,1$14) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "," IDENTIFIER+\,1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE IDENTIFIER+\,1$))) :-BUILD-FN IDENTIFIER+\,1$15)))) -(MODULE-REVISION* . #S(ZEBU::ZB-RULE :-NAME MODULE-REVISION* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-REVISION MODULE-REVISION*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE MODULE-REVISION) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE MODULE-REVISION*))) :-BUILD-FN MODULE-REVISION*13)))) -(GARBAGE+ . #S(ZEBU::ZB-RULE :-NAME GARBAGE+ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (GARBAGE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE GARBAGE))) :-BUILD-FN GARBAGE+11) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (GARBAGE GARBAGE+) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE GARBAGE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE GARBAGE+))) :-BUILD-FN GARBAGE+12)))) -(SYMBOL+\,1$ . #S(ZEBU::ZB-RULE :-NAME SYMBOL+\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOL) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOL))) :-BUILD-FN SYMBOL+\,1$9) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOL "," SYMBOL+\,1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOL) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE SYMBOL+\,1$))) :-BUILD-FN SYMBOL+\,1$10)))) -(SYMBOLS-FROM-MODULE* . #S(ZEBU::ZB-RULE :-NAME SYMBOLS-FROM-MODULE* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOLS-FROM-MODULE SYMBOLS-FROM-MODULE*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOLS-FROM-MODULE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE SYMBOLS-FROM-MODULE*))) :-BUILD-FN SYMBOLS-FROM-MODULE*8)))) -(|Rest-SYMBOL*,1$| . #S(ZEBU::ZB-RULE :-NAME |Rest-SYMBOL*,1$| :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX ("," SYMBOL |Rest-SYMBOL*,1$|) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOL) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE |Rest-SYMBOL*,1$|))) :-BUILD-FN |Rest-SYMBOL*,1$7|)))) -(SYMBOL*\,1$ . #S(ZEBU::ZB-RULE :-NAME SYMBOL*\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOL |Rest-SYMBOL*,1$|) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOL) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE |Rest-SYMBOL*,1$|))) :-BUILD-FN SYMBOL*\,1$6)))) -(ASSIGNMENT* . #S(ZEBU::ZB-RULE :-NAME ASSIGNMENT* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (ASSIGNMENT ASSIGNMENT*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE ASSIGNMENT) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE ASSIGNMENT*))) :-BUILD-FN ASSIGNMENT*5)))) +(GARBAGE* . #S(ZEBU::ZB-RULE :-NAME GARBAGE* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (GARBAGE GARBAGE*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE GARBAGE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE GARBAGE*))) :-BUILD-FN GARBAGE*26)))) +(NAMED-NUMBER+\,1$ . #S(ZEBU::ZB-RULE :-NAME NAMED-NUMBER+\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (NAMED-NUMBER) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE NAMED-NUMBER))) :-BUILD-FN NAMED-NUMBER+\,1$24) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (NAMED-NUMBER "," NAMED-NUMBER+\,1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE NAMED-NUMBER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE NAMED-NUMBER+\,1$))) :-BUILD-FN NAMED-NUMBER+\,1$25)))) +(SPLITED-NUMBERS+\|1$ . #S(ZEBU::ZB-RULE :-NAME SPLITED-NUMBERS+\|1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (SPLITED-NUMBERS) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SPLITED-NUMBERS))) :-BUILD-FN SPLITED-NUMBERS+\|1$22) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (SPLITED-NUMBERS "|" SPLITED-NUMBERS+\|1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SPLITED-NUMBERS) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE SPLITED-NUMBERS+\|1$))) :-BUILD-FN SPLITED-NUMBERS+\|1$23)))) +(NUMBERS+\|1$ . #S(ZEBU::ZB-RULE :-NAME NUMBERS+\|1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (NUMBERS) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE NUMBERS))) :-BUILD-FN NUMBERS+\|1$20) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (NUMBERS "|" NUMBERS+\|1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE NUMBERS) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE NUMBERS+\|1$))) :-BUILD-FN NUMBERS+\|1$21)))) +(OBJ-ID-COMPONENT+ . #S(ZEBU::ZB-RULE :-NAME OBJ-ID-COMPONENT+ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (OBJ-ID-COMPONENT) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE OBJ-ID-COMPONENT))) :-BUILD-FN OBJ-ID-COMPONENT+18) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (OBJ-ID-COMPONENT OBJ-ID-COMPONENT+) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE OBJ-ID-COMPONENT) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE OBJ-ID-COMPONENT+))) :-BUILD-FN OBJ-ID-COMPONENT+19)))) +(MODULE-COMPLIANCE-ITEM* . #S(ZEBU::ZB-RULE :-NAME MODULE-COMPLIANCE-ITEM* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-COMPLIANCE-ITEM MODULE-COMPLIANCE-ITEM*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE MODULE-COMPLIANCE-ITEM) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE MODULE-COMPLIANCE-ITEM*))) :-BUILD-FN MODULE-COMPLIANCE-ITEM*17)))) +(|Rest-IDENTIFIER*,1$| . #S(ZEBU::ZB-RULE :-NAME |Rest-IDENTIFIER*,1$| :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX ("," IDENTIFIER |Rest-IDENTIFIER*,1$|) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE |Rest-IDENTIFIER*,1$|))) :-BUILD-FN |Rest-IDENTIFIER*,1$16|)))) +(IDENTIFIER*\,1$ . #S(ZEBU::ZB-RULE :-NAME IDENTIFIER*\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER |Rest-IDENTIFIER*,1$|) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE |Rest-IDENTIFIER*,1$|))) :-BUILD-FN IDENTIFIER*\,1$15)))) +(OBJECT-TYPE-INDEX-VALUE+\,1$ . #S(ZEBU::ZB-RULE :-NAME OBJECT-TYPE-INDEX-VALUE+\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (OBJECT-TYPE-INDEX-VALUE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE OBJECT-TYPE-INDEX-VALUE))) :-BUILD-FN OBJECT-TYPE-INDEX-VALUE+\,1$13) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (OBJECT-TYPE-INDEX-VALUE "," OBJECT-TYPE-INDEX-VALUE+\,1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE OBJECT-TYPE-INDEX-VALUE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE OBJECT-TYPE-INDEX-VALUE+\,1$))) :-BUILD-FN OBJECT-TYPE-INDEX-VALUE+\,1$14)))) +(MODULE-COMPLIANCE-BODY+ . #S(ZEBU::ZB-RULE :-NAME MODULE-COMPLIANCE-BODY+ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-COMPLIANCE-BODY) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE MODULE-COMPLIANCE-BODY))) :-BUILD-FN MODULE-COMPLIANCE-BODY+11) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-COMPLIANCE-BODY MODULE-COMPLIANCE-BODY+) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE MODULE-COMPLIANCE-BODY) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE MODULE-COMPLIANCE-BODY+))) :-BUILD-FN MODULE-COMPLIANCE-BODY+12)))) +(IDENTIFIER+\,1$ . #S(ZEBU::ZB-RULE :-NAME IDENTIFIER+\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE IDENTIFIER))) :-BUILD-FN IDENTIFIER+\,1$9) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (IDENTIFIER "," IDENTIFIER+\,1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE IDENTIFIER) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE IDENTIFIER+\,1$))) :-BUILD-FN IDENTIFIER+\,1$10)))) +(MODULE-REVISION* . #S(ZEBU::ZB-RULE :-NAME MODULE-REVISION* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (MODULE-REVISION MODULE-REVISION*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE MODULE-REVISION) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE MODULE-REVISION*))) :-BUILD-FN MODULE-REVISION*8)))) +(GARBAGE+ . #S(ZEBU::ZB-RULE :-NAME GARBAGE+ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (GARBAGE) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE GARBAGE))) :-BUILD-FN GARBAGE+6) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (GARBAGE GARBAGE+) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE GARBAGE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE GARBAGE+))) :-BUILD-FN GARBAGE+7)))) +(SYMBOL+\,1$ . #S(ZEBU::ZB-RULE :-NAME SYMBOL+\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOL) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOL))) :-BUILD-FN SYMBOL+\,1$4) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOL "," SYMBOL+\,1$) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOL) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE SYMBOL+\,1$))) :-BUILD-FN SYMBOL+\,1$5)))) +(SYMBOLS-FROM-MODULE* . #S(ZEBU::ZB-RULE :-NAME SYMBOLS-FROM-MODULE* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOLS-FROM-MODULE SYMBOLS-FROM-MODULE*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOLS-FROM-MODULE) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE SYMBOLS-FROM-MODULE*))) :-BUILD-FN SYMBOLS-FROM-MODULE*3)))) +(|Rest-SYMBOL*,1$| . #S(ZEBU::ZB-RULE :-NAME |Rest-SYMBOL*,1$| :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX ("," SYMBOL |Rest-SYMBOL*,1$|) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOL) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE |Rest-SYMBOL*,1$|))) :-BUILD-FN |Rest-SYMBOL*,1$2|)))) +(SYMBOL*\,1$ . #S(ZEBU::ZB-RULE :-NAME SYMBOL*\,1$ :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (SYMBOL |Rest-SYMBOL*,1$|) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE SYMBOL) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE |Rest-SYMBOL*,1$|))) :-BUILD-FN SYMBOL*\,1$1)))) +(ASSIGNMENT* . #S(ZEBU::ZB-RULE :-NAME ASSIGNMENT* :-PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(ZEBU::PRODUCTION-RHS :-SYNTAX (ASSIGNMENT ASSIGNMENT*) :-SEMANTICS #S(ZEBU::FEAT-TERM :-TYPE KB-SEQUENCE :-SLOTS (#S(ZEBU::LABEL-VALUE-PAIR :-LABEL FIRST :-VALUE ASSIGNMENT) #S(ZEBU::LABEL-VALUE-PAIR :-LABEL REST :-VALUE ASSIGNMENT*))) :-BUILD-FN ASSIGNMENT*0)))) ) \ No newline at end of file Modified: trunk/smi/counter.lisp ============================================================================== --- trunk/smi/counter.lisp (original) +++ trunk/smi/counter.lisp Wed Oct 17 08:46:55 2007 @@ -5,7 +5,7 @@ (defclass counter64 (counter) ()) (defun counter (v) - (make-instance 'counter32 :value v)) + (counter32 v)) (defun counter32 (v) (make-instance 'counter32 :value v)) Modified: trunk/smi/integer.lisp ============================================================================== --- trunk/smi/integer.lisp (original) +++ trunk/smi/integer.lisp Wed Oct 17 08:46:55 2007 @@ -1,5 +1,8 @@ (in-package :smi) +(defmethod plain-value ((object integer)) + object) + (defun ber-encode-integer (value) (declare (type integer value)) (labels ((iter (n acc l) Modified: trunk/smi/null.lisp ============================================================================== --- trunk/smi/null.lisp (original) +++ trunk/smi/null.lisp Wed Oct 17 08:46:55 2007 @@ -1,5 +1,8 @@ (in-package :smi) +(defmethod plain-value ((object (eql nil))) + object) + ;;; NULL (:null) (defmethod ber-encode ((value (eql nil))) (declare (ignore value)) Modified: trunk/smi/oid.lisp ============================================================================== --- trunk/smi/oid.lisp (original) +++ trunk/smi/oid.lisp Wed Oct 17 08:46:55 2007 @@ -9,6 +9,9 @@ (rev-names :initform nil :type list :reader oid-name :initarg :name) (length :initform 0 :type integer :reader oid-length))) +(defmethod plain-value ((object object-id)) + (reverse (oid-revid object))) + (defun oid (oid) (declare (type object-id oid)) (reverse (slot-value 'rev-ids oid))) Modified: trunk/smi/package.lisp ============================================================================== --- trunk/smi/package.lisp (original) +++ trunk/smi/package.lisp Wed Oct 17 08:46:55 2007 @@ -4,7 +4,7 @@ (:nicknames smi) (:use :common-lisp :asn.1 #-(and lispworks win32) :net.sockets) (:export ;; general - value-of general-type + value-of general-type plain-value ;; object-id object-id oid make-object-id rev-ids rev-names oid-< @@ -39,4 +39,8 @@ (print-unreadable-object (obj stream :type t) (format stream "~A" (value-of obj)))) +(defgeneric plain-value (object)) +(defmethod plain-value ((object general-type)) + (value-of object)) + (defparameter *version* 2) Modified: trunk/smi/sequence.lisp ============================================================================== --- trunk/smi/sequence.lisp (original) +++ trunk/smi/sequence.lisp Wed Oct 17 08:46:55 2007 @@ -2,6 +2,9 @@ ;;; SEQUENCE (:sequence) +(defmethod plain-value ((object sequence)) + object) + (defmethod ber-encode ((value sequence)) (let ((sub-encode (apply #'nconc (map 'list #'ber-encode value)))) Modified: trunk/smi/string.lisp ============================================================================== --- trunk/smi/string.lisp (original) +++ trunk/smi/string.lisp Wed Oct 17 08:46:55 2007 @@ -1,5 +1,8 @@ (in-package :smi) +(defmethod plain-value ((object string)) + object) + ;;; OCTET STRING (:octet-string) (defmethod ber-encode ((value string)) Modified: trunk/smi/timeticks.lisp ============================================================================== --- trunk/smi/timeticks.lisp (original) +++ trunk/smi/timeticks.lisp Wed Oct 17 08:46:55 2007 @@ -7,6 +7,9 @@ (seconds :type fixnum) (seconds/100 :type fixnum))) +(defmethod plain-value ((object timeticks)) + (ticks object)) + (defmethod print-object ((obj timeticks) stream) (with-slots (ticks hours minutes seconds seconds/100) obj (print-unreadable-object (obj stream :type t) Modified: trunk/snmp/session.lisp ============================================================================== --- trunk/snmp/session.lisp (original) +++ trunk/snmp/session.lisp Wed Oct 17 08:46:55 2007 @@ -67,8 +67,8 @@ (port *default-port*) (community *default-community*)) (let ((s (make-socket :remote-host host - :remote-port port - :type :datagram - :ipv6 nil))) + :remote-port port + :type :datagram + :ipv6 nil))) (set-socket-option s :receive-timeout :sec 1 :usec 0) (make-instance class :socket s :community community))) From ctian at common-lisp.net Wed Oct 17 12:51:21 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 08:51:21 -0400 (EDT) Subject: [cl-net-snmp-cvs] r73 - tags/1.1 Message-ID: <20071017125121.4778225005@common-lisp.net> Author: ctian Date: Wed Oct 17 08:51:21 2007 New Revision: 73 Added: tags/1.1/ - copied from r72, trunk/ Log: Release 1.1: snmp-walk and more data type support From ctian at common-lisp.net Wed Oct 17 13:05:40 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 09:05:40 -0400 (EDT) Subject: [cl-net-snmp-cvs] r74 - in vendor: . zebu zebu/doc zebu/test zebu/test/binary Message-ID: <20071017130540.2E4B674386@common-lisp.net> Author: ctian Date: Wed Oct 17 09:04:46 2007 New Revision: 74 Added: vendor/ vendor/zebu/ vendor/zebu/COPYRIGHT vendor/zebu/ChangeLog vendor/zebu/INSTALL.mk-defsystem vendor/zebu/README vendor/zebu/README.asdf-system vendor/zebu/Version vendor/zebu/doc/ vendor/zebu/doc/Zebu_intro.ps vendor/zebu/doc/Zebu_intro.tex vendor/zebu/test/ vendor/zebu/test/arith.zb vendor/zebu/test/avm-p.lisp vendor/zebu/test/avm.zb vendor/zebu/test/avm1.zb vendor/zebu/test/binary/ vendor/zebu/test/bug-exp.zb vendor/zebu/test/bug-exp1.zb vendor/zebu/test/bug-exp2.zb vendor/zebu/test/bug-exp3.zb vendor/zebu/test/dYoung.lisp vendor/zebu/test/dangelse.zb vendor/zebu/test/ex1.zb vendor/zebu/test/ex1a.zb vendor/zebu/test/ex2.zb vendor/zebu/test/ex3.zb vendor/zebu/test/ex4.40.zb vendor/zebu/test/ex4.41.zb vendor/zebu/test/ex4.42.zb vendor/zebu/test/ex5.zb vendor/zebu/test/ex6_2.zb vendor/zebu/test/ex7.zb vendor/zebu/test/ex8.zb vendor/zebu/test/exercise.lisp vendor/zebu/test/fsg.zb vendor/zebu/test/g0.zb vendor/zebu/test/g1.zb vendor/zebu/test/g2.zb vendor/zebu/test/hh-tdl.zb vendor/zebu/test/hh-test.tdl vendor/zebu/test/lex1.zb vendor/zebu/test/lieber.zb vendor/zebu/test/lr4-21.zb vendor/zebu/test/mini-la.zb vendor/zebu/test/mini.zb vendor/zebu/test/pb.zb vendor/zebu/test/pc.zb vendor/zebu/test/pc1-p.lisp vendor/zebu/test/pc1.zb vendor/zebu/test/pc2.zb vendor/zebu/test/pc3.zb vendor/zebu/test/regextst.lisp vendor/zebu/test/sample-avm1 vendor/zebu/test/sample-ex1 vendor/zebu/test/sb-tr.zb vendor/zebu/test/simple.zb vendor/zebu/test/tl1.zb vendor/zebu/test/useless.zb vendor/zebu/zebra-debug.lisp vendor/zebu/zebu-actions.lisp vendor/zebu/zebu-asdf-setup.lisp vendor/zebu/zebu-aux.lisp vendor/zebu/zebu-closure.lisp vendor/zebu/zebu-compile-mg.lisp vendor/zebu/zebu-compile.lisp vendor/zebu/zebu-compiler.asd vendor/zebu/zebu-compiler.system vendor/zebu/zebu-driver.lisp vendor/zebu/zebu-dump.lisp vendor/zebu/zebu-empty-st.lisp vendor/zebu/zebu-first.lisp vendor/zebu/zebu-follow.lisp vendor/zebu/zebu-g-symbol.lisp vendor/zebu/zebu-generator.lisp vendor/zebu/zebu-kb-domain.lisp vendor/zebu/zebu-lalr1.lisp vendor/zebu/zebu-loader.lisp vendor/zebu/zebu-loadgram.lisp vendor/zebu/zebu-lr0-sets.lisp vendor/zebu/zebu-mg-hierarchy.lisp vendor/zebu/zebu-mg.tab vendor/zebu/zebu-mg.zb vendor/zebu/zebu-oset.lisp vendor/zebu/zebu-package.lisp vendor/zebu/zebu-printers.lisp vendor/zebu/zebu-regex.lisp vendor/zebu/zebu-rr.asd vendor/zebu/zebu-rr.system vendor/zebu/zebu-slr.lisp vendor/zebu/zebu-tables.lisp vendor/zebu/zebu-tree-attributes.lisp vendor/zebu/zebu.asd vendor/zebu/zebu.system Log: Add zebu-3.5.5 as vendor Added: vendor/zebu/COPYRIGHT ============================================================================== --- (empty file) +++ vendor/zebu/COPYRIGHT Wed Oct 17 09:04:46 2007 @@ -0,0 +1,251 @@ + + + Copyright (C) 1989, by William M. Wells III + All Rights Reserved + Permission is granted for unrestricted non-commercial use. + + +;;; ************************************************************************* +;;; Copyright (c) 1990, 91,92,93,94 Hewlett-Packard Company +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Hewlett-Packard Company +;;; makes no warranty about the software, its performance or its conformity +;;; to any specification. +;;; +;;; Suggestions, comments and requests for improvements are welcome +;;; and should be mailed to laubsch at hpl.hp.com +;;; ************************************************************************* + + Copyright (C) 1990, 91,92,93,94,95,96 by Joachim Laubsch + All Rights Reserved + + Permission is granted under the + + GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS Added: vendor/zebu/ChangeLog ============================================================================== --- (empty file) +++ vendor/zebu/ChangeLog Wed Oct 17 09:04:46 2007 @@ -0,0 +1,139 @@ +1999-01-13 Joachim Laubsch + + * In zebu-generator.lisp replace the def of type->predicate by new + def which considers the builtin types NUMBER IDENTIFIER STRING + +Thu Oct 2 12:43:10 1997 Joachim Laubsch + + * changes for CMUCL suggested by Raymond Toy + +Fri Mar 15 09:41:11 1996 Joachim Laubsch + + * lexical categories are sorted in the way they are declared. + Fix supplied by (Marc Dzaebel), marc at rose.de + +Fri Mar 8 15:12:09 1996 Joachim Laubsch + + * test/exercise.lisp ((compile-module "ex2")): Release 3.4.8 + print each rule if :verbose is T + eliminate EMPTY action + updated doc on number, identifier and string as subtypes of the + root domain + +Tue Mar 5 09:58:21 1996 Joachim Laubsch + + * Release 3.4.7 + * COPYRIGHT: added GNU Copyleft + * COMPILE-ZEBU.lisp corrections for Allegro + +Thu Dec 21 17:01:24 1995 Joachim Laubsch + + * 3.4.5 first release of a version that will run in ACL 3.0 + Windows 3.1. The script winzebu translates to short filenames, + creating the subdirectory 'win' + +Tue Aug 2 14:17:18 1994 Joachim H. Laubsch (laubsch at hpljhl.hpl.hp.com) + + * COMPILE-ZEBU.lisp: *load-binary-pathname-types* for + (and :SUN :LUCID) + + * zebu-driver.lisp (read-parser): if a lex cat is scanned and + iff an IDENTIFIER is also expected prefer the IDENTIFIER in case + it is longer. + +Thu Jul 28 09:50:16 1994 Joachim H. Laubsch (laubsch at hpljhl.hpl.hp.com) + + * zebu-loadgram.lisp: Fixed Bug with "." as separator + (ambiguous constituent names were made) + Version 3.3.2 + + * zebu-generator.lisp (insert-clause): warn if syntax is not + unparsable, because some non-terminal is unbound in semantics + +Fri May 13 11:00:43 1994 Joachim H. Laubsch (laubsch at hpljl) + + * zebu-generator.lisp (insert-clause): fixed error that led to + wrong printers + (gen-printers): warning message for use of undefined domain type, + assume possibility of undefined type in is-subtype-of. + +Thu May 12 10:39:12 1994 Joachim H. Laubsch (laubsch at hpljl) + + * zebu-tree-attributes.lisp: konrad at dfki.uni-sb.de fixed + bug in prepare-tree-attributes + +Thu Apr 28 15:55:22 1994 Joachim H. Laubsch (laubsch at hpljl) + + * added debug-parser (&key (grammar t) (lexer nil)) + (debug-parser) will load a version of read-parser + that traces the parsing engine's shift and reduce + moves. + (debug-parser :lexer t) will provide more information + on the lexer's progress. + (debug-parser :grammar nil :lexer nil) will reload the + silent and fast version of read-parser. + +Mon Apr 25 10:00:59 1994 Joachim H. Laubsch (laubsch at hpljl) + + * zebu-driver.lisp: implemented state-sensitive token look- + ahead + +Tue Aug 31 17:13:47 1993 Joachim H. Laubsch (laubsch at hpljl) + + * introduce the keyword CASE-SENSITIVE -- which can + be given as part of the grammar spec. If its value is + true the case of grammar keywords is significant. + +Tue Aug 17 20:14:52 1993 Joachim Laubsch (laubsch at hpljl) + + * fix number token lexer bug. Now integer, ratio and float + should be recognized. + +Tue Jul 20 20:14:52 1993 Joachim Laubsch (laubsch at hpljl) + + * introduce macro + def-tree-attributes (class &rest slots) + def-tree-attributes can be compiled and at load-time + no compiler is necessary. + +Mon May 17 21:05:39 1993 Joachim Laubsch (laubsch at hpljl) + + * KB-equal compares now also sequences which are "dotted + lists". + +Wed May 5 10:57:05 1993 Joachim Laubsch (laubsch at hpljl) + + * Printers for slots of type kb-sequence are now + generated properly if the Kleene +/* notation is + used. + + Example: + ;; Domain definition + + Program := [(-stmts kb-sequence)]; + .. + + ;; Rules + + Program --> "begin" Stmt+ ";" "end" + { Program: [(-stmts Stmt+)] } ; + .. + +Tue Apr 27 16:03:50 1993 Joachim Laubsch (laubsch at hpljl) + * kb-subtypep is now a function analogous to CL's subtypep + KB-type-name-p is a function that returns true iff its + argument is a symbol naming a subtype of KB-DOMAIN. + + Improved printer generation. + + Checked for MCL compatibility and rewrote part of + regular expression compiler. + +Wed Apr 7 10:00:18 1993 Joachim Laubsch (laubsch at hpljl) + + * To Do +; Muessen die Kleene-Operatoren eigentlich die leere KB-sequence ans +; Ende jeder Sequenz schreiben? Ein normales nil sollte mit Hilfe +; eines modifizierten Printers dasselbe leisten, oder? + + Added: vendor/zebu/INSTALL.mk-defsystem ============================================================================== --- (empty file) +++ vendor/zebu/INSTALL.mk-defsystem Wed Oct 17 09:04:46 2007 @@ -0,0 +1,26 @@ +The Zebu runtime system is all you need if you want to use the +parser/generator that was produced by the compiler (in form of a .tab +file / -domain.lisp file). + +The Zebu-compiler is necessary in order to convert the external +grammar description (in form of a .zb file) into a LALR(1) parsing +table (in form of a .tab file), and associated printers and semantic +functions (in form of a -domain.lisp file). + +Installation (using ASDF) +--------------------------------- + +To compile a freshly installed zebu, evaluate: + + (asdf:operate 'asdf:compile-op :zebu) + (asdf:operate 'asdf:compile-op :zebu-compiler) + (asdf:operate 'asdf:compile-op :zebu-rr) + +To load a component of zebu, evaluate +(asdf:operate 'asdf:load-op ). + +Please tell me if installation works for you and, more importantly, +when it does not. + + +Rudi Schlatte \ No newline at end of file Added: vendor/zebu/README ============================================================================== --- (empty file) +++ vendor/zebu/README Wed Oct 17 09:04:46 2007 @@ -0,0 +1,69 @@ +; -*- mode: Text ------------------------------------------------ ; +; File: README +; Author: Joachim H. Laubsch, laubsch at cup.hp.com +*********************************************************** +;;; Copyright (c) 1989, Hewlett-Packard Company +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Hewlett-Packard Company +;;; makes no warranty about the software, its performance or its conformity +;;; to any specification. +;;; +;;; Suggestions, comments and requests for improvements are welcome +;;; and should be mailed to laubsch at hplabs.hpl.hp.com +;;; *********************************************************** + +Zebu is a kind of YACC, and was originally implemented in Scheme by +William M. Wells III. It generates an LALR(1) parsing table. To parse +a string with a grammar, only this table and a driver need to be +loaded. + +The present version of Zebu is an extension, rewritten in Common Lisp. +It contains the ability to define several grammars and parsers +simultaneously, a declarative framework for specifying the semantics, +capabilities to define and use meta-grammars (grammars to express a +grammar in), generation of unparsers (generators) using a 'reversible +grammar' notation, as well as efficiency related improvements. + +Zebu also contains a lexical analyzer which is based on the regular +expression compiler written by Lawrence E. Freil . + +Zebu compiles a grammar with 300 productions (including +dumping of the tables to disk) in approx 2 minutes and 30 seconds on a +HP 9000/370. + +This implementation has been tested in Lucid CL, Allegro CL, and +MCL 2.0b. + +For documentation look into the doc/ directory: + + Zebu_intro.tex contains an introduction to the Common Lisp + version and the enhancements. This is a LaTeX file. The PostScript + version is Zebu_intro.ps. + +The test/ directory contains a few examples. The file exercise.lisp runs +many of them. Most example files also have a commented section at the end +that suggest some tests. + +Other features, like grammar-names, string- or symbol-delimiters, +parameterization of lexical analysis, and modes of interpretation of +the grammar actions are also documented in zebu-loader.lisp. + +If you need help or have suggestions, send email to: + + laubsch at cup.hp.com + + Joachim H. Laubsch + Hewlett-Packard + 19477 Pruneridge Avenue (MS 47UI) + Cupertino, CA 95014 + + Tel 408-447-5211 + Fax 408-447-5229 + +************************************************************ Added: vendor/zebu/README.asdf-system ============================================================================== --- (empty file) +++ vendor/zebu/README.asdf-system Wed Oct 17 09:04:46 2007 @@ -0,0 +1,73 @@ + +These are system definition files for the Zebu parser compiler. Zebu +is a Lex/Yacc-sorta thing for Common Lisp. + +Zebu can be found found at +ftp://ftp.digitool.com/pub/MCL/contrib/zebu-3.5.5.tgz, among other +places. + +Read about Daniel Barlow's asdf (Another System Definition Facility) +at http://ww.telent.net/cliki/asdf + +I have written asdf system definition files, taking the original +system files as a guideline. The package definition file +zebu-package.lisp was rewritten, since it depended on some symbols +being present in the CL-USER package, amongst other things. The file +zebu-compile-mg.lisp was added to compile the metagrammar (can't call +zb:zebu-compile-file directly from the system files, since at read +time the "zebu" package does not exist yet). The file +zebu-asdf-setup.lisp was added to hook Zebu source files into asdf +itself. A asdf system component (:file "some-grammar.zb") should do +the right thing after loading Zebu itself. + +The one thing I was too lazy to do is rewrite #p"test;exercise.lisp". +This one still excepts some symbols in the CL-USER package that are +not there anymore (the original zebu-package.lisp imported them, and +every other file expects them to be within the ZEBU package anyway). + +Please report any installation problems to me. Note that I am not the +original author of Zebu itself, so I am unlikely to be able to help +you with hairy bugs in that system. + +Oh, yes, how to use it: + +- Prepare everything: +(asdf:operate 'asdf:load-op :zebu-compiler) +(zb:zebu-compile-file "my-grammar-file.zb") +(zb:zebu-load-file "my-grammar-file") +(setf zb:*current-grammar* (zb:find-grammar "my-grammar")) + +- Ok now, parse away: +(zb:file-parser "some-file") +(zb:read-parser "2*(3+4)=++foo:") + + +Notes: + +- Regrettably, Mr. Laubsch seems to be off the 'net at the moment. I +tried to contact him and got no reply; other people on comp.lang.lisp +reported similarly. I did not want to package a "new" version of Zebu +without his okay, especially since none of the core functionality is +changed and I did some package setup differently than him. Hence, the +distribution of a "diff" package to be installed over the original +sources. + +- Here is a list of files that I removed, since they are not needed if +you load Zebu via asdf: + +COMPILE-Zebu.lisp +Compile.lisp +INSTALL.* ; except \1.asdf, obviously :-) +machine +Makefile +shar-zebu +Tar-zebu +win* ; Yay! +ZEBU-init.lisp +zebu-package.lisp ; Replaced by new version +ZEBU-sys.lisp ; the .system files were modelled after this one + + +Have fun, + +Rudi Schlatte \ No newline at end of file Added: vendor/zebu/Version ============================================================================== --- (empty file) +++ vendor/zebu/Version Wed Oct 17 09:04:46 2007 @@ -0,0 +1 @@ +3.5.5 Added: vendor/zebu/doc/Zebu_intro.ps ============================================================================== --- (empty file) +++ vendor/zebu/doc/Zebu_intro.ps Wed Oct 17 09:04:46 2007 @@ -0,0 +1,3571 @@ +%!PS-Adobe-2.0 +%%Creator: dvipsk 5.58f Copyright 1986, 1994 Radical Eye Software +%%Title: Zebu_intro.dvi +%%Pages: 31 +%%PageOrder: Ascend +%%BoundingBox: 0 0 612 792 +%%EndComments +%DVIPSCommandLine: dvips Zebu_intro.dvi -o Zebu_intro.ps +%DVIPSParameters: dpi=600, compressed, comments removed +%DVIPSSource: TeX output 1999.01.13:1307 +%%BeginProcSet: texc.pro +/TeXDict 250 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N +/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72 +mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1} +ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale +isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div +hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul +TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if} +forall round exch round exch]setmatrix}N /@landscape{/isls true N}B +/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B +/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{ +/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N +string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N +end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{ +/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0] +N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup +length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{ +128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub +get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data +dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N +/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup +/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx +0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff +setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff +.1 sub]/id ch-image N /rw ch-width 7 add 8 idiv string N /rc 0 N /gp 0 N +/cp 0 N{rc 0 ne{rc 1 sub /rc X rw}{G}ifelse}imagemask restore}B /G{{id +gp get /gp gp 1 add N dup 18 mod S 18 idiv pl S get exec}loop}B /adv{cp +add /cp X}B /chg{rw cp id gp 4 index getinterval putinterval dup gp add +/gp X adv}B /nd{/cp 0 N rw exit}B /lsh{rw cp 2 copy get dup 0 eq{pop 1}{ +dup 255 eq{pop 254}{dup dup add 255 and S 1 and or}ifelse}ifelse put 1 +adv}B /rsh{rw cp 2 copy get dup 0 eq{pop 128}{dup 255 eq{pop 127}{dup 2 +idiv S 128 and or}ifelse}ifelse put 1 adv}B /clr{rw cp 2 index string +putinterval adv}B /set{rw cp fillstr 0 4 index getinterval putinterval +adv}B /fillstr 18 string 0 1 17{2 copy 255 put pop}for N /pl[{adv 1 chg} +{adv 1 chg nd}{1 add chg}{1 add chg nd}{adv lsh}{adv lsh nd}{adv rsh}{ +adv rsh nd}{1 add adv}{/rc X nd}{1 add set}{1 add clr}{adv 2 chg}{adv 2 +chg nd}{pop nd}]dup{bind pop}forall N /D{/cc X dup type /stringtype ne{] +}if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup +length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{ +cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin +0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul +add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict +/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook +known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X +/IE 256 array N 0 1 255{IE S 1 string dup 0 3 index put cvn put}for +65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0 +0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V +{}B /RV statusdict begin /product where{pop product dup length 7 ge{0 7 +getinterval dup(Display)eq exch 0 4 getinterval(NeXT)eq or}{pop false} +ifelse}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false +RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1 +false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform +round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg +rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail +{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M} +B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{ +4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{ +p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p +a}B /bos{/SS save N}B /eos{SS restore}B end +%%EndProcSet +TeXDict begin 40258431 52099146 1000 600 600 (Zebu_intro.dvi) + at start /Fa 1 111 df<3907C007E0391FE03FF83918F8783E393879E01E39307B801F38 +707F00126013FEEAE0FC12C05B00815C0001143E5BA20003147E157C5B15FC0007ECF808 +1618EBC00115F0000F1538913803E0300180147016E0001F010113C015E390C7EAFF0000 +0E143E251F7E9D2B>110 D E /Fb 4 118 df<003FBA12E0A71AC01A80CB120F4E130060 +614E5A18FF615F614D5B5F615F614D90C7FC5F60177F604D5A5E604C5B5E605E604C90C8 +FC5E5F167F5F4C5A5D5F5D5F4B5B5D5F4B90C9FCA24B5A157F5E4B5A5C5E5C5E4A5B5C5E +5C93CAFC4A5A147F5D14FF5D495B5B5D495B5B5D5B92CBFC495A137F5C13FF5C485B5A5C +5A5C485B5A91CCFC485A90BA12E05ABBFCA7436479E352>90 D98 +D<4AB4FC021F13E0027F13FC49B57E01076E7E498149814981498190B51201489039F800 +7FFC4849EB1FFE02C0130F48496D7E91C77E5A496E1380485A82484816C0177F5B127FA2 +4916E090B8FCB9FCA701C0CAFCA37FA3127FA27FA2123F7FA26C7E7F120F6D16406C6DEC +01C06E14036C6D140F6C01F8143F6C01FE903801FFE090397FFF801F6D90B6FC7F6D16C0 +6D16006D5D010015F8023F14C0020F49C7FC020013E033417CBF3C>101 +D117 D +E /Fc 24 122 df42 +D<007FB6FCB71280A46C150021067B9B2C>45 D<1307497EA2131FA2133F137F13FF5A12 +07127FB5FC13DF139FEA7C1F1200B3AE007FB512E0B612F0A36C14E01C3477B32C>49 +DI< +EB0FFC90387FFF8048B512E0000714F84880391FF807FEEBC0004848137F6D7F1680151F +A26C5A6CC7FCC8FC153F16005D15FE14014A5AEC1FF890381FFFF0495BA215F86D7F9038 +0007FEEC00FF81ED3F80ED1FC0150FA216E01507A2123C127EB4FC150F16C0A248141F00 +7FEC3F806DEB7F006C6C5B391FF807FE6CB55A6C5C6C14E0C66C1380D90FFCC7FC23357C +B32C>II<3801FFF0000713FE001F +6D7E15E048809038C01FF81407EC01FC381F80000006C77EC8127EA3ECFFFE131F90B5FC +1203120F48EB807E383FF800EA7FC090C7FC12FE5AA47E007F14FEEB8003383FE01F6CB6 +12FC6C15FE6C14BF0001EBFE1F3A003FF007FC27247CA32C>97 D<903803FFE0011F13F8 +017F13FE48B5FC48804848C6FCEA0FF0485A49137E4848131890C9FC5A127EA25AA8127E +A2127F6C140F6DEB1F806C7E6D133F6C6CEB7F003907FE03FF6CB55A6C5C6C6C5B011F13 +E0010390C7FC21247AA32C>99 DIII<1307EB1FC0A2497EA36D5AA20107C7FC90C8FCA7387FFFC0 +80B5FC7EA2EA0007B3A8007FB512FCB612FEA36C14FC1F3479B32C>105 +D107 D<387FFFE0B57EA37EEA0003B3B3A5007FB61280B712C0A36C158022337BB22C>I< +3A7F83F007E09039CFFC1FF83AFFDFFE3FFCD87FFF13FF91B57E3A07FE1FFC3E01FCEBF8 +3F496C487E01F013E001E013C0A301C01380B33B7FFC3FF87FF0027F13FFD8FFFE6D13F8 +D87FFC4913F0023F137F2D2481A32C>I<397FF01FE039FFF87FFC9038F9FFFE01FB7F6C +B6FC00019038F03F80ECC01F02807FEC000F5B5BA25BB3267FFFE0B5FCB500F11480A36C +01E0140029247FA32C>II<397FF01FE039FFF8FFF801FB13FE90B6FC6C15800001 +9038F07FC09138801FE091380007F049EB03F85BED01FC491300A216FE167EA816FE6D14 +FCA2ED01F86D13036DEB07F0150F9138801FE09138E07FC091B51280160001FB5B01F813 +F8EC3FC091C8FCAD387FFFE0B57EA36C5B27367FA32C>I<903903FC078090391FFF0FC0 +017F13CF48B512EF4814FF3807FE07380FF00148487E49137F4848133F90C7FC48141F12 +7E150F5AA87E007E141FA26C143F7F6C6C137F6D13FF380FF0033807FC0F6CB6FC6C14EF +6C6C138F6D130FEB07F890C7FCAD0203B5FC4A1480A36E140029367DA32C>II<90387FF8700003B512F8 +120F5A5A387FC00F387E00034813015AA36CEB00F0007F140013F0383FFFC06C13FE6CEB +FF80000314E0C66C13F8010113FCEB0007EC00FE0078147F00FC143F151F7EA26C143F6D +133E6D13FE9038F007FC90B5FC15F815E000F8148039701FFC0020247AA32C>I<131E13 +3FA9007FB6FCB71280A36C1500D8003FC8FCB1ED03C0ED07E0A5EC800F011FEB1FC0ECE0 +7F6DB51280160001035B6D13F89038003FE0232E7EAD2C>I<3A7FF003FF80486C487FA3 +007F7F0001EB000FB3A3151FA2153F6D137F3900FE03FF90B7FC6D15807F6D13CF902603 +FE07130029247FA32C>I<3A7FFF01FFFCB5008113FE148314816C010113FC3A03E0000F +806C7E151F6D140012005D6D133E137C017E137E013E137CA2013F13FC6D5BA2EB0F815D +A2EB07C1ECC3E0A2EB03E3ECE7C0130114F75DEB00FFA292C7FC80A2143EA2147E147CA2 +14FC5CA2EA0C01003F5BEA7F83EB87E0EA7E0F495A387FFF806C90C8FC6C5A6C5AEA07E0 +27367EA32C>121 D E /Fd 46 122 df12 D<13F0EA03F8EA07FC120FA6EA03CCEA001C1318A213381330A2 +137013E013C0120113801203EA0700120E5A5A5A5A5A0E1D6BC41E>39 +D<1560A2157081A281151E150E150FA2811680A3ED03C0A516E0A21501A71503A91507A2 +16C0A4150FA21680A2151FA21600A25DA2153EA2157EA2157C15FCA25D1401A25D14035D +A214075D140F5DA24AC7FCA2143EA25C147814F8495AA2495A5C1307495A91C8FC131E13 +3E5B13785B485A485A485A48C9FC121E5A5A12E05A23647FCA28>41 +D<007FB5FCB6FCA214FEA21805789723>45 D<120FEA3FC0127FA212FFA31380EA7F0012 +3C0A0A76891E>I<16C01501A215031507ED0F80151F153F157F913801FF005C140F147F +903807FCFEEB0FF0EB0700EB00015DA314035DA314075DA3140F5DA3141F5DA3143F5DA3 +147F92C7FCA35C5CA313015CA313035CA313075CA2130FA2131F133FB612FCA25D224276 +C132>49 DI65 +D67 +D<91B712F818FF19C00201903980003FF06E90C7EA0FF84AED03FCF000FE4B157FA2F13F +800203EE1FC05DF10FE0A214074B16F01907A2140F5D1AF8A2141F5DA2190F143F5D1AF0 +A2147F4B151FA302FF17E092C9123FA34918C04A167F1A80A2010317FF4A1700A24E5A13 +074A4B5A611807010F5F4A4B5A181F61011F4C5A4A4BC7FC18FE4D5A013F4B5A4A4A5A4D +5A017FED3FC005FFC8FC4AEB03FE01FFEC1FF8B812E094C9FC16F845447AC34A>I<91B9 +12C0A30201902680000313806E90C8127F4A163F191F4B150FA30203EE07005DA314074B +5D190EA2140F4B1307A25F021F020E90C7FC5DA2171E023F141C4B133C177C17FC027FEB +03F892B5FCA39139FF8003F0ED00011600A2495D5CA2160101034B13705C19F061010791 +C8FC4A1501611803010F5F4A150796C7FC60131F4A151E183E183C013F167C4A15FC4D5A +017F1503EF0FF04A143F01FF913803FFE0B9FCA26042447AC342>I71 D<027FB512E091B6FCA2 +0200EBE000ED7F8015FFA293C7FCA35C5DA314035DA314075DA3140F5DA3141F5DA3143F +5DA3147F5DA314FF92C8FCA35B5CA313035CA313075CA3130F5CA3131F5CA2133FA25CEB +FFE0B612E0A25D2B447BC326>73 D<91B612F0A25F020101C0C7FC6E5B4A90C8FCA25DA3 +14035DA314075DA3140F5DA3141F5DA3143F5DA3147F5DA314FF92C9FCA35B5CA3010316 +104A1538A21878010716705C18F018E0010F15015C18C01703011F15074A1580170FA201 +3FED1F004A5C5F017F15FE16034A130F01FFEC7FFCB8FCA25F35447AC33D>76 +D<91B56C93387FFFC08298B5FC02014DEBC0006E614A5FA203DF4C6CC7FC1A0E63912603 +CFE05D038F5F1A381A711407030FEEE1FCA2F101C3020FEE0383020E60F107036F6C1507 +021E160E021C60191CF1380F143C023804705BA2F1E01F0278ED01C091267003F85EF003 +801A3F02F0ED070002E0030E5CA24E137F130102C04B91C8FC606201036D6C5B02805F4D +5A943803800113070200DA07005BA2050E1303495D010E606F6C5A1907011E5D011C4B5C +A27048130F133C01384B5C017892C7FC191F01F85C486C027E5DD807FE027C4A7EB500F0 +0178013FB512C0A216705A447AC357>I<91B56C49B512E0A28202009239000FFC00F107 +F0706E5A4A5F15DF705D1907EC03CFDB8FF892C7FCA203875D02077F0303150EA270141E +EC0F01020E161C826F153C141E021C6E1338167F1978023C800238013F1470A27113F002 +78131F02705E83040F130102F014F84A5E1607EFFC0313014A01035C17FE180701031401 +4A02FF90C8FCA2705B0107168F91C8138E177F18DE5B010EED3FDC18FCA2011E151F011C +5EA2170F133C01386F5A1378A201F81503486C5EEA07FEB500F01401A2604B447AC348> +I<91B712F018FEF0FF800201903980007FE06E90C7EA1FF04AED07F818034B15FCF001FE +1403A24B15FFA21407A25DA2140FF003FE5DA2021F16FC18074B15F8180F023F16F0F01F +E04B15C0F03F80027FED7F0018FE4BEB03FCEF0FF002FFEC7FC092B6C7FC17F892CAFC5B +A25CA21303A25CA21307A25CA2130FA25CA2131FA25CA2133FA25CA2137FA25C497EB67E +A340447AC342>80 D<91B77E18F818FE020190398001FF806E90C7EA3FC04AED1FE0F00F +F04BEC07F8180319FC14034B15FEA314075DA3020FED07FC5DA2F00FF8141F4B15F0F01F +E0F03FC0023F16804BEC7F0018FEEF03F8027F4A5A4BEB1FC04CB4C7FC92B512F891B612 +E092380003F8EE00FE177F496F7E4A6E7EA28413034A140FA2171F13075CA2173F130F5C +A24D5A131F5CA3013F170E5CA2017FEE801E191C4A163C496C1638B66C90383FC070051F +13F094380FE1E0CA3803FF80943800FE003F467AC347>82 DI<48B912F85AA2913B0007FC001FF0D807F84A130701E001 +0F140349160148485C90C71500A2001E021F15E05E121C123C0038143F4C1301007818C0 +127000F0147F485DA3C800FF91C7FC93C9FCA35C5DA314035DA314075DA3140F5DA3141F +5DA3143F5DA3147F5DA314FF92CAFCA35B5CA21303A21307497E007FB612C0A25E3D446F +C346>I<001FB500F090383FFFFCA326003FF0C7000113806D48913800FE00013F167C18 +785C187018F0017F5E5CA2170101FF5E91C8FCA21703485F5BA21707000394C7FC5BA25F +0007160E5BA2171E120F49151CA2173C121F491538A21778123F491570A217F0127F495D +A2160100FF5E90C8FCA216035F16074893C8FC5E160E161E5E007E1538007F15785E6C4A +5A6D495A001F4A5A6D49C9FC6C6C133E6C6C13F83903FC07F0C6B512C0013F90CAFCEB07 +F83E466DC348>II97 DIIIII<15FCEC03FF9139 +0F83838091393E01CFC091387C00EF4A13FF4948137F010315804948133F495A131F4A14 +00133F91C75A5B167E13FE16FE1201495CA215011203495CA21503A2495CA21507A25EA2 +150F151F5E0001143F157F6C6C13FF913801DF8090387C039F90383E0F3FEB0FFCD903F0 +90C7FC90C7FC5DA2157EA215FEA25DA2001C495A127F48495A14074A5A485C023FC8FC00 +F8137E387C01F8381FFFE0000390C9FC2A407BAB2D>I<14FE137FA3EB01FC13001301A2 +5CA21303A25CA21307A25CA2130FA25CA2131FA25C157F90393F83FFC091388F81F09138 +1E00F802387F4948137C5C4A137EA2495A91C7FCA25B484814FE5E5BA2000314015E5BA2 +000714035E5B1507000F5DA249130F5E001F1678031F1370491480A2003F023F13F0EE00 +E090C7FC160148023E13C01603007E1680EE070000FEEC1E0FED1F1E48EC0FF80038EC03 +E02D467AC432>I<143C147E14FE1301A3EB00FC14701400AE137C48B4FC3803C7803807 +03C0000F13E0120E121C13071238A21278EA700F14C0131F00F0138012E0EA003F1400A2 +5B137EA213FE5B12015BA212035B141E0007131C13E0A2000F133CEBC038A21478EB8070 +14F014E0EB81C0EA0783EBC7803803FE00EA00F8174378C11E>I<16F0ED03F8A21507A3 +16F0ED01C092C7FCAEEC01F0EC07FCEC1E1EEC380F0270138014E0130114C0EB03800107 +131F1400A2130E153F131E011C140090C7FC5DA2157EA215FEA25DA21401A25DA21403A2 +5DA21407A25DA2140FA25DA2141FA25DA2143FA292C7FCA25C147EA214FE001C5B127F48 +485A495AA248485A495AD8F81FC8FCEA707EEA3FF8EA0FC0255683C11E>I<14FE137FA3 +EB01FC13001301A25CA21303A25CA21307A25CA2130FA25CA2131FA25C167E013F49B4FC +92380783C09138000E07ED3C1F491370ED603F017E13E0EC01C09026FE03801380913907 +000E00D9FC0E90C7FC5C00015B5C495AEBF9C03803FB8001FFC9FCA214F03807F3FCEBF0 +7F9038E01FC06E7E000F130781EBC003A2001F150FA20180140EA2003F151E161C010013 +E0A2485DA2007E1578167000FE01015B15F1489038007F800038021FC7FC2A467AC42D> +IIIIII114 DI<1470EB01F8A313035CA313075CA3130F5CA3131F5CA2007FB512E0B6FC15 +C0D8003FC7FCA25B137EA313FE5BA312015BA312035BA312075BA3120F5BA2EC0780001F +140013805C140E003F131EEB001C143C14385C6C13F0495A6C485AEB8780D807FEC7FCEA +01F81B3F78BD20>I<137C48B414072603C780EB1F80380703C0000F7F000E153F121C01 +07150012385E1278D8700F147E5C011F14FE00F05B00E05DEA003FEC0001A2495C137E15 +0313FE495CA215071201495CA2030F13380003167849ECC070A3031F13F0EE80E0153F00 +011581037F13C06DEBEF8300000101148090397C03C787903A3E0F07C70090391FFE01FE +903903F000782D2D78AB34>I<017C143848B414FC3A03C78001FE380703C0000F13E012 +0E001C14000107147E1238163E1278D8700F141E5C131F00F049131C12E0EA003F91C712 +3C16385B137E167801FE14705BA216F0000115E05B150116C0A24848EB0380A2ED0700A2 +150E12015D6D5B000014786D5B90387C01E090383F0780D90FFFC7FCEB03F8272D78AB2D +>I<017CEE038048B4020EEB0FC02603C780013FEB1FE0380703C0000E7F5E001C037E13 +0F01071607123804FE130300785DEA700F4A1501011F130100F001804914C012E0EA003F +DA000314034C14805B137E0307140701FE1700495CA2030F5C0001170E495CA260A24848 +495A60A2601201033F5C7F4B6C485A000002F713036D9039E7E0078090267E01C349C7FC +903A1F0781F81E903A0FFF007FF8D901FCEB0FE03B2D78AB41>I<02F8133FD907FEEBFF +E0903A0F0F83C0F0903A1C07C780F890393803CF03017013EE01E0EBFC07120101C013F8 +000316F00180EC01C000074AC7FC13001407485C120EC7FC140F5DA3141F5DA3143F92C8 +FCA34AEB03C01780147EA202FEEB0700121E003F5D267F81FC130E6E5BD8FF83143CD903 +BE5B26FE079E5B3A7C0F1F01E03A3C1E0F83C0271FF803FFC7FC3907E000FC2D2D7CAB2D +>I<137C48B414072603C780EB1F80380703C0000F7F000E153F001C1600130712385E00 +78157EEA700F5C011F14FE00F0495B12E0EA003FEC00015E5B137E150301FE5C5BA21507 +00015D5BA2150F00035D5BA2151F5EA2153F12014BC7FC6D5B00005BEB7C0390383E0F7E +EB1FFEEB03F090C712FE5DA214015D121F397F8003F0A24A5A4848485A5D48131F00F049 +C8FC0070137E007813F8383801F0381E07C06CB4C9FCEA01FC294078AB2F>I +E /Fe 7 111 df<49B4FC010F13E0013F13F8497F48B6FC4815804815C04815E04815F0 +A24815F84815FCA3B712FEAA6C15FCA36C15F86C15F0A26C15E06C15C06C15806C15006C +6C13FC6D5B010F13E0010190C7FC27267BAB32>15 D102 D<12FEEAFFE0EA07F8EA00FEEB7F806D7E6D +7E130F6D7EA26D7EB3AD6D7EA26D7E806E7E6E7EEC0FE0EC03FC913800FFE0A2913803FC +00EC0FE0EC3FC04A5A4AC7FC5C495AA2495AB3AD495AA2495A131F495A495A01FEC8FCEA +07F8EAFFE048C9FC236479CA32>I<140C141E143EA2143C147CA214F8A214F01301A2EB +03E0A214C01307A2EB0F80A214005BA2133EA2133C137CA2137813F8A2485AA25B1203A2 +485AA25B120FA248C7FCA2121E123EA25AA2127812F8A41278127CA27EA2121E121FA26C +7EA212077FA26C7EA212017FA26C7EA21378137CA2133C133EA27FA27F1480A2EB07C0A2 +130314E0A2EB01F0A2130014F8A2147CA2143C143EA2141E140C176476CA27>I<126012 +F07EA21278127CA27EA2121E121FA26C7EA212077FA26C7EA212017FA26C7EA21378137C +A2133C133EA27FA27F1480A2EB07C0A2130314E0A2EB01F0A2130014F8A2147CA2143C14 +3EA4143C147CA214F8A214F01301A2EB03E0A214C01307A2EB0F80A214005BA2133EA213 +3C137CA2137813F8A2485AA25B1203A2485AA25B120FA248C7FCA2121E123EA25AA21278 +12F8A25A126017647BCA27>I<126012F0B3B3B3B3B3A81260046474CA1C>I<126012F07E +A21278127CA2123C123EA2121E121FA26C7EA212077FA212037FA212017FA26C7EA21378 +137CA2133C133EA2131E131FA26D7EA2130780A2130380A2130180A26D7EA21478147CA2 +143C143EA280A28081A2140781A2140381A26E7EA2140081A21578157CA2153C153EA281 +A2811680A2150716C0A2150316E0A2ED01F0A2150016F8A21678167CA2163C163EA2161E +160C27647BCA32>110 D E /Ff 91 127 df<121C127FEAFF80B3A3EA7F00B3A2123EC7 +FCA9121C127FA2EAFF80A3EA7F00A2121C093E6BBD33>33 D<00085B003EEB07C0007FEB +0FE0A24814F0A26C14E0B3A2007E1307003E14C0A20008EB01001C1E75BD33>I<903903 +E001F0A2496C487EA8010F1307A202E05BA4007FB712E0A2B812F0A36C16E06C16C03B00 +1FC00FE000013F131FA202805BA9017F133FA202005B003FB712C04816E0B812F0A36C16 +E0A2C648C66CC7FCA400015CA2495BA86C48137CA22C3D7DBC33>I37 DII<140FEC3F80147F14FF491300495AEB07F8495A495A495A495A49C7FC5B12015B485A +12075B120F5B121F5BA2123F5BA2127F90C8FCA45A5AAD7E7EA47F123FA27F121FA27F12 +0F7F12077F12036C7E7F12007F6D7E6D7E6D7E6D7E6D7EEB03FE6D7E6D1380147F143FEC +0F00194D6FC433>I<127812FE7E7F6C7E6C7EEA0FF06C7E6C7E6C7E6C7E6D7E133F8013 +1F6D7E801307801303801301A2801300A28080A41580143FAD147F1500A45C5CA213015C +A213035C13075C130F5C495A133F5C137F49C7FC485A485A485A485AEA3FE0485A485A90 +C8FC5A1278194D78C433>I<14F0497EA8007015E000F8EC01F000FE140700FF140F01C1 +133F01F113FF263FF9F913C0000FB61200000314FCC614F06D5B011F1380D907FEC7FC90 +381FFF80017F13E090B57E000314FC000F14FF263FF9F913C026FFF1F813F001C1133F01 +01130F00FE140700F814010070EC00E000001500A86D5A242B79B333>I<141FA24A7EB0 +007FB71280A2B812C0A36C1680A2C7D83F80C7FCB06EC8FCA22A2B7CB333>II<007FB612FEA2B8FCA36C15FEA228077B +A133>I<121FEA3F80EA7FC0EAFFE0A5EA7FC0EA3F80EA1F000B0B6C8A33>I<167816F8ED +01FCA21503A2ED07F8A2ED0FF0A2ED1FE0A216C0153FA2ED7F80A2EDFF00A24A5AA25D14 +03A24A5AA24A5AA24A5AA25D143FA24A5AA24AC7FCA2495AA25C1303A2495AA2495AA25C +131FA2495AA2495AA249C8FCA25B1201A2485AA2485AA2485AA25B121FA2485AA2485AA2 +48C9FCA25AA2127CA2264D7AC433>I<14FF010313C0010F13F0497F497F497F9038FF81 +FF3A01FE007F804848EB3FC049131F4848EB0FE0A24848EB07F0A24848EB03F8A24848EB +01FCA348C812FEA4007E157E00FE157FAE6C15FF6C15FEA46D1301003F15FCA26D130300 +1F15F8A26C6CEB07F0A26C6CEB0FE06D131F6C6CEB3FC0A26CB4EBFF806C018113006DB4 +5A6D5B6D5B6D5B010313C0010090C7FC283F7BBD33>III<90 +3801FFC0010F13F8013F13FF90B67E48814881489038807FF03A0FFC000FF801F06D7E48 +4813036F7EA21500A26C5A6C5AC9FC15015EA215034B5A150F4B5A4B5A913803FFC00103 +B55A4991C7FC5D8116C06D8090C76C7EED0FF8ED03FC6F7E6F7E821780163FA2EE1FC0A3 +123C127EB4FCA2163F1780167F6C16006D5C6D495A6C6C1303D81FF8EB0FFC3A0FFF807F +F86C90B55A6C5D6C15806C6C91C7FC010F13FC010113C02A3F7CBD33>I<15FF4A7F5C5C +A25C5C15DFEC3F9FA2EC7F1F14FEA2EB01FCA2EB03F8EB07F0A2EB0FE0EB1FC0A2EB3F80 +A2EB7F0013FEA2485A12035B485AA2485A485AA2485AA248C7FC12FEB812E017F0A46C16 +E0C8381F8000AC021FB512804A14C04A14E0A26E14C06E14802C3E7DBD33>I<0007B612 +F04815F85AA316F001C0C8FCB0ECFFC001C713F801DF7F90B6FC168016C0028013E09039 +FC001FF001F0EB0FF849130749EB03FC6C4813016CC713FEC9FCA216FF167FA41218127E +A2B415FF16FEA24814016C15FC6C14036DEB07F86D130F6C6CEB1FF06C6CEB7FE09039FE +03FFC06CB612806C150000015C6C14F8013F13E0010390C7FC283E7BBC33>II56 D<49B47E010F13E0013F13F84913FE90B6FC0003158048018113C09038FC00 +7F4848EB1FE04848EB0FF0485A49EB07F84848130390C7FCED01FC5A5A16FE1500A416FF +A37E7E6D5BA26C6C5B6D5B6C6C5B6C6C5BD807FE137F90B7FC6C157F6C14FC6C6CEBF8FF +6DEBE0FE010F1380903800200091C7FC150116FCA2150316F8150716F0000F140F486CEB +1FE0486C133F16C0EDFF804A13004A5A381FF01F90B512F86C5C6C5C6C1480C649C7FCEB +3FF0283F7BBD33>I<121FEA3F80EA7FC0EAFFE0A5EA7FC0EA3F80EA1F00C7FCB3A3121F +EA3F80EA7FC0EAFFE0A5EA7FC0EA3F80EA1F000B2B6CAA33>II<1608163E16FF5D15075DED3FFEED7FFC913801FFF0020713E04A1380023F1300EC +7FFC49485A4913E0010F13804990C7FCEB7FFC495A000313E0485B001F90C8FCEA7FFE13 +F8485A13C013F06C7E13FEEA1FFF000713C06C7FC613F86D7EEB1FFF6D7F010313E06D13 +F86D6C7E6EB4FC020F13806E13E0020113F09138007FFCED3FFEED0FFF81150181163E16 +0828337BB733>I<007FB71280A2B812C0A36C16806C1600CBFCA9003FB7FC481680B812 +C0A36C1680A22A177CA933>I<1210127CB4FC7F13E07FEA7FFC6C7E380FFF806C13E000 +017F6C13FCEB3FFE6D6C7E01077F010113F06D7FEC3FFE6E7E020713C06E13E0020013F8 +ED7FFE151FED0FFF1503150FED1FFE157FEDFFF8020313E04A13C0021F13004A5AECFFF8 +495B010713C0011F5B4948C7FCEBFFFC4813F000075B481380D83FFEC8FC485AEAFFF05B +138090C9FC127C121028337BB733>I<90380FFF80017F13F848B512FE0007ECFF804815 +C04815E0263FFC0113F03A7FE0001FF80180130748C7EA03FC5A6C1401A3127E15030018 +EC07F8C8121FED3FF0EDFFE04A13C04A1380913807FE004A5A4A5AEC3FE05D4A5A4AC7FC +A2495A5CA213035CA96D5A90C9FCA914E0EB03F8A2497EA36D5AA2EB00E0263E7ABD33> +I65 D<007FB512F8B7FC16C082826C813A03F8000FFCED03FE15016F7E82A2 +EE3F80A7EE7F00A25E4B5AA2ED07FCED1FF890B65A5E1680828216F89039F8000FFCED01 +FE6F7EEE7F80163F17C0161FA2EE0FE0A7161F17C0A2163FEE7F8016FF4B1300150F007F +B65AB75A5E16E05E6C4AC7FC2B3D7DBC33>I<91391FE00780DAFFFC13C00103EBFF0F01 +0F148F4914FF5B90387FF81F9038FFC00748497E4848487E497F485A167F485A49143F12 +1F5B003F151F5BA2127F90C8EA0F8093C7FCA25A5AAD7E7EA36DEC0F80003FED1FC0A27F +121F7F000F153F6D15806C7E167F6C6CECFF007F3A01FF8003FE6C6D485A90397FF81FF8 +6DB55A6D5C6D5C010391C7FC010013FCEC1FE02A3F7CBD33>I<003FB512F04814FCB7FC +826C816C813A03F8007FF0ED1FF8ED07FC15036F7E8281EE7F80A2163F17C0161FA217E0 +160FA4EE07F0AD160F17E0A4161F17C0163FA21780167FEEFF00A24B5A15034B5AED1FF8 +ED7FF0003FB6FC4815C0B75A93C7FC6C14FC6C14F02C3D7EBC33>I<003FB712E04816F0 +B8FCA27E7ED801FCC71207A8EE03E093C7FCA6151F4B7EA490B6FCA69038FC003FA46FC7 +FC92C8FCA817F8EE01FCA9003FB7FC5AB8FCA27E6C16F82E3D7EBC33>I<003FB712E048 +16F0B8FCA27E7ED801FCC71207A8EE03E093C7FCA7151F4B7EA490B6FCA69038FC003FA4 +6FC7FC92C8FCB1383FFFF8487FB57EA26C5B6C5B2C3D7DBC33>I<91387F803C903901FF +F03E0107EBFC7E011F13FE49EBFFFE5B9038FFE07F48EB803FEC000FEA03FC0007140749 +1303485A491301121F5B123F491300A2127F90C8FC167C93C7FCA25A5AA992387FFFC092 +B512E0A37E6C6E13C0923800FE00A36D1301123FA27F121F6D1303120F7F6C6C1307A26C +6C130F6C6C131F9038FF803F6CEBE0FF6DB5FC7F6D13FE010713F80101EBF07C9026007F +80C7FC2B3F7CBD33>I<3B7FFFC00FFFF8B56C4813FCA46C496C13F8D803F8C7EA7F00B3 +A290B7FCA601F8C77EB3A53B7FFFC00FFFF8B56C4813FCA46C496C13F82E3D7EBC33>I< +003FB612804815C0B712E0A26C15C06C1580260003F8C7FCB3B3AD003FB612804815C0B7 +12E0A26C15C06C1580233D78BC33>I<49B512F84914FC16FEA216FC6D14F890C7EA7F00 +B3B3A5123C127EB4FCA25D5D1401397F8007FC9038F01FF86CB5FC6C5C6C14C000035CC6 +49C7FCEB1FF0273E79BC33>II<387FFF +F8B57E80A25C6C5BD801FCC9FCB3B3A3EE03E0EE07F0A9007FB7FCB8FCA46C16E02C3D7D +BC33>II< +D87FFC90381FFFE0486C4913F07FA36C6D6C13E00003913800FC0013F780A213F380A3EB +F1F0A38013F0A280A2147C147EA2143E143FA2801580A3140F15C0A2140715E0A2140315 +F0A21401A215F81400A3157CA3153C153EA2151E151F387FFF80B5EAC00FA315076C496C +5A2C3D7DBC33>I<90381FFFF890B6FC000315C0000F15F0A24815F83A3FFC003FFC01E0 +13074913034848EB01FEA290C8FCA500FE157FB3AC6C15FF6C15FEA46D1301A36C6CEB03 +FC01F0130F01FC133F6CB612F86C15F0A2000315C0C61500011F13F8283F7BBD33>I<00 +3FB512FC48ECFF80B712E016F86C816C813A01FC000FFF030313801500EE7FC0163FEE1F +E0160FA217F01607A6160F17E0A2161FEE3FC0167FEEFF801503030F130090B65A5E5E16 +E0168003FCC7FC01FCC9FCB3383FFFE0487FB57EA26C5B6C5B2C3D7EBC33>I<90381FFF +F890B6FC000315C0000F15F0A24815F83A3FFC003FFC01F0130F01C013034848EB01FEA2 +90C8FCA54815FF48157FB3AA143F6C90387F80FF6C15FEEC3FC0A2EC1FE0A29038800FF1 +A23A3FC007FBFC01F013FFEBFC036CB612F86C15F0A2000315C0C61500011F148090C7EA +7FC0153F16E0151F16F0150F16F8150716FC150316FE1501ED00FC284C7BBD33>I<007F +B57EB612F815FE81826C812603F8007FED3FF0ED0FF815076F7E1501A26F7EA74B5AA215 +034B5A150FED3FF0EDFFE090B65A5E93C7FC5D8182D9F8007F153F6F7E150F821507AA17 +3E177FA416F8030313FF267FFFC014FEB538E001FF17FC81EE7FF86C49EB3FF0C9EA0FC0 +303E7EBC33>II<003FB712F84816FCB8FCA43AFE000FE001A800 +7CED00F8C71500B3B3A40107B512C049804980A26D5C6D5C2E3D7EBC33>I<273FFFE001 +B5FC486D481480B56C4814C0A26C496C14806C496C1400D801FCC7EA0FE0B3B3A36D141F +00005EA26D143F6D5DA26D6C49C7FC6E5B6D6C485AECF00390390FFC0FFC6DB55A6D5C6D +5C6D6C1380DA1FFEC8FCEC07F8323E80BC33>III<3A3FFF807FFF486DB51280A46C496C13003A01FE +000FE0151F6C7E4B5AEB7F805E90383FC07F93C7FC6D6C5A5DEB0FF15DEB07FB5DEB03FF +5D7F5D7F5D147F6E5AA34A7EA24A7E815B81EB03FB81EB07F181EB0FE081011F7F02C07F +013F133F02807F017F131F02007F49130F49801507000181491303000381491301D87FFF +90380FFFE0B56C4813F05DA2816C496C13E02C3D7DBC33>II<001FB612FE48815AA490C7EA01FE4B5AA24B5A5E150F4B5AA2003E4A5AC848 +5AA24BC7FC5D14014A5AA24A5A4A5AA24A5A5D143F4A5AA24AC8FC495AA2495A5C130749 +5AA2495A495AA2495A91C9FC5B4848141FEE3F80485A485AA2485A5B121F485AA2485A90 +B7FCB8FCA46C1600293D7BBC33>I<007FB512C0B612E0A415C048C8FCB3B3B3ABB612C0 +15E0A46C14C01B4D6CC433>I<127CA212FEA27EA26C7EA26C7EA26C7EA2120F7FA26C7E +A26C7EA26C7EA212007FA26D7EA26D7EA26D7EA2130F80A26D7EA26D7EA2130180A26D7E +A26E7EA26E7EA2141F81A26E7EA26E7EA26E7EA2140181A26E7EA2ED7F80A2ED3FC0A215 +1F16E0A2ED0FF0A2ED07F8A2ED03FCA21501A2ED00F81678264D7AC433>I<007FB512C0 +B612E0A47EC7120FB3B3B3AB007FB5FCB6FCA46C14C01B4D7DC433>II<007FB612FEA2B8FCA36C15FEA228077B7D33>I<131C13 +7E13FE12011203EA07FCEA0FF0EA1FE013C0EA3F80A2EA7F00127EA212FE5AA6EAFFC013 +E013F0127FA2123FA2EA1FE0EA07C00F1E6EC333>III< +ECFFF0010713FE011FEBFF804914C04914E048B612F048EBC01F9038FE000F485A485A48 +48EB07E049EB03C0484890C7FC5BA2127F90C9FCA25A5AA97E7EA27F003FEC01F06DEB03 +F86C7E6D13076C6C14F06C6C130F01FFEB1FE06CEBE07F6C90B512C06C1580013F14006D +13FC01075B010013C0252E79AC33>III< +ED3FE0913801FFFC020713FE141F4A13FF5CECFFC015004948137E4A133C010314005CA8 +003FB612F84815FCB7FCA36C15F8260003F8C7FCB3AD003FB612804815C0A46C1580283E +7DBD33>III<14E0EB03F8A2497EA36D5AA2EB00E091C8FCAA383FFFF8487FA47EEA0001B3AD +007FB612C0B712E016F0A216E06C15C0243E78BD33>I<1570EC01FCA2EC03FEA3EC01FC +A2EC00701500AA90383FFFFC4913FE90B5FCA27F7F90C7FCB3B3A9140115FCA21218007E +EB03F81407B414F0140F9038803FE090B512C06C14806C14006C5B6C13F8000113E01F55 +7BBD33>II<383FFFFC487FB5FCA27E7EC7 +FCB3B3AD003FB612F84815FCB712FEA26C15FC6C15F8273D7ABC33>I<02FC137E3B7FC3 +FF01FF80D8FFEF01877F90B500CF7F15DF92B57E6C010F13872607FE07130301FC01FE7F +9039F803FC01A201F013F8A401E013F0B3A53C7FFE0FFF07FF80B548018F13C0A46C486C +01071380322C80AB33>I<4AB4FC263FFC0713C0267FFE1F13F000FF017F7F91B5FC6CB6 +7E6CEC07FEC6EBF801ECF0004A7F4A7F5CA291C7FCA35BB3A43B3FFFF80FFFFC486D4813 +FEB56C4813FFA26C496C13FE6C496C13FC302C7FAB33>III<02FF137C0107EBE0FE011F13F0017F13FC90B512FE +4814FF4813C03907FE003F4848131F01F0130F484813071503485A491301127F90C7FC15 +005A5AA97E7E15017F123F6D130315076C7E6C6C130F6D131FD807FE137F3903FF81FF6C +EBFFFE6C14FC6D13F86D13F0010F13C0903801FE0090C8FCAF92387FFFFC92B512FEA46F +13FC2F427CAB33>II<90381FFE0F90B5EA8F80000314FF120F5A5AEBF007 +387F800190C7FC00FE147F5A153FA37E007FEC1F0001C090C7FCEA3FF8EBFFC06C13FF6C +14E0000314F8C680011F13FF01001480020713C0EC007FED1FE0007C140F00FEEC07F015 +03A27EA27F15076D14E06D130F6DEB3FC09038FE01FF90B61280160000FD5C00FC14F8D8 +F83F13E0D8780790C7FC242E79AC33>III<3B3FFFC00FFFF0486D4813F8B5 +6C4813FCA26C496C13F86C496C13F0D801F8C7EA7E006D14FE00005DA26D1301017E5CA2 +017F13036D5CA2EC8007011F5CA2ECC00F010F5CA36D6C485AA3ECF03F010391C7FCA26E +5A0101137EA2ECFCFE01005BA214FF6E5AA36E5AA26E5A6E5A2E2B7EAA33>I<3B7FFF80 +07FFF8B56C4813FC6E5AA24A7E6C496C13F8D80FC0C7EA0FC06D141F00071680A56D143F +00031600A3EC0FC0EC1FE0A23A01F83FF07EA3EC7FF8147CA20000157C9039FCFCFCFCA3 +ECF87CA2017C5C017D137EECF03EA2017F133FA26D486C5AA3ECC00F90390F8007C02E2B +7EAA33>I<3B3FFFC07FFF80486DB512C0B500F114E0A26C01E014C06C496C13803B00FE +000FE000017F495AEB3F804B5A6D6C48C7FC90380FE07E903807F0FEECF1FC903803FBF8 +EB01FF6D5B5D6E5A143F6E5A143F814A7E14FF903801FBF0ECF9F8903803F1FCEB07E015 +7E90380FC07F011F6D7E90383F801F02007F496D7E01FE6D7E484813033B7FFFC03FFFE0 +B56C4813F0A46C496C13E02C2B7DAA33>I<3B7FFF801FFFE0B56C4813F06E4813F8A24A +6C13F06C496C13E0D803F8C7EAFC00000114015E7F000014036D5C137EA2017F495A7FA2 +6E485A131FA26D6C485AA214E0010749C7FCA214F01303157EEB01F8A2157C010013FC14 +FC5D147C147DEC3FF0A36E5AA36E5AA2141F5DA2143F92C8FCA3147EA214FE003F5B1301 +387F81F81383EB87F0139FEBFFE06C5B5C6C90C9FCEA0FFCEA03F02D427DAA33>I<000F +B712804816C05AA317800180C713004B5A4B5A4B5A4B5A6CC7485AC8485A4B5A4BC7FC4A +5A4A5A4A5A4A5A4A5A4A5A4A5A4AC8FC495A495A495A495A495A495A495A49C7EA0F8048 +48EC1FC0485A485A485A485A485A48B7FCB8FCA46C16802A2B7DAA33>II<127CA212FEB3B3B3B3127CA2074D6AC433>II<013E13079039FF800F8000039038C01FC048EBE03F48 +EBF07F489038F9FF803A7FE7FFFE00D8FF835B01015B486C5B007CEB7FC00038011FC7FC +220C78BC33>I E /Fg 44 123 df12 D42 D46 D<157815FC14031407141F14FF130F0007B5FCB6FCA2147F13F0EAF800C7FC +B3B3B3A6007FB712FEA52F4E76CD43>49 DI<91380F +FFC091B512FC0107ECFF80011F15E090263FF8077F9026FF800113FC4848C76C7ED803F8 +6E7E491680D807FC8048B416C080486D15E0A4805CA36C17C06C5B6C90C75AD801FC1680 +C9FC4C13005FA24C5A4B5B4B5B4B13C04B5BDBFFFEC7FC91B512F816E016FCEEFF80DA00 +0713E0030113F89238007FFE707E7013807013C018E07013F0A218F8A27013FCA218FEA2 +EA03E0EA0FF8487E487E487EB57EA318FCA25E18F891C7FC6C17F0495C6C4816E001F04A +13C06C484A1380D80FF84A13006CB44A5A6CD9F0075BC690B612F06D5D011F1580010302 +FCC7FCD9001F1380374F7ACD43>I<177C17FEA2160116031607160FA2161F163F167FA2 +16FF5D5DA25D5DED1FBFED3F3F153E157C15FCEC01F815F0EC03E01407EC0FC01580EC1F +005C147E147C5C1301495A495A5C495A131F49C7FC133E5B13FC485A5B485A1207485A48 +5A90C8FC123E127E5ABA12C0A5C96C48C7FCAF020FB712C0A53A4F7CCE43>III<171F4D7E4D7EA24D7EA34C7FA24C7FA34C7FA34C7FA24C7F +A34C8083047F80167E8304FE804C7E03018116F8830303814C7E03078116E083030F814C +7E031F81168083033F8293C77E4B82157E8403FE824B800201835D840203834B80020783 +5D844AB87EA24A83A3DA3F80C88092C97E4A84A2027E8202FE844A82010185A24A820103 +854A82010785A24A82010F855C011F717FEBFFFCB600F8020FB712E0A55B547BD366>65 +D<932601FFFCEC01C0047FD9FFC013030307B600F81307033F03FE131F92B8EA803F0203 +DAE003EBC07F020F01FCC7383FF0FF023F01E0EC0FF94A01800203B5FC494848C9FC4901 +F8824949824949824949824949824990CA7E494883A2484983485B1B7F485B481A3FA248 +49181FA3485B1B0FA25AA298C7FC5CA2B5FCAE7EA280A2F307C07EA36C7FA21B0F6C6D19 +80A26C1A1F6C7F1C006C6D606C6D187EA26D6C606D6D4C5A6D6D16036D6D4C5A6D6D4C5A +6D01FC4C5A6D6DEE7F806D6C6C6C4BC7FC6E01E0EC07FE020F01FEEC1FF80203903AFFE0 +01FFF0020091B612C0033F93C8FC030715FCDB007F14E0040101FCC9FC525479D261>67 +DII<932601FFFCEC01C0047F +D9FFC013030307B600F81307033F03FE131F92B8EA803F0203DAE003EBC07F020F01FCC7 +383FF0FF023F01E0EC0FF94A01800203B5FC494848C9FC4901F882494982494982494982 +4949824990CA7E494883A2484983485B1B7F485B481A3FA24849181FA3485B1B0FA25AA2 +98C8FC5CA2B5FCAE6C057FB712E0A280A36C94C7003FEBC000A36C7FA36C7FA27E6C7FA2 +6C7F6C7FA26D7E6D7F6D7F6D6D5E6D7F6D01FC93B5FC6D13FF6D6C6D5C6E01F0EC07FB02 +0F01FEEC1FF10203903AFFF001FFE0020091B6EAC07F033FEE001F030703FC1307DB007F +02E01301040149CAFC5B5479D26A>71 D73 D75 DI78 D80 D82 +D<003FBC1280A59126C0003F9038C0007F49C71607D87FF8060113C001E08449197F4919 +3F90C8171FA2007E1A0FA3007C1A07A500FC1BE0481A03A6C994C7FCB3B3AC91B912F0A5 +53517BD05E>84 D97 DI<913801FFF8021FEBFF8091B612F0010315FC010F9038C00FFE903A1FFE +0001FFD97FFC491380D9FFF05B4817C048495B5C5A485BA2486F138091C7FC486F130070 +5A4892C8FC5BA312FFAD127F7FA27EA2EF03E06C7F17076C6D15C07E6E140F6CEE1F806C +6DEC3F006C6D147ED97FFE5C6D6CEB03F8010F9038E01FF0010390B55A01001580023F49 +C7FC020113E033387CB63C>I<4DB47E0407B5FCA5EE001F1707B3A4913801FFE0021F13 +FC91B6FC010315C7010F9038E03FE74990380007F7D97FFC0101B5FC49487F4849143F48 +4980485B83485B5A91C8FC5AA3485AA412FFAC127FA36C7EA37EA26C7F5F6C6D5C7E6C6D +5C6C6D49B5FC6D6C4914E0D93FFED90FEFEBFF80903A0FFFC07FCF6D90B5128F0101ECFE +0FD9003F13F8020301C049C7FC41547CD24B>I<913803FFC0023F13FC49B6FC010715C0 +4901817F903A3FFC007FF849486D7E49486D7E4849130F48496D7E48178048497F18C048 +8191C7FC4817E0A248815B18F0A212FFA490B8FCA318E049CAFCA6127FA27F7EA218E06C +EE01F06E14037E6C6DEC07E0A26C6DEC0FC06C6D141F6C6DEC3F806D6CECFF00D91FFEEB +03FE903A0FFFC03FF8010390B55A010015C0021F49C7FC020113F034387CB63D>IIII<137F +497E000313E0487FA2487FA76C5BA26C5BC613806DC7FC90C8FCADEB3FF0B5FCA512017E +B3B3A6B612E0A51B547BD325>I107 DIII<913801FFE0021F13FE91B612C0010315F0010F90 +38807FFC903A1FFC000FFED97FF86D6C7E49486D7F48496D7F48496D7F4A147F48834890 +C86C7EA24883A248486F7EA3007F1880A400FF18C0AC007F1880A3003F18006D5DA26C5F +A26C5F6E147F6C5F6C6D4A5A6C6D495B6C6D495B6D6C495BD93FFE011F90C7FC903A0FFF +807FFC6D90B55A010015C0023F91C8FC020113E03A387CB643>I<903A3FF001FFE0B501 +0F13FE033FEBFFC092B612F002F301017F913AF7F8007FFE0003D9FFE0EB1FFFC602806D +7F92C76C7F4A824A6E7F4A6E7FA2717FA285187F85A4721380AC1A0060A36118FFA2615F +616E4A5BA26E4A5B6E4A5B6F495B6F4990C7FC03F0EBFFFC9126FBFE075B02F8B612E06F +1480031F01FCC8FC030313C092CBFCB1B612F8A5414D7BB54B>I<90397FE003FEB59038 +0FFF80033F13E04B13F09238FE1FF89139E1F83FFC0003D9E3E013FEC6ECC07FECE78014 +EF150014EE02FEEB3FFC5CEE1FF8EE0FF04A90C7FCA55CB3AAB612FCA52F367CB537> +114 D<903903FFF00F013FEBFE1F90B7FC120348EB003FD80FF81307D81FE0130148487F +4980127F90C87EA24881A27FA27F01F091C7FC13FCEBFFC06C13FF15F86C14FF16C06C15 +F06C816C816C81C681013F1580010F15C01300020714E0EC003F030713F015010078EC00 +7F00F8153F161F7E160FA27E17E07E6D141F17C07F6DEC3F8001F8EC7F0001FEEB01FE90 +39FFC00FFC6DB55AD8FC1F14E0D8F807148048C601F8C7FC2C387CB635>I<143EA6147E +A414FEA21301A313031307A2130F131F133F13FF5A000F90B6FCB8FCA426003FFEC8FCB3 +A9EE07C0AB011FEC0F8080A26DEC1F0015806DEBC03E6DEBF0FC6DEBFFF86D6C5B021F5B +020313802A4D7ECB34>II119 D<007FB500F090387FFFFEA5C66C48C7000F90C7FC6D6C +EC07F86D6D5C6D6D495A6D4B5A6F495A6D6D91C8FC6D6D137E6D6D5B91387FFE014C5A6E +6C485A6EEB8FE06EEBCFC06EEBFF806E91C9FCA26E5B6E5B6F7E6F7EA26F7F834B7F4B7F +92B5FCDA01FD7F03F87F4A486C7E4A486C7E020F7FDA1FC0804A486C7F4A486C7F02FE6D +7F4A6D7F495A49486D7F01076F7E49486E7E49486E7FEBFFF0B500FE49B612C0A542357E +B447>II<001FB8FC1880A3912680007F130001FCC7B5FC01 +F0495B495D49495B495B4B5B48C75C5D4B5B5F003E4A90C7FC92B5FC4A5B5E4A5B5CC748 +5B5E4A5B5C4A5B93C8FC91B5FC495B5D4949EB0F805B495B5D495B49151F4949140092C7 +FC495A485E485B5C485E485B4A5C48495B4815074849495A91C712FFB8FCA37E31357CB4 +3C>I E /Fh 7 118 df<903901F803F8EB07FE130F131F133FEB7F0EEB7E0201FEC8FC5B +A21201ACB538FE03F8A53801FC00B3AE253B7FBA2D>12 D82 +D<007FB7FCA55EC8EA03FC15074B5AA24B5A5E153F4B5A5E15FF4A90C7FCA24A5A5D1407 +4A5A5D141F4A5AA24A5A5D14FF4990C8FC5C1303495AA2495A5C131F495A5C137F495AA2 +4890C9FC5B1203485A5B120F485AA2485A5B48B71280B8FCA5293A7BB933>90 +D<12FEB3A2EB01FCEB0FFF013F13C090B57EB67E9038F03FF8EBC007496C7EEB0001486D +7EA2157FA3ED3F80AAED7F00A35D5D14016C5CEB80039038C00FF89038F03FF090B55A48 +5C6D5BD91FFEC7FC380007F8213B7AB92B>98 D101 +D110 D<00FEEB01FCB3AA1403A214076C131F387F807F90 +B5FC6C13F914F1000F13C1D803FCC7FC1E267AA42B>117 D E /Fi +10 118 df<0107B612FCEFFF8018C0903B000FF0001FF04BEB07F81703021F15FC17014B +14FEA2023F1400A24B1301A2147F18FC92C7120318F84A140718F04AEC0FE0EF1FC00101 +ED3F80EF7F004AEB01FEEE07F849B612E05F9139F80007F0EE01FC01076E7E177F4AEC3F +80A2010F16C0171F5CA2131F173F5CA2133FEF7F805C1800017F5D4C5A91C7485A5F4914 +0FEE1FE0494A5A00014AB45AB748C7FC16F816C037397BB83A>66 +D<147F903803FFC090380FC1E090381F0070017E13784913383901F801F83803F0031207 +13E0120FD81FC013F091C7FC485AA2127F90C8FCA35A5AA45AA3153015381578007C14F0 +007EEB01E0003EEB03C0EC0F806CEB3E00380F81F83803FFE0C690C7FC1D2677A426>99 +DI +105 D108 +D110 D<147F903803FFC090380FC1F090 +381F00F8017E137C5B4848137E4848133E0007143F5B120F485AA2485A157F127F90C7FC +A215FF5A4814FEA2140115FC5AEC03F8A2EC07F015E0140F007C14C0007EEB1F80003EEB +3F00147E6C13F8380F83F03803FFC0C648C7FC202677A42A>I<9039078007C090391FE0 +3FF090393CF0787C903938F8E03E9038787FC00170497EECFF00D9F0FE148013E05CEA01 +E113C15CA2D80003143FA25CA20107147FA24A1400A2010F5C5E5C4B5A131F5EEC80035E +013F495A6E485A5E6E48C7FC017F133EEC70FC90387E3FF0EC0F8001FEC9FCA25BA21201 +A25BA21203A25B1207B512C0A3293580A42A>I<14FE903807FF8090380F83C090383E00 +E04913F00178137001F813F00001130313F0A215E00003EB01C06DC7FC7FEBFFC06C13F8 +14FE6C7F6D13807F010F13C01300143F141F140F123E127E00FE1480A348EB1F0012E06C +133E00705B6C5B381E03E06CB45AD801FEC7FC1C267AA422>115 +D<13F8D803FEEB01C0D8078FEB03E0390E0F8007121E121C0038140F131F007815C01270 +013F131F00F0130000E015805BD8007E133FA201FE14005B5D120149137EA215FE120349 +EBFC0EA20201131E161C15F813E0163CD9F003133814070001ECF07091381EF8F03A00F8 +3C78E090393FF03FC090390FC00F00272679A42D>117 D E /Fj +6 123 df45 D<13FFB5FCA412077EAF4AB47E020F13F0023F13 +FC9138FE03FFDAF00013804AEB7FC00280EB3FE091C713F0EE1FF8A217FC160FA217FEAA +17FCA3EE1FF8A217F06E133F6EEB7FE06E14C0903AFDF001FF80903AF8FC07FE009039F0 +3FFFF8D9E00F13E0D9C00390C7FC2F3A7EB935>98 D<903803FF80011F13F0017F13FC39 +01FF83FE3A03FE007F804848133F484814C0001FEC1FE05B003FEC0FF0A2485A16F81507 +12FFA290B6FCA301E0C8FCA4127FA36C7E1678121F6C6C14F86D14F000071403D801FFEB +0FE06C9038C07FC06DB51200010F13FC010113E025257DA42C>101 +D<90383FF0383903FFFEF8000F13FF381FC00F383F0003007E1301007C130012FC15787E +7E6D130013FCEBFFE06C13FCECFF806C14C06C14F06C14F81203C614FC131F9038007FFE +140700F0130114007E157E7E157C6C14FC6C14F8EB80019038F007F090B512C000F81400 +38E01FF81F257DA426>115 D<01FFEC3FC0B5EB3FFFA4000714016C80B3A35DA25DA26C +5C6E4813E06CD9C03E13FF90387FFFFC011F13F00103138030257DA435>117 +D<003FB612C0A3D9F0031380EB800749481300003E5C003C495A007C133F5D0078495A14 +FF5D495B5BC6485B92C7FC495A131F5C495A017FEB03C0EBFFF014E04813C05AEC800748 +13005A49EB0F80485A003F141F4848133F9038F001FFB7FCA322257DA42A>122 +D E /Fk 59 123 df12 D<001C131C007F137F39FF80FF80A26D13C0 +A3007F137F001C131C00001300A40001130101801380A20003130301001300485B000613 +06000E130E485B485B485B006013601A197DB92A>34 D<121C127FEAFF80A213C0A3127F +121C1200A412011380A2120313005A1206120E5A5A5A12600A1979B917>39 +D<146014E0EB01C0EB0380EB0700130E131E5B5BA25B485AA2485AA212075B120F90C7FC +A25A121EA2123EA35AA65AB2127CA67EA3121EA2121F7EA27F12077F1203A26C7EA26C7E +1378A27F7F130E7FEB0380EB01C0EB00E01460135278BD20>I<12C07E12707E7E7E120F +6C7E6C7EA26C7E6C7EA21378A2137C133C133E131EA2131F7FA21480A3EB07C0A6EB03E0 +B2EB07C0A6EB0F80A31400A25B131EA2133E133C137C1378A25BA2485A485AA2485A48C7 +FC120E5A5A5A5A5A13527CBD20>II<121C127FEAFF80A213C0A3127F121C1200A412011380A212 +0313005A1206120E5A5A5A12600A19798817>44 DI<121C127F +EAFF80A5EA7F00121C0909798817>I<150C151E153EA2153C157CA2157815F8A215F014 +01A215E01403A215C01407A21580140FA215005CA2141E143EA2143C147CA2147814F8A2 +5C1301A25C1303A2495AA25C130FA291C7FC5BA2131E133EA2133C137CA2137813F8A25B +1201A25B1203A25B1207A25B120FA290C8FC5AA2121E123EA2123C127CA2127812F8A25A +12601F537BBD2A>III<121C127FEAFF80A5EA7F00121CC7FCB2121C127FEAFF80A5EA7F +00121C092479A317>58 D<121C127FEAFF80A5EA7F00121CC7FCB2121C127F5A1380A412 +7F121D1201A412031300A25A1206A2120E5A121812385A1260093479A317>I63 +D<1538A3157CA315FEA34A7EA34A6C7EA202077FEC063FA2020E7FEC0C1FA2021C7FEC18 +0FA202387FEC3007A202707FEC6003A202C07F1501A2D901807F81A249C77F167FA20106 +810107B6FCA24981010CC7121FA2496E7EA3496E7EA3496E7EA213E0707E1201486C81D8 +0FFC02071380B56C90B512FEA3373C7DBB3E>65 D<913A01FF800180020FEBE003027F13 +F8903A01FF807E07903A03FC000F0FD90FF0EB039F4948EB01DFD93F80EB00FF49C8127F +01FE153F12014848151F4848150FA248481507A2485A1703123F5B007F1601A35B00FF93 +C7FCAD127F6DED0180A3123F7F001F160318006C7E5F6C7E17066C6C150E6C6C5D000016 +18017F15386D6C5CD91FE05C6D6CEB03C0D903FCEB0F80902701FF803FC7FC9039007FFF +FC020F13F002011380313D7BBA3C>67 DIII73 D75 +DIII80 +D82 DI<003FB812E0A3D9C003EB001F273E0001FE +130348EE01F00078160000701770A300601730A400E01738481718A4C71600B3B0913807 +FF80011FB612E0A335397DB83C>I87 +D89 D<003FB7FCA39039FC0001FE01C0 +130349495A003EC7FC003C4A5A5E0038141F00784A5A12704B5A5E006014FF4A90C7FCA2 +4A5A5DC712074A5AA24A5A5D143F4A5AA24A5A92C8FC5B495AA2495A5C130F4948EB0180 +A2495A5C137F495A16034890C7FC5B1203485AEE0700485A495C001F5D48485C5E484849 +5A49130FB8FCA329397BB833>II< +3901800180000313033907000700000E130E485B00181318003813380030133000701370 +00601360A200E013E0485BA400CE13CE39FF80FF806D13C0A3007F137FA2393F803F8039 +0E000E001A1974B92A>II97 DIIII<147E903803FF8090380FC1E0EB1F8790383F0FF0 +137EA213FCA23901F803C091C7FCADB512FCA3D801F8C7FCB3AB487E387FFFF8A31C3B7F +BA19>IIII107 DI<2703F00FF0EB1FE000FFD93FFCEB7FF8913AF03F01 +E07E903BF1C01F83803F3D0FF3800FC7001F802603F70013CE01FE14DC49D907F8EB0FC0 +A2495CA3495CB3A3486C496CEB1FE0B500C1B50083B5FCA340257EA445>I<3903F00FF0 +00FFEB3FFCECF03F9039F1C01F803A0FF3800FC03803F70013FE496D7EA25BA35BB3A348 +6C497EB500C1B51280A329257EA42E>II<3903F01FE000FFEB7FF890 +38F1E07E9039F3801F803A07F7000FC0D803FEEB07E049EB03F04914F849130116FC1500 +16FEA3167FAA16FEA3ED01FCA26DEB03F816F06D13076DEB0FE001F614C09039F7803F00 +9038F1E07E9038F0FFF8EC1FC091C8FCAB487EB512C0A328357EA42E>I<3807E01F00FF +EB7FC09038E1E3E09038E387F0380FE707EA03E613EE9038EC03E09038FC0080491300A4 +5BB3A2487EB512F0A31C257EA421>114 DI<1318A51338A31378A313F8120112031207001FB5FCB6 +FCA2D801F8C7FCB215C0A93800FC011580EB7C03017E13006D5AEB0FFEEB01F81A347FB2 +20>IIIIII<003FB512FCA2EB8003D83E0013F8003CEB07F00038EB0FE012300070EB1F +C0EC3F800060137F150014FE495AA2C6485A495AA2495A495A495AA290387F000613FEA2 +485A485A0007140E5B4848130C4848131CA24848133C48C7127C48EB03FC90B5FCA21F24 +7EA325>I E /Fl 10 58 df48 D<13381378EA01F8121F12FE12E01200B3AB +487EB512F8A215267BA521>I<13FF000313E0380E03F0381800F848137C48137E00787F +12FC6CEB1F80A4127CC7FC15005C143E147E147C5C495A495A5C495A010EC7FC5B5B9038 +70018013E0EA0180390300030012065A001FB5FC5A485BB5FCA219267DA521>I<13FF00 +0313E0380F01F8381C007C0030137E003C133E007E133FA4123CC7123E147E147C5C495A +EB07E03801FF8091C7FC380001E06D7E147C80143F801580A21238127C12FEA21500485B +0078133E00705B6C5B381F01F03807FFC0C690C7FC19277DA521>I<1438A2147814F813 +01A2130313071306130C131C131813301370136013C012011380EA03005A120E120C121C +5A12305A12E0B612E0A2C7EAF800A7497E90383FFFE0A21B277EA621>I<0018130C001F +137CEBFFF85C5C1480D819FCC7FC0018C8FCA7137F3819FFE0381F81F0381E0078001C7F +0018133EC7FC80A21580A21230127C12FCA3150012F00060133E127000305B001C5B380F +03E03803FFC0C648C7FC19277DA521>II<1230123C003FB512E0A215C0481480A23970000700006013 +0E140C48131C5C5CC75A5C1301495AA249C7FC5B130E131EA3133E133CA2137CA413FCA8 +13781B287DA621>I<137F3803FFE0380781F8380E007C48131E5A801278A3127C007E13 +1EEA3F80EBE03C6C6C5A380FFCF03807FFC06C5BC613E0487F38079FFC380F07FEEA1E03 +48C67E48133FEC1F8048130FA21407A315001278140E6C5B6C5B380F80F03803FFE0C66C +C7FC19277DA521>I<137F3801FFC03807C1E0380F0070001E1378003E7F003C133E007C +131EA200FC131FA41580A4007C133FA2123C003E137F121E380F01DF3807FF9F3801FE1F +D8001013001300A2143E123C007E133CA25C5C007C5B383003C0381C0780D80FFFC7FCEA +03F819277DA521>I E /Fm 43 122 df<4AB4FC021F13C091387F01F0903901FC0078D9 +07F0131C4948133E494813FF49485A137F1400A213FE6F5A163893C7FCAA167FB8FCA339 +00FE00018182B3AC486CECFF80007FD9FC3F13FEA32F407FBF33>12 +D<001E130F397F803FC000FF137F01C013E0A201E013F0A3007F133F391E600F30000013 +00A401E01370491360A3000114E04913C00003130101001380481303000EEB070048130E +0018130C0038131C003013181C1C7DBE2D>34 D<1430147014E0EB01C0EB03801307EB0F +00131E133E133C5B13F85B12015B1203A2485AA2120F5BA2121F90C7FCA25AA3123E127E +A6127C12FCB2127C127EA6123E123FA37EA27F120FA27F1207A26C7EA212017F12007F13 +787F133E131E7FEB07801303EB01C0EB00E014701430145A77C323>40 +D<12C07E12707E7E121E7E6C7E7F12036C7E7F12007F1378137CA27FA2133F7FA2148013 +0FA214C0A3130714E0A6130314F0B214E01307A614C0130FA31480A2131F1400A25B133E +A25BA2137813F85B12015B485A12075B48C7FC121E121C5A5A5A5A145A7BC323>I<121E +EA7F8012FF13C0A213E0A3127FEA1E601200A413E013C0A312011380120313005A120E5A +1218123812300B1C798919>44 DI<121EEA7F80A2EAFFC0A4EA +7F80A2EA1E000A0A798919>I49 D<121EEA7F80A2EAFFC0A4EA7F80A2EA1E00C7 +FCB3121EEA7F80A2EAFFC0A4EA7F80A2EA1E000A2779A619>58 D<15074B7EA34B7EA34B +7EA34B7EA34B7E15E7A2913801C7FC15C3A291380381FEA34AC67EA3020E6D7EA34A6D7E +A34A6D7EA34A6D7EA34A6D7EA349486D7E91B6FCA249819138800001A249C87EA2498201 +0E157FA2011E82011C153FA2013C820138151FA2017882170F13FC00034C7ED80FFF4B7E +B500F0010FB512F8A33D417DC044>65 D +67 D69 DI73 D76 +D82 D<003FB91280A3903AF0007FE001018090393FC0003F48C7ED1FC0007E1707127C +00781703A300701701A548EF00E0A5C81600B3B14B7E4B7E0107B612FEA33B3D7DBC42> +84 D<007FB5D8C003B512E0A3C649C7EBFC00D93FF8EC3FE06D48EC1F806D6C92C7FC17 +1E6D6C141C6D6C143C5F6D6C14706D6D13F04C5ADA7FC05B023F13036F485ADA1FF090C8 +FC020F5BEDF81E913807FC1C163C6E6C5A913801FF7016F06E5B6F5AA26F7E6F7EA28282 +153FED3BFEED71FF15F103E07F913801C07F0203804B6C7EEC07004A6D7E020E6D7E5C02 +3C6D7E02386D7E14784A6D7E4A6D7F130149486E7E4A6E7E130749C86C7E496F7E497ED9 +FFC04A7E00076DEC7FFFB500FC0103B512FEA33F3E7EBD44>88 DI<486C13C00003130101001380481303000EEB070048130E +0018130C0038131C003013180070133800601330A300E01370481360A400CFEB678039FF +C07FE001E013F0A3007F133FA2003F131F01C013E0390F0007801C1C73BE2D>92 +D97 D +I<49B4FC010F13E090383F00F8017C131E4848131F4848137F0007ECFF80485A5B121FA2 +4848EB7F00151C007F91C7FCA290C9FC5AAB6C7EA3003FEC01C07F001F140316806C6C13 +076C6C14000003140E6C6C131E6C6C137890383F01F090380FFFC0D901FEC7FC222A7DA8 +28>IIII<167C903903F801FF903A1FFF078F8090397E0FDE1F90 +38F803F83803F001A23B07E000FC0600000F6EC7FC49137E001F147FA8000F147E6D13FE +00075C6C6C485AA23901F803E03903FE0FC026071FFFC8FCEB03F80006CAFC120EA3120F +A27F7F6CB512E015FE6C6E7E6C15E06C810003813A0FC0001FFC48C7EA01FE003E140048 +157E825A82A46C5D007C153E007E157E6C5D6C6C495A6C6C495AD803F0EB0FC0D800FE01 +7FC7FC90383FFFFC010313C0293D7EA82D>III107 +DI<2701F801FE14FF +00FF902707FFC00313E0913B1E07E00F03F0913B7803F03C01F80007903BE001F87000FC +2603F9C06D487F000101805C01FBD900FF147F91C75B13FF4992C7FCA2495CB3A6486C49 +6CECFF80B5D8F87FD9FC3F13FEA347287DA74C>I<3901F801FE00FF903807FFC091381E +07E091387803F000079038E001F82603F9C07F0001138001FB6D7E91C7FC13FF5BA25BB3 +A6486C497EB5D8F87F13FCA32E287DA733>I<14FF010713E090381F81F890387E007E01 +F8131F4848EB0F804848EB07C04848EB03E0000F15F04848EB01F8A2003F15FCA248C812 +FEA44815FFA96C15FEA36C6CEB01FCA3001F15F86C6CEB03F0A26C6CEB07E06C6CEB0FC0 +6C6CEB1F80D8007EEB7E0090383F81FC90380FFFF0010090C7FC282A7EA82D>I<3901FC +03FC00FF90381FFF8091387C0FE09039FDE003F03A03FFC001FC6C496C7E91C7127F49EC +3F805BEE1FC017E0A2EE0FF0A3EE07F8AAEE0FF0A4EE1FE0A2EE3FC06D1580EE7F007F6E +13FE9138C001F89039FDE007F09039FC780FC0DA3FFFC7FCEC07F891C9FCAD487EB512F8 +A32D3A7EA733>I<3901F807E000FFEB1FF8EC787CECE1FE3807F9C100031381EA01FB14 +01EC00FC01FF1330491300A35BB3A5487EB512FEA31F287EA724>114 +D<90383FC0603901FFF8E03807C03F381F000F003E1307003C1303127C0078130112F814 +00A27E7E7E6D1300EA7FF8EBFFC06C13F86C13FE6C7F6C1480000114C0D8003F13E00103 +13F0EB001FEC0FF800E01303A214017E1400A27E15F07E14016C14E06CEB03C090388007 +8039F3E01F0038E0FFFC38C01FE01D2A7DA824>I<131CA6133CA4137CA213FCA2120112 +031207001FB512C0B6FCA2D801FCC7FCB3A215E0A912009038FE01C0A2EB7F03013F1380 +90381F8700EB07FEEB01F81B397EB723>IIIIII E /Fn 10 58 df48 D<130C133C137CEA03FC12FFEAFC +7C1200B3B113FE387FFFFEA2172C7AAB23>II +I<140EA2141E143EA2147E14FEA2EB01BE1303143E1306130E130C131813381330136013 +E013C0EA0180120313001206120E120C5A123812305A12E0B612FCA2C7EA3E00A9147F90 +381FFFFCA21E2D7EAC23>I<000CEB0180380FC01F90B512005C5C14F014C0D80C7EC7FC +90C8FCA8EB1FC0EB7FF8380DE07C380F801F01001380000E130F000CEB07C0C713E0A214 +0315F0A4127812FCA448EB07E012E0006014C00070130F6C14806CEB1F006C133E380780 +F83801FFE038007F801C2D7DAB23>II< +1230123C003FB512F8A215F05A15E039700001C000601480140348EB0700140E140CC712 +1C5C143014705C495AA2495AA249C7FCA25B130E131EA2133EA3133C137CA413FCA91378 +1D2E7CAC23>III E /Fo +6 118 df45 D82 D<007FB712F8A517F0C9EA3FE0A2EE7FC0EEFF80A24B13004B5AA2 +4B5A4B5AA24B5A153F5E4B5A15FF5E4A90C7FCA24A5A4A5AA24A5A4A5AA24A5A4A5AA24A +5A4990C8FCA2495A495AA2495A131F5C495A137F5C495AA24890C9FC485AA2485A485AA2 +485A485AA248B712FCB8FCA52E3F7BBE38>90 D<12FEB3A414FF010713E0011F7F017F7F +B67E819038F80FFFEBE001D98000138090C7EA7FC0153F48141F16E0150FA3ED07F0AAED +0FE0A3151FED3FC07E6DEB7F8015FFD9E00313009038F81FFE90B55A485C6D5B6D5B010F +1380260001FEC7FC244079BE2F>98 D101 D<00FE147FB3AC15FFA25C6C +5B6C130FEBC03F90B6FC6CEBFE7F6C13FC6C13E0000390C7FC202979A72F>117 +D E /Fp 7 117 df<16FCA24B7EA24B7EA34B7FA24B7FA34B7FA24B7FA34B7F157C03FC +7FEDF87FA2020180EDF03F0203804B7E02078115C082020F814B7E021F811500824A8102 +3E7F027E81027C7FA202FC814A147F49B77EA34982A2D907E0C7001F7F4A80010F835C83 +011F8391C87E4983133E83017E83017C81B500FC91B612FCA5463F7CBE4F>65 +D<903807FFC0013F13F848B6FC48812607FE037F260FF8007F6DEB3FF0486C806F7EA36F +7EA26C5A6C5AEA01E0C8FC153F91B5FC130F137F3901FFFE0F4813E0000F1380381FFE00 +485A5B485A12FF5BA4151F7F007F143F6D90387BFF806C6C01FB13FE391FFF07F36CEBFF +E100031480C6EC003FD91FF890C7FC2F2B7DA933>97 D<13FFB5FCA512077EAFEDFFE002 +0713FC021FEBFF80027F80DAFF8113F09139FC003FF802F06D7E4A6D7E4A13074A807013 +80A218C082A318E0AA18C0A25E1880A218005E6E5C6E495A6E495A02FCEB7FF0903AFCFF +01FFE0496CB55AD9F01F91C7FCD9E00713FCC7000113C033407DBE3A>II<3901FE01FE00FF903807FF804A13E04A13F0EC3F1F91387C3F +F8000713F8000313F0EBFFE0A29138C01FF0ED0FE091388007C092C7FCA391C8FCB3A2B6 +FCA525297DA82B>114 D<90383FFC1E48B512BE000714FE5A381FF00F383F800148C7FC +007E147EA200FE143EA27E7F6D90C7FC13F8EBFFE06C13FF15C06C14F06C806C806C806C +80C61580131F1300020713C014000078147F00F8143F151F7EA27E16806C143F6D140001 +E013FF9038F803FE90B55A15F0D8F87F13C026E00FFEC7FC222B7DA929>II +E /Fq 20 118 df<027FEB3FC0903801FFC013075B5B5B14C190387F804091C9FC5B5BA2 +1201AEB638C03FC0A6D801FEC7FCB3B3A22A467EC534>12 D45 +D67 D76 +D82 +DI<003FB81280A51800C9EA07FEA24C +5A5F161F4C5AA24C5A4C5AA24B5B4B90C7FCA24B5A4B5AA24B5AA24B5A4B5AA24B5A4A5B +A24A90C8FC4A5AA24A5A5D141F4A5AA24A5A4A5AA2495B4990C9FCA2495A495AA2495AA2 +495A495AA2495A485BA24890CAFC485AA2485A5B121F485AA248B81280B9FCA531457BC4 +3C>90 D98 DI101 D104 +DI<12FFB3B3B3AF084579C417>108 +DIIII<141F +00FE13FF13035B131F5B5BEBFFF0148038FFFE005B5B5B5B5BA25BA390C7FCB3A8182D79 +AC21>114 DI117 D E /Fr 4 116 df<121EEA7F80A2EAFFC0A4EA7F80A2EA1E000A0A78891B> +58 D<91B612F8A3020001E0C8FC6F5A4B5AA293C9FCA35C5DA314035DA314075DA3140F +5DA3141F5DA3143F5DA3147F5DA314FF92CAFCA35B4A16C0A21801010317804A15031900 +A201075E4A1506180E181E010F161C4A153C18381878011F16F84A4A5A1703013F150F4D +5A4A14FF01FF02075BB9FCA2603A447CC342>76 D<01F8D903FCEC7F80D803FED91FFF90 +3803FFE0D8071F903B7C0FC00F81F83E0E0F80E007E01C00FC001C9026C3C0030178137C +271807C700D9F0E0137E02CE902601F1C0133E003801DCDAFB80133F003001D892C7FCD9 +0FF814FF0070495C0060495CA200E04949485CD8C01F187E4A5C1200040715FE013F6091 +C75BA2040F14014960017E5D1903041F5D13FE494B130762043F160E0001060F130C4992 +C713C0191F4CED801C00031A1849027E1638F2003004FE167000071A60494A16E0F201C0 +030192380F0380000FF18700494AEC03FED80380D90070EC00F84F2D7DAB55>109 +D115 D E +/Fs 64 123 df12 D34 D<141FA5ECFFE0010713FE013F6D7E4914E048B612F84890389F1FFC3A07FC1F01 +FED80FF0EB007FD81FE08001C0EC1F80003FED0FC001801407007F150F0100EC7FE016FF +485CA41380A201C06D13C013E001F0EC3F0001F891C7FCEA7FFCEBFF9F14FF6C14C015F8 +6C14FE6C6E7E16E06C816C81C6816D80131F01078001001580141F6F13C0150F81030113 +E0000680EA3FC0D87FE0147FD8FFF0143FA3161FA313E017C01380D87800143F127C1780 +6C157F003FEDFF00D81F80495AD80FE01303D807F8495AD803FFEB3FF86C90B55A6C15C0 +013F91C7FC010F13FC010013E0021FC8FCA52B517ACA38>36 D40 D<12F07E127E7E6C7E6C7E6C7E7F6C7E6C7E1200 +7F137F80133F806D7EA26D7EA26D7EA2801303A2801301A280A27F1580A4EC7FC0A615E0 +A2143FAE147FA215C0A6ECFF80A415005BA25CA213035CA213075CA2495AA2495AA2495A +5C137F91C7FC13FE5B1201485A485A5B485A485A48C8FC127E12F85A1B647ACA2C>I<14 +3E147F4A7EA56EC8FC00081508003E153E007F157FD8FFC0903801FF8001E05B9038F03E +0701F85BD87FFE013F130001FF5B001F9038BEFFFC000390B512E0C66C91C7FC010F13F8 +010113C0A2010F13F8017F13FF0003B612E0001F01BE13FC007F90383E7FFF01FE7FD8FF +F8010F138001F07F9038E07F0301C07FD87F009038007F00003E153E00081508C791C7FC +4A7EA56EC8FC143E292C79CA38>I<161E163FB3AF007FBB1280BC12C0A46C1A80C9003F +CAFCB3AF161E4A4A7ABD57>I45 DI49 DII<163FA25E5E5D5DA25D5D5D5DA25D92B5FCEC01F7EC03E714 +0715C7EC0F87EC1F07143E147E147C14F8EB01F0EB03E0130714C0EB0F80EB1F00133E5B +A25B485A485A485A120F5B48C7FC123E5A12FCB91280A5C8000F90C7FCAC027FB61280A5 +31417DC038>I<0007150301E0143F01FFEB07FF91B6FC5E5E5E5E5E16804BC7FC5D15E0 +92C8FC01C0C9FCAAEC3FF001C1B5FC01C714C001DF14F09039FFE03FFC9138000FFE01FC +6D7E01F06D13804915C0497F6C4815E0C8FC6F13F0A317F8A4EA0F80EA3FE0487E12FF7F +A317F05B5D6C4815E05B007EC74813C0123E003F4A1380D81FC0491300D80FF0495AD807 +FEEBFFFC6CB612F0C65D013F1480010F01FCC7FC010113C02D427BC038>I<4AB47E021F +13F0027F13FC49B6FC01079038807F8090390FFC001FD93FF014C04948137F4948EBFFE0 +48495A5A1400485A120FA248486D13C0EE7F80EE1E00003F92C7FCA25B127FA2EC07FC91 +381FFF8000FF017F13E091B512F89039F9F01FFC9039FBC007FE9039FF8003FF17804A6C +13C05B6F13E0A24915F0A317F85BA4127FA5123FA217F07F121FA2000F4A13E0A26C6C15 +C06D4913806C018014006C6D485A6C9038E01FFC6DB55A011F5C010714C0010191C7FC90 +38003FF02D427BC038>I<121E121F13FC90B712FEA45A17FC17F817F017E017C0A24816 +80007EC8EA3F00007C157E5E00785D15014B5A00F84A5A484A5A5E151FC848C7FC157E5D +A24A5A14035D14074A5AA2141F5D143FA2147F5D14FFA25BA35B92C8FCA35BA55BAA6D5A +6D5A6D5A2F447AC238>IIII<903807FFC0013F13FC48B612804815E0260FF8 +0013F0D81FC0EB3FF848C7EA1FFC4815FE01C0130F486C14FF7FA66C485B6C4814FE000F +C7FCC8EA3FFCED7FF8EDFFF04A13E04A13801600EC07FC4A5A5D4A5A5D4A5A92C7FCA214 +7E147CA31478AA91C8FCA814F8EB03FE497E497FA2497FA56D5BA26D90C7FC6D5AEB00F8 +28467AC535>63 D65 DII< +BA12F8A485D8001F90C71201EF003F180F180318011800A2197E193EA3191EA21778A285 +A405F890C7FCA316011603161F92B5FCA5ED001F160316011600A2F101E01778A2F103C0 +A494C7FC1907A21A80A2190FA2191FA2193FF17F0061601807181F4DB5FCBBFC61A44344 +7DC34A>69 DII73 +D75 DIII<923807FFC092B512FE0207ECFFC0021F15F091267FFE0013FC +902601FFF0EB1FFF01070180010313C04990C76C7FD91FFC6E6C7E49486F7E49486F7E01 +FF8348496F7E48496F1380A248496F13C0A24890C96C13E0A24819F04982003F19F8A300 +7F19FC49177FA400FF19FEAD007F19FC6D17FFA3003F19F8A26D5E6C19F0A26E5D6C19E0 +A26C6D4B13C06C19806E5D6C6D4B13006C6D4B5A6D6C4B5A6D6C4B5A6D6C4A5B6D01C001 +075B6D01F0011F5B010101FE90B5C7FC6D90B65A023F15F8020715C002004AC8FC030713 +C047467AC454>II82 DI<003FBA12E0A59026FE000FEB8003D87FE09338003FF049171F90C716 +07A2007E1803007C1801A300781800A400F819F8481978A5C81700B3B3A20107B8FCA545 +437CC24E>II87 D91 D<01181418013C143C01FC14FC4848495A4848495A495C4848495A4848 +495A001F141F90C790C7FC003E143EA2003C143C007C147C00781478A200F814F8A2485C +D8F1F0EBF1F0D8F7FCEBF7FCB46CEBFFFE6D806E1480A36C80A36C806C496C13006C486D +5A6C486D5AD801F0EB01F0292274C43A>II<903801FFE0011F13FE017F6D7E48B612E03A03FE007FF84848EB1FFC6D6D7E48 +6C6D7EA26F7FA36F7F6C5A6C5AEA00F090C7FCA40203B5FC91B6FC1307013F13F19038FF +FC01000313E0000F1380381FFE00485A5B127F5B12FF5BA35DA26D5B6C6C5B4B13F0D83F +FE013EEBFFC03A1FFF80FC7F0007EBFFF86CECE01FC66CEB8007D90FFCC9FC322F7DAD36 +>97 DIIIIII< +EB7FC0B5FCA512037EB1ED07FE92383FFF8092B512E002C114F89139C7F03FFC9138CF80 +1F9139DF000FFE14DE14FC4A6D7E5CA25CA35CB3A7B60083B512FEA537457CC43E>I<13 +7C48B4FC4813804813C0A24813E0A56C13C0A26C13806C1300EA007C90C7FCAAEB7FC0EA +7FFFA512037EB3AFB6FCA518467CC520>I107 DI<90277F8007FEEC0FFCB590263FFFC090387FFF8092B5D8F001B512E00281 +6E4880913D87F01FFC0FE03FF8913D8FC00FFE1F801FFC0003D99F009026FF3E007F6C01 +9E6D013C130F02BC5D02F86D496D7EA24A5D4A5DA34A5DB3A7B60081B60003B512FEA557 +2D7CAC5E>I<90397F8007FEB590383FFF8092B512E0028114F8913987F03FFC91388F80 +1F000390399F000FFE6C139E14BC02F86D7E5CA25CA35CB3A7B60083B512FEA5372D7CAC +3E>II<90397FC00FF8B590 +B57E02C314E002CF14F89139DFC03FFC9139FF001FFE000301FCEB07FF6C496D13804A15 +C04A6D13E05C7013F0A2EF7FF8A4EF3FFCACEF7FF8A318F017FFA24C13E06E15C06E5B6E +4913806E4913006E495A9139DFC07FFC02CFB512F002C314C002C091C7FCED1FF092C9FC +ADB67EA536407DAC3E>I<90387F807FB53881FFE0028313F0028F13F8ED8FFC91389F1F +FE000313BE6C13BC14F8A214F0ED0FFC9138E007F8ED01E092C7FCA35CB3A5B612E0A527 +2D7DAC2E>114 D<90391FFC038090B51287000314FF120F381FF003383FC00049133F48 +C7121F127E00FE140FA215077EA27F01E090C7FC13FE387FFFF014FF6C14C015F06C14FC +6C800003806C15806C7E010F14C0EB003F020313E0140000F0143FA26C141F150FA27EA2 +6C15C06C141FA26DEB3F8001E0EB7F009038F803FE90B55A00FC5CD8F03F13E026E007FE +C7FC232F7CAD2C>III119 DII<001FB71280A49026FC001F130001E0495A5B +49495A90C7485A48495B123E4A5B4A5B003C495BA24A90C7FC4A5A4A5AC7FC4A5A495B49 +5BA2495B499038800780491300A2495A4948130F49481400A2485B48495B485BA248495B +4890C75A48485C15034848EB1FFEB7FCA4292C7DAB32>I E /Ft +39 122 df<16F04B7E1507151F153FEC01FF1407147F010FB5FCB7FCA41487EBF007C7FC +B3B3B3B3007FB91280A6395E74DD51>49 D<913801FFF8021FEBFFC091B612F8010315FF +010F16C0013F8290267FFC0114F89027FFE0003F7F4890C7000F7F48486E7FD807F86E14 +8048486E14C048486E14E048486F13F001FC17F8486C816D17FC6E80B56C16FE8380A219 +FFA283A36C5BA26C5B6C90C8FCD807FC5DEA01F0CA14FEA34D13FCA219F85F19F04D13E0 +A294B512C019804C14004C5B604C5B4C5B604C13804C90C7FC4C5A4C5A4B13F05F4B1380 +4B90C8FC4B5AED1FF84B5A4B5A4B48143F4A5B4A48C8FC4A5A4A48157E4A5A4A5AEC7F80 +92C9FC02FE16FE495A495A4948ED01FCD90FC0150749B8FC5B5B90B9FC5A4818F85A5A5A +5A5ABAFCA219F0A4405E78DD51>I<92B5FC020F14F8023F14FF49B712C04916F0010FD9 +C01F13FC90271FFC00077FD93FE001017F49486D8049C86C7F484883486C6F7F14C0486D +826E806E82487FA4805CA36C5E4A5E6C5B6C5B6C495E011FC85A90C95CA294B55A614C91 +C7FC604C5B4C5B4C5B4C5B047F138092260FFFFEC8FC020FB512F817E094C9FC17F817FF +91C7003F13E0040713F8040113FE707F717F7113E085717FA2717F85A285831A80A31AC0 +EA03FCEA0FFF487F487F487FA2B57EA31A80A34D14005C7E4A5E5F6C495E49C8485BD81F +F85F000F5ED807FE92B55A6C6C6C4914806C01F0010791C7FC6C9026FF803F5B6D90B65A +011F16F0010716C001014BC8FCD9001F14F0020149C9FC426079DD51>II<01C0EE01C0D801F8160F01 +FF167F02F0EC07FFDAFF8090B5FC92B7128019006060606060606095C7FC17FC5F17E017 +8004FCC8FC16E09026FC3FFCC9FC91CBFCADED3FFE0203B512F0020F14FE023F6E7E91B7 +12E001FDD9E00F7F9027FFFE00037F02F801007F02E06EB4FC02806E138091C8FC496F13 +C04917E07113F0EA00F090C914F8A219FC83A219FEA419FFA3EA03F0EA0FFC487E487E48 +7FA2B57EA319FEA35C4D13FC6C90C8FC5B4917F8EA3FF001804B13F06D17E0001F5E6C6C +17C06D4B1380D807FC92B512006C6C4A5B6C6C6C01075B6C01E0011F5BD97FFE90B55A6D +B712C0010F93C7FC6D15FC010115F0D9003F1480020301F0C8FC406078DD51>III< +F00FE04E7EA24E7EA34E7EA24E7EA34D7FA24D80A24D80A34D80A24D80A34D80A2DD7FBF +7FA2181F05FF8017FE04016D7FA24D7E04038217F804076D80A24D7E040F8217E0041F6D +80A24D7F043F825F047F6E7FA294C77E4C825E03016F7FA24C800303845E03076F80A24C +80030F845E031F6F80A24C81033F845E037F707F93B9FCA292BA7EA24A85A203FCC91207 +0203865D020771805D86020F864B82021F865D87023F864B83027F8692CBFC874A864A84 +0101875C496C728090381FFFC0B700E092B812FEA66F647BE37A>65 +D<4DB5ED03C0057F02F014070407B600FE140F047FDBFFC0131F4BB800F0133F030F05FC +137F033F9127F8007FFE13FF92B6C73807FF814A02F0020113C3020702C09138007FE74A +91C9001FB5FC023F01FC16074A01F08291B54882490280824991CB7E4949844949844949 +8449865D49498490B5FC484A84A2484A84A24891CD127FA25A4A1A3F5AA348491A1FA448 +99C7FCA25CA3B5FCB07EA380A27EA2F50FC0A26C7FA37E6E1A1F6C1D80A26C801D3F6C6E +1A00A26C6E616D1BFE6D7F6F4E5A7F6D6D4E5A6D6D4E5A6D6D4E5A6D6E171F6D02E04D5A +6E6DEFFF806E01FC4C90C7FC020F01FFEE07FE6E02C0ED1FF8020102F8ED7FF06E02FF91 +3803FFE0033F02F8013F1380030F91B648C8FC030117F86F6C16E004071680DC007F02F8 +C9FC050191CAFC626677E375>67 D70 D<4DB5ED03C0057F02F014070407B600FE14 +0F047FDBFFC0131F4BB800F0133F030F05FC137F033F9127F8007FFE13FF92B6C73807FF +814A02F0020113C3020702C09138007FE74A91C9001FB5FC023F01FC16074A01F08291B5 +4882490280824991CB7E49498449498449498449865D49498490B5FC484A84A2484A84A2 +4891CD127FA25A4A1A3F5AA348491A1FA44899C8FCA25CA3B5FCB07E071FB812F880A37E +A296C70001ECC000A26C7FA37E807EA26C80A26C80A26C807F6D7F816D7F7F6D7F6D6D5F +6D14C06D6E5E6E7F6E01FC5E020F01FF5E6E02C0ED7FEF020102F8EDFFC76E02FF020713 +83033F02FC013F1301030F91B638FC007F03014D131F6F6C04E01307040704801301DC00 +7F02F8CAFC050191CBFC6D6677E37F>I73 D76 DI<94381FFFE00407B67E04 +3F15F04BB712FE030FEEFFC0033FD9FC0014F092B500C0010F13FC020349C7000113FF4A +01F86E6C7F021F496F13E04A01C0030F7F4A496F7F91B5C96C7F0103497013FF49497080 +4B834949717F49874949717F49874B8390B586484A717FA24891CB6C7FA2481D804A8448 +1DC0A348497214E0A3481DF0A34A85481DF8A5B51CFCB06C1DF8A36E96B5FCA36C1DF0A4 +6C6D4E14E0A36C1DC06E606C1D80A26C6E4D1400A26C6E4D5BA26C6E4D5BA26D6D4D5B6D +636D6D4D5B6F94B5FC6D636D6D4C5C6D6D4C91C7FC6D6E4B5B6D02E0031F5B023F6D4B13 +F06E01FC92B55A6E01FF02035C020302C0010F91C8FC020002FC90B512FC033F90B712F0 +030F17C0030394C9FCDB007F15F804071580DC001F01E0CAFC666677E379>79 +D82 D<001FBEFCA64849C79126E0000F148002E0180091 +C8171F498601F81A0349864986A2491B7FA2491B3F007F1DC090C9181FA4007E1C0FA600 +FE1DE0481C07A5CA95C7FCB3B3B3A3021FBAFCA663617AE070>84 +DI87 +D<913803FFFE027FEBFFF00103B612FE010F6F7E4916E090273FFE001F7FD97FE001077F +D9FFF801017F486D6D7F717E486D6E7F85717FA2717FA36C496E7FA26C5B6D5AEB1FC090 +C9FCA74BB6FC157F0207B7FC147F49B61207010F14C0013FEBFE004913F048B512C04891 +C7FC485B4813F85A5C485B5A5CA2B55AA45FA25F806C5E806C047D7F6EEB01F96C6DD903 +F1EBFF806C01FED90FE114FF6C9027FFC07FC01580000191B5487E6C6C4B7E011F02FC13 +0F010302F001011400D9001F90CBFC49437CC14E>97 D<92380FFFF04AB67E020F15F002 +3F15FC91B77E01039039FE001FFF4901F8010113804901E0010713C04901804913E0017F +90C7FC49484A13F0A2485B485B5A5C5A7113E0485B7113C048701380943800FE0095C7FC +485BA4B5FCAE7EA280A27EA2806C18FCA26C6D150119F87E6C6D15036EED07F06C18E06C +6D150F6D6DEC1FC06D01E0EC7F806D6DECFF00010701FCEB03FE6D9039FFC03FFC010091 +B512F0023F5D020F1580020102FCC7FCDA000F13C03E437BC148>99 +DI< +92380FFFC04AB512FC020FECFF80023F15E091B712F80103D9FE037F499039F0007FFF01 +1F01C0011F7F49496D7F4990C76C7F49486E7F48498048844A804884485B727E5A5C4871 +7EA35A5C721380A2B5FCA391B9FCA41A0002C0CBFCA67EA380A27EA27E6E160FF11F806C +183F6C7FF17F006C7F6C6D16FE6C17016D6C4B5A6D6D4A5A6D01E04A5A6D6DEC3FE00103 +01FC49B45A6D9026FFC01F90C7FC6D6C90B55A021F15F8020715E0020092C8FC030713F0 +41437CC14A>III<903807FF80B6FCA6C6FC7F7FB3A8EF1FFF94B5 +12F0040714FC041F14FF4C8193267FE07F7F922781FE001F7FDB83F86D7FDB87F07FDB8F +C0814C7F039FC78015BE03BC8003FC825DA25DA25DA45DB3B2B7D8F007B71280A651647B +E35A>II<90 +3807FF80B6FCA6C6FC7F7FB3A90503B61280A6DD003FEB8000DE0FFCC7FCF01FF04E5AF0 +FFC04D5B4D90C8FCEF07FC4D5AEF3FF04D5A4D5A4C90C9FC4C5AEE0FFC4C5A4C5AEE7FC0 +4C7E03837F03877F158F039F7F03BF7F92B5FC838403FC804B7E03F0804B6C7F4B6C7F15 +80707F707F707FA270807080717FA2717F717F717FA2717F717F83867180727F95B57EB7 +D8E00FECFFF0A64C647BE355>107 D<903807FF80B6FCA6C6FC7F7FB3B3B3B3ADB712E0 +A623647BE32C>I<902607FF80D91FFFEEFFF8B691B500F00207EBFF80040702FC023F14 +E0041F02FF91B612F84C6F488193267FE07F6D4801037F922781FE001F9027E00FF0007F +C6DA83F86D9026F01FC06D7F6DD987F06D4A487F6DD98FC0DBF87EC7804C6D027C80039F +C76E488203BEEEFDF003BC6E4A8003FC04FF834B5FA24B5FA24B94C8FCA44B5EB3B2B7D8 +F007B7D8803FB612FCA67E417BC087>I<902607FF80EB1FFFB691B512F0040714FC041F +14FF4C8193267FE07F7F922781FE001F7FC6DA83F86D7F6DD987F07F6DD98FC0814C7F03 +9FC78015BE03BC8003FC825DA25DA25DA45DB3B2B7D8F007B71280A651417BC05A>I<92 +3807FFE092B6FC020715E0021F15F8027F15FE494848C66C6C7E010701F0010F13E04901 +C001037F49496D7F4990C87F49486F7E49486F7E48496F13804819C04A814819E048496F +13F0A24819F8A348496F13FCA34819FEA4B518FFAD6C19FEA46C6D4B13FCA36C19F8A26C +6D4B13F0A26C19E06C6D4B13C0A26C6D4B13806C6D4B13006D6C4B5A6D6D495B6D6D495B +010701F0010F13E06D01FE017F5B010090B7C7FC023F15FC020715E0020092C8FC030713 +E048437CC151>I<902607FF80EBFFF8B6010FEBFF80047F14F00381B612FC038715FF03 +8F010114C09227BFF0003F7FC6DAFFC0010F7F6D91C76C7F6D496E7F03F86E7F4B6E7F4B +17804B6F13C0A27313E0A27313F0A21BF885A21BFCA3851BFEAE4F13FCA41BF861A21BF0 +611BE0611BC06F92B512801B006F5C6F4A5B6F4A5B03FF4A5B70495B04E0017F13C09226 +CFFC03B55A03C7B648C7FC03C115F803C015E0041F91C8FC040313E093CBFCB3A3B712F0 +A64F5D7BC05A>I114 D<913A3FFF8007800107 +B5EAF81F011FECFE7F017F91B5FC48B8FC48EBE0014890C7121FD80FFC1407D81FF08016 +00485A007F167F49153FA212FF171FA27F7F7F6D92C7FC13FF14E014FF6C14F8EDFFC06C +15FC16FF6C16C06C16F06C826C826C826C82013F1680010F16C01303D9007F15E0020315 +F0EC001F1500041F13F81607007C150100FC81177F6C163FA2171F7EA26D16F0A27F173F +6D16E06D157F6D16C001FEEDFF806D0203130002C0EB0FFE02FCEB7FFC01DFB65A010F5D +D8FE0315C026F8007F49C7FC48010F13E035437BC140>II<902607FFC0ED3FFEB60207B5FCA6C6EE00 +076D826D82B3B3A260A360A2607F60183E6D6D147E4E7F6D6D4948806D6DD907F0ECFF80 +6D01FFEB3FE06D91B55A6E1500021F5C020314F8DA003F018002F0C7FC51427BC05A>I< +007FB600C0017FB512F8A6D8001F01F8C70007EBF0006D040190C7FC6D6D5D6D6D4A5A6D +6D4A5A70495A6D4C5A6E7F6E6D495A6E6D495A7049C8FC6E4A5A6E6D485A6E6D485A6E13 +FFEF8FF06EEC9FE06FEBFFC06F5C6F91C9FC5F6F5B816F7F6F7F8481707F8493B57E4B80 +5D4B80DB0FF37FDB1FE17F04C080153F4B486C7F4B486C7F4A486D7F4A486D7F4A5A4B6D +7F020F6E7F4A486D7F4A486D804A5A4AC86C7F49486F7F4A6F7F0107707FEB3FFFB600F0 +49B7FCA650407EBF55>120 DI E /Fu 85 125 df<9239FFC001FC020F +9038F80FFF913B3F803E3F03C0913BFC00077E07E0D903F890390FFC0FF0494890383FF8 +1F4948EB7FF0495A494814E049C7FCF00FE04991393FC0038049021F90C7FCAFB912F0A3 +C648C7D81FC0C7FCB3B2486CEC3FF0007FD9FC0FB512E0A33C467EC539>11 +D<4AB4FC020F13E091387F80F8903901FC001C49487FD907E0130F4948137F011FECFF80 +495A49C7FCA25B49EC7F00163E93C7FCACEE3F80B8FCA3C648C7FC167F163FB3B0486CEC +7FC0007FD9FC1FB5FCA330467EC536>I<913801FFC0020FEBFB8091387F803F903801FC +00494813FFEB07E0EB1FC0A2495A49C7FC167F49143F5BAFB8FCA3C648C7123FB3B2486C +EC7FC0007FD9FC1FB5FCA330467EC536>II<001EEB +03C0397F800FF000FF131F01C013F8A201E013FCA3007F130F391E6003CC0000EB000CA4 +01E0131C491318A3000114384913300003147090C712604814E0000614C0000E130148EB +038048EB070048130E0060130C1E1D7DC431>34 D<121EEA7F8012FF13C0A213E0A3127F +EA1E601200A413E013C0A312011380120313005A1206120E5A5A5A12600B1D78C41B>39 +D<140C141C1438147014E0EB01C01303EB0780EB0F00A2131E5BA25B13F85B12015B1203 +A2485AA3485AA348C7FCA35AA2123EA2127EA4127CA312FCB3A2127CA3127EA4123EA212 +3FA27EA36C7EA36C7EA36C7EA212017F12007F13787FA27F7FA2EB0780EB03C01301EB00 +E014701438141C140C166476CA26>I<12C07E12707E7E7E120F6C7E6C7EA26C7E6C7EA2 +1378137C133C133E131E131FA2EB0F80A3EB07C0A3EB03E0A314F0A21301A214F8A41300 +A314FCB3A214F8A31301A414F0A21303A214E0A3EB07C0A3EB0F80A3EB1F00A2131E133E +133C137C13785BA2485A485AA2485A48C7FC120E5A5A5A5A5A16647BCA26>I<14F0A280 +5CA70078EC01E000FCEC03F0B4140FD87F80EB1FE0D83FC0EB3FC03A0FF060FF003903F8 +61FC3900FC63F090383F6FC0D90FFFC7FCEB03FCEB00F0EB03FCEB0FFF90383F6FC09038 +FC63F03903F861FC390FF060FF3A3FC0F03FC0D87F80EB1FE0D8FF00EB0FF000FC140300 +78EC01E0C790C7FCA7805CA2242B7ACA31>I<16C04B7EB3AB007FBAFCBB1280A26C1900 +C8D801E0C9FCB3AB6F5A41407BB84C>I<121EEA7F8012FF13C0A213E0A3127FEA1E6012 +00A413E013C0A312011380120313005A1206120E5A5A5A12600B1D78891B>II<121EEA7F80A2EAFFC0A4EA7F80A2EA1E000A0A78891B>I<1618163C167C +A2167816F8A216F01501A216E01503A216C01507A21680150FA2ED1F00A2151E153EA215 +3C157CA2157815F8A25D1401A24A5AA25D1407A25D140FA292C7FC5CA2141E143EA2143C +147CA25CA25C1301A25C1303A25C1307A25C130FA291C8FC5BA2133EA2133C137CA21378 +13F8A25B1201A25B1203A2485AA25B120FA290C9FC5AA2121E123EA2123C127CA2127812 +F8A25A126026647BCA31>I<14FF010713E090381F81F890383E007C01FC133F4848EB1F +8049130F4848EB07C04848EB03E0A2000F15F0491301001F15F8A2003F15FCA390C8FC48 +15FEA54815FFB3A46C15FEA56D1301003F15FCA3001F15F8A26C6CEB03F0A36C6CEB07E0 +000315C06D130F6C6CEB1F806C6CEB3F00013E137C90381F81F8903807FFE0010090C7FC +28447CC131>I<143014F013011303131F13FFB5FC13E713071200B3B3B0497E497E007F +B6FCA3204278C131>II<49B4FC010F +13E0013F13FC9038FE01FE3A01F0007F80D803C0EB3FC048C7EA1FE0120EED0FF0EA0FE0 +486C14F8A215077F5BA26C48130FEA03C0C813F0A3ED1FE0A2ED3FC01680ED7F0015FE4A +5AEC03F0EC1FC0D90FFFC7FC15F090380001FCEC007FED3F80ED1FC0ED0FE016F0ED07F8 +16FC150316FEA2150116FFA3121EEA7F80487EA416FE491303A2007EC713FC0070140700 +3015F80038140F6C15F06CEC1FE06C6CEB3FC0D803E0EB7F803A01FE01FE0039007FFFF8 +010F13E0010190C7FC28447CC131>II<000615C0D807C0130701FCEB7F8090 +B612005D5D5D15E0158026063FFCC7FC90C9FCAE14FF010713C090381F01F090383800FC +01F0137ED807C07F49EB1F8016C090C7120F000615E0C8EA07F0A316F81503A216FCA512 +3E127F487EA416F890C712075A006015F0A20070140F003015E00038EC1FC07E001EEC3F +806CEC7F006C6C13FE6C6C485A3901F807F039007FFFE0011F90C7FCEB07F826447BC131 +>II<121CA2EA1F8090B712C0A3481680A217005E00 +38C8120C0030151C00705D0060153016705E5E4814014B5A4BC7FCC81206150E5D151815 +385D156015E04A5AA24A5A140792C8FC5CA25C141E143EA2147E147CA214FCA21301A349 +5AA41307A6130FAA6D5AEB01C02A457BC231>I<14FF010713E0011F13F890387F00FE01 +FC133FD801F0EB1F804848EB0FC049EB07E00007EC03F048481301A290C713F8481400A4 +7FA26D130116F07F6C6CEB03E013FC6C6CEB07C09039FF800F806C9038C01F006CEBF03E +ECF87839007FFEF090383FFFC07F01077F6D13F8497F90381E7FFFD97C1F1380496C13C0 +2601E00313E048486C13F000079038007FF84848EB3FFC48C7120F003EEC07FE15014814 +0016FF167F48153FA2161FA56C151E007C153EA2007E153C003E157C6C15F86DEB01F06C +6CEB03E06C6CEB07C0D803F8EB1F80C6B4EBFF0090383FFFFC010F13F00101138028447C +C131>I<14FF010713E0011F13F890387F80FC9038FC007E48487F4848EB1F804848EB0F +C0000FEC07E0485AED03F0485A16F8007F140190C713FCA25AA216FE1500A516FFA46C5C +A36C7E5D121F7F000F5C6C6C1306150E6C6C5B6C6C5BD8007C5B90383F01E090390FFF80 +FE903801FE0090C8FC150116FCA4ED03F8A216F0D80F801307486C14E0486C130F16C0ED +1F80A249EB3F0049137E001EC75A001C495A000F495A3907E01FE06CB51280C649C7FCEB +1FF028447CC131>I<121EEA7F80A2EAFFC0A4EA7F80A2EA1E00C7FCB3A5121EEA7F80A2 +EAFFC0A4EA7F80A2EA1E000A2B78AA1B>I<121EEA7F80A2EAFFC0A4EA7F80A2EA1E00C7 +FCB3A5121E127FEAFF80A213C0A4127F121E1200A512011380A3120313005A1206120E12 +0C121C5A5A12600A3E78AA1B>I<007FBAFCBB1280A3CEFCB0BB1280A36C190041187BA4 +4C>61 D64 D<16C04B7EA34B7EA34B7EA34B7EA3 +ED19FEA3ED30FFA203707FED607FA203E07FEDC03FA2020180ED801FA2DA03007F160FA2 +0206801607A24A6D7EA34A6D7EA34A6D7EA20270810260147FA202E08191B7FCA2498202 +80C7121FA249C87F170FA20106821707A2496F7EA3496F7EA3496F7EA201788313F8486C +83D80FFF03037FB500E0027FEBFFC0A342477DC649>IIIIII +III<010FB512FEA3D9000313806E130080 +B3B3AB123F487E487EA44A5A13801300006C495A00705C6C13076C5C6C495A6CEB1F8026 +03E07FC7FC3800FFFCEB1FE027467BC332>IIIIIIIII<49B41303010FEBE007013F13F89039FE00FE +0FD801F8131FD807E0EB079F49EB03DF48486DB4FC48C8FC4881003E81127E82127C00FC +81A282A37E82A27EA26C6C91C7FC7F7FEA3FF813FE381FFFE06C13FE6CEBFFE06C14FC6C +14FF6C15C0013F14F0010F80010180D9001F7F14019138001FFF03031380816F13C0167F +163F161F17E000C0150FA31607A37EA36C16C0160F7E17806C151F6C16006C5D6D147ED8 +FBC05CD8F9F0495AD8F07C495A90393FC00FE0D8E00FB51280010149C7FC39C0003FF02B +487BC536>I<003FB912F8A3903BF0001FF8001F01806D481303003EC7150048187C0078 +183CA20070181CA30060180CA5481806A5C81600B3B3A54B7EED7FFE49B77EA33F447DC3 +46>IIII89 D<001FB81280A39126800001130001FCC7FC01F04A5A01C04A5A5B90C8485A12 +1E4C5A484B5AA200384B5A4C5AA24B90C7FC00304A5AA24B5AA24B5AC8485AA24B5A4B5A +A24B5A5C93C8FC4A5AA24A5A4A5AA24A5A4A5AA24A5A14FF5D4990C9FCEF0180495A495A +A2495A494814031800495AA2495A495A5F4890C8FC485A5F485A48485D5F48485D17FE48 +4814034848140F16FFB8FCA331447BC33C>II<01C01318000114384848137048C712E0000EEB01C0000C1480001C1303 +0018140000385B003013060070130E0060130CA300E0131C481318A400CFEB19E039FFC0 +1FF801E013FCA3007F130FA2003F130701C013F8390F0001E01E1D71C431>II<130C131E133F497EEBF3C03801E1E038 +03C0F03807807848487E001E7F487F0070EB038048EB01C00040EB00801A0E75C331>I< +EB07FC90383FFF809038F80FE03903C003F048C66C7E000E6D7ED80FC0137E486C137F6D +6D7EA36F7EA26C5AEA0380C8FCA4EC0FFF49B5FC90380FFE1FEB3FC0EBFF00EA03FC485A +485A485A485A127F5B176048C7FCA3153FA36D137F007F14EF6D9038C7E0C0003F13013A +1FE00783F13B07F81E03FF802701FFFC0113003A001FE0007C2B2E7CAC31>97 +DII<167FED3FFFA315018182B3EC7F80903803FFF090380FC07C +90383F000E017E1307496D5AD803F87F48487F5B000F81485AA2485AA2127FA290C8FC5A +AB7E7FA2123FA26C7EA2000F5D7F6C6C5B00035C6C6C9038077F806C6C010E13C0013F01 +1C13FE90380FC0F8903803FFE09026007F0013002F467DC436>III +III<143C14FFA2491380A46D1300A2143C91C7FCADEC7F80EB +3FFFA31300147F143FB3B3AA123E127F39FF807F00A2147EA25C6C485A383C01F06C485A +3807FF80D801FEC7FC195785C21E>IIII<3901FC01FE00FF903807FFC091381E07F091383801F800070170 +7F0003EBE0002601FDC07F5C01FF147F91C7FCA25BA35BB3A8486CECFF80B5D8F83F13FE +A32F2C7DAB36>II<3901FC03FC00FF9038 +0FFF8091383C07E091387001F83A07FDE000FE00010180137F01FFEC3F8091C7EA1FC049 +15E049140F17F0160717F8160317FCA3EE01FEABEE03FCA3EE07F8A217F0160F6D15E0EE +1FC06D143F17806EEB7E00D9FDC05B9039FCF003F891383C0FE091381FFF80DA03FCC7FC +91C9FCAE487EB512F8A32F3F7DAB36>I<91387F8003903903FFE00790380FE07890393F +801C0F90387E000E496D5AD803F8EB039F0007EC01BF4914FF48487F121F5B003F81A248 +5AA348C8FCAB6C7EA3123F7F121F6D5C120F6D5B12076C6C5B6C6C497E6C6C130E013F13 +1C90380FC0F8903803FFE09038007F0091C7FCAEEEFF80033F13FEA32F3F7DAB33>I<39 +03F803F000FFEB1FFCEC3C3EEC707F0007EBE0FF3803F9C000015B13FBEC007E153C01FF +13005BA45BB3A748B4FCB512FEA3202C7DAB26>I<90383FE0183901FFFC383907E01F78 +390F0003F8001E1301481300007C1478127800F81438A21518A27EA27E6C6C13006C7E13 +FC383FFFE06C13FC6C13FF6C14C06C14E0C614F0011F13F81300EC0FFC140300C0EB01FE +1400157E7E153EA27EA36C143C6C147C15786C14F86CEB01F039F38003E039F1F00F8039 +E07FFE0038C00FF01F2E7DAC26>I<1306A5130EA4131EA3133E137EA213FE1201120700 +1FB512F0B6FCA2C648C7FCB3A4150CAA017E131C017F1318A26D133890381F8030ECC070 +903807E0E0903801FFC09038007F001E3E7EBC26>III +III<003FB612E0A29038C0003F90C713C0003CEC7F800038ECFF +00A20030495A0070495AA24A5A0060495AA24A5A4A5AA2C7485A4AC7FC5B5C495A13075C +495A131F4A1360495A495AA249C712C0485AA2485A485A1501485A48481303A24848EB07 +804848131F00FF14FF90B6FCA2232B7DAA2B>III E /Fv 24 122 df<15E01401EC03C0EC0780EC0F00141E5C147C5C495A13035C +495A130F5C131F91C7FC133E137EA25BA2485AA25B1203A2485AA3120F5BA2121FA25BA2 +123FA290C8FCA35AA5127EA312FEB3A3127EA3127FA57EA37FA2121FA27FA2120FA27F12 +07A36C7EA212017FA26C7EA2137EA2133E7F80130F8013076D7E8013016D7E147C143C80 +80EC0780EC03C0EC01E014001B7974D92E>40 D<12E07E12787E7E7E6C7E7F6C7E6C7E7F +1200137C137E133E133F7F6D7E80A26D7EA26D7EA2130180A26D7EA380147EA2147FA280 +A21580A2141FA315C0A5140FA315E0B3A315C0A3141FA51580A3143FA21500A25CA2147E +A214FE5CA3495AA25C1303A2495AA2495AA25C49C7FC5B133E137E137C5B12015B485A48 +5A5B48C8FC121E5A5A5A5A1B797AD92E>I<120FEA3FC0EA7FE012FF13F0A213F8A3127F +123FEA0F381200A513781370A313F013E0A2120113C0120313801207EA0F00121EA25A5A +12300D23768B21>44 D<120FEA3FC0EA7FE0EAFFF0A6EA7FE0EA3FC0EA0F000C0C768B21 +>46 D<14075C5C147F5C1307133F000FB5FCB6FC13F913C1EAF0011200B3B3B3A7497F01 +0F13E0B712FEA4274F75CE3B>49 D51 +D57 D +64 D<49B612FEA490C7003F138092380FFE001507B3B3B3A21206EA3FC0487E487EA44B +5AA25B007F5D0180131F0078C75B6C143F003E4A5A6C5D6C6C495A2707E003FEC7FC3901 +FC07FC6CB512F0013F13C0D907FCC8FC2F547BD13C>74 D76 D97 DII104 D<1378EA01FE487E487FA66C90C7FC6C5AEA007890C8FCB0EB7F80B5FCA41203 +C6FC137FB3B3A43801FFE0B61280A419507CCF21>I108 D<01FFD907FEEC03FFB590261FFFC0010F13 +E0037F01F0013F13F8912701F80FFC9038FC07FE913D03C003FE01E001FF000390260700 +019038038000C6010E6D6C48C76C7E6D48DA7F8E6E7E4A159CA24ADA3FF86E7E02605D14 +E04A5DA34A5DB3AD2601FFE0DAFFF0EC7FF8B6D8C07F9026FFE03FB512F0A45C347CB363 +>I<01FFEB07FCB590383FFF8092B512E0913901F00FF8913903C007FC000349C66C7EC6 +010E13016D486D7E5C143002706E7E146014E05CA35CB3AD2601FFE0903801FFE0B600C0 +B612C0A43A347CB341>II<90397F8007FCB590387FFF80 +0281B512E0913987F00FF891398F8003FC000190399E0001FF6C01BC6D7FD97FF86E7E4A +6E7E4A6E7E4A140F844A6E7EA2717EA3717EA4711380AB4D1300A44D5AA24D5AA2606E14 +0F4D5A6E5D6E4A5A6E4A5A02BC4AC7FC029E495A028FEB07FC913987E01FF00281B512C0 +DA807F90C8FCED0FF892CAFCB13801FFE0B612C0A4394B7DB341>I<01FFEB1F80B5EB7F +F0913801FFF8913803E1FC91380783FE0003EB0F07C6131EEB7F1C1438143091387003FC +91386000F0160014E05CA45CB3AA8048487EB612F0A427347DB32E>114 +DI117 D121 D E /Fw 25 122 df[<1638167816F0ED01E0ED03C0 +ED0780ED0F00151E153E5D5D4A5A4A5AA24A5A4A5A141F92C7FC143E147E147C14FC495A +A2495AA2495AA2495AA2495AA2133F91C8FC5B137EA213FE5B1201A25B1203A3485AA448 +5AA4485AA5123F5BA5127FA390C9FCA65AB3A87EA67FA3123FA57F121FA56C7EA46C7EA4 +6C7EA312017FA212007F137EA2137F7F80131FA26D7EA26D7EA26D7EA26D7EA26D7E147C +147E143E8081140F6E7E6E7EA26E7E6E7E157C81151E81ED0780ED03C0ED01E0ED00F016 +781638>37 172 113 256 61 40 D[<12E07E12787E7E7E6C7E6C7E7F6C7E6C7E137C7F +A27F6D7E8013076D7E801301806D7EA2147EA280A26E7EA26E7EA2811407811403A28114 +0181A2140081A3157FA4ED3F80A4ED1FC0A516E0150FA516F0A31507A616F8B3A816F0A6 +150FA316E0A5151F16C0A5ED3F80A4ED7F00A415FEA35D1401A25D14035DA214075D140F +5DA24A5AA24AC7FCA2147EA25CA2495A5C13035C495A130F5C49C8FC133EA25B5B485A48 +5A5B485A48C9FC121E5A5A5A5A>37 172 120 256 61 I<150E151E153E157E15FE1403 +1407141F14FF130790B5FCB6FC14E7140713F81300C7FCB3B3B3B3B24A7E4A7F49B512F8 +007FB812E0A5337272F14F>49 D58 D65 D76 D80 +D82 DI<001FBE12F8A502F8C7000F01F0C7121F4801806E49020113FC01FCC86C49EC003F49 +1B1F01E01B07491B03491B0190C91800A2003E1D7CA2003C1D3CA3481D1EA500701D0EA8 +481D07A6CA1900B3B3B3B14D7F4D7F057F13FE031FB812F8A568757BF473>I<913803FF +80021F13F891B512FE903A03FC01FF80903A07E0003FE0D91F80EB0FF8013EC76C7E496E +7E01F06E7E48486E7F717E4848153F4982D807A06F7E13FC487E6D6F7E80A2717EA46C90 +C8FC6C5A6C5ACAFCA6EE07FF0303B5FC157F913903FFFE07021F138091387FF800903801 +FFC0010790C7FCEB1FFCEB3FF0EBFFE0485B485B4890C8FC5B485A485AA2485A1A0E485A +A312FF5B170FA4171FA26D153F007F163B177B6DDBF1FE131C003F16E16C6C14016C6C91 +2603C0FF13386C6CEC0F806C6C6C903A1F007F80706C6D017CECE1E028007FF803F8EB3F +FF011FB500E06D1380010391C7000713009026003FF8EC01FC474D79CB4F>97 +D<14F8EA03FFB5FCA5C6FC133F131FA2130FB3B04CB47E041F13F8047F13FE923A01FC01 +FF80923A07E0003FE0031FC7EA0FF0033EEC07FC0378EC01FE4B6E7EDAF9E06F7EDAFBC0 +6F7EDAFF808292C96C7E737E5C4A707E864A160386851B80A37313C0A31BE0A31A7FA21B +F0AE1BE0A21AFFA31BC0A2611B80A21B0061626E1607626E160F626E4C5A02F75FDAE780 +4B5ADAE3C0157FDAC1E04B5ADAC0F04A48C7FC03784A5A4A6CEC0FF8031F4A5A4A6C6CEB +7FC0922703F803FFC8FC0300B512FC010E023F13E090C8D807FEC9FC4C797BF758>II101 +DII<13 +1EEB7F80497E487F487FA66C5B6C5B6D5A011EC7FC90C8FCB3A7EB01F0EA07FFB5FCA512 +01EA007F133FA2131FB3B3B3A3497EEBFFFEB612FCA51E727AF12A>105 +D108 D110 DI<02F849B47ED803FF021F13F8B5027F13 +FE923A01FC01FF80923A07E0003FE0031FC76C7E033EEC0FFCC60278EC03FE013F496E7E +90261FF9E06E7FDAFBC0826DB4486F7E92C96C7E737E5C4A707E864A160786851B80A285 +1BC0A2851BE0A5F27FF0AEF2FFE0A54F13C0A34F1380A21B0061626E160F626E161F626E +4C5A4F5A6F5EDAFBC015FFDAF9E04A5BDAF8F04A48C7FC03784A5A6F4A5A031FEC3FF06F +6CEBFFC0922603F80790C8FC0300B512FC043F13E0DC07FEC9FC93CBFCB3A7497EEB7FFF +B77EA54C6C7BCA58>I114 DI118 +D121 D E /Fx 4 118 df<003FBCFCA863A263CC00075B616361634F5B616396 +B5FC4E91C7FC626062604E5B626062604E5B6295B5FC97C8FC5F4D5B615F615F4D5B615F +615F94B55A96C9FC5E605E4C5B605E605E4C5B605E6093B5FC4B91CAFC5F5D5F5D4B5B5F +5D5F5D4B5B5F92B5FC94CBFC5C4A5B5E5C5E5C4A5B5E5C5E5C91B55A93CCFC5B5D5B495B +5D5B5D5B495B5D5B5D90B5FC4891CDFC5C5A5C485B5A5C5A5C4890BB12805AA2BDFCA851 +7877F763>90 D98 D101 +D117 D E end +%%EndProlog +%%BeginSetup +%%Feature: *Resolution 600dpi +TeXDict begin + +%%EndSetup +%%Page: 1 1 +1 0 bop 237 809 a Fx(Zebu)p Fw(:)70 b(A)52 b(T)-13 b(o)t(ol)53 +b(for)g(Sp)t(ecifying)i(Rev)l(ersible)f(LALR\(1\))1671 +1017 y(P)l(arsers)810 1313 y Fv(Joac)m(him)36 b(Laubsc)m(h)j(\(laubsc)m +(h at hplabs.hp.com\))1483 1592 y(Jan)m(uary)f(13,)f(1999)2143 +3922 y Fu(Application)30 b(Engineering)i(Departmen)m(t)2331 +4043 y(Soft)m(w)m(are)i(T)-8 b(ec)m(hnology)33 b(Lab)s(oratory)2446 +4163 y(Hewlett-P)m(ac)m(k)-5 b(ard)33 b(Lab)s(oratories)2247 +4283 y(1501)f(P)m(age)h(Mill)d(Road,)i(Bldg.)43 b(1U-17)3056 +4404 y(P)-8 b(.O.)33 b(Bo)m(x)g(10490)1610 4524 y(P)m(alo)f(Alto,)f +(Calif.)42 b(94304-1126)30 b(laubsc)m(h at hpl.hp.com)3091 +4764 y(\(415\))i(857-7695)1896 5656 y(1)p eop +%%Page: 2 2 +2 1 bop 120 407 a Ft(Con)l(ten)l(ts)120 720 y Fs(1)90 +b(In)m(tro)s(duction)2780 b(3)120 1030 y(2)90 b(The)38 +b(Represen)m(tations)f(of)h(Grammars)f(in)g(Files)1303 +b(5)266 1207 y Fu(2.1)100 b(Grammar)30 b(notation)80 +b Fr(:)50 b(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g +(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)192 b +Fu(5)491 1383 y(2.1.1)111 b(Grammar)30 b(Rules)46 b Fr(:)k(:)g(:)g(:)g +(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:) +g(:)g(:)g(:)g(:)192 b Fu(5)120 1693 y Fs(3)90 b(Grammar)37 +b(Options)2501 b(9)266 1870 y Fu(3.1)100 b(Keyw)m(ord)34 +b(Argumen)m(ts)f(to)f(Grammar)e(Construction)87 b Fr(:)50 +b(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)192 b Fu(9)266 +2047 y(3.2)100 b(De\014ning)32 b(a)g(Domain)77 b Fr(:)50 +b(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)g(:)g +(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)143 b Fu(10)120 +2357 y Fs(4)90 b(The)38 b Fq(Zebu)f Fs(Meta)h(Grammar)2104 +b(13)266 2534 y Fu(4.1)100 b(Domain)30 b(De\014nition)94 +b Fr(:)50 b(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g +(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)143 b +Fu(15)266 2710 y(4.2)100 b(Example)32 b(Grammars)26 b +Fr(:)50 b(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g +(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)143 b +Fu(15)266 2887 y(4.3)100 b(The)33 b(Kleene)g(*)f(Notation)59 +b Fr(:)50 b(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)g(:)g +(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)143 b Fu(18)120 +3197 y Fs(5)90 b(Using)37 b(the)h(Compiler)2376 b(19)266 +3374 y Fu(5.1)100 b(Compiling)29 b(a)j(grammar)99 b Fr(:)50 +b(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g +(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)143 b Fu(19)266 3550 y(5.2)100 +b(Loading)31 b(a)h(grammar)41 b Fr(:)50 b(:)g(:)g(:)g(:)g(:)g(:)g(:)g +(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:) +g(:)g(:)143 b Fu(22)266 3727 y(5.3)100 b(P)m(arsing)32 +b(a)g(string)g(with)h(a)f(grammar)23 b Fr(:)50 b(:)g(:)g(:)f(:)h(:)g(:) +g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)143 +b Fu(22)266 3904 y(5.4)100 b(P)m(arsing)32 b(from)f(a)i(\014le)f(with)g +(a)g(grammar)67 b Fr(:)50 b(:)f(:)h(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g +(:)f(:)h(:)g(:)g(:)g(:)g(:)143 b Fu(23)266 4080 y(5.5)100 +b(P)m(arsing)32 b(from)f(a)i(list)e(of)h(tok)m(ens)62 +b Fr(:)50 b(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g +(:)f(:)h(:)g(:)g(:)g(:)g(:)143 b Fu(24)266 4257 y(5.6)100 +b(Debugging)31 b(a)h(grammar)84 b Fr(:)50 b(:)g(:)g(:)g(:)g(:)g(:)g(:)g +(:)f(:)h(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:) +143 b Fu(25)120 4567 y Fs(6)90 b(Lexical)37 b(Analysis)2548 +b(25)266 4744 y Fu(6.1)100 b(Customization)31 b(and)h(Regular)g +(Expressions)c Fr(:)50 b(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:) +g(:)g(:)g(:)g(:)143 b Fu(25)266 4920 y(6.2)100 b(In)m(tro)s(ducing)32 +b(new)i(Categories)e(b)m(y)i(Regular)d(Expressions)66 +b Fr(:)50 b(:)g(:)g(:)f(:)h(:)g(:)g(:)g(:)g(:)143 b Fu(25)266 +5097 y(6.3)100 b(The)33 b(functional)e(in)m(terface)i(to)f(the)h +(parsing)f(engine)84 b Fr(:)50 b(:)g(:)g(:)g(:)g(:)g(:)f(:)h(:)g(:)g(:) +g(:)g(:)143 b Fu(27)120 5407 y Fs(7)90 b(F)-9 b(uture)38 +b(W)-9 b(ork)2710 b(28)1896 5656 y Fu(2)p eop +%%Page: 3 3 +3 2 bop 120 407 a Fs(A)61 b(Installation)2784 b(29)1720 +1001 y Fp(Abstract)500 1234 y Fo(Zebu)690 1201 y Fn(1)760 +1234 y Fm(is)29 b(part)h(of)g(a)h(set)g(of)f(to)s(ols)g(for)g(the)g +(translation)g(of)g(formal)f(languages.)41 b Fo(Zebu)364 +1347 y Fm(con)m(tains)32 b(a)h(LALR\(1\))h(parser)d(generator)j(lik)m +(e)e(Y)-8 b(acc)34 b(do)s(es.)46 b(Aside)32 b(from)g(generating)h(a)364 +1460 y(parser,)h Fo(Zebu)g Fm(will)d(also)j(generate)h(the)f(in)m(v)m +(erse)f(of)h(a)h(parser)e(\(unparser\).)50 b(In)33 b(con)m(trast)364 +1573 y(to)g(Y)-8 b(acc,)34 b(the)e(seman)m(tics)g(is)f(not)h(giv)m(en)g +(in)f(terms)h(of)g(\\routines")g(but)f(declarativ)m(ely)g(in)364 +1686 y(terms)f(of)h(t)m(yp)s(ed)f(feature)h(structures.)500 +1803 y(The)39 b(abilit)m(y)f(to)i(declarativ)m(ely)f(de\014ne)g(a)h +(rev)m(ersible)e(grammar,)k(together)f(with)d(a)364 1916 +y(rewrite-rule)29 b(mec)m(hanism)i(\()p Fo(Zebu-RR)p +Fm(\))h(for)f(transforming)f(abstract)i(syn)m(tax)g(trees)f(con-)364 +2029 y(stitute)f(the)h(basic)f(to)s(ols)g(for)g(sp)s(ecifying)e +(translators)i(for)g(formal)g(languages.)364 2294 y Fs(Keyw)m(ords)91 +b Fm(F)-8 b(ormal)33 b(language,)g(LALR-grammar,)g(parsing,)f +(translation,)g(genera-)364 2407 y(tion,)e(in)m(terop)s(erabilit)m(y)-8 +b(,)29 b(LEX,)h(Y)-8 b(A)m(CC.)120 2809 y Ft(1)161 b(In)l(tro)t +(duction)120 3080 y Fu(Our)37 b(goal)e(is)h(to)g(dev)m(elop)h(an)g(en)m +(vironmen)m(t)g(for)f(the)h(design,)h(analysis)e(and)g(manipulation)d +(of)120 3200 y(formal)43 b(languages,)48 b(suc)m(h)e(as)g(programming)c +(languages,)48 b(markup)d(languages,)j(data)d(in)m(ter-)120 +3321 y(c)m(hange)h(formats)e(or)g(kno)m(wledge)i(represen)m(tation)f +(languages)g(\(suc)m(h)h(as)f(the)g(translation)e(to)120 +3441 y(and)28 b(from)e(KIF\))i([4].)42 b(Being)27 b(able)g(to)h +(design,)g(analyze,)h(and)f(manipulate)e(formal)f(languages)i(is)120 +3562 y(crucial)32 b(for)h(ac)m(hieving)g(soft)m(w)m(are)h(in)m(terop)s +(erabilit)m(y)e([3)o(],)i(automatic)e(co)s(de)h(analysis,)h(indexing,) +120 3682 y(and)42 b(retriev)-5 b(al)40 b(for)i(p)s(oten)m(tial)e +(reuse.)72 b(Zebu)42 b(has)g(b)s(een)h(applied)e(to)g(writing)f +(translators)h(for)120 3802 y(formal)32 b(languages)i([6].)50 +b(The)36 b(main)c(idea)i(of)h(this)f(w)m(ork)i(is)e(that)g(a)g(mo)s +(dule)g Fr(m)h Fu(comm)m(unicates)120 3923 y(b)m(y)k(sending)f(or)g +(receiving)f(messages)i(in)e(some)h(language)f Fr(L)p +Fu(\()p Fr(m)p Fu(\),)j(and)e(that)g(for)f(v)-5 b(arious)37 +b(rea-)120 4043 y(sons)g(di\013eren)m(t)f(mo)s(dules)f(use)h +(di\013eren)m(t)g(languages.)53 b(F)-8 b(or)35 b(comm)m(unication)f(to) +h(b)s(e)h(successful,)120 4163 y(translators)d(ha)m(v)m(e)i(to)f(b)s(e) +g(used.)48 b Fq(Zebu)34 b Fu(pro)m(vides)g(to)s(ols)f(to)g(de\014ne)i +(translators)e(at)h(a)f(high)g(lev)m(el)120 4284 y(of)f(abstraction)709 +4248 y Fn(2)748 4284 y Fu(.)266 4451 y(McCarth)m(y)38 +b(in)m(tro)s(duced)e(the)h(notion)e(of)g(\\abstract")h(and)g +(\\concrete")h(syn)m(tax.)55 b(The)37 b(con-)120 4572 +y(crete)f(syn)m(tax)g(describ)s(es)h(the)e(surface)h(form)e(of)g(a)h +(linguistic)d(expression,)37 b(while)d(the)i(abstract)120 +4692 y(syn)m(tax)30 b(describ)s(es)f(a)f(\(comp)s(osite\))f(ob)5 +b(ject.)43 b(E.g.)g(\\1+a")27 b(is)h(the)g(surface)i(string)d(rendered) +j(b)m(y)f(a)120 4813 y(particular)e(concrete)i(syn)m(tax)i(for)d(an)g +(ob)5 b(ject)29 b(describ)s(ed)h(b)m(y)f(an)f(abstract)h(syn)m(tax:)43 +b(an)29 b(addition)p 120 4917 1440 4 v 232 4979 a Fl(1)269 +5009 y Fk(\\)p Fj(zebu)p Fi(n)p Fk(.,)k Fi(pl)p Fk(.)49 +b Fj(-bus)p Fk(,)32 b Fj(-bu)p Fk(:)45 b(1.)j(an)31 b(o)n(xlik)n(e)g +(domestic)g(animal)g(\()p Fi(Bos)j(indicus)p Fk(\))f(nativ)n(e)e(to)g +(Asia)g(and)h(parts)120 5108 y(of)c(Africa:)36 b(it)28 +b(has)f(a)g(large)f(h)n(ump)i(o)n(v)n(er)e(the)i(shoulders,)f(short,)f +(curving)h(horns,)g(p)r(endulous)h(ears,)e(and)h(a)g(large)120 +5208 y(dewlap)34 b(and)g(is)g(resistan)n(t)g(to)g(heat)g(and)g +(insect-b)r(orn)g(diseases.")55 b([W)-7 b(ebster's)34 +b(New)g(W)-7 b(orld)34 b(Dictionary)-7 b(.])57 b(A)120 +5308 y(zebu)28 b(should)f(not)h(b)r(e)g(confused)f(with)h(a)f(y)n(acc)g +(or)g(a)g(gn)n(u)g(although)g(it)h(b)r(ears)f(similarit)n(y)f(to)i(eac) +n(h)f(of)g(them.)232 5377 y Fl(2)269 5407 y Fk(The)22 +b(rewrite-rule)f(mec)n(hanism)g(\(Zebu-RR\))h(is)g(implemen)n(ted,)i +(and)d(will)h(b)r(e)g(describ)r(ed)g(in)g(a)g(future)g(rep)r(ort.)1896 +5656 y Fu(3)p eop +%%Page: 4 4 +4 3 bop 120 407 a Fu(op)s(eration)33 b(with)i(t)m(w)m(o)g(op)s(erands,) +h(the)f(\014rst)h(b)s(eing)e(the)h(n)m(umeral)f(\\1",)h(and)f(the)i +(second)g(b)s(eing)120 527 y(the)d(v)-5 b(ariable)31 +b(named)h(\\a".)266 695 y(Manipulation)39 b(of)i(linguistic)d +(expressions)43 b(is)e(m)m(uc)m(h)g(easier)h(to)e(express)k(in)c(the)i +(abstract)120 815 y(syn)m(tax)34 b(than)f(in)f(the)h(concrete)g(syn)m +(tax.)266 983 y(If)42 b(w)m(e)g(w)m(ere)g(to)f(design)h(an)f(algorithm) +d(for)i(simplifying)e(expressions)43 b(of)e(some)g(language)120 +1103 y(|)46 b(sa)m(y)h(\\arithmetic")d(|)i(w)m(e)h(w)m(ould)f(use)h(as) +g(the)g(fron)m(t)f(end)h(the)f(\\arithmetic-parser")e(to)120 +1224 y(translate)36 b(in)m(to)g(abstract)h(syn)m(tax,)j(then)d(express) +i(the)e(simpli\014cation)d(rules)i(in)g(terms)h(of)f(tree)120 +1344 y(transformation)25 b(rules)i(that)g(op)s(erate)g(on)f(the)i +(abstract)f(syn)m(tax,)j(and)d(\014nally)f(add)h(as)g(the)g(bac)m(k-) +120 1464 y(end)33 b(the)g(\\arithmetic-unparser".)266 +1632 y(More)d(generally)-8 b(,)29 b(if)f(w)m(e)j(w)m(ere)g(to)e(design) +g(an)h(algorithm)c(for)j(translating)e(from)i(language)f(A)120 +1752 y(to)j(language)f(B,)h(w)m(e)h(w)m(ould)f(de\014ne)i(rev)m +(ersible)e(grammars)f(for)g(languages)h(A)g(and)g(B,)h(and)f(sets)120 +1873 y(of)k(rewrite)g(rules)g(to)g(transform)f(the)i(abstract)f(syn)m +(tax)i(trees)f(from)e(the)i(domain)d(of)i(language)120 +1993 y(A)45 b(to)f(the)i(domain)d(of)h(language)g(B.)h(The)h(fron)m(t)e +(end)i(w)m(ould)f(b)s(e)g(the)g(\\A-parser")g(and)g(the)120 +2114 y(bac)m(k-end)34 b(the)f(\\B-unparser")266 2281 +y(The)f(w)m(ork)f(describ)s(ed)g(in)f(this)g(rep)s(ort)g(o)m(w)m(es)i +(a)e(lot)f(to)h(the)h(pioneering)e(researc)m(h)j(at)e(Kestrel)120 +2402 y([9])38 b(that)f(resulted)h(in)f(the)h Fq(Re\014ne)1394 +2365 y Fn(3)1471 2402 y Fu(program)f(transformation)e(system)k([8].)58 +b(The)39 b(basic)e(ideas)120 2522 y(underlying)45 b Fq(Zebu)g +Fu(are)g(already)f(presen)m(t)j(in)d Fq(Re\014ne)p Fu(.)82 +b Fq(Zebu)45 b Fu(is)f(m)m(uc)m(h)i(more)e(compact)h(than)120 +2642 y Fq(Re\014ne)371 2606 y Fn(4)411 2642 y Fu(,)37 +b(and)f(the)g(seman)m(tics)g(is)g(expressed)i(in)d(t)m(yp)s(ed)i +(feature)g(structures.)55 b Fq(Zebu)36 b Fu(also)f(o\013ers)120 +2763 y(the)25 b(p)s(ossibilit)m(y)e(of)i(de\014ning)g(a)f +(meta-grammar.)38 b Fq(Zebu)25 b Fu(lac)m(ks)g Fq(Re\014ne)p +Fu('s)h(abilit)m(y)d(to)i(declarativ)m(ely)120 2883 y(sp)s(ecify)33 +b(transformations)e(using)h(a)g(pattern)h(language.)2231 +2847 y Fn(5)266 3051 y Fu(The)45 b(LALR\(1\))e(parsing)g(table)g +(generated)i(b)m(y)g Fq(Zebu)f Fu(follo)m(ws)e(algorithms)f(describ)s +(ed)k(in)120 3171 y([1])j(or)f([2].)89 b(The)48 b(curren)m(t)h +(implemen)m(tation)c(w)m(as)j(dev)m(elop)s(ed)h(from)d(the)i +Fq(Scheme)h Fu(program)120 3291 y(dev)m(elop)s(ed)34 +b(b)m(y)f(William)28 b(W)-8 b(ells)32 b(and)h(is)f(written)g(in)g +Fq(Common)h(Lisp)p Fu(.)266 3459 y(The)h(next)g(section)f(will)e +(explain)h(ho)m(w)i(a)e(grammar)f(can)i(b)s(e)g(de\014ned,)i(and)e(ho)m +(w)h(seman)m(tics)120 3579 y(can)45 b(b)s(e)g(asso)s(ciated)g(with)f(a) +h(grammar)d(rule.)80 b(Section)45 b(3)f(describ)s(es)i(the)f +(de\014nition)f(of)h(the)120 3700 y(seman)m(tic)36 b(domain.)52 +b(With)35 b(this)g(capabilit)m(y)g(it)g(is)g(p)s(ossible)g(to)h(state)g +(declarativ)m(ely)f(what)i(the)120 3820 y(abstract)43 +b(syn)m(tax)i(should)d(lo)s(ok)g(lik)m(e.)74 b(Section)42 +b(4)h(describ)s(es)h(a)e(simpler)g(grammar)e(notation)120 +3941 y(that)33 b(is)f(v)m(ery)i(close)f(to)g(ordinary)f(BNF.)44 +b(Section)33 b(5)g(summarizes)f(the)h(functional)e(in)m(terface)i(of) +120 4061 y(Zebu)j(and)g(explains)f(ho)m(w)i(a)e(parser)h(can)g(b)s(e)g +(customized.)53 b(Section)36 b(6)f(describ)s(es)i(ho)m(w)g(lexical)120 +4181 y(analysis)32 b(can)h(b)s(e)g(extended)h(using)e(regular)g +(expressions)i(and)f(parameterization.)p 120 5017 1440 +4 v 232 5078 a Fl(3)269 5108 y Fh(Re\014ne)27 b Fk(is)g(a)h(trademark)e +(of)h(Reasoning)f(Systems,)i(P)n(alo)e(Alto.)232 5178 +y Fl(4)269 5208 y Fh(Zebu)i Fk(runs)f(on)g(a)g(MacIn)n(tosh)g(in)h +(MacIn)n(tosh)e(Common)i(Lisp.)232 5277 y Fl(5)269 5308 +y Fh(Zebu)52 b Fk(can)g(b)r(e)h(obtained)f(via)g(anon)n(ymous)f(ftp)i +(from)f(ftp.cs.cm)n(u.edu)h(as)f(a)g(compressed)f(tar)h(\014le:)120 +5407 y(/user/ai/lang/lisp/co)r(de/zebu/zebu-???.tar.gz.)31 +b(It)d(con)n(tains)e(sev)n(eral)g(example)h(grammar)f(de\014nitions.) +1896 5656 y Fu(4)p eop +%%Page: 5 5 +5 4 bop 120 407 a Ft(2)161 b(The)53 b(Represen)l(tations)f(of)i +(Grammars)f(in)h(Files)120 704 y Fg(2.1)135 b(Grammar)46 +b(notation)120 937 y Fu(W)-8 b(e)31 b(\014rst)h(describ)s(e)f(the)h(n)m +(ull-grammar,)27 b(whic)m(h)k(is)g(a)g(p)s(o)m(w)m(erful)g(but)g(v)m +(erb)s(ose)h(w)m(a)m(y)g(to)f(sp)s(ecify)g(a)120 1057 +y(grammar.)43 b(Only)33 b(a)g(parser)g(and)h(optionally)c(a)j(domain)e +(will)g(b)s(e)j(generated)f(but)h(an)f(unparser)120 1178 +y(\(prin)m(ter\))f(will)f(not.)43 b(If)33 b(this)f(is)h(desired,)g(y)m +(ou)g(m)m(ust)g(use)h(the)f(notation)e(of)h(the)h(meta-grammar)120 +1298 y("zebu-mg")f(whic)m(h)h(is)f(describ)s(ed)h(in)f(section)65 +b(4.)266 1466 y(Non-terminals)21 b(are)j(represen)m(ted)i(b)m(y)e(sym)m +(b)s(ols,)h(terminals)d(\(also)g(referred)j(to)e(as)g(k)m(eyw)m(ords\)) +120 1586 y(b)m(y)33 b(strings.)44 b(There)34 b(are)e(the)h(follo)m +(wing)d(op)s(en)j(classes)g(of)f(non-terminals)2878 1550 +y Fn(6)2916 1586 y Fu(:)283 1870 y Ff(identifier)j Fu(::=)d +Fe(h)p Fu(lisp)f(sym)m(b)s(ol)p Fe(i)283 1991 y Ff(number)239 +b Fu(::=)32 b Fe(h)p Fu(in)m(teger)p Fe(i)283 2111 y +Ff(keyword)188 b Fu(::=)32 b Fe(h)p Fu(string)p Fe(i)120 +2231 y Fu(where)283 2352 y Fe(h)p Fu(in)m(teger)p Fe(i)177 +b Fu(::=)32 b Fe(h)p Fu(digit)p Fe(i)n Fu(*)283 2472 +y Fe(h)p Fu(string)p Fe(i)222 b Fu(::=)32 b(")h Fe(h)p +Fu(c)m(haracter)p Fe(i)p Fu(*)f(")266 2756 y(A)48 b Fe(h)p +Fu(lisp)32 b(sym)m(b)s(ol)p Fe(i)47 b Fu(ma)m(y)g(b)s(e)i(quali\014ed)e +(b)m(y)i(a)f(pac)m(k)-5 b(age)48 b(name,)k(e.g.)90 b +Ff(zb:cons-1-3)51 b Fu(is)c(a)120 2877 y(v)-5 b(alid)41 +b(iden)m(ti\014er.)75 b(In)43 b(case)h(pac)m(k)-5 b(ages)44 +b(should)f(b)s(e)h(disallo)m(w)m(ed)e(during)g(lexical)f(analysis,)46 +b(the)120 2997 y(v)-5 b(ariable)33 b Ff(*disallow-packages*)39 +b Fu(should)c(b)s(e)f(b)s(ound)h(to)f Fd(true)p Fu(.)50 +b(\(It)35 b(defaults)f(to)g Fd(false)p Fu(\).)49 b(The)120 +3117 y(alphab)s(etic)37 b(case)i(of)e(a)h(k)m(eyw)m(ord)i(is)e(not)f +(signi\014can)m(t)h(if)f(the)h(v)-5 b(ariable)36 b Ff(*case-sensitive*) +42 b Fu(is)120 3238 y Fd(false)32 b Fu(\(the)h(default\))f(when)h(the)g +(grammar)e(is)h(loaded.)266 3405 y(If)c(alphab)s(etic)e(case)j(of)e +(iden)m(ti\014ers)h(is)f(to)g(b)s(e)h(preserv)m(ed,)j +Ff(*preserve-case*)h Fu(should)27 b(b)s(e)h(set)120 3526 +y(to)k Fd(true)p Fu(.)44 b(Other)33 b(categories)f(can)h(b)s(e)g +(de\014ned)h(as)f(regular)e(expressions)k(\(see)e(6.2\).)120 +3840 y Fs(2.1.1)112 b(Grammar)37 b(Rules)120 4074 y(Grammar)25 +b(Rule)g(Syn)m(tax)99 b Fu(A)22 b(grammar)f(\014le)h(consists)h(of)f(a) +h(header)g(\(the)g(\\options)f(list",)h(see)120 4194 +y(section)62 b(3.1\))30 b(follo)m(w)m(ed)g(b)m(y)h(one)g(or)g(more)f +(domain)f(de\014nitions)h(or)g(grammar)f(rules.)43 b(The)31 +b(non-)120 4314 y(terminal)h(de\014ned)k(b)m(y)g(the)e(\014rst)h +(grammar)e(rule)h(is)g(also)f(the)i Fd(start-symb)-5 +b(ol)69 b Fu(of)34 b(the)h(grammar.)120 4435 y(A)e(parser)g(will)d +(accept)k(exactly)f(the)g(strings)f(that)g(rewrite)h(to)f(the)h +Fd(start-symb)-5 b(ol)p Fu(.)266 4602 y(This)31 b(example)e(sho)m(ws)j +(ho)m(w)f(a)f(BNF-lik)m(e)f(rule)h(can)g(b)s(e)h(enco)s(ded)g(as)f(a)g +Fq(Zebu)g Fu(grammar)e(rule)120 4723 y(\(using)k(the)h(n)m +(ull-grammar\):)265 5007 y Fe(\017)49 b Fu(BNF)32 b(rule)g(example)578 +5217 y Fe(h)p Fu(A)p Fe(i)h Fu(::=)f Fe(h)p Fu(B)p Fe(i)g(j)g(h)p +Fu(C)p Fe(i)h(h)p Fu(n)m(um)m(b)s(er)p Fe(i)f(j)h Fu(\\fo)s(o")e +Fe(h)p Fu(A)p Fe(i)h(j)g Fu(\\c")g Fe(j)h(h)p Fu(the-empt)m(y-string)p +Fe(i)p 120 5316 1440 4 v 232 5377 a Fl(6)269 5407 y Fk(The)28 +b(Kleene)f(*)g(indicates)h(0)f(or)g(more)f(o)r(ccurrences)g(of)i(the)g +(preceding)f(constituen)n(t)1896 5656 y Fu(5)p eop +%%Page: 6 6 +6 5 bop 265 407 a Fe(\017)49 b Fq(Zebu)32 b Fu(n)m(ull-grammar)d +(example:)364 667 y Ff(\(defrule)53 b(A)825 788 y(:=)f(B)1282 +b(;)52 b(\(1\))825 908 y(:=)g(\(C)g(NUMBER\))822 b(;)52 +b(\(2\))825 1028 y(:=)g(\("foo")h(A\))872 b(;)52 b(\(3\))825 +1149 y(:=)g("c")1180 b(;)52 b(\(4\))825 1269 y(:=)g(\(\))1231 +b(;)52 b(\(5\))825 1389 y(\))266 1679 y Fu(The)45 b(rule)f(describ)s +(es)h(5)f(pro)s(ductions,)i(all)c(deriving)h(the)i(non-terminal)c +Ff(A)p Fu(.)j(Eac)m(h)h(of)f(the)120 1800 y(pro)s(ductions)36 +b(has)g(the)h(left-hand)e(side)h Ff(A)p Fu(.)g(The)h(righ)m(t-hand)e +(side)i(of)e(\(1\))h(consists)h(of)e(just)i(one)120 1920 +y(constituen)m(t,)32 b(the)f(non-terminal)e Ff(B)p Fu(.)i(\(2\))f(has)i +(a)e(righ)m(t-hand)g(of)h(length)f(2,)h(and)h(its)e(second)i(con-)120 +2040 y(stituen)m(t)i(is)f(the)g(non-terminal)e Ff(NUMBER)k +Fu(\(whic)m(h)f(rewrites)f(to)g(an)m(y)h(in)m(teger,)g(real)e(or)h +(rational\).)120 2161 y(\(3\))38 b(is)g(a)h(recursiv)m(e)h(pro)s +(duction.)61 b(\(4\))38 b(con)m(tains)h(just)g(the)g(terminal)d(\(or)i +(k)m(eyw)m(ord\))j Ff("c")p Fu(.)62 b(\(5\))120 2281 +y(deriv)m(es)34 b(the)f(empt)m(y)g(string.)266 2449 y(None)42 +b(of)f(these)i(pro)s(ductions)e(has)h(a)g(seman)m(tic)f(action)f(attac) +m(hed.)72 b(By)42 b(default,)h(the)f(se-)120 2569 y(man)m(tic)35 +b(action)g(is)h(the)g Ff(identity)i Fu(function)e(if)f(the)i(righ)m +(t-hand)e(side)h(of)f(the)i(rule)f(consists)g(of)120 +2690 y(a)30 b(single)g(constituen)m(t)i(and)e(the)i Ff(identity*)h +Fu(function)d(otherwise.)43 b(\()p Ff(identity*)33 b +Fu(is)e(de\014ned)h(as)120 2810 y(the)h(function)f(that)g(returns)i +(all)c(its)i(argumen)m(ts)h(as)g(a)f(list.\))120 3129 +y Fs(Grammar)f(Rule)g(Seman)m(tic)f(Actions)97 b Fu(If)27 +b(w)m(e)i(w)m(an)m(t)f(to)g(attac)m(h)f(other)h(than)g(these)h(default) +120 3250 y(seman)m(tic)j(actions,)h(w)m(e)g(ha)m(v)m(e)h(to)e(use)i(a)e +Ff(:build)i Fu(clause)f(after)f(a)h(pro)s(duction.)266 +3417 y(The)h(build)d(clause)i(has)g(the)g(syn)m(tax:)120 +3707 y Fe(h)p Fu(build)e(clause)p Fe(i)i Fu(::=)f Ff(:build)i +Fu(\()p Fe(h)p Fu(lisp)d(function)p Fe(i)h(h)p Fu(argumen)m(t)g(list)p +Fe(i)n Fu(\))120 3828 y Fe(h)p Fu(build)f(clause)p Fe(i)i +Fu(::=)f Ff(:build)i Fe(h)p Fu(atomic)d(lisp)g(form)p +Fe(i)120 3948 y(h)p Fu(build)g(clause)p Fe(i)i Fu(::=)f +Ff(:build)i Fu(\()p Ff(:form)g Fe(h)p Fu(lisp)d(form)p +Fe(i)o Fu(\))120 4068 y Fe(h)p Fu(build)g(clause)p Fe(i)i +Fu(::=)f Ff(:build)i Fu(\()p Ff(:type)g Fe(h)p Fu(struct-t)m(yp)s(e)p +Fe(i)1275 4189 y Ff(:map)85 b Fu(\(\()p Fe(h)p Fu(non-terminal)p +Fe(i)29 b Fu(.)44 b Fe(h)p Fu(Slot)p Fe(i)n Fu(\)*\)\))266 +4478 y(The)34 b(\014rst)f(case)364 4739 y Ff(:build)h +Fu(\()p Fe(h)p Fu(lisp)d(function)p Fe(i)h(h)p Fu(argumen)m(t)g(list)p +Fe(i)n Fu(\))266 4999 y(is)41 b(lik)m(e)g(a)h(function)f(call.)69 +b(It)42 b(ma)m(y)f(con)m(tain)g(free)h(v)-5 b(ariable)40 +b(o)s(ccurrences.)73 b(These)43 b(will)d(b)s(e)120 5119 +y(b)s(ound)28 b(to)f(the)i(non-terminal)c(constituen)m(ts)k(of)e(the)h +(same)g(name)f(o)s(ccurring)h(in)f(the)h(righ)m(t-hand)120 +5240 y(side)33 b(of)f(the)h(pro)s(duction)f(at)g(the)h(time)e(of)h +(applying)f(the)i(seman)m(tic)g(action.)266 5407 y(In)g(the)g(second)h +(case)1896 5656 y(6)p eop +%%Page: 7 7 +7 6 bop 364 407 a Ff(:build)34 b Fe(h)p Fu(atomic)c(lisp)i(form)p +Fe(i)266 672 y Fu(the)k Fe(h)p Fu(atomic)31 b(lisp)g(form)p +Fe(i)j Fu(m)m(ust)h(b)s(e)h(a)f(function.)51 b(It)35 +b(will)e(b)s(e)j(applied)e(to)h(the)h(constituen)m(ts)120 +792 y(of)e(the)h(righ)m(t-hand)e(side.)50 b(This)34 b(function)g +(should)g(ha)m(v)m(e)i(the)f(same)f(n)m(um)m(b)s(er)h(of)f(argumen)m +(ts)h(as)120 913 y(the)e(righ)m(t-hand)f(side)g(of)g(the)h(corresp)s +(onding)g(pro)s(duction)f(has)h(constituen)m(ts.)266 +1080 y(Since)i(it)f(happ)s(ens)i(often,)f(that)g(only)f(some)g(of)h +(the)g(constituen)m(ts)h(of)e(the)h(righ)m(t-hand)f(side)120 +1201 y(are)23 b(selected,)j(or)d(com)m(bined,)i(a)e(few)h(useful)f +(seman)m(tic)g(actions)g(ha)m(v)m(e)h(b)s(een)g(prede\014ned)h(in)d +Fq(Zebu)p Fu(.)3680 1164 y Fn(7)266 1368 y Fu(An)35 b(example)g(for)f +(suc)m(h)i(a)f(prede\014ned)h(action)e(is)h(the)g(function)f +Ff(cons-2-3)j Fu(whic)m(h)e(tak)m(es)h(3)120 1489 y(argumen)m(ts)d(and) +f(returns)i(a)e Fd(c)-5 b(ons)32 b Fu(of)g(its)g(second)i(and)f(third)f +(argumen)m(t.)266 1656 y(The)g(third)e(form)g(of)g(the)h +Ff(:build)i Fu(clause)e(is)f(just)h(a)g(long)f(w)m(a)m(y)i(to)e(write)h +(the)g(\014rst)g(form,)f(i.e.)364 1921 y Ff(:build)k +Fu(\()p Fe(h)p Fu(lisp)d(function)p Fe(i)h(h)p Fu(argumen)m(t)g(list)p +Fe(i)n Fu(\))266 2186 y(is)g(the)h(same)g(as)364 2451 +y Ff(:build)h Fu(\()p Ff(:form)g Fu(\()p Fe(h)p Fu(lisp)d(function)p +Fe(i)h(h)p Fu(argumen)m(t)g(list)p Fe(i)n Fu(\)\))266 +2716 y(Similarly)-8 b(,)364 3013 y Ff(:build)34 b Fu(\(progn)e +Fe(h)p Fu(atomic)f(lisp)g(form)p Fe(i)o Fu(\))266 3310 +y(is)h(the)h(same)g(as)364 3607 y Ff(:build)h Fu(\()p +Ff(:form)g Fe(h)p Fu(atomic)c(lisp)i(form)p Fe(i)n Fu(\))266 +3904 y(The)i(last)e Ff(:build)i Fu(clause)f(is)f(more)f(in)m +(teresting:)608 4169 y Ff(:build)j Fu(\()p Ff(:type)g +Fe(h)p Fu(struct-t)m(yp)s(e)p Fe(i)986 4289 y Ff(:map)85 +b Fu(\(\()p Fe(h)p Fu(Non)m(terminal)p Fe(i)30 b Fu(.)43 +b Fe(h)p Fu(Slot)p Fe(i)o Fu(\)*\)\))266 4554 y(where)50 +b Fe(h)p Fu(struct-t)m(yp)s(e)p Fe(i)e Fu(is)g(a)g(sym)m(b)s(ol)f(that) +h(m)m(ust)g(b)s(e)h(the)f(name)g(of)f(a)h(structure)h(t)m(yp)s(e)3652 +4518 y Fn(8)3693 4554 y Fu(.)120 4674 y(Instead)37 b(of)f(ha)m(ving)g +(to)f(write)h(the)h(seman)m(tic)f(action)f(as)h(a)g(constructing)g +(form,)g(w)m(e)h(just)g(ha)m(v)m(e)120 4795 y(to)k(sp)s(ecify)i(the)f +(t)m(yp)s(e)h(and)f(the)g(mapping)e(of)h(non-terminals)f(to)h(slots,)j +(as)e(in)f(the)i(follo)m(wing)120 4915 y(example)470 +4879 y Fn(9)509 4915 y Fu(:)p 120 5017 1440 4 v 232 5078 +a Fl(7)269 5108 y Fk(These)79 b(seman)n(tic)g(actions)f(\()p +Fc(cons-1-3)41 b(cons-2-3)f(empty-seq)g(empty-set)g(k-2-1)i(k-2-2)f +(k-3-2)120 5208 y(k-4-3)h(identity*)d(seq-cons)i(set-cons)p +Fk(\))24 b(are)j(describ)r(ed)g(in)h(the)g(\014le)g +("zebu-actions.lisp".)232 5277 y Fl(8)269 5308 y Fk(a)g(t)n(yp)r(e)f +(de\014ned)h(b)n(y)g Fc(defstruct)c Fk(or)i Fc(defclass)p +Fk(.)232 5377 y Fl(9)269 5407 y Fk(\(tak)n(en)i(from)f(the)h(grammar)e +(named)h(\\p)r(c1";)g(see)g(the)h(\014le)g(\\p)r(c1.zb")e(in)i(the)g +(test)g(directory\))1896 5656 y Fu(7)p eop +%%Page: 8 8 +8 7 bop 120 407 a Ff(\(defrule)53 b(Boolean-Expr)581 +527 y(:=)f(\(Formula.1)i("and")f(Formula.2\))581 648 +y(:build)g(\(:type)g(Boolean-And)992 768 y(:map)f(\(\(Formula.1)i(.)103 +b(:-rand1\))1299 888 y(\(Formula.2)54 b(.)103 b(:-rand2\)\)\))581 +1129 y(:=)52 b(\(Formula.1)i("or")e(Formula.2\))581 1249 +y(:build)h(\(:type)g(Boolean-Or)992 1370 y(:map)f(\(\(Formula.1)i(.)103 +b(:-rand1\))1299 1490 y(\(Formula.2)54 b(.)103 b(:-rand2\)\)\))581 +1611 y(\))266 2122 y Fu(The)41 b(map)e(indicates)g(that)g(the)h(slot)f +Ff(-rand1)i Fu(is)e(to)g(b)s(e)h(\014lled)f(b)m(y)h(the)g(v)-5 +b(alue)39 b(of)g(the)h(non-)120 2243 y(terminal)30 b +Ff(Formula.1)p Fu(,)35 b(etc.)266 2410 y(This)f(example)e(also)h(mak)m +(es)h(use)g(of)f(the)g Ff(".n")h Fu(notation:)44 b(If)33 +b(on)g(the)h(righ)m(t-hand)e(side)h(of)g(a)120 2531 y(pro)s(duction)e +(a)h(non)m(terminal)e(o)s(ccurs)i(rep)s(eatedly)-8 b(,)33 +b(w)m(e)g(distinguish)d(it)h(b)m(y)i(app)s(ending)e Ff(".")i +Fu(and)120 2651 y(a)f(digit,)f(to)h(the)h(non)m(terminal)e(\(e.g.)i +Ff(Formula.1)p Fu(\).)266 2819 y(The)45 b(function)f +Ff(print-actions)k Fu(applied)43 b(to)h(the)g(name)g(of)g(a)g(grammar)d +(ma)m(y)j(b)s(e)h(used)120 2939 y(to)d(\014nd)i(out)f(what)g(the)g +(generated)h(co)s(de)f(for)f(the)h(seman)m(tic)g(actions)f(lo)s(oks)g +(lik)m(e,)j(e.g.)e(after)120 3060 y(compiling)29 b(the)k(sample)f +(grammar)e Ff(``pc1.zb'')p Fu(:)120 3571 y Ff(\(print-actions)55 +b("pc1"\))120 3812 y(...)120 3932 y(Rule:)e(BOOLEAN-EXPR)120 +4053 y(\(LAMBDA)g(\(FORMULA.1)h(DUMMY)f(FORMULA.2\))530 +4173 y(\(DECLARE)h(\(IGNORE)f(DUMMY\)\))530 4294 y(\(MAKE-BOOLEAN-AND)j +(:-RAND1)d(FORMULA.1)h(:-RAND2)f(FORMULA.2\)\))120 4414 +y(\(LAMBDA)g(\(FORMULA.1)h(DUMMY)f(FORMULA.2\))530 4534 +y(\(DECLARE)h(\(IGNORE)f(DUMMY\)\))530 4655 y(\(MAKE-BOOLEAN-OR)j +(:-RAND1)d(FORMULA.1)g(:-RAND2)h(FORMULA.2\)\))120 4775 +y(...)266 5287 y Fu(These)30 b(seman)m(tic)e(actions)g(ha)m(v)m(e)i(b)s +(een)f(generated)g(from)e(the)i Ff(:build)h Fu(clauses)f(of)e(the)i(ab) +s(o)m(v)m(e)120 5407 y(rule)j(for)g Ff(Boolean-Expr)p +Fu(.)1896 5656 y(8)p eop +%%Page: 9 9 +9 8 bop 120 407 a Ft(3)161 b(Grammar)53 b(Options)120 +1372 y Fg(3.1)135 b(Keyw)l(ord)46 b(Argumen)l(ts)f(to)h(Grammar)f +(Construction)120 2274 y Fu(Some)40 b(global)e(information)f(to)j(con)m +(trol)g(grammar)e(compilation,)h(lexical)f(analysis,)k(and)f(the)120 +2394 y(generation)e(of)h(seman)m(tic)g(actions)f(is)h(declared)g(in)f +(the)i(b)s(eginning)e(of)g(a)h(grammar)e(\014le)3480 +2358 y Fn(10)3554 2394 y Fu(.)66 b(A)120 2515 y(grammar)41 +b(\014le)i(m)m(ust)h(b)s(egin)e(with)h(a)g(list)f(of)h(alternating)e(k) +m(eyw)m(ords)46 b(and)e(argumen)m(ts.)76 b(The)120 2635 +y(follo)m(wing)30 b(k)m(eyw)m(ords)35 b(are)e(v)-5 b(alid:)p +120 5316 1440 4 v 199 5377 a Fl(10)269 5407 y Fk(A)28 +b(grammar)e(\014le)i(has)f(the)h(default)g(t)n(yp)r(e)g(".zb".)1896 +5656 y Fu(9)p eop +%%Page: 10 10 +10 9 bop 316 391 a Fm(:name)839 b Fu(a)32 b(string,)g(the)h(name)f(of)g +(the)h(grammar)d(to)j(b)s(e)f(de\014ned.)316 512 y Fm(:pac)m(k)-5 +b(age)745 b Fu(a)22 b(string,)h(the)g(name)f(of)g(the)g(pac)m(k)-5 +b(age)23 b(where)h(the)e(non-terminal)1392 632 y(sym)m(b)s(ols)33 +b(and)i(the)f(function)g(sym)m(b)s(ols)g(used)h(in)e(seman)m(tic)h(ac-) +1392 753 y(tions)e(reside.)316 873 y Fm(:iden)m(ti\014er-start-c)m +(hars)246 b Fu(a)41 b(string.)69 b(During)40 b(lexical)f(analysis)i(an) +m(y)h(c)m(haracter)g(in)f(this)1392 993 y(string)36 b(can)i(start)f(an) +h Ff(identifier)i Fu(non-terminal.)55 b(The)39 b(de-)1392 +1114 y(fault)31 b(is)h Ff(*identifier-start-chars*)p +Fu(.)316 1234 y Fm(:iden)m(ti\014er-con)m(tin)m(ue-c)m(hars)100 +b Fu(a)41 b(string.)69 b(During)40 b(lexical)f(analysis)i(an)m(y)h(c)m +(haracter)g(in)f(this)1392 1355 y(string)34 b(can)i(con)m(tin)m(ue)g +(an)f Ff(identifier)j Fu(\(i.e.)51 b(c)m(haracters)37 +b(not)1392 1475 y(in)45 b(this)h(string)f(terminate)g +Ff(identifier)p Fu(\).)87 b(The)47 b(default)e(is)1392 +1595 y Ff(*identifier-continue-chars*)q Fu(.)316 1716 +y Fm(:in)m(tern-iden)m(ti\014er)432 b Fd(true)p Fu(,)47 +b(if)42 b(the)j(iden)m(ti\014er)e(is)g(to)h(b)s(e)g(returned)h(as)e(an) +h(in)m(terned)1392 1836 y(Lisp)38 b(sym)m(b)s(ol,)i(or)f +Fd(false)g Fu(if)f(the)h(iden)m(ti\014er)g(is)g(to)f(b)s(e)i(returned) +1392 1956 y(as)32 b(a)h(string)f(\(default)f Fd(true)p +Fu(\).)316 2077 y Fm(:string-delimiter)436 b Fu(a)40 +b(c)m(haracter,)k(the)d(c)m(haracter)h(that)f(delimits)d(a)j(string)f +(to)g(b)s(e)1392 2197 y(represen)m(ted)35 b(as)d(a)h +Fq(Common)f(Lisp)h Fu(string.)43 b(\(default)32 b Ff(#\\")p +Fu(\))316 2318 y Fm(:sym)m(b)s(ol-delimiter)383 b Fu(a)40 +b(c)m(haracter,)k(the)d(c)m(haracter)h(that)f(delimits)d(a)j(string)f +(to)g(b)s(e)1392 2438 y(represen)m(ted)35 b(as)d(a)h +Fq(Common)f(Lisp)h Fu(sym)m(b)s(ol.\(default)e Ff(#\\')p +Fu(\))316 2558 y Fm(:domain)757 b Fu(a)45 b(list,)i(represen)m(ting)g +(the)f(t)m(yp)s(e)g(hierarc)m(h)m(y)g(of)f(the)h(domain.)1392 +2679 y(See)33 b(section)g(3.2)f(b)s(elo)m(w.)316 2799 +y Fm(:domain-\014le)610 b Fu(a)57 b(string)h(naming)e(the)j(\014le)f +(where)h(the)g(generated)g(Com-)1392 2919 y(mon)33 b(Lisp)h(program)f +(that)h(implemen)m(ts)e(the)j(domain)e(will)e(b)s(e)1392 +3040 y(stored.)42 b(De\014nitions)26 b(of)g(functions)h(for)g(seman)m +(tic)g(actions)g(and)1392 3160 y(regular)i(expression)j(for)e(lexical)f +(categories)h(are)g(k)m(ept)i(here)f(as)1392 3281 y(w)m(ell.)73 +b(This)43 b(string)g(defaults)f(to)h(the)g(concatenation)g(of)f(the) +1392 3401 y(grammar's)30 b(:name)j(and)f(\\-domain".)316 +3521 y Fm(:grammar)692 b Fu(a)21 b(string,)i(b)m(y)g(default:)37 +b Ff("null-grammar")p Fu(,)28 b(naming)20 b(the)i(gram-)1392 +3642 y(mar)j(to)i(b)s(e)f(used)i(to)f(parse)g(the)g(grammar)e +(de\014ned)j(in)e(this)g(\014le.)1392 3762 y(If)h(the)g(grammar)e +Ff("zebu-mg")30 b Fu(is)d(used,)i(an)e(unparser)i(will)c(also)1392 +3883 y(b)s(e)32 b(generated.)316 4003 y Fm(:lex-cats)751 +b Fu(an)35 b(asso)s(ciation)e(list)h(of)h(terminal)e(category)i(names)h +(and)f(reg-)1392 4123 y(ular)c(expressions)j(\(see)g(section)f(6.2\).) +316 4244 y Fm(:white-space)591 b Fu(a)33 b(list)f(of)h(c)m(haracters)i +(eac)m(h)f(of)f(whic)m(h)h(will)d(b)s(e)j(ignored)f(b)s(efore)1392 +4364 y(a)f(tok)m(en,)h(\(default)f Ff(\(#\\Space)54 b(#\\Newline)105 +b(#\\Tab\))p Fu(\))316 4484 y Fm(:case-sensitiv)m(e)525 +b Fd(true)27 b Fu(if)e(the)i(case)h(of)e(k)m(eyw)m(ords)k(is)c +(signi\014can)m(t,)h Fd(false)f Fu(otherwise)1392 4605 +y(\(default)31 b Fd(false\).)120 4932 y Fg(3.2)135 b(De\014ning)45 +b(a)h(Domain)120 5166 y Fu(The)g Ff(:domain)h Fu(k)m(eyw)m(ord)g(is)d +(used)j(to)d(sp)s(ecify)i(a)e(t)m(yp)s(e)i(hierarc)m(h)m(y)-8 +b(.)82 b(This)45 b(sp)s(eci\014cation)f(will)120 5287 +y(expand)e(in)m(to)d Ff(defstruct)k Fu(forms)d(that)g(implemen)m(t)f +(this)h(hierarc)m(h)m(y)-8 b(.)68 b(It)41 b(is)f(also)f(p)s(ossible)h +(to)120 5407 y(write)33 b(suc)m(h)j(structure)f(de\014nitions)e +(directly)g(in)m(to)g(the)h(grammar)d(\014le.)47 b(The)35 +b(argumen)m(t)e(to)h(the)1871 5656 y(10)p eop +%%Page: 11 11 +11 10 bop 120 407 a Ff(:domain)34 b Fu(k)m(eyw)m(ord)h(argumen)m(t)d(m) +m(ust)h(b)s(e)g(a)f(list)f(of)h(the)h(follo)m(wing)d(form:)283 +677 y(\()p Fe(h)p Fu(Ro)s(ot)h(Struct)p Fe(i)283 797 +y Ff(:subtype)j Fe(h)p Fu(Struct)f(Desc)p Fe(i)283 917 +y Ff(:subtype)h Fe(h)p Fu(Struct)f(Desc)p Fe(i)283 1038 +y Fu(...\))283 1279 y Fe(h)p Fu(Ro)s(ot)e(Struct)p Fe(i)i +Fu(::=)f Fe(h)p Fu(Sym)m(b)s(ol)p Fe(i)283 1519 y(h)p +Fu(Struct)g(Desc)p Fe(i)h Fu(::=)g Fe(h)p Fu(Sym)m(b)s(ol)p +Fe(i)e(j)1053 1640 y Fu(\()h Fe(h)p Fu(Sym)m(b)s(ol)p +Fe(i)f Ff(:slots)k Fu(\()p Fe(h)p Fu(Slot)p Fe(i)n Fu(*\))d(\))h +Fe(j)1053 1760 y Fu(\()f Fe(h)p Fu(Sym)m(b)s(ol)p Fe(i)f +Ff(:slots)k Fu(\()p Fe(h)p Fu(Slot)p Fe(i)n Fu(*\))1550 +1881 y Ff(:subtype)g Fe(h)p Fu(Struct)e(Desc)p Fe(i)1550 +2001 y Ff(:subtype)i Fe(h)p Fu(Struct)e(Desc)p Fe(i)1053 +2121 y Fu(...)44 b(\))283 2362 y Fe(h)p Fu(Slot)p Fe(i)31 +b Fu(::=)h Fe(h)p Fu(Sym)m(b)s(ol)p Fe(i)f(j)h Fu(\()h +Fe(h)p Fu(Slot)e(Name)p Fe(i)h(h)p Fu(Filler)d(T)m(yp)s(e)p +Fe(i)34 b Fu(\))283 2482 y Fe(h)p Fu(Filler)29 b(T)m(yp)s(e)p +Fe(i)34 b Fu(::=)e Fe(h)p Fu(Sym)m(b)s(ol)g(naming)f(t)m(yp)s(e)p +Fe(i)266 2752 y Fu(This)22 b(describ)s(es)h(the)f(syn)m(tax)i(for)d +(declaring)f(a)i(t)m(yp)s(e)g(hierarc)m(h)m(y)h(with)e(ro)s(ot)g(no)s +(de)h Fe(h)p Fu(Ro)s(ot)31 b(Struct)p Fe(i)p Fu(.)120 +2873 y(A)f(no)s(de)g(of)f(the)i(hierarc)m(h)m(y)f(tree)h(can)f(ha)m(v)m +(e)h(c)m(hildren,)f(denoted)h(b)m(y)g Ff(:subtype)h Fu(follo)m(w)m(ed)d +(b)m(y)i(the)120 2993 y(structure)j(description)e(of)g(the)h(c)m(hild)e +(no)s(de.)44 b(Eac)m(h)34 b(no)s(de)e(can)h(ha)m(v)m(e)h(slots,)e +(describ)s(ed)h(as)g(a)f(list)120 3113 y(follo)m(wing)g +Ff(:slots)p Fu(.)53 b(A)36 b(c)m(hild)e(no)s(de)h(inherits)g(the)g +(slots)g(of)g(its)g(paren)m(t)g(no)s(de.)52 b(The)36 +b(v)-5 b(alue)35 b(of)f(a)120 3234 y(slot)e(can)h(b)s(e)f(t)m(yp)s +(e-restricted)i(to)e Fe(h)p Fu(Filler)e(T)m(yp)s(e)p +Fe(i)q Fu(.)266 3401 y Fe(h)p Fu(Ro)s(ot)i(Struct)p Fe(i)k +Fu(will)e(b)s(e)i(implemen)m(ted)e(as)j(a)e(structure)j(t)m(yp)s(e)f +(directly)e(b)s(elo)m(w)h(the)g(prede-)120 3522 y(\014ned)42 +b(structure)h(t)m(yp)s(e)f Ff(kb-domain)p Fu(,)k(i.e.)41 +b(\()p Ff(kb-domain-p)j Fu(x\))d(is)g Fd(true)h Fu(for)f(an)m(y)h +(instance)f(of)g(a)120 3642 y(subt)m(yp)s(e)34 b(of)e +Fe(h)p Fu(Ro)s(ot)g(Struct)p Fe(i)p Fu(.)43 b(kb-domain)31 +b(is)i(the)g(top)f(of)g(the)h(domain)e(hierarc)m(h)m(y)-8 +b(.)266 3810 y(The)39 b(t)m(yp)s(e)g Ff(kb-sequence)i +Fu(is)c(already)h(prede\014ned)i(as)e(a)f(subt)m(yp)s(e)j(of)e +(kb-domain.)58 b(It)38 b(has)120 3930 y(the)33 b(slots)f +Ff(first)i Fu(and)f Ff(rest)p Fu(.)266 4098 y(Similarly)-8 +b(,)35 b(t)m(yp)s(es)k Ff(number)p Fu(,)i Ff(string)p +Fu(,)g(and)d Ff(identifier)i Fu(are)e(prede\014ned)h(as)f(subt)m(yp)s +(es)i(of)120 4218 y(kb-domain.)266 4386 y(Tw)m(o)c(ob)5 +b(jects)37 b(of)d(t)m(yp)s(e)i(kb-domain)e(can)h(b)s(e)h(compared)e +(for)h(equalit)m(y)g(with)f(the)i(functions)120 4506 +y Ff(kb-equal)f Fu(and)d Ff(kb-compare)p Fu(.)120 4776 +y Ff(kb-equal)j Fd(a)d(b)2682 b(function)266 5046 y(a)40 +b Fu(and)g Fd(b)g Fu(are)f(assumed)i(to)f(b)s(e)g(of)f(t)m(yp)s(e)i +(kb-domain.)64 b(If)39 b(they)i(are)f Ff(equal)h Fu(they)g(are)f(also) +120 5166 y Ff(kb-equal)p Fu(.)77 b(But)43 b(in)g(con)m(trast)g(to)g +Ff(equal)h Fu(it)e(is)h(p)s(ossible)f(to)h(de\014ne)i(whic)m(h)e(slots) +g(are)g(to)g(b)s(e)120 5287 y(examined)35 b(b)m(y)g Ff(kb-equal)i +Fu(when)f(comparing)e(the)h(comp)s(onen)m(ts)g(of)g Fd(a)f +Fu(and)h Fd(b)p Fu(.)50 b(These)37 b(relev)-5 b(an)m(t)120 +5407 y(slots)28 b(are)f(called)g Fd(tr)-5 b(e)g(e)31 +b(attributes)p Fu(,)e(and)f(the)g(macro)f Ff(def-tree-attributes)33 +b Fu(is)27 b(used)i(to)f(de\014ne)1871 5656 y(11)p eop +%%Page: 12 12 +12 11 bop 120 407 a Fu(these)37 b(for)e(a)g(particular)f(t)m(yp)s(e.)54 +b(The)36 b(rationale)e(for)h(ha)m(ving)g(this)g(equalit)m(y)h(relation) +d(is)j(that)f(it)120 527 y(is)29 b(often)h(useful)f(to)g(store)h +(commen)m(ts)g(or)f(auxiliary)e(information)f(with)j(the)h(feature)g +(structures)120 648 y(pro)s(duced)j(b)m(y)h(parsing.)266 +815 y(In)i(feature)g(structures)i(the)e(v)-5 b(alue)35 +b(of)g(a)g(relev)-5 b(an)m(t)36 b(feature)g(\(or)f(slot\))g(ma)m(y)h(b) +s(e)f(declared)h(to)120 936 y(b)s(e)j(a)f(set)h(\(using)f +Ff(def-tree-attributes)p Fu(\).)66 b(If)39 b(a)f(slot)g(has)h(b)s(een)g +(declared)g(set-v)-5 b(alued,)40 b(the)120 1056 y Ff(kb-equal)28 +b Fu(comparison)c(will)f(use)k(set)f(equalit)m(y)f(for)g(v)-5 +b(alues)26 b(of)f(that)g(slot)g(\(represen)m(ted)j(as)e(lists\).)120 +1324 y Ff(def-tree-attributes)38 b Fd(typ)-5 b(e)32 b(slot1)h(slot2)f +Fu(..)1612 b Fd(macr)-5 b(o)266 1591 y Ff(def-tree-attributes)29 +b Fu(de\014nes)c Fd(slot1)e(slot2)g Fu(.)16 b(.)g(.)g(as)24 +b(tree)g(attributes)f(for)g(instances)h(of)f(t)m(yp)s(e)120 +1712 y Fd(typ)-5 b(e)p Fu(.)266 1879 y(If)32 b Fd(slot)f +Fu(is)g(a)g(sym)m(b)s(ol,)g(this)g(sym)m(b)s(ol)f(is)h(de\014ned)i(as)e +(a)g(tree)h(attribute.)43 b(Otherwise)32 b Fd(slot)f +Fu(m)m(ust)120 2000 y(b)s(e)42 b(of)f(the)i(form)d(\()p +Fd(symb)-5 b(ol)42 b Fu(:set\).)72 b(As)42 b(b)s(efore,)j(the)d +Fd(symb)-5 b(ol)41 b Fu(b)s(ecomes)i(a)e(tree-attribute,)j(and)120 +2120 y(furthermore)32 b(it)g(is)g(declared)h(set-v)-5 +b(alued.)120 2426 y Fs(Example)38 b(domain)h(de\014nition)97 +b Fu(The)35 b(grammar)d(de\014ned)j(in)f(\\p)s(c1.zb")g(accepts)i(a)d +(simple)120 2547 y(prop)s(ositional)d(calculus)i(language)f(with)h(sen) +m(tences)k(suc)m(h)e(as)364 2791 y Ff(walks\(agent:)106 +b(John\))p Fu(,)120 3036 y(whic)m(h)30 b(yields)f(the)h(follo)m(wing)d +(abstract)j(syn)m(tax)i(\(prin)m(ted)d(out)h(using)f(the)h +Fq(Common)g(Lisp)g Fu(struc-)120 3157 y(ture)j(prin)m(ter\):)223 +3424 y Ff(#S\(ATOMIC-WFF)54 b(-PREDICATE)g(WALKS)940 +3545 y(-ROLE-ARGUMENT-PAIRS)j(#S\(ROLE-ARGUMENT-PAIR)2171 +3665 y(-ROLE)52 b(AGENT)2171 3785 y(-ARGUMENT)h(JOHN\))g(\))266 +4053 y Fu(The)28 b(t)m(yp)s(es)h(|)e(suc)m(h)h(as)g Ff(ATOMIC-WFF)i +Fu(and)d Ff(ROLE-ARGUMENT-PAIR)32 b Fu(|)27 b(are)g(de\014ned)h(b)m(y)h +(the)120 4173 y(follo)m(wing)h(domain)h(declaration:)120 +4441 y Ff(:domain)53 b(\(PC)f(;;)g(PC)g(is)g(the)g(root)g(type)g(of)g +(the)g(hierarchy)581 4562 y(:subtype)i(\(Formula)1094 +4682 y(:subtype)f(\(Propositional-variable)58 b(:slots)53 +b(\(-name\)\))1094 4802 y(:subtype)g(\(Boolean-Expr)1555 +4923 y(:slots)g(\(\(-rand1)h(Formula\))1966 5043 y(\(-rand2)f +(Formula\)\))1555 5164 y(:subtype)h(Boolean-Or)1555 5284 +y(:subtype)g(Boolean-And\)\))581 5404 y(:subtype)g(\(Boolean-Op)g +(:slots)f(\(-name\)\))1871 5656 y Fu(12)p eop +%%Page: 13 13 +13 12 bop 581 407 a Ff(:subtype)54 b(\(Atomic-Wff)1094 +527 y(:slots)f(\(-predicate)1504 648 y(\(-Role-Argument-Pairs)k +(KB-Sequence\)\)\))581 768 y(:subtype)d(\(Role-Argument-Pair)i(:slots)d +(\(-Role)g(-Argument\)\))581 888 y(\))266 1220 y Fu(Note)33 +b(the)g(use)h(of)e(the)i(prede\014ned)g(t)m(yp)s(e)g(KB-Sequence.)46 +b(It)33 b(is)f(used)i(to)e(construct)i(the)f(list)120 +1340 y(of)f(Role-Argumen)m(t-P)m(airs)f(in)h(the)h(follo)m(wing)c +(rule:)120 1672 y Ff(\(defrule)53 b(Role-Argument-Pairs)223 +1792 y(:=)e(\(\))223 2033 y(:=)g(\(Role-Argument-Pair)57 +b(Role-Argument-Pairs\))223 2154 y(:build)52 b(\(:type)h(KB-Sequence) +633 2274 y(:map)103 b(\(\(Role-Argument-Pair)108 b(.)52 +b(:first\))992 2394 y(\(Role-Argument-Pairs)k(.)c(:rest\)\)\))223 +2515 y(\))120 3063 y Ft(4)161 b(The)53 b Fb(Zebu)i Ft(Meta)f(Grammar) +120 3339 y Fu(Using)36 b("zebu-mg")g(as)h(the)g Ff(:grammar)i +Fu(argumen)m(t)d(in)g(the)h(grammar)d(options)i(indicates)g(that)120 +3460 y(the)44 b(follo)m(wing)e(grammar)f(is)j(to)f(b)s(e)h(prepro)s +(cessed)i(with)e(the)g(grammar)e(\\zebu-mg")h(b)s(efore)120 +3580 y(compilation.)266 3748 y(The)23 b(adv)-5 b(an)m(tages)23 +b(of)e(the)i(meta-grammar)18 b(\(v)m(ersus)24 b(the)f(default)e(n)m +(ull-grammar\))d(are)k(a)g(more)120 3868 y(concise)29 +b(represen)m(tation)h(of)f(rules,)g(automatic)e(generation)i(of)f(the)h +(functions)g(that)g(implemen)m(t)120 3988 y(the)23 b(seman)m(tic)g +(actions)f(and)h(rev)m(ersibilit)m(y)f(of)h(the)g(grammar)e +(\(generation)h(of)g(prin)m(ting)g(functions)120 4109 +y({)32 b(the)h(unparser\).)266 4277 y(The)27 b(disadv)-5 +b(an)m(tage)26 b(of)g(using)g("zebu-mg")f(is)g(that)h(the)h(seman)m +(tics)f(is)g(limited)d(to)i(construct-)120 4397 y(ing)i(t)m(yp)s(ed)j +(feature)e(structures.)44 b(But)29 b(these)g(ha)m(v)m(e)h(great)e +(expressiv)m(e)j(p)s(o)m(w)m(er,)f(and)e(furthermore)120 +4517 y(could)21 b(subsequen)m(tly)k(b)s(e)d(transformed)g(in)m(to)f +(some)h(other)g(program.)38 b(T)m(yp)s(ed)24 b(feature)e(structures)120 +4638 y(are)40 b(ideally)e(suited)i(to)g(presen)m(t)i(abstract)e(syn)m +(tax.)68 b(The)41 b(fact)f(that)f(uni\014cation,)i(sp)s(ecializa-)120 +4758 y(tion)28 b(and)h(generalization)d(are)j(w)m(ell)f(de\014ned)i(op) +s(erations)e(on)g(feature)i(structures,)h(mak)m(es)e(them)120 +4878 y(appropriate)37 b(for)g(further)h(transformations)d(\(b)m(y)k +(e.g.)f Fq(Zebu-RR)p Fu(\).)e(F)-8 b(or)37 b(an)h(in)m(tro)s(duction)e +(in)m(to)120 4999 y(feature)d(structures)h(see)g([5].)266 +5166 y(Since)d(there)h(is)e(a)g(restricted)i(w)m(a)m(y)g(of)e +(expressing)i(the)f(seman)m(tics)g(of)f(a)h(rule)f({)g(namely)g(as)h(a) +120 5287 y(t)m(yp)s(ed)h(feature)f(structure)h({)f(the)g(grammar)e +(compiler)g(will)f(b)s(e)k(able)e(to)g(generate)i(co)s(de)f(for)g(the) +120 5407 y(domain)g(hierarc)m(h)m(y)i(and)g(prin)m(t-functions)f(asso)s +(ciated)g(with)g(eac)m(h)i(t)m(yp)s(e)f(of)f(that)h(domain.)1871 +5656 y(13)p eop +%%Page: 14 14 +14 13 bop 266 407 a Fu("zebu-mg")32 b(is)g(de\014ned)i(in)e(terms)g(of) +h(the)g(n)m(ull-grammar)28 b(describ)s(ed)34 b(ab)s(o)m(v)m(e)3137 +371 y Fn(11)3212 407 y Fu(.)120 712 y Fs(BNF)j(description)f(of)i +(\\zebu-mg":)364 952 y Fe(h)p Fu(Zebu-Grammar)p Fe(i)238 +b Fu(::=)33 b Fe(h)p Fu(Options)p Fe(i)f(h)p Fu(Domain-Defn)p +Fe(i)l Fu(*)g Fe(h)p Fu(zb-rule)p Fe(i)364 1072 y(h)p +Fu(Domain-Defn)p Fe(i)325 b Fu(::=)33 b Fe(h)p Fu(T)m(yp)s(e-name)p +Fe(i)g Ff(":=")g Fe(h)p Fu(F)-8 b(eat-T)g(erm)p Fe(i)1502 +1193 y Fu([)33 b Ff("<<")g Fu("prin)m(t-function:")e(Iden)m(ti\014er)i +Ff(">>")h Fu(])e Ff(";")364 1313 y Fe(h)p Fu(zb-rule)p +Fe(i)604 b Fu(::=)33 b Fe(h)p Fu(Non-terminal)p Fe(i)c +Ff("-->")34 b Fe(h)p Fu(Rhs)p Fe(i)f Ff(";")364 1433 +y Fe(h)p Fu(Rhs)p Fe(i)733 b Fu(::=)33 b Fe(h)p Fu(Rhs1)p +Fe(i)f(h)p Fu(More-Rhs)p Fe(i)h(j)f(h)p Fu(Kleene-Rhs)p +Fe(i)364 1554 y(h)p Fu(Rhs1)p Fe(i)684 b Fu(::=)33 b +Fe(h)p Fu(Constituen)m(t)p Fe(i)p Fu(*)g([)f Ff(")p Fe(f)p +Ff(")h Fe(h)p Fu(Seman)m(tics)p Fe(i)f Ff(")p Fe(g)p +Ff(")h Fu(])364 1674 y Fe(h)p Fu(Constituen)m(t)p Fe(i)396 +b Fu(::=)33 b Fe(h)p Fu(Iden)m(ti\014er)p Fe(i)g(j)f(h)p +Fu(String)p Fe(i)364 1795 y(h)p Fu(More-Rhs)p Fe(i)481 +b Fu(::=)33 b Fe(j)f(h)p Fu(Rhs1)p Fe(i)g(h)p Fu(More-Rhs)p +Fe(i)364 1915 y(h)p Fu(Seman)m(tics)p Fe(i)471 b Fu(::=)33 +b Fe(h)p Fu(F)-8 b(eat-T)g(erm)p Fe(i)266 2275 y Fu(A)33 +b Fe(h)p Fu(F)-8 b(eat-T)g(erm)p Fe(i)31 b Fu(is)h(a)g(t)m(yp)s(ed)i +(attribute)e(v)-5 b(alue)32 b(matrix.)364 2515 y Fe(h)p +Fu(F)-8 b(eat-T)g(erm)p Fe(i)453 b Fu(::=)33 b([)p Fe(h)p +Fu(T)m(yp)s(e-name)p Fe(i)g Fu(":"])f Fe(h)p Fu(Conj)p +Fe(i)364 2635 y(h)p Fu(Conj)p Fe(i)694 b Fu(::=)33 b +Ff("[")g Fe(h)p Fu(Lab)s(el-v)-5 b(alue-pair)p Fe(i)29 +b Fu(*)j Ff("]")364 2756 y Fe(h)p Fu(Lab)s(el-v)-5 b(alue-pair)p +Fe(i)204 b Fu(::=)33 b Ff("\(")g Fe(h)p Fu(Iden)m(ti\014er)p +Fe(i)g(h)p Fu(F)-8 b(eat-T)g(erm)p Fe(i)31 b Ff("\)")364 +2876 y Fe(h)p Fu(T)m(yp)s(e-name)p Fe(i)418 b Fu(::=)33 +b Fe(h)p Fu(Iden)m(ti\014er)p Fe(i)266 3116 y(h)p Fu(Options)p +Fe(i)f Fu(is)g(describ)s(ed)h(in)f(section)h(3.)266 3284 +y(This)g(BNF-notation)e(mak)m(es)i(use)g(of)239 3524 +y(1.)49 b(star)33 b(\(*\))f(for)g(0)g(or)g(more)g(rep)s(etitions)g(of)g +(the)h(preceding)g(constituen)m(t)239 3723 y(2.)49 b(bar)32 +b(\()p Fe(j)p Fu(\))g(for)g(alternation)239 3923 y(3.)49 +b(brac)m(k)m(ets)34 b(\([]\))f(for)f(marking)f(the)i(enclosed)g +(constituen)m(ts)h(as)f(optional)239 4123 y(4.)49 b(a)32 +b(quotation)g(sym)m(b)s(ol)g(\("\))g(for)g(delimiting)d(k)m(eyw)m(ords) +266 4363 y(The)38 b(ab)s(o)m(v)m(e)g(de\014nition)e(is)g(somewhat)h(o)m +(v)m(ersimpli\014ed,)g(since)h(it)e(do)s(es)h(not)g(deal)f(with)h(the) +120 4483 y(".n")45 b(notation)e(for)h Fe(h)p Fu(Constituen)m(t)p +Fe(i)q Fu(:)68 b(if)44 b(on)g(the)i(righ)m(t-hand)e(side)h(of)f(a)h +(pro)s(duction)f(a)g(non-)120 4604 y(terminal)28 b(o)s(ccurs)k(rep)s +(eatedly)-8 b(,)31 b(w)m(e)h(can)f(distinguish)f(the)h(o)s(ccurrences)h +(b)m(y)g(app)s(ending)e(".")h(and)120 4724 y(a)25 b(digit)e(to)i(the)g +(iden)m(ti\014er.)41 b(The)26 b(seman)m(tics)f(can)h(then)f(unam)m +(biguously)f(refer)i(to)e(an)h(o)s(ccurrence)120 4844 +y(of)32 b(a)g(constituen)m(t.)266 5012 y(The)38 b(seman)m(tics)f(is)g +(describ)s(ed)h(as)f(a)g(t)m(yp)s(ed)h(feature)f(structure.)58 +b(Names)37 b(of)g(v)-5 b(ariables)36 b(o)s(c-)120 5132 +y(curring)i(in)g(feature)h(term)f(p)s(osition)f(corresp)s(ond)j(to)e +(constituen)m(t)h(names)g(in)f(the)h(righ)m(t-hand)p +120 5216 1440 4 v 199 5277 a Fl(11)269 5308 y Fk(Y)-7 +b(ou)36 b(ma)n(y)f(study)h(the)g(de\014nition)g(of)f(the)h(meta)g +(grammar)d(in)j(terms)f(of)h(the)g(n)n(ull-grammar)d(in)j(the)g(\014le) +120 5407 y("zebu-mg.zb".)1871 5656 y Fu(14)p eop +%%Page: 15 15 +15 14 bop 120 407 a Fu(side)35 b(of)f(the)h(rule.)50 +b(The)36 b(e\013ect)f(of)g(applying)e(a)i(rule)f(is)g(to)h(instan)m +(tiate)f(a)g(feature)h(structure)h(of)120 527 y(the)d(t)m(yp)s(e)g +(describ)s(ed)h(in)e(the)h(rule)f(seman)m(tics,)h(substituting)f(v)-5 +b(ariables)31 b(with)h(their)g(v)-5 b(alues.)266 695 +y(If)28 b(the)g(relation)e(b)s(et)m(w)m(een)j(seman)m(tics)f(and)g(syn) +m(tax)h(is)e(one-to-one,)h(the)g(in)m(v)m(erse)h(of)e(a)g(parser,)120 +815 y(a)32 b(prin)m(ter,)h(can)g(b)s(e)f(generated.)120 +1150 y Fg(4.1)135 b(Domain)46 b(De\014nition)120 1382 +y Fu(Although)37 b(it)h(is)f(p)s(ossible)h(to)g(sp)s(ecify)g(the)h +(hierarc)m(h)m(y)g(of)f(domain)e(t)m(yp)s(es)k(using)e(the)g +Ff(:domain)120 1502 y Fu(k)m(eyw)m(ord)45 b(as)e(in)f(section)h(3.2,)i +(a)d(more)h(con)m(v)m(enien)m(t)h(syn)m(tax)h(is)d(o\013ered)h(b)m(y)h +(the)f(meta)f(ab)s(o)m(v)m(e)120 1623 y(grammar)30 b(rule)i +Fe(h)p Fu(Domain-Defn)p Fe(i)m Fu(.)266 1790 y(The)i(t)m(yp)s(e)f +(de\014nition)364 2034 y Fd(atyp)-5 b(e)33 b Fu(:=)f +Fd(sup)-5 b(er)p Fu(:)43 b([\()p Fr(s)1155 2049 y Fn(1)1195 +2034 y Fu(\))32 b(...)44 b(\()p Fr(s)1474 2049 y Fa(n)1521 +2034 y Fu(\)];)120 2277 y(will)30 b(de\014ne)k(the)f(t)m(yp)s(e)h +Fd(atyp)-5 b(e)32 b Fu(inheriting)f(from)g Fd(sup)-5 +b(er)p Fu(,)33 b(and)f(ha)m(ving)h(slots)f Fr(s)2956 +2292 y Fn(1)3028 2277 y Fu(through)g Fr(s)3442 2292 y +Fa(n)3489 2277 y Fu(.)364 2543 y Fd(atyp)-5 b(e)33 b +Fu(:=)f([\()p Fr(s)862 2558 y Fn(1)901 2543 y Fu(\))h(...)44 +b(\()p Fr(s)1181 2558 y Fa(n)1227 2543 y Fu(\)];)120 +2809 y(is)27 b(as)i(ab)s(o)m(v)m(e)f(but)g(de\014nes)i(the)e(t)m(yp)s +(e)h Fd(atyp)-5 b(e)28 b Fu(as)g(a)g(subt)m(yp)s(e)i(of)d(the)h(top)g +(t)m(yp)s(e)h(named)f Ff(kb-domain)p Fu(.)266 2977 y(A)33 +b(slot)f(ma)m(y)g(b)s(e)h(t)m(yp)s(e)g(restricted)g(as)g(in:)364 +3220 y Fd(atyp)-5 b(e)33 b Fu(:=)f Fd(sup)-5 b(er)p Fu(:)43 +b([\()p Fr(s)1155 3235 y Fn(1)1227 3220 y Ff(KB-sequence)p +Fu(\)];)120 3463 y(whic)m(h)g(restricts)g Fr(s)840 3478 +y Fn(1)921 3463 y Fu(to)f(b)s(e)h(of)e(t)m(yp)s(e)j Ff(KB-sequence)p +Fu(.)75 b(An)43 b(optional)d Fd(print-function)i Fu(ma)m(y)g(b)s(e)120 +3584 y(sp)s(eci\014ed,)34 b(as)e(in)364 3850 y Fd(atyp)-5 +b(e)33 b Fu(:=)f Fd(sup)-5 b(er)p Fu(:)43 b([\()p Fr(s)1155 +3865 y Fn(1)1195 3850 y Fu(\)])32 b Ff(<<)h(print-function:)48 +b Fd(print-atyp)-5 b(e)32 b Ff(>>)p Fu(;)120 4115 y(Here)44 +b(w)m(e)g(supply)g(for)f Fd(atyp)-5 b(e)43 b Fu(its)f(o)m(wn)i(prin)m +(ter)f(called)f Fd(print-atyp)-5 b(e)43 b Fu(and)h(no)f(prin)m(ter)g +(will)e(b)s(e)120 4236 y(generated)30 b(for)g Fd(atyp)-5 +b(e)p Fu(.)42 b(Usually)29 b(it)g(is)g(not)g(necessary)j(to)e(pro)m +(vide)g(a)f(prin)m(t-function,)g(but)h(if)f(the)120 4356 +y(grammar)h(is)i(am)m(biguous,)g(this)g(is)g(a)h(w)m(a)m(y)g(to)g +(force)f(a)h(particular)e(canonical)g(unparser.)120 4691 +y Fg(4.2)135 b(Example)46 b(Grammars)120 4923 y Fs(Example)36 +b(Grammar)h(for)h(Arithmetic)c(Expressions)120 5166 y +Ff(\(:name)53 b("arith-exp")h(:grammar)f("zebu-mg"\))120 +5407 y(;;)f(Domain)h(definition)1871 5656 y Fu(15)p eop +%%Page: 16 16 +16 15 bop 120 527 a Ff(Arith-exp)54 b(:=)d(Kb-domain:)j([];)120 +648 y(Factor)207 b(:=)51 b(Arith-exp:)j([\(-value\)])g +(<>;)120 768 y(Mult-op)156 +b(:=)51 b(Arith-exp:)j([\(-arg1\))g(\(-arg2\)];)120 888 +y(Plus-op)156 b(:=)51 b(Arith-exp:)j([\(-arg1\))g(\(-arg2\)];)120 +1129 y(;;)e(Productions)120 1370 y(EE)g(-->)103 b(EE)52 +b("+")g(TT)g({)f(Plus-op:)j([\(-arg1)f(EE\))f(\(-arg2)h(TT\)])f(})530 +1490 y(|)103 b(TT)52 b(;)120 1731 y(TT)g(-->)g(TT)g("*")g(F)154 +b({)51 b(Mult-op:)j([\(-arg1)f(TT\))f(\(-arg2)h(F\)])f(})479 +1851 y(|)f(F)h(;)120 2092 y(F)g(-->)103 b("\(")52 b(EE)g("\)")411 +b({)51 b(factor:)i([\(-value)h(EE\)])e(})479 2213 y(|)f(IDENTIFIER)311 +b({)51 b(factor:)i([\(-value)h(IDENTIFIER\)])g(})479 +2333 y(|)d(NUMBER)515 b({)51 b(factor:)i([\(-value)h(NUMBER\)])f(})f(;) +266 2685 y Fu(The)32 b(seman)m(tics)e(of)g(the)h(\014rst)g(rule)f(sa)m +(ys)h(that)f(an)h(ob)5 b(ject)31 b(of)f(t)m(yp)s(e)h +Ff(+-op)g Fu(should)g(b)s(e)f(created)120 2806 y(with)i(slot)g +Ff(-arg1)i Fu(\014lled)d(with)h(the)h(v)-5 b(alue)33 +b(of)f Ff(EE)h Fu(and)f Ff(-arg2)i Fu(\014lled)e(with)g(the)h(v)-5 +b(alue)32 b(of)g Ff(TT)p Fu(.)120 3110 y Fs(Example)59 +b(Grammar)h(for)g(Prop)s(ositional)e(Calculus)97 b Fu(This)52 +b(grammar)e(de\014nes)55 b(the)120 3230 y(same)32 b(domain)f(as)i(ab)s +(o)m(v)m(e)g(\(3.2\).)43 b(Compiling)30 b(it)h(generates)j(a)e(parser)i +(and)e(a)h(generator.)120 3601 y Ff(\(:name)53 b("pc2")171 +3722 y(:package)h("CL-USER")171 3842 y(:grammar)g("zebu-mg"\))120 +4083 y(;;)e(Domain)h(definition)120 4324 y(Formula)g(:=)f(kb-domain:)i +([];)171 4565 y(Propositional-variable)j(:=)52 b(Formula:)i([\(-name\)) +f(];)171 4685 y(P-Formula)720 b(:=)52 b(Formula:)i([\(-content\))g(];) +171 4805 y(Boolean-Expr)567 b(:=)52 b(Formula:)i([\(-rand1)f(Formula\)) +g(\(-rand2)g(Formula\)];)325 4926 y(Boolean-Or)515 b(:=)52 +b(Boolean-Expr:)j([];)325 5046 y(Boolean-And)464 b(:=)52 +b(Boolean-Expr:)j([];)171 5166 y(Atomic-Wff)669 b(:=)52 +b(Formula:)i([\(-predicate\))2017 5287 y(\(-Role-Argument-Pairs)j +(kb-sequence\)];)1871 5656 y Fu(16)p eop +%%Page: 17 17 +17 16 bop 120 407 a Ff(Role-Argument-Pair)56 b(:=)c(kb-domain:)i +([\(-Role\))f(\(-Argument\)];)120 648 y(;;)f(Productions)120 +888 y(Formula)h(-->)f(Propositional-variable)735 1009 +y(|)g(Boolean-Expr)735 1129 y(|)g("\(")g(Formula)h("\)")f +({P-Formula:[\(-content)57 b(Formula\)]})735 1249 y(|)52 +b(Atomic-Wff;)120 1490 y(Propositional-Variable)223 1611 +y(-->)g(Identifier)i({Propositional-variable:)j([\(-name)c +(Identifier\)]};)120 1851 y(Boolean-Expr)h(-->)f(Formula.1)g("and")g +(Formula.2)992 1972 y({Boolean-And:)h([\(-rand1)g(Formula.1\))1761 +2092 y(\(-rand2)f(Formula.2\)]})940 2333 y(|)f(Formula.1)h("or")g +(Formula.2)1043 2453 y({Boolean-Or:)h([\(-rand1)g(Formula.1\))1761 +2574 y(\(-rand2)f(Formula.2\)]};)120 2814 y(Atomic-Wff)h(-->)e +(Identifier)i("\(")e(Role-Argument-Pairs)k("\)")889 2935 +y({)c(Atomic-Wff:)992 3055 y([\(-predicate)i(Identifier\))1043 +3176 y(\(-Role-Argument-Pairs)j(Role-Argument-Pairs\)]};)120 +3416 y(Role-Argument-Pairs)f(-->)428 3537 y(|)51 b(Role-Argument-Pair) +56 b(Role-Argument-Pairs)530 3657 y({)c(RAP-list:)h([\(-first)h +(Role-Argument-Pair\))1197 3778 y(\(-rest)104 b +(Role-Argument-Pairs\)]};)120 4018 y(Role-Argument-Pair)56 +b(-->)428 4139 y(Identifier)e(":")e(Term)428 4259 y +({Role-Argument-Pair:)k([\(-Role)d(Identifier\))1555 +4379 y(\(-Argument)h(Term\)]};)120 4620 y(Term)e(-->)104 +b(Identifier)54 b(|)d(Number)i(;)1871 5656 y Fu(17)p +eop +%%Page: 18 18 +18 17 bop 120 407 a Fg(4.3)135 b(The)45 b(Kleene)h(*)f(Notation)120 +639 y Fu(The)33 b(meta-grammar)c(\\zebu-mg")i(pro)m(vides)i(an)f +(abbreviated)g(notation)f(for)g(rep)s(eated)i(o)s(ccur-)120 +759 y(rences)h(of)e(a)h(non-terminal,)d(separated)j(b)m(y)h(a)e(k)m +(eyw)m(ord.)46 b(The)33 b(syn)m(tax)h(for)e(this)h(is:)445 +1021 y Fe(h)p Fu(Kleene-Rhs)p Fe(i)170 b Fu(::=)32 b +Fe(h)p Fu(Iden)m(ti\014er)p Fe(i)h Ff(*)g Fe(h)p Fu(String)p +Fe(i)1115 b Fu(\(1\))445 1141 y Fe(h)p Fu(Kleene-Rhs)p +Fe(i)170 b Fu(::=)32 b Fe(h)p Fu(Iden)m(ti\014er)p Fe(i)h +Ff(+)g Fe(h)p Fu(String)p Fe(i)1115 b Fu(\(2\))266 1523 +y(The)42 b(meaning)d(of)h(\(1\))h(is)f(that)g(0)h(or)f(more)g(o)s +(ccurrences)j(of)d(the)h(constituen)m(t)h(named)e(b)m(y)120 +1643 y Fe(h)p Fu(Iden)m(ti\014er)p Fe(i)45 b Fu(and)h(separated)g(b)m +(y)g Fe(h)p Fu(String)p Fe(i)e Fu(will)f(b)s(e)i(accepted)i(b)m(y)f +(this)f(rule,)j(and)d(that)h(the)120 1764 y(sequence)j(of)d(the)h +(results)f(of)g(these)i(constituen)m(ts)f(will)d(b)s(e)i(returned)i(as) +e(the)h(seman)m(tics)f(of)120 1884 y Fe(h)p Fu(Kleene-Rhs)p +Fe(i)p Fu(.)c(The)31 b(meaning)d(of)i(\(2\))f(is)h(the)g(same,)g +(except)i(that)d(at)h(least)f(one)h(o)s(ccurrence)h(of)120 +2004 y(the)i(constituen)m(t)g(has)g(to)f(b)s(e)h(found.)266 +2172 y(The)h(seman)m(tics)f(of)g(a)f Fe(h)p Fu(Kleene-Rhs)p +Fe(i)h Fu(pro)s(duction)f(is)h(an)f(implicit)d(kb-sequence)36 +b(construc-)120 2292 y(tion.)46 b(The)34 b(Kleene-constituen)m(t)h(\()p +Fe(h)p Fu(Iden)m(ti\014er)p Fe(i)e Fu(concatenated)i(with)e +Ff(*)h Fu(or)g Ff(+)p Fu(\))f(is)h(b)s(ound)g(in)f(the)120 +2413 y(seman)m(tics)g(of)f(the)h(pro)s(duction,)f(e.g.)120 +2674 y Ff(Disjunction)54 b(-->)e(Conjunction+)j("|")940 +2795 y({Disj:)e([\(-terms)h(Conjunction+\)]};)266 3177 +y Fu(builds)42 b(a)f(structure)j(of)d(t)m(yp)s(e)i Ff(Disj)h +Fu(with)d(the)i Ff(-terms)g Fu(slot)f(\014lled)f(b)m(y)i(the)f(v)-5 +b(alue)42 b(of)g(the)120 3297 y(Kleene-constituen)m(t)33 +b Ff(Conjunction+)p Fu(.)120 3602 y Fs(Example)j(grammar)h(using)g +(Kleene)g(*)h(Notation)120 3963 y Ff(\(:name)53 b("mini-la")h(:grammar) +f("zebu-mg")h(\))120 4203 y(;;)e(Domain)h(definition)120 +4444 y(Program)g(:=)f([\(-stmts)h(kb-sequence\)];)120 +4565 y(Application)h(:=)e([\(-function\))i(\(-args)f(kb-sequence\)];) +120 4805 y(;;)f(rules)120 5046 y(Program)h(-->)f("begin")h(Stmt+)g(";") +f("end")786 5166 y({)g(Program:)h([\(-stmts)h(Stmt+\)])f(})e(;)120 +5407 y(Stmt)206 b(-->)52 b(Identifier)i(|)e(Appl)g(|)g(Program)h(;)1871 +5656 y Fu(18)p eop +%%Page: 19 19 +19 18 bop 120 527 a Ff(Appl)206 b(-->)52 b(Identifier)i("\(")e(Arg*)h +(")e(")h("\)")786 648 y({Application:)j([\(-function)f(Identifier\))h +(\(-args)d(Arg*\)]};)120 888 y(Arg)257 b(-->)52 b(Identifier)i(|)e +(Number)h(|)e(Appl)h(;)266 1261 y Fu(Compiling)38 b(this)j(grammar)e +(generates)j(a)f(parser/unparser)i(\(i.e.)e(the)g(prin)m(ting)f +(routines)120 1381 y(are)33 b(generated)g(automatically\).)120 +1660 y Ff(\(zb:read-parser)55 b("begin)e(A;)f(B)f(;)h(C)g(end")940 +1780 y(:grammar)i(\(zb:find-grammar)h("mini-la"\)\))266 +2178 y Fu(returns)34 b(a)e(structure)i(of)e(t)m(yp)s(e)i +Ff(PROGRAM)g Fu(whic)m(h)f(is)f(prin)m(ted)h(in)f(the)h(syn)m(tax)h(of) +e(\\mini-la":)120 2457 y Ff(begin)53 b(A;B;C)f(end)120 +2577 y(>)g(\(describe)h(*\))120 2697 y(begin)g(A;B;C)f(end)g(is)g(a)g +(structure)h(of)f(type)g(PROGRAM.)120 2818 y(It)g(has)g(1)f(slot,)i +(with)f(the)g(following)i(values:)171 2938 y(-STMTS:)1130 +b(A;B;C)120 3179 y(\(describe)54 b(\(PROGRAM--STMTS)h(*\)\))120 +3299 y(A;B;C)e(is)e(a)h(structure)i(of)d(type)i(KB-SEQUENCE.)120 +3420 y(It)f(has)g(2)f(slots,)i(with)g(the)f(following)h(values:)171 +3540 y(FIRST:)1181 b(A)171 3660 y(REST:)1232 b(B)52 b(C)120 +4163 y Ft(5)161 b(Using)54 b(the)f(Compiler)120 4459 +y Fg(5.1)135 b(Compiling)46 b(a)g(grammar)120 4691 y +Fu(The)36 b Fq(Zebu)p Fu(-compiler)924 4655 y Fn(12)1032 +4691 y Fu(can)f(b)s(e)h(called)e(using)h(an)m(y)h(of)f(the)g +(functions:)49 b Ff(zebu-compile-file)p Fu(,)120 4811 +y Ff(compile-slr-grammar)p Fu(,)38 b Ff(compile-lalr1-grammar)p +Fu(.)120 5090 y Ff(zebu-compile-file)2466 b Fd(function)770 +5210 y(gr)-5 b(ammar-\014le)31 b Ff(&key)j Fd(output-\014le)f(gr)-5 +b(ammar)31 b(verb)-5 b(ose)p 120 5316 1440 4 v 199 5377 +a Fl(12)269 5407 y Fk(F)e(or)27 b(installation)g(see)h(app)r(endix)f +(A.)1871 5656 y Fu(19)p eop +%%Page: 20 20 +20 19 bop 266 407 a Fu(This)25 b(compiles)f(the)h(LALR\(1\))f(grammar)e +(in)i(a)h(\014le)f(named)h Fd(gr)-5 b(ammar-\014le)p +Fu(.)39 b(The)26 b Fd(output-\014le)120 527 y Fu(defaults)31 +b(to)g(a)g(\014le)g(with)g(the)h(same)f(name)g(as)g Fd(gr)-5 +b(ammar-\014le)30 b Fu(but)h(t)m(yp)s(e)i(")p Ff(tab)p +Fu(".)43 b(The)32 b(grammar)120 648 y(used)26 b(for)e(compilation)e +(defaults)i(to)h(the)g(n)m(ull-grammar.)37 b(If)25 b +Fd(verb)-5 b(ose)24 b Fu(is)g Fd(true)p Fu(,)j(con\015ict)e(w)m +(arnings)120 768 y(will)30 b(b)s(e)j(prin)m(ted.)44 b +Ff(zebu-compile-file)37 b Fu(returns)c(the)g(pathname)g(of)f +Fd(output-\014le)p Fu(.)120 1074 y Fs(Example:)171 1320 +y Ff(\(let)53 b(\(\(*warn-conflicts*)j(t\))479 1441 y +(\(*allow-conflicts*)g(t\)\))274 1561 y(\(zebu-compile-file)g +("dangelse.zb")1248 1681 y(:output-file)e("/tmp/dangelse.tab"\)\))171 +1922 y(;)e(Zebu)g(Compiling)i(\(Version)f(2.0\))171 2042 +y(;)f("~/zebu/test/dangelse.zb")58 b(to)52 b("/tmp/dangelse.tab")171 +2283 y(Reading)h(grammar)h(from)e(dangelse.zb)171 2524 +y(Start)h(symbols)g(is:)f(S)171 2765 y(4)g(productions,)i(8)e(symbols) +171 2885 y(.........9)i(item)f(sets)171 3006 y(.........)171 +3126 y(.........)171 3246 y(;;;)f(Warning:)i(ACTION)f(CONFLICT!!!--)h +(state:)f(8)171 3367 y(;;;)514 b(old)52 b(entry:)h(\(6)e(:S)h(2\))103 +b(new)52 b(entry:)h(\(6)f(:R)g(2\))171 3487 y(;;;)171 +3607 y(;;;)g(Warning:)i(Continuing)g(to)d(build)i(tables)g(despite)g +(conflicts...)171 3728 y(;;;)514 b(Will)52 b(prefer)h(old)f(entry:)h +(\(6)f(:S)f(2\))171 3969 y(Dumping)i(parse)g(tables)g(to)f +(/tmp/dangelse.tab)171 4089 y(#P"/tmp/dangelse.tab")120 +4358 y(*warn-conflicts*)2517 b Fd(variable)266 4628 y +Fu(If)26 b Fd(true)g Fu(during)f(LALR-table)g(construction,)i +(shift-reduce)f(con\015icts)g(will)e(b)s(e)i(rep)s(orted.)41 +b(By)120 4748 y(default,)32 b Ff(*warn-conflicts*)37 +b Fu(is)32 b Fd(false)p Fu(.)120 5017 y Ff(*allow-conflicts*)2466 +b Fd(variable)266 5287 y Fu(If)36 b Fd(true)g Fu(during)g(LALR-table)e +(construction,)j(shift-reduce)f(con\015icts)g(will)e(b)s(e)i(resolv)m +(ed)h(in)120 5407 y(fa)m(v)m(or)c(of)f(the)h(old)f(en)m(try)-8 +b(.)44 b(By)33 b(default,)f Ff(*allow-conflicts*)37 b +Fu(is)32 b Fd(true)p Fu(.)1871 5656 y(20)p eop +%%Page: 21 21 +21 20 bop 120 407 a Ff(*check-actions*)2568 b Fd(variable)266 +624 y Fu(If)27 b Fd(true)h Fu(the)f(seman)m(tic)g(action)f(asso)s +(ciated)h(with)f(a)h(pro)s(duction)f(will)f(b)s(e)i(compiled)e(at)i +(gram-)120 745 y(mar)44 b(compilation)e(time)h(in)i(order)g(to)f +(displa)m(y)h(p)s(ossible)f(w)m(arning)h(messages.)82 +b(By)46 b(default,)120 865 y Ff(*check-actions*)37 b +Fu(is)32 b Fd(false)p Fu(.)120 1083 y Ff(compile-slr-grammar)38 +b Fd(gr)-5 b(ammar-\014le)31 b Ff(&key)i Fd(output-\014le)g(gr)-5 +b(ammar)673 b(function)266 1300 y Fu(This)33 b(is)f(lik)m(e)g +Ff(zebu-compile-file)p Fu(,)37 b(but)c(an)f(SLR-table)g(will)e(b)s(e)j +(made.)266 1468 y(Example:)171 1675 y Ff(\(compile-slr-grammar)57 +b("dangelse.zb")376 1796 y(:output-file)e("/tmp/dangelse.tab"\))171 +2036 y(Reading)e(grammar)h(from)e(dangelse.zb)171 2277 +y(Start)h(symbols)g(is:)f(S)171 2518 y(4)g(productions,)i(8)e(symbols) +171 2638 y(.........9)i(item)f(sets)171 2879 y(Dumping)g(parse)g +(tables)g(to)f(/tmp/dangelse.tab)171 3000 y(#P"/tmp/dangelse.tab")120 +3338 y(compile-lalr1-grammar)38 b Fd(gr)-5 b(ammar-\014le)31 +b Ff(&key)j Fd(output-\014le)f(gr)-5 b(ammar)570 b(function)266 +3555 y Fu(This)33 b(is)f(lik)m(e)g Ff(zebu-compile-file)p +Fu(,)37 b(but)c(do)s(es)g(not)f(expand)i(logical)c(pathnames.)266 +3723 y(Example:)171 3940 y Ff(\(compile-lalr1-grammar)57 +b("dangelse.zb")1350 4061 y(:output-file)e("/tmp/dangelse.tab"\))171 +4302 y(Reading)e(grammar)h(from)e(dangelse.zb)171 4542 +y(Start)h(symbols)g(is:)f(S)171 4783 y(4)g(productions,)i(8)e(symbols) +171 4904 y(.........9)i(item)f(sets)171 5024 y(.........)171 +5144 y(.........)171 5265 y(Dumping)g(parse)g(tables)g(to)f +(/tmp/dangelse.tab)171 5385 y(#P"/tmp/dangelse.tab")1871 +5656 y Fu(21)p eop +%%Page: 22 22 +22 21 bop 120 407 a Fg(5.2)135 b(Loading)46 b(a)f(grammar)120 +639 y Ff(zebu-load-file)36 b Fd(\014lename)31 b Ff(&key)j +Fd(verb)-5 b(ose)1653 b(function)266 916 y(\014lename)31 +b Fu(should)g(b)s(e)h(the)g(name)f(of)h(a)f(compiled)f(grammar)f +(\014le,)j(i.e.)f(a)h(\014le)f(of)g(t)m(yp)s(e)i(")p +Ff(tab)p Fu(".)120 1036 y(If)38 b(suc)m(h)h(a)e(\014le)h(can)g(b)s(e)f +(found,)j(it)c(will)g(b)s(e)i(loaded,)g(returning)f(the)h(grammar)e(ob) +5 b(ject)38 b(needed)120 1157 y(for)g(parsing.)59 b(In)38 +b(case)h(a)f(domain-\014le)e(w)m(as)j(generated)g(b)m(y)g(compiling)34 +b(the)39 b(grammar,)e(it)g(will)120 1277 y(also)50 b(b)s(e)g(loaded.)97 +b(The)52 b(t)m(yp)s(e)f(of)f(the)h(domain-\014le)d(is)j(the)g(\014rst)g +(for)f(whic)m(h)h(a)f(\014le)g(named)120 1397 y Fd(\014lename)p +Ff(-domain)p Fu(.)p Fe(h)p Fu(t)m(yp)s(e)p Fe(i)34 b +Fu(exists,)f(b)m(y)h(examining)c(the)j(lists)364 1649 +y Ff(*load-binary-pathname-typ)q(es*)39 b Fu(and)364 +1769 y Ff(*load-source-pathname-typ)q(es*)120 2021 y +Fu(for)32 b(.)p Fe(h)p Fu(t)m(yp)s(e)p Fe(i)h Fu(in)f(turn.)266 +2188 y(The)i(k)m(eyw)m(ord)h(argumen)m(t)d Fd(verb)-5 +b(ose)32 b Fu(defaults)g(to)g Fd(true)p Fu(.)120 2496 +y Fs(Example:)171 2748 y Ff(\(zebu-load-file)56 b +("/tmp/dangelse.tab"\))171 2868 y()266 +3120 y Fu(It)36 b(is)f(p)s(ossible)g(to)g(ha)m(v)m(e)i(man)m(y)f +(grammars)d(loaded)i(concurren)m(tly)-8 b(.)54 b(Giv)m(en)35 +b(the)h(name)f(of)g(a)120 3240 y(grammar,)30 b(one)j(can)g(\014nd)g(a)f +(grammar)f(that)h(has)h(b)s(een)g(loaded)f(b)m(y:)120 +3517 y Ff(find-grammar)k Fd(name)2455 b(function)266 +3794 y(name)32 b Fu(m)m(ust)i(b)s(e)f(a)g(string.)44 +b(If)33 b(a)g(grammar)e(of)h(the)i(same)e(name)h(\(ignoring)e(case\))j +(has)f(b)s(een)120 3914 y(loaded,)f(the)h(grammar)d(ob)5 +b(ject)34 b(is)e(returned,)h(else)g Fd(false)f Fu(is)g(returned.)120 +4222 y Fs(Example:)171 4474 y Ff(\(find-grammar)55 b("dangelse"\))171 +4594 y()120 5052 y Fg(5.3)135 +b(P)l(arsing)46 b(a)f(string)h(with)f(a)g(grammar)120 +5284 y Ff(read-parser)2772 b Fd(function)770 5404 y(string)33 +b Ff(&key)g Fd(gr)-5 b(ammar)32 b(junk-al)5 b(lowe)-5 +b(d)31 b(print-p)-5 b(arse-err)g(ors)31 b(err)-5 b(or-fn)32 +b(start)1871 5656 y Fu(22)p eop +%%Page: 23 23 +23 22 bop 266 407 a Fu(The)29 b(argumen)m(t)e(of)g(the)h +Ff(:grammar)i Fu(k)m(eyw)m(ord)g(defaults)d(to)g Ff(*current-grammar*) +32 b Fu(\(initially)120 527 y(b)s(ound)h(to)f(the)h(n)m(ull-grammar\),) +c(e.g.)283 795 y Ff(\(read-parser)54 b Fe(h)p Fd(string)p +Fe(i)d Ff(:grammar)i(\(find-grammar)i Fe(h)p Fd(name)p +Fe(i)n Ff(\)\))283 1036 y Fu(is)32 b(equiv)-5 b(alen)m(t)32 +b(to)283 1277 y Ff(\(setq)52 b(zebu:*current-grammar*)57 +b(\(find-grammar)e Fe(h)p Fd(name)p Fe(i)o Ff(\)\))283 +1397 y(\(read-parser)f Fe(h)p Fd(string)p Fe(i)o Ff(\))266 +1665 y(read-parser)38 b Fu(parses)f(the)f(string)e(starting)h(at)f(the) +i(p)s(osition)e(indicated)g(b)m(y)i Ff(:start)h Fu(\(de-)120 +1786 y(fault)31 b(0\).)266 1953 y Ff(read-parser)38 b +Fu(tak)m(es)e(the)f(k)m(eyw)m(ord)i(argumen)m(t)e Ff(:junk-allowed)p +Fu(,)j(whic)m(h)e(if)d Fd(true)j Fu(will)c(re-)120 2074 +y(turn)d(as)h(second)h(v)-5 b(alue)28 b(an)h(index)h(to)f(the)h +(unparsed)g(remainder)f(of)f(the)i(string)f(in)f(case)i(not)g(the)120 +2194 y(en)m(tire)j(string)f(w)m(as)h(consumed)g(b)m(y)h(the)f(parse.) +266 2362 y(The)g(k)m(eyw)m(ord)g Ff(:junk-allowed)i Fu(has)d(the)f +(same)g(meaning)f(as)i(in)e(the)i Fq(Common)g(Lisp)f +Fu(func-)120 2482 y(tion)h Ff(read-from-string)p Fu(.)266 +2650 y Ff(:print-parse-errors)k Fu(con)m(trols)30 b(the)g(prin)m(ting)f +(of)h(errors)h(during)e(parsing)h(and)g(defaults)120 +2770 y(to)i Fd(true)p Fu(.)266 2938 y Ff(:error-fn)46 +b Fu(is)d(a)h(function)f(used)i(to)e(rep)s(ort)g(errors,)k(it)c +(defaults)g(to)g(the)h Fq(Common)g(Lisp)120 3058 y Ff(error)34 +b Fu(function.)120 3364 y Fs(Example:)171 3609 y Ff(\(read-parser)55 +b("if)d(f)f(then)i(if)e(g)h(then)g(h)g(else)g(i")838 +3729 y(:grammar)h(\(find-grammar)i("dangelse"\)\))171 +3850 y(\("if")e(F)e("then")i(\("if")g(G)e("then")i(H)f("else")h(I\)\)) +171 4091 y(\(read-parser)i("1)d(+)f(a")h(:grammar)h(\(find-grammar)i +("ex1"\)\))171 4211 y(\(+OP)e(\(EXPRESSION)h(\(TERM)e(\(FACTOR)i +(1\)\)\))428 4331 y(\(TERM)e(\(FACTOR)h(A\)\)\))120 4666 +y Fg(5.4)135 b(P)l(arsing)46 b(from)f(a)g(\014le)h(with)f(a)g(grammar) +120 4898 y Ff(file-parser)35 b Fd(\014le)d Ff(&key)i +Fd(gr)-5 b(ammar)32 b(print-p)-5 b(arse-err)g(ors)31 +b(verb)-5 b(ose)839 b(function)266 5166 y Ff(file-parser)36 +b Fu(parses)d(expressions)i(using)d(the)h(grammar)d(sp)s(eci\014ed)j(b) +m(y)h Ff(:grammar)p Fu(,)g(read-)120 5287 y(ing)d(from)g +Fd(\014le)p Fu(.)42 b(It)33 b(returns)f(a)g(list)f(of)g(the)i +(parse-results,)f(i.e.)g(a)g(list)e(of)i(what)g(w)m(ould)g(ha)m(v)m(e)h +(b)s(een)120 5407 y(returned)h(b)m(y)f Ff(read-parser)p +Fu(.)1871 5656 y(23)p eop +%%Page: 24 24 +24 23 bop 266 407 a Fu(The)24 b Ff(:grammar)g Fu(argumen)m(t)e +(defaults)g(to)g Ff(*current-grammar*)27 b Fu({)22 b(whic)m(h)h +(initially)18 b(is)k(b)s(ound)120 527 y(to)32 b(the)h(\\n)m +(ull-grammar".)266 695 y Ff(:print-parse-errors)j Fu(con)m(trols)30 +b(the)g(prin)m(ting)f(of)h(errors)h(during)e(parsing)h(and)g(defaults) +120 815 y(to)i Fd(true)p Fu(.)266 983 y Ff(:verbose)j +Fu(con)m(trols)d(whether)i(prin)m(ting)d(of)i(parse-results)g(o)s +(ccurs,)g(and)g(defaults)f(to)h Fd(true)p Fu(.)266 1150 +y(The)j(pro)s(cessing)g(of)e(commen)m(ts)h(b)m(y)h Ff(file-parser)i +Fu(can)d(b)s(e)g(in\015uenced)h(b)m(y)g(the)g(follo)m(wing)120 +1271 y(v)-5 b(ariables:)265 1608 y Fe(\017)49 b Ff(*comment-brackets*)k +Fu(is)47 b(a)h(list)e(of)h(brac)m(k)m(et)j(pairs.)89 +b(Ev)m(erything)49 b(b)s(et)m(w)m(een)h(an)m(y)e(of)364 +1729 y(brac)m(k)m(et)34 b(pairs)e(is)g(ignored.)43 b(Initially)29 +b Ff(*comment-brackets*)38 b Fu(is)32 b(set)h(to:)364 +1916 y Ff(\(\("#\\|")53 b(.)f("|#"\)\))p Fu(.)265 2171 +y Fe(\017)d Ff(*comment-start*)i Fu(A)c(line)f(b)s(eginning)g(with)h +(this)g(c)m(haracter)h(is)e(ignored.)87 b(Initially)364 +2291 y Ff(*comment-start*)36 b Fu(is)c(set)i(to)e(the)h(semicolon)e(c)m +(haracter:)44 b Ff(#\\;)120 2652 y Fs(Example:)171 2943 +y Ff(\(file-parser)55 b("sample-ex1")f(:grammar)g(\(find-grammar)g +("ex1"\)\))171 3064 y(...)120 3453 y Fg(5.5)135 b(P)l(arsing)46 +b(from)f(a)g(list)h(of)f(tok)l(ens)120 3696 y Ff(list-parser)35 +b Fd(token-list)e Ff(&key)g Fd(gr)-5 b(ammar)32 b(junk-al)5 +b(lowe)-5 b(d)1137 b(function)266 4033 y Ff(list-parser)39 +b Fu(is)c(lik)m(e)h Ff(read-parser)i Fu(except)g(that)d(the)i(tok)m +(ens)g(that)f(are)f(passed)j(b)m(y)f(the)120 4153 y(scanner)c(to)e(the) +i(driv)m(er)f(are)g(already)f(giv)m(en)h(as)g(the)g(elemen)m(ts)g(of)f +Fd(token-list)p Fu(.)43 b(This)32 b(function)f(is)120 +4274 y(useful)26 b(if)g(the)h(options)e(for)h(con)m(trolling)e(lexical) +h(analysis)g(giv)m(en)i(in)f(section)g(3.1)g(are)g(insu\016cien)m(t.) +120 4634 y Fs(Example:)171 4926 y Ff(\(let)53 b(\(\(*current-grammar*)j +(\(find-grammar)f("ex1"\)\)\))325 5046 y(\(list-parser)g('\(1)d("+")g +(x)f("*")h(y\)\)\))171 5166 y(\(+OP)h(\(EXPRESSION)h(\(TERM)e(\(FACTOR) +i(1\)\)\))428 5287 y(\(*-OP)e(\(TERM)h(\(FACTOR)g(X\)\))f(\(FACTOR)h +(Y\)\)\))1871 5656 y Fu(24)p eop +%%Page: 25 25 +25 24 bop 120 407 a Fg(5.6)135 b(Debugging)46 b(a)f(grammar)120 +640 y Ff(debug-parser)36 b(&key)d Fd(gr)-5 b(ammar)32 +b(lexer)1833 b(function)120 923 y Ff(debug-parser)30 +b Fu(will)24 b(cause)k(a)e(trace)h(of)g(the)g(parser)g(to)g(b)s(e)f +(displa)m(y)m(ed.)42 b(The)28 b Fd(gr)-5 b(ammar)26 b +Fu(k)m(eyw)m(ord)120 1044 y(defaults)36 b(to)h Fd(true)g +Fu(and)g Fd(lexer)f Fu(defaults)g(to)g Fd(false)p Fu(.)55 +b(If)37 b Fd(lexer)f Fu(is)g Fd(true)p Fu(,)i(more)e(information)d(ab)s +(out)120 1164 y(lexical)e(analysis)h(\(see)h(section)g(6)f(b)s(elo)m +(w\))h(will)d(b)s(e)j(displa)m(y)m(ed.)120 1550 y Ft(6)161 +b(Lexical)56 b(Analysis)120 1847 y Fg(6.1)135 b(Customization)47 +b(and)e(Regular)h(Expressions)120 2080 y Fu(It)32 b(should)g(only)g +(seldomly)f(b)s(e)h(necessary)j(to)d(write)g(a)g(lexical)e(analyzer.)43 +b(Before)33 b(y)m(ou)g(attempt)120 2201 y(to)38 b(in)m(tro)s(duce)g(y)m +(our)h(o)m(wn)g(lexical)e(categories,)j(c)m(hec)m(k)g(whether)g(the)f +(follo)m(wing)d(v)-5 b(ariables)37 b(and)120 2321 y(k)m(eyw)m(ords)e(w) +m(ould)e(su\016ce)h(to)e(parameterize)g(lexical)f(analysis:)325 +2604 y Ff(*comment-start*)325 2725 y(*comment-brackets*)325 +2845 y(*disallow-packages*)325 2965 y(*preserve-case*)325 +3086 y(*case-sensitive*)325 3206 y(:case-sensitive)325 +3327 y(:identifier-start-chars)325 3447 y(:identifier-continue-char)q +(s)325 3567 y(:string-delimiter)325 3688 y(:symbol-delimiter)325 +3808 y(:white-space)325 3928 y(:lex-cats)266 4332 y Fu(The)i(lexical)d +(analyzer)i(w)m(orks)i(in)d(a)g(top-do)m(wn)i(one)f(tok)m(en)h(lo)s +(ok-ahead)d(w)m(a)m(y)-8 b(.)45 b(It)32 b(tries)f(only)120 +4452 y(to)j(recognize)h(tok)m(ens)h(that)f(w)m(ould)f(b)s(e)h(legal)e +(con)m(tin)m(uations)h(of)h(the)g(string)f(parsed)h(so)g(far.)50 +b(In)120 4573 y(case)33 b(lexical)e(categories)i(o)m(v)m(erlap)f(this)h +(will)d(serv)m(e)k(to)e(disam)m(biguate)f(tok)m(enization.)120 +4915 y Fg(6.2)135 b(In)l(tro)t(ducing)45 b(new)g(Categories)i(b)l(y)e +(Regular)h(Expressions)120 5149 y Fu(The)34 b(k)m(eyw)m(ord)g +Ff(:lex-cats)h Fu(tak)m(es)f(as)f(argumen)m(t)f(an)h(asso)s(ciation)e +(list)g(of)h(the)h(form:)325 5404 y Ff(\(\()p Fe(h)p +Ff(Category)p Fe(i)53 b(h)p Ff(Regular)g(Expression)p +Fe(i)s Ff(\))e(*\))1871 5656 y Fu(25)p eop +%%Page: 26 26 +26 25 bop 266 407 a Fe(h)p Fu(Category)p Fe(i)37 b Fu(is)g(a)g(sym)m(b) +s(ol)f(naming)g(a)g(lexical)g(category)h(and)g Fe(h)p +Fu(Regular)31 b(Expression)p Fe(i)39 b Fu(is)d(a)120 +527 y(string)24 b(represen)m(ting)h(a)f(regular)f(expression)j(as)e +(de\014ned)i(in)d(the)i(GNU)f(Emacs)g(Lisp)g(Man)m(ual)g([7].)120 +648 y(The)k(regular)e(expression)j(will)c(b)s(e)i(compiled)f(in)m(to)g +(a)h(Common)f(Lisp)h(function)g(and)g(in)m(v)m(ok)m(ed)i(b)m(y)120 +768 y Ff(read-parser)f Fu(b)s(efore)d(the)h(built-in)c(categories)j +(\(Iden)m(ti\014er,)i(String,)f(Num)m(b)s(er\))f(are)g(examined.)120 +888 y(The)34 b(categories)e(can)h(b)s(e)f(used)i(in)e(grammar)e(rules)j +(lik)m(e)f(an)m(y)h(of)f(the)h(built-in)d(categories.)266 +1056 y(The)k(regular)d(expression)j(compiler)1632 1020 +y Fn(13)1738 1056 y Fu(handles)e(the)h(follo)m(wing)d(constructs:)120 +1324 y Fs(.)49 b Fu(P)m(erio)s(d)32 b(matc)m(hes)h(an)m(y)h(single)d(c) +m(haracter)j(except)g(a)e(newline.)120 1525 y Fs(*)49 +b Fu(rep)s(eats)33 b(preceding)g(regular)f(expression)h(as)g(man)m(y)g +(times)e(as)i(p)s(ossible.)120 1727 y Fs(+)49 b Fu(lik)m(e)32 +b(*)g(but)h(m)m(ust)g(matc)m(h)f(at)g(least)g(once.)120 +1928 y Fs(?)49 b Fu(lik)m(e)32 b(*)g(but)h(m)m(ust)f(matc)m(h)h(once)g +(or)f(not)h(at)f(all.)120 2130 y Fs([.)19 b(.)g(.)g(])48 +b Fu('[')33 b(b)s(egins)g(a)f(c)m(haracter)h(set,)h(whic)m(h)f(is)f +(terminated)f(b)m(y)j(']'.)364 2250 y(Character)f(ranges)g(can)g(b)s(e) +g(indicated,)f(e.g.)g(a-z,)h(0-9.)120 2452 y Fs([)13 +b Fu(^)g Fs(.)19 b(.)f(.)h(])49 b Fu(forms)32 b(the)h(complemen)m(t)f +(c)m(haracter)h(set.)120 2653 y Fs($)49 b Fu(matc)m(hes)33 +b(only)f(at)g(the)h(end)h(of)e(a)g(line.)120 2855 y Fe(n)p +Fs(\(.)18 b(.)h(.)g Fe(n)p Fs(\))48 b Fu(is)32 b(a)g(grouping)g +(construct.)120 3056 y Fe(n)37 b(h)p Fs(digit)p Fe(i)47 +b Fu(means:)59 b(accept)41 b(the)f(same)g(string)g(as)h(w)m(as)g(matc)m +(hed)f(b)m(y)h(the)g(group)f(in)g(p)s(osition)364 3176 +y Fe(h)p Fu(digit)p Fe(i)m Fu(.)120 3483 y Fs(Example:)171 +3727 y Ff(:lex-cats)54 b(\(\(BibTeX-in-braces)i("{[^\\\\n}]*}"\)\))266 +4093 y Fu(de\014nes)33 b(a)f(new)g(category)g Ff(BibTeX-in-braces)j +Fu(whic)m(h)d(matc)m(hes)g(an)m(ything)g(starting)e(with)120 +4213 y(\\)p Fe(f)p Fu(",)i(ending)g(in)g(\\)p Fe(g)p +Fu(",)g(and)h(not)f(con)m(taining)f(either)i(a)f(newline)g(or)h(\\)p +Fe(g)p Fu(".)171 4481 y Ff(:lex-cats)223 4601 y(\(\(Ratio_Number)55 +b("-?[0-9]+/[0-9]+"\))274 4722 y(\(Simple_Float)g +("-?[0-9]*\\\\.[0-9]+"\)\))266 5110 y Fu(de\014nes)34 +b(the)e(syn)m(tax)h(for)e(rationals)e(and)j(\015oating)e(p)s(oin)m(t)h +(n)m(um)m(b)s(ers.)44 b(Note)32 b(that)f(the)h(p)s(erio)s(d)120 +5230 y(needs)f(to)e(b)s(e)g(escap)s(ed,)j(since)d(it)f(is)h(a)g(sp)s +(ecial)g(c)m(haracter)h(of)e(the)i(regular)e(expression)j(language.)p +120 5316 1440 4 v 199 5377 a Fl(13)269 5407 y Fk(Thanks)c(to)h(La)n +(wrence)e(E.)h(F)-7 b(reil)28 b(who)f(wrote)g(the)h(main)f(part)g(of)h +(the)g(Regular)e(Expression)g(Compiler.)1871 5656 y Fu(26)p +eop +%%Page: 27 27 +27 26 bop 120 407 a Fg(6.3)135 b(The)45 b(functional)g(in)l(terface)i +(to)e(the)g(parsing)h(engine)120 842 y Fu(In)f(case)h(the)f(ab)s(o)m(v) +m(e)h(parameterization)c(facilities)g(for)i(lexical)f(analysis)h(are)h +(insu\016cien)m(t)g(or)120 962 y(y)m(ou)37 b(w)m(an)m(t)f(to)g(use)h +(an)e(existing)g(lexical)g(analyzer,)h(y)m(ou)h(need)g(to)e(understand) +i(the)g(functional)120 1082 y(in)m(terface)c(to)f(the)h(parsing)f +(engine)g(as)h(implemen)m(ted)e(b)m(y)j(the)f Ff(lr-parse)p +Fu(.)120 2535 y Ff(lr-parse)2925 b Fd(function)283 2656 +y(next-sym-fn)31 b(err)-5 b(or-fn)32 b(gr)-5 b(ammar)32 +b Ff(&optional)j Fd(junk-al)5 b(lowe)-5 b(d)31 b(last-p)-5 +b(os-fn)266 4109 y Ff(lr-parse)32 b Fu(returns)f(the)f(result)g(of)f +(parsing)g(the)h(tok)m(en)h(stream)f(pro)s(duced)g(b)m(y)h +Fd(next-sym-fn)120 4229 y Fu(with)k Fd(gr)-5 b(ammar)35 +b Fu(b)m(y)h(the)g(LALR\(1\))f(metho)s(d.)52 b(In)35 +b(case)i Fd(junk-al)5 b(lowe)-5 b(d)44 b Fu(is)35 b Fd(true)44 +b Fu(it)34 b(pro)s(duces)j(as)120 4350 y(second)j(v)-5 +b(alue)38 b(a)h(handle)f(to)h(the)g(y)m(et)h(unconsumed)g(tok)m(en)g +(stream)e(b)m(y)i(calling)c(the)j(function)120 4470 y +Fd(last-p)-5 b(os-fn)p Fu(.)266 4638 y Fd(next-sym-fn)23 +b Fu(should)g(b)s(e)h(b)s(ound)g(to)f(a)g(generator)g(function)g(|)g(a) +g(function)g(of)g(no)h(argumen)m(ts)120 4758 y(|)30 b(that)g(will)e(b)s +(e)i(called)f(to)h(pro)s(duce)h(the)g(next)g(tok)m(en.)43 +b(It)31 b(should)f(return)h(t)m(w)m(o)f(v)-5 b(alues:)43 +b(\(1\))30 b(the)120 4878 y(tok)m(en)c(found)g(and)f(\(2\))g(the)h +(category)g(of)f(the)g(tok)m(en)i(\(obtained)d(b)m(y)j(the)e(function)g +Ff(categorize)p Fu(\).)266 5166 y Fd(err)-5 b(or-fn)33 +b Fu(is)f(the)h(function)g(to)f(b)s(e)h(called)f(in)g(case)i(of)e(an)h +(error.)44 b Fd(gr)-5 b(ammar)32 b Fu(is)g(the)h(grammar)120 +5287 y(ob)5 b(ject)49 b(that)e(con)m(tains)h(imp)s(ortan)m(t)e +(information)e(for)j(lexical)f(analysis,)51 b(\(e.g.)d(the)g(table)f +(of)120 5407 y(k)m(eyw)m(ords\).)1871 5656 y(27)p eop +%%Page: 28 28 +28 27 bop 266 407 a Fu(T)-8 b(o)36 b(understand)i(the)e(in)m(terface)g +(to)g Ff(lr-parse)p Fu(,)j(consider)d(ho)m(w)g Ff(list-parser)j +Fu(\(describ)s(ed)120 527 y(ab)s(o)m(v)m(e\))33 b(migh)m(t)e(ha)m(v)m +(e)j(b)s(een)g(de\014ned:)120 796 y Ff(\(defun)53 b(list-parser)h +(\(token-list)g(&key)f(\(grammar)g(*current-grammar*\))1966 +917 y(junk-allowed\))223 1037 y(\(let)f(\(\(last-position)j +(token-list\))530 1157 y(token1\))325 1278 y(\(check-type)f(token-list) +g(list\))325 1398 y(\(lr-parse)376 1519 y(;;)e(The)g(LEXER)h(supplied)g +(to)f(the)g(parsing)h(engine:)376 1639 y(#'\(lambda)h(\(\))581 +1759 y(\(if)e(\(null)h(token-list\))786 1880 y +(\(end-of-tokens-category)58 b(grammar\))684 2000 y(\(progn)786 +2120 y(\(setq)53 b(last-position)i(token-list)1094 2241 +y(token1)e(\(pop)f(token-list\)\))786 2361 y(\(categorize)j(token1)e +(grammar\)\)\)\))376 2482 y(;;)f(The)g(error)h(function)g(supplied)h +(to)d(the)h(parsing)i(engine:)376 2602 y(#'\(lambda)g(\(string\))581 +2722 y(\(error)f("~S~\045)g(Remaining)h(tokens:)f(~S~{)f(~S~}")940 +2843 y(string)h(token1)g(token-list\)\))376 2963 y(grammar)376 +3084 y(junk-allowed)376 3204 y(;;)f(Function)i(that)e(returns)h(the)f +(remaining)i(unparsed)f(token-list)376 3324 y(#'\(lambda)h(\(\))e +(last-position\)\)\)\))120 3714 y(end-of-tokens-category)38 +b Fd(gr)-5 b(ammar)1791 b(function)266 3983 y Ff +(end-of-tokens-category)44 b Fu(returns)39 b(t)m(w)m(o)g(v)-5 +b(alues:)54 b(a)37 b(tok)m(en)i(signifying)d(the)i(end)h(of)f(the)120 +4103 y(tok)m(en)c(stream)e(and)h(the)g(appropriate)e(lexical)g +(category)-8 b(.)120 4372 y Ff(categorize)35 b Fd(token)d(gr)-5 +b(ammar)2147 b(function)266 4641 y Ff(categorize)41 b +Fu(returns)e(the)f Fd(token)75 b Fu(itself)36 b(and)i(its)g(category)-8 +b(,)39 b(a)f(n)m(um)m(b)s(er)g(that)f(represen)m(ts)120 +4762 y(one)c(of)f Ff(number)p Fu(,)i Ff(identifier)p +Fu(,)h Ff(string)g Fu(or)d(a)g(terminal)e(tok)m(en)k(de\014ned)g(b)m(y) +f Ff(:lex-cats)p Fu(.)120 5141 y Ft(7)161 b(F)-13 b(uture)53 +b(W)-13 b(ork)120 5407 y Fu(T)-8 b(ranslation)31 b(in)m(v)m(olv)m(es)i +(three)h(pro)s(cesses:)1871 5656 y(28)p eop +%%Page: 29 29 +29 28 bop 265 407 a Fe(\017)49 b Fu(parsing)265 609 y +Fe(\017)g Fu(transformation)265 812 y Fe(\017)g Fu(generation)266 +1060 y Fq(Zebu)c Fu(is)e(a)h(to)s(ol)f(that)h(helps)g(in)g(1)f(and)i +(3.)78 b(There)45 b(are)g(cases)g(where)h(2)e(reduces)i(to)e(the)120 +1180 y(iden)m(tit)m(y)32 b(function,)g(since)g(the)h(abstract)f(syn)m +(tax)i(is)d(the)i(same)f(for)f(the)i(source)g(and)f(the)g(target)120 +1301 y(language)h(of)g(translation.)46 b(Examples)33 +b(for)h(these)h(\\syn)m(tactic)f(v)-5 b(arian)m(ts")33 +b(are)h(in\014x)g(and)g(pre\014x)120 1421 y(notation)d(for)h +(arithmetic)f(or)h(b)s(o)s(olean)f(expressions.)266 1589 +y(In)40 b(general,)g(the)f(situation)e(is)i(more)f(complicated.)61 +b(F)-8 b(or)38 b(languages)g(with)h(the)g(same)g(ex-)120 +1709 y(pressiv)m(e)31 b(p)s(o)m(w)m(er,)f(some)f(transformation)e(pro)s +(cess)j(can)f(b)s(e)g(de\014ned.)44 b(Bet)m(w)m(een)31 +b(languages)d(with)120 1829 y(di\013eren)m(t)40 b(expressiv)m(e)i(p)s +(o)m(w)m(er)e(suc)m(h)i(a)d(transformation)e(is)j(not)f(alw)m(a)m(ys)h +(p)s(ossible.)64 b(F)-8 b(or)39 b(a)g(lan-)120 1950 y(guage)24 +b(that)h(is)f(not)g(T)-8 b(uring)24 b(complete,)h(it)f(is)g(not)g(p)s +(ossible)g(to)g(express)j(ev)m(ery)f(computation,)f(e.g.)120 +2070 y(SQL)32 b(cannot)h(express)i(recursion,)d(and)h(hence)h(it)d(is)h +(not)g(p)s(ossible)g(to)g(express)j(the)e(\\ancestor")120 +2190 y(relation)i(\(whic)m(h)i(is)g(recursiv)m(ely)g(de\014ned\).)58 +b(A)37 b(tec)m(hnique)h(to)e(represen)m(t)j(transformation)c(are)120 +2311 y(\\rewrite)30 b(rule)g(systems".)44 b(The)31 b +Fq(Re\014ne)g Fu(language)f([8])g(con)m(tains)g(a)h(rewrite-rule)e(mec) +m(hanism)h(in)120 2431 y(whic)m(h)d(the)h(rules)e(are)h(in)f(terms)h +(of)g(patterns)g(of)f(the)i(concrete)g(syn)m(tax.)43 +b(W)-8 b(e)27 b(ha)m(v)m(e)h(implemen)m(ted)120 2552 +y(a)37 b(rewrite-rule)f(system)i(based)g(on)f(t)m(yp)s(ed)h(feature)f +(structures,)j(called)c Fq(Zebu-RR)p Fu(,)g(whic)m(h)h(will)120 +2672 y(b)s(e)c(describ)s(ed)g(in)f(a)g(future)h(rep)s(ort.)120 +3052 y Ft(A)161 b(Installation)120 3318 y Fu(There)34 +b(are)e(t)m(w)m(o)i(w)m(a)m(ys)g(to)e(install)e Fq(Zebu)p +Fu(:)265 3590 y Fe(\017)49 b Fu(Installation)30 b(using)i +Ff(defsystem)364 3751 y Fu(This)40 b(mak)m(es)h(it)f(easier)g(to)g +(load)g(and)g(compile)f(grammars,)h(since)h(one)g(do)s(es)g(not)f(need) +364 3872 y(to)j(remem)m(b)s(er)h(the)g(lo)s(cation)e(of)h(a)h(mo)s +(dule)e(in)i(a)f(directory)h(structure)h(and)f(the)h(par-)364 +3992 y(ticular)38 b(compilation)e(and)k(loading)d(functions.)65 +b(T)-8 b(o)40 b(install,)f(follo)m(w)f(the)i(directions)f(in)364 +4112 y Ff(ZEBU-sys.lisp)p Fu(.)64 b(Y)-8 b(ou)39 b(need)g(the)g(p)s +(ortable)e Ff(defsys)j Fu(for)e(that.)61 b(This)39 b(is)f(a)m(v)-5 +b(ailable)36 b(as)364 4233 y Ff(Defsys.tar.gz)g Fu(at)c(the)h(same)f +(place)h(as)g Ff(zebu-???.tar.gz)p Fu(.)364 4394 y(The)28 +b(\014le)e Ff(ZEBU-sys.lisp)k Fu(is)c(used)i(to)f(load)e(or)i(compile)d +Fq(Zebu)p Fu(,)29 b(whic)m(h)e(actually)e(consists)364 +4515 y(of)32 b(t)m(w)m(o)h(systems)h(\(de\014ned)g(b)m(y)g +Ff(defsystem)p Fu(\))770 4780 y Fq(Zebu)1017 b Fu(the)33 +b(run)m(time)f(system)770 4901 y Fq(Zebu-compiler)643 +b Fu(the)33 b(compiler)265 5287 y Fe(\017)49 b Fu(Installation)30 +b(without)i Ff(defsystem)364 5407 y Fu(If)37 b(y)m(ou)i(don't)f(w)m(an) +m(t)g(to)f(use)i Ff(defsystem)p Fu(,)i(load)c(the)h(\014le)f +Ff(COMPILE-ZEBU.lisp)p Fu(,)43 b(whic)m(h)1871 5656 y(29)p +eop +%%Page: 30 30 +30 29 bop 364 407 a Fu(compiles)20 b(the)i Fq(Zebu)g +Fu(\014les)g(in)f(the)h(righ)m(t)f(order.)80 b(After)22 +b(loading)d(the)j(\014le)g Ff(ZEBU-init.lisp)364 527 +y Fu(y)m(ou)33 b(can)g(call:)364 689 y Ff(\(zb:zebu\))i +Fu(to)d(load)f(the)i(run)m(time)f(system)364 809 y(or)364 +930 y Ff(\(zb:zebu-compiler\))37 b Fu(to)32 b(load)g(the)h(grammar)d +(compiler.)120 1310 y Ft(References)169 1570 y Fu([1])49 +b(A.V.)41 b(Aho)g(and)h(J.D.)f(Ullman.)67 b Fd(Principles)42 +b(of)g(Compiler)g(Design)p Fu(.)68 b(Addison)41 b(W)-8 +b(esley)g(,)321 1691 y(New)33 b(Y)-8 b(ork,)33 b(1979.)169 +1894 y([2])49 b(Charles)59 b(N.)g(Fisc)m(her)h(and)f(Ric)m(hard)f(J.)i +(LeBlanc.)122 b Fd(Cr)-5 b(afting)59 b(a)g(Compiler)p +Fu(.)121 b(Ben-)321 2015 y(jamin/Cummings,)29 b(Menlo)j(P)m(ark,)i(CA,) +f(1988.)169 2218 y([3])49 b(Mic)m(hael)40 b(R.)g(Genesereth.)70 +b(An)41 b(agen)m(t-based)h(framew)m(ork)e(for)h(soft)m(w)m(are)h(in)m +(terop)s(erabil-)321 2338 y(it)m(y)-8 b(.)53 b(T)-8 b(ec)m(hnical)36 +b(Rep)s(ort)f(Logic-92-02,)f(Departmen)m(t)i(Of)f(Computer)h(Science,)i +(Stanford)321 2459 y(Univ)m(ersit)m(y)-8 b(,)33 b(Stanford,)f(1992.)169 +2662 y([4])49 b(Mic)m(hael)44 b(R.)g(Genesereth,)49 b(Ric)m(hard)44 +b(Fik)m(es,)k(et)d(al.)77 b(Kno)m(wledge)45 b(in)m(terc)m(hange)g +(format,)321 2783 y(v)m(ersion)23 b(3.0.)g(reference)i(man)m(ual.)i +(Rep)s(ort)c(Logic-92-1,)f(Logic)g(Group)h(Rep)s(ort,)i(Computer)321 +2903 y(Science)33 b(Departmen)m(t,)f(Stanford)h(Univ)m(ersit)m(y)-8 +b(,)33 b(Stanford,)f(June)i(1992.)169 3106 y([5])49 b(Mark)37 +b(Johnson.)58 b Fd(A)n(ttribute)40 b(V)-7 b(alue)38 b(L)-5 +b(o)g(gic)39 b(and)f(the)h(The)-5 b(ory)39 b(of)g(Gr)-5 +b(ammar)p Fu(.)56 b(Cen)m(ter)38 b(for)321 3227 y(the)33 +b(Study)g(of)f(Language)g(and)h(Information,)e(Stanford,)h(1988.)169 +3430 y([6])49 b(Joac)m(him)41 b(Laubsc)m(h)i(and)g(Derek)g(Proudian.)72 +b(A)42 b(case)h(study)h(in)d(REFINE:)i(in)m(terfacing)321 +3550 y(mo)s(dules)31 b(via)h(languages.)43 b(Rep)s(ort)32 +b(HPL-STL-TM-88-11,)g(Hewlett)g(P)m(ac)m(k)-5 b(ard,)34 +b(1988.)169 3754 y([7])49 b(Bill)42 b(Lewis,)49 b(Dan)c(LaLib)s(erte,)j +(and)e(the)g(GNU)f(Man)m(ual)g(Group.)81 b Fd(GNU)48 +b(Emacs)e(Lisp)321 3874 y(R)-5 b(efer)g(enc)g(e)38 b(Manual)p +Fu(.)57 b(The)38 b(F)-8 b(ree)37 b(Soft)m(w)m(are)h(F)-8 +b(oundation,)37 b(Cam)m(bridge,)h(MA,)g(Decem)m(b)s(er)321 +3995 y(1990.)169 4198 y([8])49 b(Reasoning)43 b(Systems,)48 +b(P)m(alo)43 b(Alto,)i(3260)e(Hillview)f(Av)m(e.,)48 +b(CA)c(94304.)76 b Fd(R)-5 b(e\014ne)44 b(User's)321 +4318 y(Guide)p Fu(,)32 b(1989.)169 4522 y([9])49 b(Douglas)43 +b(R.)i(Smith,)i(Gordon)e(B.)g(Kotik,)i(and)e(Stephen)i(J.)e(W)-8 +b(estfold.)80 b(Researc)m(h)47 b(on)321 4642 y(kno)m(wledge-based)32 +b(soft)m(w)m(are)f(en)m(vironmen)m(ts)h(at)e(KESTREL)h(institute.)40 +b Fd(IEEE)33 b(T)-7 b(r)i(ansac-)321 4763 y(tions)34 +b(on)h(Softwar)-5 b(e)34 b(Engine)-5 b(ering)p Fu(,)31 +b(SE-11:1278{1295,)f(No)m(v)m(em)m(b)s(er)k(1985.)1871 +5656 y(30)p eop +%%Page: 31 31 +31 30 bop 120 557 a Ft(Index)120 755 y Fu(*allo)m(w-con\015icts*,)31 +b(18)120 876 y(*case-sensitiv)m(e*,)i(5,)g(24)120 998 +y(*c)m(hec)m(k-actions*,)h(18)120 1119 y(*commen)m(t-brac)m(k)m(ets*,)f +(23,)f(24)120 1240 y(*commen)m(t-start*,)f(23,)h(24)120 +1361 y(*disallo)m(w-pac)m(k)-5 b(ages*,)31 b(5,)h(24)120 +1482 y(*preserv)m(e-case*,)j(5,)d(24)120 1604 y(*w)m(arn-con\015icts*,) +h(18)120 1725 y(:build)e(seman)m(tic)i(action,)e(6)120 +1846 y(:case-sensitiv)m(e,)j(9,)e(24)120 1967 y(:domain,)f(8)120 +2088 y(:domain-\014le,)f(8)120 2209 y(:grammar,)g(8)120 +2331 y(:iden)m(ti\014er-con)m(tin)m(ue-c)m(hars,)j(8,)f(24)120 +2452 y(:iden)m(ti\014er-start-c)m(hars,)g(8,)h(24)120 +2573 y(:in)m(tern-iden)m(ti\014er,)f(8)120 2694 y(:lex-cats,)h(8,)f(24) +120 2815 y(:name,)g(8)120 2937 y(:pac)m(k)-5 b(age,)33 +b(8)120 3058 y(:prin)m(t-parse-errors,)g(22)120 3179 +y(:string-delimiter,)c(8,)j(24)120 3300 y(:sym)m(b)s(ol-delimiter,)d +(8,)j(24)120 3421 y(:white-space,)h(9,)g(24)120 3639 +y(categorize,)f(27)120 3760 y(compile-lalr1-gramm)o(ar,)26 +b(20)120 3881 y(compile-slr-grammar,)h(20)120 4099 y(debug-parser,)34 +b(23)120 4220 y(def-tree-attributes,)e(11)120 4341 y(domain)286 +4462 y(de\014ning,)h(9,)f(13)286 4584 y(top)g(t)m(yp)s(e,)i(10)120 +4705 y(feature)f(structures,)h(12)120 4826 y(\014le-parser,)e(22)120 +4947 y(\014nd-grammar,)e(21)120 5165 y(grammar)286 5286 +y(name,)i(8)286 5407 y(options,)g(8)2065 755 y(kb-compare,)h(10)2065 +876 y(kb-domain,)e(10)2065 996 y(kb-domain-p,)g(10)2065 +1116 y(kb-equal,)i(10)2065 1237 y(kb-sequence,)j(10)2065 +1357 y(Kleene)d(*,)f(5,)h(16,)f(17)2065 1561 y(lexical)f(category)-8 +b(,)33 b(24)2065 1681 y(list-parser,)f(23,)g(26)2065 +1801 y(lr-parse,)g(25)2065 2005 y(meta)g(grammar,)f(4,)h(12)2065 +2208 y(non-terminal,)e(5)2231 2328 y(\\.n")j(notation,)e(8)2065 +2449 y(n)m(ull-grammar,)e(4)2065 2652 y(option)j(list,)f(8)2065 +2856 y(prin)m(t-actions,)h(8)2065 2976 y(prin)m(t-function,)g(12,)g(14) +2065 3179 y(read-parser,)h(17,)g(21)2065 3300 y(regular)f(expression,)i +(9,)e(23)2065 3503 y(seman)m(tic)h(actions,)f(6,)g(7)2065 +3624 y(start-sym)m(b)s(ol,)g(5)2065 3827 y(zebu,)i(28)2065 +3947 y(zebu-compile-\014le,)d(18)2065 4068 y(zebu-compiler,)h(28)2065 +4188 y(zebu-load-\014le,)g(20)2065 4309 y(zebu-mg,)h(12)1871 +5656 y(31)p eop +%%Trailer +end +userdict /end-hook known{end-hook}if +%%EOF Added: vendor/zebu/doc/Zebu_intro.tex ============================================================================== --- (empty file) +++ vendor/zebu/doc/Zebu_intro.tex Wed Oct 17 09:04:46 2007 @@ -0,0 +1,1661 @@ +% -*- mode: LaTeX -*- ------------------------------------------------ % +% File: Zebu_intro.tex +% Description: Introduction to the reversible grammar formalism +% Author: Joachim H. Laubsch +% Created: 27-May-92 +% Modified: Fri Mar 8 11:24:31 1996 (Joachim H. Laubsch) +% Language: LaTeX +% RCS $Header: $ +% +% (c) Copyright 1992, Hewlett-Packard Company +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Revisions: +% RCS $Log: $ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\documentstyle[twoside,12pt]{article} + +\makeindex + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\newcommand{\alt}[0]{$\dot{|}\: $} +\newcommand{\metavar}[1]{\mbox{$\langle\/$#1$\/\rangle$}} +\newcommand{\metavm}[1]{\mbox{\em $\langle\/$#1$\/\rangle$}} + +\topmargin 0in +\textheight 8.5in +\oddsidemargin 0.2in +\evensidemargin 0.2in +\textwidth 6.0in +\parskip 0.2cm +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\begin{document} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\title{{\sf Zebu}: A Tool for Specifying Reversible LALR(1) Parsers \\ +%{\small Revised \today} + } +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\author{Joachim Laubsch (laubsch at hplabs.hp.com)} +\maketitle + +\vspace{3in} +\begin{flushright} +Application Engineering Department\\ +Software Technology Laboratory\\ +Hewlett-Packard Laboratories\\ +1501 Page Mill Road, Bldg. 1U-17\\ +P.O. Box 10490\\ +Palo Alto, Calif. 94304-1126 +\vspace{0.2in} +laubsch at hpl.hp.com\\ +(415) 857-7695 +\end{flushright} +\newpage +\newpage +\tableofcontents\contentsline {paragraph}{Keywords}{1} + +\vspace*{0.5 in} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\bibliographystyle{plain} + +\begin{abstract} +{\sf Zebu}\footnote{``{\bf zebu}{\em n}., {\em pl}. {\bf -bus}, {\bf +-bu}: 1. an oxlike domestic animal ({\em Bos indicus}) native to Asia +and parts of Africa: it has a large hump over the shoulders, short, +curving horns, pendulous ears, and a large dewlap and is resistant to +heat and insect-born diseases.'' [Webster's New World Dictionary.] +A zebu should not be confused with a yacc or a gnu although it bears +similarity to each of them.} is part of a set of tools for the +translation of formal languages. {\sf Zebu} contains a LALR(1) parser +generator like Yacc does. Aside from generating a parser, {\sf Zebu} +will also generate the inverse of a parser (unparser). In contrast to +Yacc, the semantics is not given in terms of ``routines'' but +declaratively in terms of typed feature structures. + +The ability to declaratively define a reversible grammar, together with +a rewrite-rule mechanism ({\sf Zebu-RR}) for transforming abstract syntax +trees constitute the basic tools for specifying translators for formal +languages. + +\paragraph{Keywords} Formal language, LALR-grammar, parsing, translation, +generation, interoperability, LEX, YACC. + +\end{abstract} + +\section{Introduction} +Our goal is to develop an environment for the design, analysis and +manipulation of formal languages, such as programming languages, +markup languages, data interchange formats or knowledge representation +languages (such as the translation to and from KIF) \cite{cs:kif92}. +Being able to design, analyze, and manipulate formal languages is +crucial for achieving software interoperability +\cite{cs:Genesereth92}, automatic code analysis, indexing, and +retrieval for potential reuse. Zebu has been applied to writing +translators for formal languages \cite{ap:refine}. The main idea of +this work is that a module $m$ communicates by sending or receiving +messages in some language $L(m)$, and that for various reasons +different modules use different languages. For communication to be +successful, translators have to be used. {\sf Zebu} provides tools to +define translators at a high level of abstraction\footnote{The +rewrite-rule mechanism (Zebu-RR) is implemented, and will be +described in a future report.}. + + +McCarthy introduced the notion of ``abstract'' and ``concrete'' +syntax. The concrete syntax describes the surface form of a +linguistic expression, while the abstract syntax describes a +(composite) object. E.g. ``1+a'' is the surface string rendered by a +particular concrete syntax for an object described by an abstract +syntax: an addition operation with two operands, the first being the +numeral ``1'', and the second being the variable named ``a''. + +Manipulation of linguistic expressions is much easier to express in +the abstract syntax than in the concrete syntax. + +If we were to design an algorithm for simplifying expressions of some +language --- say ``arithmetic'' --- we would use as the front end the +``arithmetic-parser'' to translate into abstract syntax, then express +the simplification rules in terms of tree transformation rules that +operate on the abstract syntax, and finally add as the back-end the +``arithmetic-unparser''. + +More generally, if we were to design an algorithm for translating +from language A to language B, we would define reversible grammars for +languages A and B, and sets of rewrite rules to transform the abstract +syntax trees from the domain of language A to the domain of language +B. The front end would be the ``A-parser'' and the back-end the +``B-unparser'' + +The work described in this report owes a lot to the pioneering research +at Kestrel \cite{ap:smith85} that resulted in the {\sf +Refine}\footnote{{\sf Refine} is a trademark of Reasoning Systems, +Palo Alto.} program transformation system \cite{refine}. The basic +ideas underlying {\sf Zebu} are already present in {\sf Refine}. {\sf +Zebu} is much more compact than {\sf Refine}\footnote{{\sf Zebu} runs +on a MacIntosh in MacIntosh Common Lisp.}, and the semantics is +expressed in typed feature structures. {\sf Zebu} also offers the +possibility of defining a meta-grammar\index{meta grammar}. {\sf +Zebu} lacks {\sf Refine}'s ability to declaratively specify +transformations using a pattern language.\footnote{{\sf Zebu} can be +obtained via anonymous ftp from ftp.cs.cmu.edu as a compressed tar +file: /user/ai/lang/lisp/code/zebu/zebu-???.tar.gz. It contains +several example grammar definitions.} + +The LALR(1) parsing table generated by {\sf Zebu} follows algorithms +described in \cite{aho:79} or \cite{compiler:88}. The current +implementation was developed from the {\sf Scheme} program developed by +William Wells and is written in {\sf Common Lisp}. + +The next section will explain how a grammar can be defined, and how +semantics can be associated with a grammar rule. Section~\ref{Options} +describes the definition of the semantic domain. With this capability +it is possible to state declaratively what the abstract syntax should +look like. Section~\ref{meta-grammar} describes a simpler grammar +notation that is very close to ordinary BNF\@. Section~\ref{Compiler} +summarizes the functional interface of Zebu and explains how a parser +can be customized. Section~\ref{lex} describes how lexical analysis +can be extended using regular expressions and parameterization. + + +\section{The Representations of Grammars in Files} + +\subsection{Grammar notation} + +We first describe the null-grammar\index{null-grammar}, which is a +powerful but verbose way to specify a grammar. Only a parser and +optionally a domain will be generated but an unparser (printer) will +not. If this is desired, you must use the notation of the +meta-grammar "zebu-mg" which is described in section +~\ref{meta-grammar}. + +Non-terminals\index{non-terminal} are represented by symbols, +terminals (also referred to as keywords) by strings. There are the +following open classes of non-terminals\footnote{The Kleene * +indicates 0 or more occurrences of the preceding constituent}: +\index{Kleene *} + +\begin{tabbing} +mm\=mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm\kill + \> {\tt identifier} \= ::= \metavar{lisp symbol} \\ + \> {\tt number} \> ::= \metavar{integer} \\ + \> {\tt keyword} \> ::= \metavar{string} \\ +where\\ + \>\metavar{integer} \> ::= \metavar{digit}* \\ + \>\metavar{string} \> ::= " \metavar{character}* " +\end{tabbing} + +A \metavar{lisp symbol} may be qualified by a package name, e.g. {\tt +zb:cons-1-3} is a valid identifier. In case packages should be +disallowed during lexical analysis, the variable {\tt +*disallow-packages*} \index{*disallow-packages*} should be bound to +{\em true}. (It defaults to {\em false}). The alphabetic case of a +keyword is not significant if the variable {\tt *case-sensitive*} +is {\em false} (the default) when the grammar is +loaded. \index{*case-sensitive*} + +If alphabetic case of identifiers is to be preserved, {\tt +*preserve-case*} should be set to {\em true}. Other +categories can be defined as regular expressions (see~\ref{lex-cats}). +\index{*preserve-case*} + +\subsubsection{Grammar Rules} + +\paragraph{Grammar Rule Syntax} + +\index{start-symbol} +A grammar file consists of a header (the ``options list'', see section +~\ref{grammar-options}) followed by one or more domain definitions or +grammar rules. The non-terminal defined by the first grammar rule is +also the {\em start-symbol} \/ of the grammar. A parser will accept +exactly the strings that rewrite to the {\em start-symbol}. + +This example shows how a BNF-like rule can be encoded as a {\sf Zebu} +grammar rule (using the null-grammar): + +\begin{itemize} + \item BNF rule example + \begin{quote} + \metavar{A} ::= \metavar{B} $|$ \metavar{C} \metavar{number} + $|$ ``foo'' \metavar{A} $|$ ``c'' $|$ \metavar{the-empty-string} + \end{quote} + + \item {\sf Zebu} null-grammar example: + {\tt \begin{tabbing} +mmmmmmmmm\=mmmmmmmmmmmmmmmmmmmmmmmmmmmmm\=\kill + (defrule \>A \\ + \> := B \>; (1)\\ + \> := (C NUMBER) \>; (2)\\ + \> := ("foo" A) \>; (3)\\ + \> := "c" \>; (4)\\ + \> := () \>; (5)\\ + \>) +\end{tabbing}} +\end{itemize} + + +The rule describes 5 productions, all deriving the non-terminal {\tt +A}. Each of the productions has the left-hand side {\tt A}. The +right-hand side of (1) consists of just one constituent, the +non-terminal {\tt B}. (2) has a right-hand of length 2, and its second +constituent is the non-terminal {\tt NUMBER} (which rewrites to any +integer, real or rational). (3) is a recursive production. (4) +contains just the terminal (or keyword) {\tt "c"}. (5) derives the +empty string. + +None of these productions has a semantic action attached. By default, +the semantic action is the {\tt identity} function if the right-hand +side of the rule consists of a single constituent and the {\tt +identity*} function otherwise. ({\tt identity*} is defined as the +function that returns all its arguments as a list.) + +\paragraph{Grammar Rule Semantic Actions} +\index{semantic actions} + +If we want to attach other than these default semantic actions, we have to +use a {\tt :build} clause after a production. +\index{:build semantic action} + +The build clause has the syntax: + +\begin{tabbing} +mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm\kill + \metavar{build clause} ::= \={\tt :build} (\metavar{lisp function} \metavar{argument list})\\ + \metavar{build clause} ::= \>{\tt :build} \metavar{atomic lisp form}\\ + \metavar{build clause} ::= \>{\tt :build} ({\tt :form} \metavar{lisp form})\\ + \metavar{build clause} ::= \={\tt :build} (\={\tt :type} \= \metavar{struct-type}\\ + \> \>{\tt :map} \> ((\metavar{non-terminal} . \metavar{Slot})*)) +\end{tabbing} + +The first case +\begin{quote} + {\tt :build} (\metavar{lisp function} \metavar{argument list}) +\end{quote} + +is like a function call. It may contain free variable occurrences. +These will be bound to the non-terminal constituents of the same name +occurring in the right-hand side of the production at the time of +applying the semantic action. + +In the second case +\begin{quote} + {\tt :build} \metavar{atomic lisp form} +\end{quote} + +the \metavar{atomic lisp form} must be a function. It will be applied to the +constituents of the right-hand side. This function should have the same +number of arguments as the right-hand side of the corresponding +production has constituents. + +Since it happens often, that only some of the constituents of the +right-hand side are selected, or combined, a few useful semantic +actions have been predefined in {\sf Zebu}.\footnote{These semantic + actions ({\tt cons-1-3 cons-2-3 empty-seq empty-set k-2-1 k-2-2 + k-3-2 k-4-3 identity* seq-cons set-cons}) are described in the + file "zebu-actions.lisp".} + +An example for such a predefined action is the function {\tt cons-2-3} +which takes 3 arguments and returns a {\em cons} of its second and +third argument. + +The third form of the {\tt :build} clause is just a long way to write +the first form, i.e. +\begin{quote} + {\tt :build} (\metavar{lisp function} \metavar{argument list}) +\end{quote} + + is the same as +\begin{quote} + {\tt :build} ({\tt :form} (\metavar{lisp function} \metavar{argument list})) +\end{quote} + +Similarly, + +\begin{quote} + {\tt :build} (progn \metavar{atomic lisp form}) +\end{quote} + + is the same as + +\begin{quote} + {\tt :build} ({\tt :form} \metavar{atomic lisp form}) +\end{quote} + +The last {\tt :build} clause is more interesting: +\begin{tabbing} +mmmmmm\=mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm\kill + \>{\tt :build} (\={\tt :type} \= \metavar{struct-type}\\ + \> \>{\tt :map} \>((\metavar{Nonterminal} . \metavar{Slot})*)) +\end{tabbing} + +where \metavar{struct-type} is a symbol that must be the name of a +structure type\footnote{a type defined by {\tt defstruct} or {\tt +defclass}.}. Instead of having to write the semantic action as a +constructing form, we just have to specify the type and the mapping of +non-terminals to slots, as in the following example\footnote{(taken +from the grammar named ``pc1''; see the file ``pc1.zb'' in the test +directory)}: + +{\tt \begin{tabbing} +mmmmmmmmm\=mmmmmmmmmmmmmmmmmmmmmmmmmmmmm\=\kill +(defrule Boolean-Expr\\ + \> := (Formula.1 "and" Formula.2)\\ + \> :build (\=:type Boolean-And \\ + \> \>:map (\=(Formula.1 . :-rand1) \\ + \> \> \>(Formula.2 . :-rand2))) \\ +\\ + \> := (Formula.1 "or" Formula.2) \\ + \> :build (:type Boolean-Or \\ + \> \>:map ((Formula.1 . :-rand1) \\ + \> \> \>(Formula.2 . :-rand2))) \\ + \>) + \end{tabbing}} + +The map indicates that the slot {\tt -rand1} is to be filled by the +value of the non-terminal {\tt Formula.1}, etc. + +This example also makes use of the {\tt ".n"} notation: If on the +right-hand side of a production a nonterminal occurs repeatedly, we +distinguish it by appending {\tt "."} and a digit, to the +nonterminal (e.g.\ {\tt Formula.1}). +\index{non-terminal ``.n'' notation} + +The function {\tt print-actions} \index{print-actions} applied to the +name of a grammar may be used to find out what the generated code for +the semantic actions looks like, e.g.\ after compiling the sample +grammar {\tt ``pc1.zb''}: + +{\tt \begin{verbatim} +(print-actions "pc1") + +... +Rule: BOOLEAN-EXPR +(LAMBDA (FORMULA.1 DUMMY FORMULA.2) + (DECLARE (IGNORE DUMMY)) + (MAKE-BOOLEAN-AND :-RAND1 FORMULA.1 :-RAND2 FORMULA.2)) +(LAMBDA (FORMULA.1 DUMMY FORMULA.2) + (DECLARE (IGNORE DUMMY)) + (MAKE-BOOLEAN-OR :-RAND1 FORMULA.1 :-RAND2 FORMULA.2)) +... +\end{verbatim}} + +These semantic actions have been generated from the {\tt :build} +clauses of the above rule for {\tt Boolean-Expr}. + +\section {Grammar Options} \label{Options} +\index{grammar options} \index{option list} + +\subsection{Keyword Arguments to Grammar Construction} +\label{grammar-options} + +Some global information to control grammar compilation, lexical +analysis, and the generation of semantic actions is declared in the +beginning of a grammar file\footnote{A grammar file has the default +type ".zb".}. A grammar file must begin with a list of alternating +keywords and arguments. The following keywords are valid: + +\index{grammar name} \index{:name} \index{:package} +\index{:identifier-start-chars} \index{:identifier-continue-chars} +\index{:string-delimiter} \index{:symbol-delimiter} \index{:domain} +\index{:domain-file} \index{:grammar} \index{:lex-cats} + +{% table of option keywords +\def\name {a string, the name of the grammar to be defined.} + +\def\package {a string, the name of the package where the + non-terminal symbols and the function symbols used in semantic + actions reside.} + +\def\identifierStartChars {a string. {During lexical analysis any +character in this string can start an {\tt identifier} non-terminal. +The default is {\tt *identifier-start-chars*}.} } + +\def\identifierContinueChars {a string. During lexical analysis + any character in this string can continue an {\tt identifier} + (i.e. characters not in this string terminate {\tt identifier}). The + default is {\tt *identifier-continue-chars*}. } + +\index{:intern-identifier} + +\def\intern-identifier {{\em true}, if the identifier is to be + returned as an interned Lisp symbol, or {\em false} if the + identifier is to be returned as a string (default {\em true}).} + +\def\stringDelimiter {a character, the character that delimits a + string to be represented as a {\sf Common Lisp} string. } + +\def\symbolDelimiter {a character, the character that delimits a + string to be represented as a {\sf Common Lisp} symbol.} + +\def\domain {a list, representing the type hierarchy of the domain. + See section~\ref{domain} below. } + +\def\domainFile {a string naming the file where the generated Common + Lisp program that implements the domain will be stored. Definitions + of functions for semantic actions and regular expression for lexical + categories are kept here as well. This string defaults to the + concatenation of the grammar's :name and ``-domain''. } + +\def\grammar {a string, by default: {\tt "null-grammar"}, naming the +grammar to be used to parse the grammar defined in this file. If the +grammar {\tt "zebu-mg"} is used, an unparser will also be generated. } + +\def\lexCats {an association list of terminal category names and + regular expressions (see section~\ref{lex-cats}). } + +\def\whiteSpace {a list of characters each of which will be ignored + before a token, } + +\def\caseSensitive {{\em true} if the case of keywords is significant, + {\em false} otherwise (default \em{false}). } + +\begin{tabular}{lp{10cm}} % \hline +{\tt \small :name} & \name \\ +{\tt \small :package} & \package \\ +{\tt \small :identifier-start-chars} & \identifierStartChars \\ +{\tt \small :identifier-continue-chars} & \identifierContinueChars \\ +{\tt \small :intern-identifier} & \intern-identifier \\ +{\tt \small :string-delimiter} & \stringDelimiter (default \verb+#\"+) \\ +{\tt \small :symbol-delimiter} & \symbolDelimiter (default \verb+#\'+) \\ +{\tt \small :domain} & \domain \\ +{\tt \small :domain-file} & \domainFile \\ +{\tt \small :grammar} & \grammar \\ +{\tt \small :lex-cats} & \lexCats \\ +{\tt \small :white-space} & \whiteSpace (default \verb+(#\Space #\Newline + #\Tab)+) \\ +{\tt \small :case-sensitive} & \caseSensitive +\end{tabular}} + +\index{regular expression} \index{:white-space} \index{:case-sensitive} + +\subsection{Defining a Domain} \label{domain} \index{domain, defining} + +The {\tt :domain} keyword is used to specify a type hierarchy. This +specification will expand into {\tt defstruct} forms that implement +this hierarchy. It is also possible to write such structure +definitions directly into the grammar file. The argument to the {\tt +:domain} keyword argument must be a list of the following form: + +\begin{tabbing} +mm\=\=mmmmmmmmmmmmmmmmmmm\kill + \>(\metavar{Root Struct} \\ + \>\>{\tt :subtype} \metavar{Struct Desc} \\ + \>\>{\tt :subtype} \metavar{Struct Desc} \\ + \>\> ...) \\ +\\ + \>\metavar{Root Struct} ::= \metavar{Symbol} \\ +\\ +mm\=mmmmmmmmmmmmmmmmmmm\kill + \>\metavar{Struct Desc} ::= \= \metavar{Symbol} $|$ \\ + \> \>( \metavar{Symbol} {\tt :slots} (\metavar{Slot}*) ) $|$ \\ + \> \>( \metavar{Symbol} \= {\tt :slots} (\metavar{Slot}*) \\ + \> \> \> {\tt :subtype} \metavar{Struct Desc} \\ + \> \> \> {\tt :subtype} \metavar{Struct Desc} \\ + \> \> ... )\\ +\\ + \> \metavar{Slot} ::= \metavar{Symbol} $|$ ( \metavar{Slot Name} +\metavar{Filler Type} ) \\ + \> \metavar{Filler Type} ::= \metavar{Symbol naming type} +\end{tabbing} + +This describes the syntax for declaring a type hierarchy with root +node \metavar{Root Struct}. A node of the hierarchy tree can have +children, denoted by {\tt :subtype} followed by the structure +description of the child node. Each node can have slots, described as +a list following {\tt :slots}. A child node inherits the slots of its +parent node. The value of a slot can be type-restricted to +\metavar{Filler Type}. + +\metavar{Root Struct} will be implemented as a structure type directly +below the predefined structure type {\tt kb-domain}, i.e.\ ({\tt +kb-domain-p} x) is {\em true} for any instance of a subtype of +\metavar{Root Struct}. kb-domain is the top of the domain +hierarchy. \index{kb-domain} \index{kb-domain-p} \index{domain, top type} + +The type {\tt kb-sequence} is already predefined as a subtype of +kb-domain. It has the slots {\tt first} and {\tt rest}. +\index{kb-sequence} + +Similarly, types {\tt number}, {\tt string}, and {\tt identifier} are +predefined as subtypes of kb-domain. + +Two objects of type kb-domain can be compared for equality with the +functions {\tt kb-equal} and {\tt kb-compare}. \index{kb-equal} +\index{kb-compare} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmm\=\kill +{\tt kb-equal} {\em a} {\em b} \>\>\>{\em function} +\end{tabbing} + +{\em a} and {\em b} are assumed to be of type kb-domain. If they are +{\tt equal} they are also {\tt kb-equal}. But in contrast to {\tt + equal} it is possible to define which slots are to be examined by +{\tt kb-equal} when comparing the components of {\em a} and {\em b}. +These relevant slots are called {\em tree attributes}, and the macro +{\tt def-tree-attributes} is used to define these for a particular +type. The rationale for having this equality relation is that it is +often useful to store comments or auxiliary information with the +feature structures produced by parsing. + +In feature structures the value of a relevant feature (or slot) may be +declared to be a set (using {\tt def-tree-attributes}). If a slot has +been declared set-valued, the {\tt kb-equal} comparison will use set +equality for values of that slot (represented as lists). + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt def-tree-attributes} {\em type} {\em slot1} {\em slot2} .. \>\>\>{\em macro} +\end{tabbing} +\index{def-tree-attributes} + +{\tt def-tree-attributes} defines {\em slot1} {\em slot2} \ldots as +tree attributes for instances of type {\em type}. + +If {\em slot} is a symbol, this symbol is defined as a tree attribute. +Otherwise {\em slot} must be of the form ({\em symbol} :set). As +before, the {\em symbol} becomes a tree-attribute, and furthermore it +is declared set-valued. + +\paragraph{Example domain definition} +\label{pc1} +The grammar defined in ``pc1.zb'' accepts a simple propositional +calculus language with sentences such as +\begin{quote} + {\tt walks(agent: John)}, +\end{quote} +which yields the following abstract syntax (printed out using the +{\sf Common Lisp} structure printer): + +{\samepage \tt \begin{tabbing} +mm\=mmmmm\kill + \>\#S(ATOMIC-WFF \=-PREDICATE WALKS \\ + \> \>-ROLE-ARGUMENT-PAIRS \#S(\=ROLE-ARGUMENT-PAIR\\ + \> \> \>-ROLE AGENT\\ + \> \> \>-ARGUMENT JOHN) ) + \end{tabbing} +} + +The types --- such as {\tt ATOMIC-WFF} and {\tt ROLE-ARGUMENT-PAIR} +--- are defined by the following domain declaration: + +{\tt \begin{tabbing} +mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm\kill + :domain (\=PC ;; PC is the root type of the hierarchy\\ + \>:subtype (\=Formula \\ + \> \>:subtype (Propositional-variable :slots (-name)) \\ + \> \>:subtype \=(Boolean-Expr \\ + \> \> \> :slots (\=(-rand1 Formula) \\ + \> \> \> \>(-rand2 Formula)) \\ + \> \> \>:subtype Boolean-Or \\ + \> \> \>:subtype Boolean-And)) \\ + \>:subtype (Boolean-Op :slots (-name)) \\ +mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm\kill + \>:subtype (\=Atomic-Wff \\ + \> \>:slots (\=-predicate\\ + \> \> \>(-Role-Argument-Pairs KB-Sequence))) \\ + \>:subtype (Role-Argument-Pair :slots (-Role -Argument)) \\ + \>) +\end{tabbing}} + +Note the use of the predefined type KB-Sequence. It is used to +construct the list of Role-Argument-Pairs in the following rule: + +{\tt \begin{verbatim} +(defrule Role-Argument-Pairs + := () + + := (Role-Argument-Pair Role-Argument-Pairs) + :build (:type KB-Sequence + :map ((Role-Argument-Pair . :first) + (Role-Argument-Pairs . :rest))) + ) + \end{verbatim}} + +\section{The {\sf Zebu} Meta Grammar\index{meta grammar}} +\label{meta-grammar} + +Using "zebu-mg" as the {\tt :grammar} argument in the grammar +options indicates that the following grammar is to be +preprocessed with the grammar ``zebu-mg'' before compilation. +\index{zebu-mg} + +The advantages of the meta-grammar (versus the default null-grammar) +are a more concise representation of rules, automatic generation of +the functions that implement the semantic actions and reversibility of +the grammar (generation of printing functions -- the unparser). + +The disadvantage of using "zebu-mg" is that the semantics is limited +to constructing typed feature structures. \index{feature structures} +But these have great expressive power, and furthermore could +subsequently be transformed into some other program. Typed feature +structures are ideally suited to present abstract syntax. The fact +that unification, specialization and generalization are well defined +operations on feature structures, makes them appropriate for further +transformations (by e.g.\ {\sf Zebu-RR}). For an introduction into feature +structures see \cite{johnson:88}. + +Since there is a restricted way of expressing the semantics of a rule +-- namely as a typed feature structure -- the grammar compiler will be +able to generate code for the domain hierarchy and print-functions +associated with each type of that domain. +\index{print-function} + +"zebu-mg" is defined in terms of the null-grammar described +above\footnote{You may study the definition of the meta grammar in +terms of the null-grammar in the file "zebu-mg.zb".}. + +\paragraph {BNF description of ``zebu-mg'':} +{\samepage \begin{tabbing} +mmm\=mmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmmm\kill + \>\metavar{Zebu-Grammar}\> ::= \= \metavar{Options} \metavar{Domain-Defn}* \metavar{zb-rule} \\ + \>\metavar{Domain-Defn} \> ::= \= \metavar{Type-name} \verb+":="+ +\metavar{Feat-Term} \\ + \> \> \>[ \verb+"<<"+ "print-function:" Identifier \verb+">>"+ ] {\tt ";"}\\ + \>\metavar{zb-rule} \> ::= \metavar{Non-terminal} \verb+"-->"+ +\metavar{Rhs} {\tt ";"}\\ + \>\metavar{Rhs} \> ::= \metavar{Rhs1} \metavar{More-Rhs} $|$ \metavar{Kleene-Rhs}\\ + \>\metavar{Rhs1} \> ::= \metavar{Constituent}* [ {\tt "\{"} +\metavar{Semantics} {\tt "\}"} ]\\ + \>\metavar{Constituent} \> ::= \metavar{Identifier} $|$ \metavar{String}\\ + \>\metavar{More-Rhs} \> ::= $|$ \metavar{Rhs1} \metavar{More-Rhs}\\ + \>\metavar{Semantics} \> ::= \metavar{Feat-Term}\\ +\end{tabbing}} + + +A \metavar{Feat-Term} is a typed attribute value matrix. +\begin{tabbing} +mmm\=mmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmmm\kill + \>\metavar{Feat-Term} \> ::= [\metavar{Type-name} ":"] \metavar{Conj}\\ + \>\metavar{Conj} \> ::= {\tt "["} \metavar{Label-value-pair} * {\tt "]"}\\ + \>\metavar{Label-value-pair} \> ::= {\tt "("} \metavar{Identifier} +\metavar{Feat-Term} {\tt ")"} \\ + \>\metavar{Type-name} \> ::= \metavar{Identifier} +\end{tabbing} + +\metavar{Options} is described in section~\ref{Options}. + +This BNF-notation makes use of +\begin{enumerate} + \item star (*) for 0 or more repetitions of the preceding constituent + \item bar ($|$) for alternation + \item brackets ([]) for marking the enclosed constituents as optional + \item a quotation symbol (") for delimiting keywords +\end{enumerate} + +The above definition is somewhat oversimplified, since it does not +deal with the ".n" notation for \metavar{Constituent}: if on the +right-hand side of a production a non-terminal occurs repeatedly, we +can distinguish the occurrences by appending "." and a digit to the +identifier. The semantics can then unambiguously refer to an +occurrence of a constituent. + +The semantics is described as a typed feature structure. Names of +variables occurring in feature term position correspond to constituent +names in the right-hand side of the rule. The effect of applying a +rule is to instantiate a feature structure of the type described in +the rule semantics, substituting variables with their values. + +If the relation between semantics and syntax is one-to-one, the +inverse of a parser, a printer, can be generated. + +\subsection {Domain Definition} \index{domain, defining} + +Although it is possible to specify the hierarchy of domain types using +the {\tt :domain} keyword as in section~\ref{domain}, a more +convenient syntax is offered by the meta above grammar rule +\metavar{Domain-Defn}. + +The type definition +\begin{quote} +{\it atype} := {\it super}: [({\it $s_1$}) ... ({\it $s_n$})]; +\end{quote} +will define the type {\it atype} inheriting from {\it super}, and +having slots {\it $s_1$} through {\it $s_n$}. + +\begin{quote} +{\it atype} := [({\it $s_1$}) ... ({\it $s_n$})]; +\end{quote} +is as above but defines the type {\it atype} as a subtype of the +top type named {\tt kb-domain}. + +A slot may be type restricted as in: +\begin{quote} +{\it atype} := {\it super}: [({\it $s_1$} {\tt KB-sequence})]; +\end{quote} +which restricts {\it $s_1$} to be of type {\tt KB-sequence}. An +optional {\it print-function} may be specified, as in +\index{print-function} + +\begin{quote} +{\it atype} := {\it super}: [({\it $s_1$})] + \verb+<<+ {\tt print-function:} {\it print-atype} \verb+>>+; +\end{quote} +Here we supply for {\it atype} its own printer called {\it +print-atype} and no printer will be generated for {\it atype}. +Usually it is not necessary to provide a print-function, but if the +grammar is ambiguous, this is a way to force a particular canonical +unparser. + +\subsection {Example Grammars} + +\paragraph {Example Grammar for Arithmetic Expressions} + +{\tt \begin{verbatim} +(:name "arith-exp" :grammar "zebu-mg") + +;; Domain definition + +Arith-exp := Kb-domain: []; +Factor := Arith-exp: [(-value)] <>; +Mult-op := Arith-exp: [(-arg1) (-arg2)]; +Plus-op := Arith-exp: [(-arg1) (-arg2)]; + +;; Productions + +EE --> EE "+" TT { Plus-op: [(-arg1 EE) (-arg2 TT)] } + | TT ; + +TT --> TT "*" F { Mult-op: [(-arg1 TT) (-arg2 F)] } + | F ; + +F --> "(" EE ")" { factor: [(-value EE)] } + | IDENTIFIER { factor: [(-value IDENTIFIER)] } + | NUMBER { factor: [(-value NUMBER)] } ; + +\end{verbatim}} + +The semantics of the first rule says that an object of type {\tt +-op} +should be created with slot {\tt -arg1} filled with the value of {\tt +EE} and {\tt -arg2} filled with the value of {\tt TT}. + +\paragraph {Example Grammar for Propositional Calculus} + +This grammar defines the same domain as above (\ref{pc1}). Compiling +it generates a parser and a generator. + +{\tt \begin{verbatim} + +(:name "pc2" + :package "CL-USER" + :grammar "zebu-mg") + +;; Domain definition + +Formula := kb-domain: []; + + Propositional-variable := Formula: [(-name) ]; + P-Formula := Formula: [(-content) ]; + Boolean-Expr := Formula: [(-rand1 Formula) (-rand2 Formula)]; + Boolean-Or := Boolean-Expr: []; + Boolean-And := Boolean-Expr: []; + Atomic-Wff := Formula: [(-predicate) + (-Role-Argument-Pairs kb-sequence)]; + +Role-Argument-Pair := kb-domain: [(-Role) (-Argument)]; + +;; Productions + +Formula --> Propositional-variable + | Boolean-Expr + | "(" Formula ")" {P-Formula:[(-content Formula)]} + | Atomic-Wff; + +Propositional-Variable + --> Identifier {Propositional-variable: [(-name Identifier)]}; + +Boolean-Expr --> Formula.1 "and" Formula.2 + {Boolean-And: [(-rand1 Formula.1) + (-rand2 Formula.2)]} + + | Formula.1 "or" Formula.2 + {Boolean-Or: [(-rand1 Formula.1) + (-rand2 Formula.2)]}; + +Atomic-Wff --> Identifier "(" Role-Argument-Pairs ")" + { Atomic-Wff: + [(-predicate Identifier) + (-Role-Argument-Pairs Role-Argument-Pairs)]}; + +Role-Argument-Pairs --> + | Role-Argument-Pair Role-Argument-Pairs + { RAP-list: [(-first Role-Argument-Pair) + (-rest Role-Argument-Pairs)]}; + +Role-Argument-Pair --> + Identifier ":" Term + {Role-Argument-Pair: [(-Role Identifier) + (-Argument Term)]}; + +Term --> Identifier | Number ; + \end{verbatim} +} + +\subsection {The Kleene * Notation} \index{Kleene *} + +The meta-grammar ``zebu-mg'' provides an abbreviated notation for +repeated occurrences of a non-terminal, separated by a keyword. The +syntax for this is: + +\begin{tabbing} +mmmm\=mmmmmmmmm\=mmmmmmmmmmmmmmmmmmmmmmmmmmm\=\kill + \>\metavar{Kleene-Rhs} \> ::= \metavar{Identifier} {\tt *} \metavar{String} \>(1)\\ + \>\metavar{Kleene-Rhs} \> ::= \metavar{Identifier} {\tt +} \metavar{String} \>(2)\\ +\end{tabbing} + +The meaning of (1) is that 0 or more occurrences of the constituent +named by \metavar{Identifier} and separated by \metavar{String} will +be accepted by this rule, and that the sequence of the results of +these constituents will be returned as the semantics of +\metavar{Kleene-Rhs}. The meaning of (2) is the same, except that at +least one occurrence of the constituent has to be found. + +The semantics of a \metavar{Kleene-Rhs} production is an implicit +kb-sequence construction. The Kleene-constituent (\metavar{Identifier} +concatenated with {\tt *} or {\tt +}) is bound in the semantics of +the production, e.g. + +{\tt \begin{verbatim} +Disjunction --> Conjunction+ "|" + {Disj: [(-terms Conjunction+)]}; + \end{verbatim} +} + +builds a structure of type {\tt Disj} with the {\tt -terms} slot +filled by the value of the Kleene-constituent {\tt Conjunction+}. + +\paragraph {Example grammar using Kleene * Notation} \index{Kleene *} + +{\tt \begin{verbatim} + +(:name "mini-la" :grammar "zebu-mg" ) + +;; Domain definition + +Program := [(-stmts kb-sequence)]; +Application := [(-function) (-args kb-sequence)]; + +;; rules + +Program --> "begin" Stmt+ ";" "end" + { Program: [(-stmts Stmt+)] } ; + +Stmt --> Identifier | Appl | Program ; + +Appl --> Identifier "(" Arg* " " ")" + {Application: [(-function Identifier) (-args Arg*)]}; + +Arg --> Identifier | Number | Appl ; + \end{verbatim} +} + +Compiling this grammar generates a parser/unparser (i.e.\ the printing +routines are generated automatically). + +\index{read-parser} +{\tt \begin{verbatim} +(zb:read-parser "begin A; B ; C end" + :grammar (zb:find-grammar "mini-la")) + \end{verbatim} +} + +returns a structure of type {\tt PROGRAM} which is printed in the +syntax of ``mini-la'': + +{\tt \begin{verbatim} +begin A;B;C end +> (describe *) +begin A;B;C end is a structure of type PROGRAM. +It has 1 slot, with the following values: + -STMTS: A;B;C + +(describe (PROGRAM--STMTS *)) +A;B;C is a structure of type KB-SEQUENCE. +It has 2 slots, with the following values: + FIRST: A + REST: B C + \end{verbatim} +} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Using the Compiler} \label{Compiler} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\subsection{Compiling a grammar} + +The {\sf Zebu}-compiler\footnote{For installation see appendix +\ref{installation}.} can be called using any of the functions: {\tt +zebu-compile-file}, {\tt compile-slr-grammar}, {\tt +compile-lalr1-grammar}. + +\index{zebu-compile-file} +\index{*warn-conflicts*} \index{*allow-conflicts*} +\index{*check-actions*} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt zebu-compile-file} \>\>\>{\em function} \\ + \>{\em grammar-file} {\tt \&key} {\em output-file} {\em grammar} {\em verbose} +\end{tabbing} + +This compiles the LALR(1) grammar in a file named {\em grammar-file}. +The {\em output-file} defaults to a file with the same name as {\em +grammar-file} but type "{\tt tab}". The grammar used for compilation +defaults to the null-grammar. If {\em verbose} is {\em true}, conflict +warnings will be printed. {\tt zebu-compile-file} returns the +pathname of {\em output-file}. + +\paragraph {Example:} +{\tt \begin{verbatim} + (let ((*warn-conflicts* t) + (*allow-conflicts* t)) + (zebu-compile-file "dangelse.zb" + :output-file "/tmp/dangelse.tab")) + + ; Zebu Compiling (Version 2.0) + ; "~/zebu/test/dangelse.zb" to "/tmp/dangelse.tab" + + Reading grammar from dangelse.zb + + Start symbols is: S + + 4 productions, 8 symbols + .........9 item sets + ......... + ......... + ;;; Warning: ACTION CONFLICT!!!-- state: 8 + ;;; old entry: (6 :S 2) new entry: (6 :R 2) + ;;; + ;;; Warning: Continuing to build tables despite conflicts... + ;;; Will prefer old entry: (6 :S 2) + + Dumping parse tables to /tmp/dangelse.tab + #P"/tmp/dangelse.tab" +\end{verbatim}} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt *warn-conflicts*} \>\>\>{\em variable} +\end{tabbing} + +If {\em true} during LALR-table construction, shift-reduce conflicts +will be reported. By default, {\tt *warn-conflicts*} is {\em false}. + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt *allow-conflicts*} \>\>\>{\em variable} +\end{tabbing} + +If {\em true} during LALR-table construction, shift-reduce conflicts will be +resolved in favor of the old entry. By default, {\tt *allow-conflicts*} +is {\em true}. + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt *check-actions*} \>\>\>{\em variable} +\end{tabbing} + +If {\em true} the semantic action associated with a production will be +compiled at grammar compilation time in order to display possible +warning messages. By default, {\tt *check-actions*} is {\em false}. + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt compile-slr-grammar} {\em grammar-file} {\tt \&key} {\em output-file} {\em grammar} \>\>\>{\em function} +\end{tabbing} +\index{compile-slr-grammar} + +This is like {\tt zebu-compile-file}, but an SLR-table will be made. + +Example: +{\tt \begin{verbatim} + (compile-slr-grammar "dangelse.zb" + :output-file "/tmp/dangelse.tab") + + Reading grammar from dangelse.zb + + Start symbols is: S + + 4 productions, 8 symbols + .........9 item sets + + Dumping parse tables to /tmp/dangelse.tab + #P"/tmp/dangelse.tab" + \end{verbatim}} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt compile-lalr1-grammar} {\em grammar-file} {\tt \&key} {\em output-file} {\em grammar} \>\>\>{\em function} +\end{tabbing} +\index{compile-lalr1-grammar} + +This is like {\tt zebu-compile-file}, but does not expand logical pathnames. + +Example: + +{\tt \begin{verbatim} + (compile-lalr1-grammar "dangelse.zb" + :output-file "/tmp/dangelse.tab") + + Reading grammar from dangelse.zb + + Start symbols is: S + + 4 productions, 8 symbols + .........9 item sets + ......... + ......... + Dumping parse tables to /tmp/dangelse.tab + #P"/tmp/dangelse.tab" +\end{verbatim}} + +\subsection{Loading a grammar} +\index{zebu-load-file} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt zebu-load-file} {\em filename} {\tt \&key} {\em verbose} \>\>\>{\em function} +\end{tabbing} + +{\em filename} should be the name of a compiled grammar file, i.e.\ a +file of type "{\tt tab}". If such a file can be found, it will be +loaded, returning the grammar object needed for parsing. In case a +domain-file was generated by compiling the grammar, it will also be +loaded. The type of the domain-file is the first for which a file +named {\em filename}{\tt -domain}.\metavar{type} exists, by examining +the lists +\begin{quote} +{\tt *load-binary-pathname-types*} and\\ +{\tt *load-source-pathname-types*} +\end{quote} +for .\metavar{type} in turn. + + The keyword argument {\em verbose} defaults to {\em true}. + +\paragraph {Example:} +{\tt \begin{verbatim} + (zebu-load-file "/tmp/dangelse.tab") + +\end{verbatim}} + +It is possible to have many grammars loaded concurrently. Given the name +of a grammar, one can find a grammar that has been loaded by: +\index{find-grammar} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt find-grammar} {\em name} \>\>\>{\em function} +\end{tabbing} + + +{\em name} must be a string. If a grammar of the same name (ignoring +case) has been loaded, the grammar object is returned, else {\em +false} is returned. + +\paragraph {Example:} +{\tt \begin{verbatim} + (find-grammar "dangelse") + + \end{verbatim}} + +\subsection{Parsing a string with a grammar} +\index{read-parser} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt read-parser} \>\>\>{\em function} \\ + \> {\em string} {\tt \&key} {\em grammar} {\em junk-allowed} {\em +print-parse-errors} {\em error-fn} {\em start} +\end{tabbing} + +The argument of the {\tt :grammar} keyword defaults to {\tt +*current-grammar*} (initially bound to the null-grammar), +e.g. + +\begin{tabbing} +mm\=mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm\kill +\> {\tt (read-parser \metavm{string} :grammar (find-grammar \metavm{name}))} \\ +\\ +\> is equivalent to\\ +\\ +\> {\tt (setq zebu:*current-grammar* (find-grammar \metavm{name}))} \\ +\> {\tt (read-parser \metavm{string})} +\end{tabbing} + + +{\tt read-parser} parses the string starting at the position indicated +by {\tt :start} (default 0). + +{\tt read-parser} takes the keyword argument {\tt :junk-allowed}, +which if {\em true} will return as second value an index to the +unparsed remainder of the string in case not the entire string was +consumed by the parse. + +The keyword {\tt :junk-allowed} has the same meaning as in the {\sf +Common Lisp} function {\tt read-from-string}. + +{\tt :print-parse-errors} controls the printing of errors during +parsing and defaults to {\em true}. + +{\tt :error-fn} is a function used to report errors, it defaults to +the {\sf Common Lisp} {\tt error} function. + +\paragraph{Example:} + +\begin{verbatim} + (read-parser "if f then if g then h else i" + :grammar (find-grammar "dangelse")) + ("if" F "then" ("if" G "then" H "else" I)) + + (read-parser "1 + a" :grammar (find-grammar "ex1")) + (+OP (EXPRESSION (TERM (FACTOR 1))) + (TERM (FACTOR A))) +\end{verbatim} + +\subsection{Parsing from a file with a grammar} +{\samepage +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt file-parser} {\em file} {\tt \&key} {\em grammar} {\em print-parse-errors} {\em verbose} \>\>\>{\em function} +\end{tabbing} +\index{file-parser} + +{\tt file-parser} parses expressions using the +grammar specified by {\tt :grammar}, reading from {\em file}. It +returns a list of the parse-results, i.e.\ a list of what would have +been returned by {\tt read-parser}. } + +The {\tt :grammar} argument defaults to {\tt *current-grammar*} -- which +initially is bound to the ``null-grammar''. + +\index{:print-parse-errors} +{\tt :print-parse-errors} controls the printing of errors during parsing and +defaults to {\em true}. + +{\tt :verbose} controls whether printing of parse-results occurs, and +defaults to {\em true}. + +The processing of comments by {\tt file-parser} can be influenced by +the following variables: +\index{*comment-brackets*} \index{*comment-start*} + +\begin{itemize} + \item {\tt *comment-brackets*} is a list of bracket pairs. + Everything between any of bracket pairs is ignored. + Initially {\tt *comment-brackets*} is set to: + + \verb+(("#\|" . "|#"))+. + + \item {\tt *comment-start*} A line beginning with this + character is ignored. Initially {\tt *comment-start*} is set to + the semicolon character: \verb+#\;+ +\end{itemize} + +\paragraph{Example:} + +{\tt \begin{verbatim} + (file-parser "sample-ex1" :grammar (find-grammar "ex1")) + ... +\end{verbatim}} + + +\subsection{Parsing from a list of tokens} +\index{list-parser} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt list-parser} {\em token-list} {\tt \&key} {\em grammar} {\em junk-allowed} \>\>\>{\em function} +\end{tabbing} + +{\tt list-parser} is like {\tt read-parser} except that the tokens +that are passed by the scanner to the driver are already given as the +elements of {\em token-list}. This function is useful if the options for +controlling lexical analysis given in section~\ref{grammar-options} +are insufficient. + +\paragraph {Example:} +{\tt \begin{verbatim} + (let ((*current-grammar* (find-grammar "ex1"))) + (list-parser '(1 "+" x "*" y))) + (+OP (EXPRESSION (TERM (FACTOR 1))) + (*-OP (TERM (FACTOR X)) (FACTOR Y))) + \end{verbatim}} + +\subsection{Debugging a grammar} +\index{debug-parser} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt debug-parser} {\tt \&key} {\em grammar} {\em lexer} \>\>\>{\em function} +\end{tabbing} +{\tt debug-parser} will cause a trace of +the parser to be displayed. The {\em + grammar} keyword defaults to {\em true} +and {\em lexer} defaults to {\em false}. +If {\em lexer} is {\em true}, more information about lexical analysis +(see section \ref{lex} below) will be displayed. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section {Lexical Analysis} \label{lex} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Customization and Regular Expressions} +\index{regular expression} + +It should only seldomly be necessary to write a lexical analyzer. +Before you attempt to introduce your own lexical categories, check +whether the following variables and keywords would suffice to +parameterize lexical analysis: + +{\tt \begin{tabbing} +mmmm\=mmmmmmmmmmmmmmmmmmmmmmmmmm\kill + \>*comment-start*\\ + \>*comment-brackets*\\ + \>*disallow-packages*\\ + \>*preserve-case*\\ + \>*case-sensitive*\\ + \>:case-sensitive\\ + \>:identifier-start-chars\\ + \>:identifier-continue-chars\\ + \>:string-delimiter\\ + \>:symbol-delimiter\\ + \>:white-space \\ + \>:lex-cats \\ +\end{tabbing} +} +\index{*comment-start*} +\index{*comment-brackets*} +\index{*disallow-packages*} +\index{*preserve-case*} +\index{*case-sensitive*} +\index{:case-sensitive} +\index{:identifier-start-chars} +\index{:identifier-continue-chars} +\index{:string-delimiter} +\index{:symbol-delimiter} +\index{:white-space} +\index{:lex-cats} + +The lexical analyzer works in a top-down one token look-ahead way. It +tries only to recognize tokens that would be legal continuations of +the string parsed so far. In case lexical categories overlap this +will serve to disambiguate tokenization. + + +\subsection{Introducing new Categories by Regular Expressions} +\label{lex-cats} \index{lexical category} + +The keyword {\tt :lex-cats} takes as argument an association list of +the form: +{\tt \begin{tabbing} +mmmm\=mmmmmmmmmmmmmmmmmmmmmmmmmm\kill + \>((\metavar{Category} \metavar{Regular Expression}) *) + \end{tabbing} +} + +\metavar{Category} is a symbol naming a lexical category and +\metavar{Regular Expression} is a string representing a regular +expression as defined in the GNU Emacs Lisp Manual \cite{cs:GNULisp}. +The regular expression will be compiled into a Common Lisp function +and invoked by {\tt read-parser} before the built-in categories +(Identifier, String, Number) are examined. The categories can be used +in grammar rules like any of the built-in categories. + +The regular expression compiler\footnote{Thanks to Lawrence E. Freil +who wrote the main part of the Regular Expression Compiler.} handles the +following constructs: + +\begin{description} + +\item[.] Period matches any single character except a newline. +\item[*] repeats preceding regular expression as many times as possible. +\item[+] like * but must match at least once. +\item[?] like * but must match once or not at all. +\item[{[\ldots]}] '[' begins a character set, which is terminated by ']'.\\ + Character ranges can be indicated, e.g.\ a-z, 0-9. +\item[{[ $\hat{}$ \ldots]}] forms the complement character set. +\item[\$] matches only at the end of a line. +\item[$\backslash$(\ldots $\backslash$)] is a grouping construct. +\item[$\backslash$ \metavar{digit}] means: accept the same string as was matched + by the group in position \metavar{digit}. +\end{description} + +\paragraph {Example:} + +{\tt \begin{verbatim} + :lex-cats ((BibTeX-in-braces "{[^\\n}]*}")) + \end{verbatim}} + +defines a new category {\tt BibTeX-in-braces} which matches anything +starting with ``\{'', ending in ``\}'', and not containing either a +newline or ``\}''. + + +{\tt \begin{verbatim} + :lex-cats + ((Ratio_Number "-?[0-9]+/[0-9]+") + (Simple_Float "-?[0-9]*\\.[0-9]+")) + \end{verbatim}} + +defines the syntax for rationals and floating point numbers. Note +that the period needs to be escaped, since it is a special character of +the regular expression language. + +\subsection{The functional interface to the parsing engine} + +In case the above parameterization facilities for lexical analysis are +insufficient or you want to use an existing lexical analyzer, you need +to understand the functional interface to the parsing engine as +implemented by the {\tt lr-parse}. +\index{lr-parse} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt lr-parse} \>\>\>{\em function} \\ +mm\=mmmmmmmmmmmmmm\kill + \> {\em next-sym-fn} {\em error-fn} {\em grammar} {\tt \&optional} +{\em junk-allowed} {\em last-pos-fn} +\end{tabbing} + +{\tt lr-parse} returns the result of parsing the token stream produced +by {\em next-sym-fn} with {\em grammar} by the LALR(1) method. In case +{\em junk-allowed}\/ is {\em true}\/ it produces as second value a handle +to the yet unconsumed token stream by calling the function {\em +last-pos-fn}. + +{\em next-sym-fn} should be bound to a generator function --- a +function of no arguments --- that will be called to produce the next +token. It should return two values: (1) the token found and (2) the +category of the token (obtained by the function {\tt categorize}). +\index{categorize} + +{\em error-fn} is the function to be called in case of an error. {\em +grammar} is the grammar object that contains important information for +lexical analysis, (e.g.\ the table of keywords). + +To understand the interface to {\tt lr-parse}, consider how +{\tt list-parser} (described above) might have been defined: +\index{list-parser} + +{\tt \samepage \begin{verbatim} +(defun list-parser (token-list &key (grammar *current-grammar*) + junk-allowed) + (let ((last-position token-list) + token1) + (check-type token-list list) + (lr-parse + ;; The LEXER supplied to the parsing engine: + #'(lambda () + (if (null token-list) + (end-of-tokens-category grammar) + (progn + (setq last-position token-list + token1 (pop token-list)) + (categorize token1 grammar)))) + ;; The error function supplied to the parsing engine: + #'(lambda (string) + (error "~S~% Remaining tokens: ~S~{ ~S~}" + string token1 token-list)) + grammar + junk-allowed + ;; Function that returns the remaining unparsed token-list + #'(lambda () last-position)))) + \end{verbatim} +} + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt end-of-tokens-category} {\em grammar} \>\>\>{\em function} +\end{tabbing} + +{\tt end-of-tokens-category} returns two values: a token signifying +the end of the token stream and the appropriate lexical category. + + +\begin{tabbing} +mmmmmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmmmmmm\=\kill +{\tt categorize} {\em token} {\em grammar} \>\>\>{\em function} +\end{tabbing} +\index{categorize} + +{\tt categorize} returns the {\em token} \/ itself and its category, a +number that represents one of {\tt number}, {\tt identifier}, {\tt + string} or a terminal token defined by {\tt :lex-cats}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section {Future Work} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +Translation involves three processes: +\begin{itemize} + \item parsing + \item transformation + \item generation +\end{itemize} + + {\sf Zebu} is a tool that helps in 1 and 3. There are cases where 2 +reduces to the identity function, since the abstract syntax is the +same for the source and the target language of translation. Examples +for these ``syntactic variants'' are infix and prefix notation for +arithmetic or boolean expressions. + + In general, the situation is more complicated. For languages with +the same expressive power, some transformation process can be defined. +Between languages with different expressive power such a +transformation is not always possible. For a language that is not +Turing complete, it is not possible to express every computation, e.g. +SQL cannot express recursion, and hence it is not possible to express +the ``ancestor'' relation (which is recursively defined). A technique +to represent transformation are ``rewrite rule systems''. The {\sf +Refine} language \cite{refine} contains a rewrite-rule mechanism in +which the rules are in terms of patterns of the concrete syntax. We +have implemented a rewrite-rule system based on typed feature +structures, called {\sf Zebu-RR}, which will be described in a future +report. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Appendix +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\appendix + +\section{Installation} +\label{installation} + +There are two ways to install {\sf Zebu}: + +\begin{itemize} + \item Installation using {\tt defsystem} + +This makes it easier to load and compile grammars, since one does not +need to remember the location of a module in a directory structure and +the particular compilation and loading functions. To install, follow +the directions in {\tt ZEBU-sys.lisp}. You need the portable {\tt +defsys} for that. This is available as {\tt Defsys.tar.gz} at the same +place as {\tt zebu-???.tar.gz}. + +The file {\tt ZEBU-sys.lisp} is used to load or compile {\sf Zebu}, +which actually consists of two systems (defined by {\tt defsystem}) + +\begin{tabbing} +mmmmm\=mmmmmmmmmmmmmmm\=mmmmmmmmmmmmmm\=\kill + \>{\sf Zebu} \>the runtime system\\ + \>{\sf Zebu-compiler} \>the compiler\\ +\end{tabbing} + + \item Installation without {\tt defsystem}\\ +If you don't want to use {\tt defsystem}, load the file {\tt +COMPILE-ZEBU.lisp}, which compiles the {\sf Zebu} files in the right +order. +\index{zebu} \index{zebu-compiler} +After loading the file {\tt ZEBU-init.lisp} you can call: + + {\tt (zb:zebu)} to load the runtime system\\ +or\\ + {\tt (zb:zebu-compiler)} to load the grammar compiler. +\end{itemize} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%\bibliography{/users/laubsch/texlib/general} +\begin{thebibliography}{99} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\bibitem{aho:79} +A.V. Aho and J.D. Ullman. +\newblock {\em Principles of Compiler Design}. +\newblock Addison Wesley, New York, 1979. + +\bibitem{compiler:88} +Charles~N. Fischer and Richard~J. LeBlanc. +\newblock {\em Crafting a Compiler}. +\newblock Benjamin/Cummings, Menlo Park, CA, 1988. + +\bibitem{cs:Genesereth92} +Michael~R. Genesereth. +\newblock An agent-based framework for software interoperability. +\newblock Technical Report Logic-92-02, Department Of Computer Science, Stanford + University, Stanford, 1992. + +\bibitem{cs:kif92} +Michael~R. Genesereth, Richard Fikes, et~al. +\newblock Knowledge interchange format, version 3.0. reference manual. +\newblock Report Logic-92-1, Logic Group Report, Computer Science Department, + Stanford University, Stanford, June 1992. + +\bibitem{johnson:88} +Mark Johnson. +\newblock {\em Attribute Value Logic and the Theory of Grammar}. +\newblock Center for the Study of Language and Information, Stanford, 1988. + +\bibitem{ap:refine} +Joachim Laubsch and Derek Proudian. +\newblock A case study in {REFINE}: interfacing modules via languages. +\newblock Report HPL-STL-TM-88-11, Hewlett Packard, 1988. + +\bibitem{cs:GNULisp} +Bill Lewis, Dan LaLiberte, and the GNU Manual~Group. +\newblock {\em GNU Emacs Lisp Reference Manual}. +\newblock The Free Software Foundation, Cambridge, MA, December 1990. + +\bibitem{refine} +Reasoning Systems, Palo Alto, 3260 Hillview Ave., CA 94304. +\newblock {\em Refine User's Guide}, 1989. + +\bibitem{ap:smith85} +Douglas~R. Smith, Gordon~B. Kotik, and Stephen~J. Westfold. +\newblock Research on knowledge-based software environments at {KESTREL} + institute. +\newblock {\em IEEE Transactions on Software Engineering}, SE-11:1278--1295, + November 1985. + +\end{thebibliography} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\begin{theindex} + + \item *allow-conflicts*, 18 + \item *case-sensitive*, 5, 24 + \item *check-actions*, 18 + \item *comment-brackets*, 23, 24 + \item *comment-start*, 23, 24 + \item *disallow-packages*, 5, 24 + \item *preserve-case*, 5, 24 + \item *warn-conflicts*, 18 + \item :build semantic action, 6 + \item :case-sensitive, 9, 24 + \item :domain, 8 + \item :domain-file, 8 + \item :grammar, 8 + \item :identifier-continue-chars, 8, 24 + \item :identifier-start-chars, 8, 24 + \item :intern-identifier, 8 + \item :lex-cats, 8, 24 + \item :name, 8 + \item :package, 8 + \item :print-parse-errors, 22 + \item :string-delimiter, 8, 24 + \item :symbol-delimiter, 8, 24 + \item :white-space, 9, 24 + + \indexspace + + \item categorize, 27 + \item compile-lalr1-grammar, 20 + \item compile-slr-grammar, 20 + + \indexspace + + \item debug-parser, 23 + \item def-tree-attributes, 11 + \item domain + \subitem defining, 9, 13 + \subitem top type, 10 + + \item feature structures, 12 + \item file-parser, 22 + \item find-grammar, 21 + + \indexspace + + \item grammar + \subitem name, 8 + \subitem options, 8 + + \indexspace + + \item kb-compare, 10 + \item kb-domain, 10 + \item kb-domain-p, 10 + \item kb-equal, 10 + \item kb-sequence, 10 + \item Kleene *, 5, 16, 17 + + \indexspace + + \item lexical category, 24 + \item list-parser, 23, 26 + \item lr-parse, 25 + + \indexspace + + \item meta grammar, 4, 12 + + \indexspace + + \item non-terminal, 5 + \subitem ``.n'' notation, 8 + \item null-grammar, 4 + + \indexspace + + \item option list, 8 + + \indexspace + + \item print-actions, 8 + \item print-function, 12, 14 + + \indexspace + + \item read-parser, 17, 21 + \item regular expression, 9, 23 + + \indexspace + + \item semantic actions, 6, 7 + \item start-symbol, 5 + + \indexspace + + \item zebu, 28 + \item zebu-compile-file, 18 + \item zebu-compiler, 28 + \item zebu-load-file, 20 + \item zebu-mg, 12 + +%\input{Zebu_intro.ind} +\end{theindex} + +\end{document} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% End of Zebu_intro.tex +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Added: vendor/zebu/test/arith.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/arith.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,79 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: arith.zb +; Description: Grammar 4.19 from Dragon, p. 222 +; Author: Joachim H. Laubsch +; Created: 8-Apr-92 +; Modified: Thu Oct 2 13:02:08 1997 (Joachim H. Laubsch) +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "arith" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-continue-chars + "$-+*&_.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :domain-file "ar-dom") + +;; Domain definition + +Arith-exp := Kb-domain: []; +Factor := Arith-exp: [(-value)] <>; +Mult-op := Arith-exp: [(-arg1) (-arg2)]; +Plus-op := Arith-exp: [(-arg1) (-arg2)]; + +;; Productions + +EE --> EE "+" TT { Plus-op: [(-arg1 EE) (-arg2 TT)] } + | TT ; + +TT --> TT "*" F { Mult-op: [(-arg1 TT) (-arg2 F)] } + | F ; + +F --> "(" EE ")" { factor: [(-value EE)] } + | IDENTIFIER { factor: [(-value IDENTIFIER)] } + | NUMBER { factor: [(-value NUMBER)] } ; + +#|| + +(read-parser "EE --> EE \"+\" TT { Plus-op: [(-arg1 EE) (-arg2 TT)] } + | TT ;" :grammar (find-grammar "zebu-mg")) + +(zb:compile-slr-grammar (merge-pathnames "arith.zb" *ZEBU-test-directory*) + :output-file (merge-pathnames + "binary/arith.tab" *ZEBU-test-directory*) + :grammar (find-grammar "zebu-mg")) + +(zb:zebu-load-file (merge-pathnames "binary/arith.tab" *ZEBU-test-directory*)) +(zebu::print-actions "arith") + +(defun print-factor (item stream level) + (declare (ignore level)) + (let ((v (factor--value item))) + (if (or (symbolp v) (numberp v)) + (format stream "~a" v) + (format stream "(~a)" v)))) + +(equalp (list-parser '(ned "+" jed) :grammar (zb:find-grammar "arith")) + (read-parser "ned + jed" :grammar (zb:find-grammar "arith"))) + +(equalp (read-parser "(ned + jed) * 4" :grammar (zb:find-grammar "arith")) + '#S(Mult-op + -ARG1 #S(FACTOR + -VALUE #S(PLUS-OP -ARG1 #S(FACTOR -VALUE NED) + -ARG2 #S(FACTOR -VALUE JED))) + -ARG2 #S(FACTOR -VALUE 4))) + + +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of arith.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/avm-p.lisp ============================================================================== --- (empty file) +++ vendor/zebu/test/avm-p.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,49 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: av-printers.l +; Description: +; Author: Joachim H. Laubsch +; Created: 13-Apr-92 +; Modified: Thu Oct 2 12:49:53 1997 (Joachim H. Laubsch) +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "CL-USER") + +(defun print-FEAT-TERM (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "~@[type: ~S ~][~{~S~^ ~}]" + (FEAT-TERM--type ITEM) + (FEAT-TERM--slots ITEM))) + +(defun print-General-Var (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "%~S" + (General-Var--name ITEM))) + +(defun print-Label-value-pair (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "(~S ~S)" + (Label-value-pair--label ITEM) + (Label-value-pair--value ITEM))) + +(defun PRINT-TAGGED-TERM (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "~S=~S" + (Tagged-Term--tag ITEM) + (Tagged-Term--term ITEM))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of av-printers.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/avm.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/avm.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,101 @@ +; -*- mode: Lisp -*- --------------------------------------------------- ; +; File: avm.zb +; Description: typed attribute-value language +; Author: Joachim H. Laubsch +; Created: 13-Apr-92 +; Modified: Thu Oct 2 12:50:10 1997 (Joachim H. Laubsch) +; Language: Lisp +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "avm" + :grammar "null-grammar" + :package "CL-USER" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + ) + +;; Domain definition + +(defstruct (avm (:include kb-domain))) + +(defstruct (Feat-Term (:include avm)) + -type -slots) +(defstruct (Label-value-pair (:include avm)) + -label -value) +(defstruct (general-var (:include avm)) + -name) +(defstruct (tagged-term (:include avm)) + -term -tag) + +;; Productions + +(defrule Feat-Term + := General-Var + := Untagged-Term + := Tagged-Term + ) + +(defrule Tagged-Term + := ( General-Var "=" Untagged-Term ) + :build (:type Tagged-Term + :map ((General-Var . :-tag) + (Untagged-Term . :-term)))) + +(defrule Untagged-Term + := Pos-Untagged-Term + ) + +(defrule Pos-Untagged-Term + := Identifier + + := ( "type:" Identifier Conj ) + :build (:type Feat-Term + :map ((Conj . :-slots) + (Identifier . :-type))) + := Conj + :build (:type Feat-Term + :map ((Conj . :-slots))) + ) + +(defrule Conj + := ( "[" Label-value-pairs "]" ) + :build (:form Label-value-pairs)) + +(defrule Label-value-pair + := ( "(" Identifier Feat-Term ")" ) + :build (:type Label-value-pair + :map ((Identifier . :-label) + (Feat-Term . :-value)))) + +(defrule Label-value-pairs + := () + + := ( Label-value-pair Label-value-pairs ) + :build cons + ) + +(defrule General-Var + := ( "%" Number ) + :build (:type General-Var + :map ((Number . :-name))) ) + +#|| +(let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*)) + (zb:zebu-compile-file "avm.zb" + :output-file (merge-pathnames + "avm.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + + (load "avm-p")) + +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of avm.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/avm1.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/avm1.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,77 @@ +; -*- mode: Lisp -*- --------------------------------------------------- ; +; File: avm1.zb +; Description: typed attribute-value language +; Author: Joachim H. Laubsch +; Created: 13-Apr-92 +; Modified: Thu Oct 2 12:50:29 1997 (Joachim H. Laubsch) +; Language: Lisp +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "avm1" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :domain-file "avm1-domain" +) + +;; Domain definition + +Neg-Term := [(-subterm)]; +Feat-Term := [(-type) (-slots)] ; +Label-value-pair := [(-label) (-value)]; +General-Var := [(-name)]; +Tagged-Term := [(-term) (-tag)]; +Za-Avm := [(-type)]; + +;; Productions + +Feat-Term --> General-Var | Untagged-Term | Tagged-Term | Term ; + +Term --> + Number | + Identifier + {Za-Avm:[(-type Identifier)]} | + "(" Tagged-Term ")" ; + + +Tagged-Term --> General-Var "=" Untagged-Term + {Tagged-Term: + [(-tag General-Var) + (-term Untagged-Term)]} ; + +General-Var --> "%" Number + {General-Var: [(-name Number)]} ; + +Untagged-Term --> Pos-Untagged-Term | Neg-Untagged-Term; + +Neg-Untagged-Term --> "~" Pos-Untagged-Term + {Neg-Term:[(-subterm Pos-Untagged-Term)]}; + +Pos-Untagged-Term --> Identifier + | String + | Identifier ":" "[" Label-value-pairs "]" + {Feat-Term: + [(-type Identifier) (-slots Label-value-pairs)]} + | "[" Label-value-pairs "]" + {Feat-Term: [(-slots Label-value-pairs)]} ; + +Label-value-pair --> "(" Identifier Feat-Term ")" + {Label-value-pair: + [(-label Identifier) (-value Feat-Term)]} ; + +Label-value-pairs --> Label-value-pair * " " ; + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of avm1.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/bug-exp.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/bug-exp.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,16 @@ +(:name "bug-exp" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-start-chars + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars + "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :lex-cats ((SIMPLEID "[a-zA-Z][_a-zA-Z0-9]*")) + ) + +Underlying_type --> String_type | + "any junk" ; + +String_type --> "STRING" "(" NUMBER ")" ; + + \ No newline at end of file Added: vendor/zebu/test/bug-exp1.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/bug-exp1.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,16 @@ +(:name "bug-exp1" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-start-chars + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars + "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :lex-cats ((SIMPLEID "[a-zA-Z][_a-zA-Z0-9]*")) + ) + +Underlying_type --> String_type | + IDENTIFIER ; + +String_type --> "STRING" "(" NUMBER ")" ; + + \ No newline at end of file Added: vendor/zebu/test/bug-exp2.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/bug-exp2.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,17 @@ +(:name "bug-exp2" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-start-chars + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars + "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :intern-identifier t + :lex-cats ((SIMPLEID "[a-zA-Z][_a-zA-Z0-9]*")) + ) + +Underlying_type --> String_type | + SIMPLEID ; + +String_type --> "STRING" "(" NUMBER ")" ; + + \ No newline at end of file Added: vendor/zebu/test/bug-exp3.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/bug-exp3.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,16 @@ +(:name "bug-exp3" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-start-chars + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars + "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :intern-identifier nil + ) + +Underlying_type --> String_type | + Identifier ; + +String_type --> "STRING" "(" NUMBER ")" ; + + \ No newline at end of file Added: vendor/zebu/test/dYoung.lisp ============================================================================== --- (empty file) +++ vendor/zebu/test/dYoung.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,7 @@ +(cd "~/zebu") +(load "ZEBU-init.lisp") +(zb:zebu-compiler :compiled nil) +(setq zb::*grammar-debug* t) +(zb:read-parser "Program := KB-domain: [(-stmts KB-Sequence)];" + :grammar (zb:find-grammar "zebu-mg")) + \ No newline at end of file Added: vendor/zebu/test/dangelse.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/dangelse.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,12 @@ +;;; The dangling else example of pp 228 of the old dragon book. +(:name "dangelse" :grammar "null-grammar") + +;; Productions + +(defrule s + := ("if" s "then" s "else" s) + + := ("if" s "then" s) + + := IDENTIFIER) + \ No newline at end of file Added: vendor/zebu/test/ex1.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex1.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,79 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: ex1.zb +; Description: Grammar 4.19 from Dragon, p. 222 +; Author: Joachim H. Laubsch +; Created: 8-Apr-92 +; Modified: Thu Oct 2 12:51:48 1997 (Joachim H. Laubsch) +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "ex1" + :domain-file "ex1-dom" + :package "CL-USER" + :grammar "null-grammar" + :lex-cats ((Ratio_Number "-?[0-9]+/[0-9]+") + (Simple_Float "-?[0-9]*\\.[0-9]+")) + ) + +(defrule EE + := ( EE "+" TT ) + :build (:form (LIST '+op EE TT)) + := TT + :build (:form (LIST 'expression TT))) + +(defrule TT + := (TT "*" F) + :build (:form (LIST '*-op TT F)) + + := F + :build (:form (LIST 'term F)) ) + +(defrule F + := ( "(" EE ")" ) + :build (:form (LIST 'factor EE)) + + := IDENTIFIER + :build (:form (list 'factor IDENTIFIER)) + + := Numeric + :build (:form (list 'factor Numeric)) ) + +(defrule Numeric + := NUMBER + := Ratio_Number + :build (:form (read-from-string Ratio_Number)) + := Simple_Float + :build (:form (read-from-string Simple_Float))) + +#|| +(set-working-directory *ZEBU-test-directory*) +(zb:compile-slr-grammar "ex1.zb" :output-file "binary/ex1.tab") + +(zb:zebu-load-file "binary/ex1.tab") +(zb::print-collection nil) +(zb::print-collection t) + +(zb:read-parser "b" :grammar (zb:find-grammar "ex1")) +(zb:read-parser "1" :grammar (zb:find-grammar "ex1")) +(zb:read-parser "1/2" :grammar (zb:find-grammar "ex1")) +(zb:read-parser "1.2" :grammar (zb:find-grammar "ex1")) +(zb:read-parser "(1)" :grammar (zb:find-grammar "ex1")) +(zb:read-parser "-1.2" :grammar (zb:find-grammar "ex1")) + +(zb:read-parser "(b + a)" :grammar (zb:find-grammar "ex1")) +(zb:read-parser "(1 + a)" :grammar (zb:find-grammar "ex1")) + +(zb::cruise-first-sets) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of ex1.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/ex1a.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex1a.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,63 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: ex1a.zb +; Description: Variation of ex1 which accepts empty string +; Author: Joachim H. Laubsch +; Created: 8-Apr-92 +; Modified: Thu Oct 2 12:51:56 1997 (Joachim H. Laubsch) +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "ex1a" :package "CL-USER" :grammar "null-grammar") + +(defrule EE + := ( EE "+" TT ) + :build (:form (LIST '+op EE TT)) + := TT + :build (:form (LIST 'expression TT))) + +(defrule TT + := (TT "*" F) + :build (:form (LIST '*-op TT F)) + + := F + :build (:form (LIST 'term F)) ) + +(defrule F + := ( "(" EE ")" ) + :build (:form (LIST 'factor EE)) + + := IDENTIFIER + :build (:form (list 'factor IDENTIFIER)) + + := NUMBER + :build (:form (list 'factor NUMBER)) + + := () + ) + +#|| +(set-working-directory *ZEBU-test-directory*) +(compile-slr-grammar + (merge-pathnames "ex1a.zb" *ZEBU-test-directory*) + :output-file (merge-pathnames "ex1a.tab" *ZEBU-test-binary-directory*)) + +(zb:zebu-load-file (merge-pathnames "ex1a.tab" *ZEBU-test-binary-directory*)) + +(zb:read-parser "" :grammar (find-grammar "ex1a")) +(zb:read-parser "11" :grammar (find-grammar "ex1a")) +(zb:read-parser "(b + a)" :grammar (find-grammar "ex1a")) + +(zb::cruise-first-sets) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of ex1a.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/ex2.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex2.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,61 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: ex2.zb +; Description: +; Author: Joachim H. Laubsch +; Created: 27-Mar-92 +; Modified: Thu Oct 2 12:52:05 1997 (Joachim H. Laubsch) +; Language: ZEBU +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "ex2" :package "CL-USER" :grammar "null-grammar" + :domain-file "ex2-dom") + +(defrule EE + := (TT E-PRIME) + :build (:form (append TT E-PRIME)) ) + +(defrule E-PRIME + := ("+" TT E-PRIME) + :build (:form (cons "+" (append TT E-PRIME))) + + := ()) + +(defrule TT + := (FF T-PRIME) + :build (:form (cons FF T-PRIME)) ) + +(defrule T-PRIME + := ("*" FF T-PRIME) + :build (:form (list* "*" FF T-PRIME)) + + := ()) + +(defrule FF + := ( "(" EE ")") + :build (:form EE) + := IDENTIFIER + := NUMBER + ) + +#|| +(set-working-directory *ZEBU-test-directory*) +(compile-slr-grammar "ex2.zb") +(zb:zebu-load-file "ex2.tab") +(zebu::print-actions "ex2") +(equal (zb:read-parser "x * y" :grammar (find-grammar "ex2")) + '(X "*" Y)) +(equal (zb:read-parser "(x * y) + (x * y)" :grammar (find-grammar "ex2")) + '((X "*" Y) "+" (X "*" Y))) +||# + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of ex2.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/ex3.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex3.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,49 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: ex3.zb +; Description: +; Author: Joachim H. Laubsch +; Created: 7-Apr-92 +; Modified: Thu Oct 2 12:52:13 1997 (Joachim H. Laubsch) +; Language: CL +; Package: USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "ex3" :grammar "null-grammar") + +(defrule a + := "b" + := ()) + +(defrule c + := "b" + := ()) + + +(defrule d + := (a c a)) + +(defrule e + := (a "f" a)) + +#|| +(set-working-directory *ZEBU-test-directory*) +(compile-slr-grammar "ex3.zb") +(zb:zebu-load-file "ex3.tab") + +(equal (zb:read-parser "b" :grammar (find-grammar "ex3")) + "b") + +(compile-lalr1-grammar "ex3.zb" "/tmp/ex3-lalr1.tab") +(zb:zebu-load-file "/tmp/ex3-lalr1.tab") +(equal (zb:read-parser "b" :grammar (find-grammar "ex3")) + "b") +||# + + + \ No newline at end of file Added: vendor/zebu/test/ex4.40.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex4.40.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,55 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: ex4.40.zb +; Description: Variation on Example 3 (ex3.zb) +; Author: Joachim H. Laubsch +; Created: 7-Apr-92 +; Modified: Thu Oct 2 12:52:23 1997 (Joachim H. Laubsch) +; Language: CL +; Package: USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "ex4.40" :grammar "null-grammar") + +(defrule a + := "b" + := ()) + +(defrule c + := "b" + := ()) + + +(defrule d + := (a c a)) + +(defrule e + := (a "f" a)) + +#|| +(compile-slr-grammar (merge-pathnames "ex4.40.zb" *ZEBU-test-directory*)) + +(zb:zebu-load-file (merge-pathnames "ex4.40.tab" *ZEBU-test-directory*)) + +(zb:read-parser "b xx" :grammar (find-grammar "ex4.40") + :junk-allowed t) + +(list-parser '("b") :grammar (find-grammar "ex4.40")) + +(list-parser '("b" "xx") :grammar (find-grammar "ex4.40") :junk-allowed t) + +(equal (zb:read-parser "b" :grammar (find-grammar "ex4.40")) + "b") +||# + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of ex4.40.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/ex4.41.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex4.41.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,35 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: ex4.41.zb +; Description: p. 231 (Dragon) +; Author: Joachim H. Laubsch +; Created: 7-Apr-92 +; Modified: Thu Oct 2 12:52:33 1997 (Joachim H. Laubsch) +; Language: CL +; Package: USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "ex4.41") + +(defrule S := ( B B ) ) + +(defrule B := ( "a" B ) + := "b" ) +#|| +(set-working-directory *ZEBU-test-directory*) +(compile-slr-grammar "ex4.41.zb") +(zb::cruise-first-sets) +(zb::cruise-follow-sets) +||# + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of ex4.41.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/ex4.42.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex4.42.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,70 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: ex4.42.zb +; Description: p. 231 (Dragon) +; Author: Joachim H. Laubsch +; Created: 7-Apr-92 +; Modified: Thu Oct 2 12:52:46 1997 (Joachim H. Laubsch) +; Language: CL +; Package: USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "ex4.42") + +(defrule S := ( C C ) ) + +(defrule C := ( "c" C ) + := "d" ) +#|| +(set-working-directory *ZEBU-test-directory*) +(compile-slr-grammar "ex4.42.zb") +(zb::cruise-first-sets) +(zb::cruise-follow-sets) + +(zb::load-grammar "ex4.42.zb") +(zb::make-lr0-collection) +(zb::print-collection nil) +(zb::print-collection t) + +(zb::lalr1-tables-from-grammar "ex4.42.zb") +(zb::print-collection t) + +Start state index: 0 +------------------ 0 ------------------- +AUGMENTED-START -> . S { THE-END-G-SYMBOL } +S -> . C C { THE-END-G-SYMBOL } +C -> . c C { c d } +C -> . d { c d } +gotos: S -> 1 C -> 2 c -> 4 d -> 6 +------------------ 1 ------------------- +AUGMENTED-START -> S . { THE-END-G-SYMBOL } +------------------ 2 ------------------- +S -> C . C { THE-END-G-SYMBOL } +C -> . c C { THE-END-G-SYMBOL } +C -> . d { THE-END-G-SYMBOL } +gotos: C -> 3 c -> 4 d -> 6 +------------------ 3 ------------------- +S -> C C . { THE-END-G-SYMBOL } +------------------ 4 ------------------- +C -> . c C { THE-END-G-SYMBOL c d } +C -> c . C { THE-END-G-SYMBOL c d } +C -> . d { THE-END-G-SYMBOL c d } +gotos: C -> 5 c -> 4 d -> 6 +------------------ 5 ------------------- +C -> c C . { THE-END-G-SYMBOL c d } +------------------ 6 ------------------- +C -> d . { THE-END-G-SYMBOL c d } +NIL + +(zb::cruise-parse-tables) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of ex4.42.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/ex5.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex5.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,28 @@ +(:grammar "zebu-mg") + +;; Domain definition + +Program := [(-stmts kb-sequence)]; +Combination := [(-function) (-args kb-sequence)]; +Tuple := [(-members kb-sequence)]; + +;; Rules + +Program --> "begin" Stmt+ "." "end" + { Program: [(-stmts Stmt+)] } ; + +Stmt --> Identifier | Appl | Program ; + +Appl --> Identifier "(" Arg* "," ")" + {Combination: [(-function Identifier) (-args Arg*)]}; + +Arg --> Identifier | Number | Appl | Tuple ; + +Tuple --> "<" Arg+ " " ">" + { Tuple: [(-members Arg+)] }; + +#|| +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of ex5.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/ex6_2.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex6_2.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,39 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +(:name "ex6_2" + :domain-file "ex6-dom" + :grammar "zebu-mg" + :identifier-start-chars + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars + "_-=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + ) + +;; Domain definition + + assignment := [(-lhs) (-rhs)]; + locative := [(-path)]; + +;; Productions + + S --> L "=" R {assignment: [(-lhs L) (-rhs R)]} + | R ; + + L --> "*" R {locative: [(-path R)]} + | Identifier; + + R --> NUMBER + | L; + + +#|| +(ds:compile-module "ex6_2") +(ds:load-module "ex6_2") +(read-parser "foo = 0" :grammar (find-grammar "ex6_2")) +(type-of (read-parser "**foo = ***x" :grammar (find-grammar "ex6_2"))) +(equalp (ASSIGNMENT--lhs + (read-parser "**foo = ***x" :grammar (find-grammar "ex6_2"))) + (read-parser "**foo" :grammar (find-grammar "ex6_2"))) +||# + + + \ No newline at end of file Added: vendor/zebu/test/ex7.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex7.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,30 @@ +(:name "ex5" + :package "CL-USER" + :grammar "zebu-mg" + :lex-cats ((BEGIN "begin") + (END "end") + (Id2 "[-a-zA-Z][-$_a-zA-Z0-9]*") + )) + + +;; Domain definition + + Program := [(-stmts kb-sequence)]; + Combination := [(-function) (-args kb-sequence)]; + Tuple := [(-members kb-sequence)]; + +;; Rules + + Program --> BEGIN Stmt+ ";" END + { Program: [(-stmts Stmt+)] } ; + + Stmt --> Id2 | Appl | Program ; + + Appl --> Identifier "(" Arg* "," ")" + {Combination: [(-function Identifier) (-args Arg*)]}; + + Arg --> Identifier | Number | Appl | Tuple ; + + Tuple --> "<" Arg+ " " ">" + { Tuple: [(-members Arg+)] }; + \ No newline at end of file Added: vendor/zebu/test/ex8.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/ex8.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,6 @@ +(:name "ex8" :package "USER" :grammar "zebu-mg") + +_root := [(ids kb-sequence)]; + +starttoken --> IDENTIFIER+ " " {_root:[(ids IDENTIFIER+)]}; + \ No newline at end of file Added: vendor/zebu/test/exercise.lisp ============================================================================== --- (empty file) +++ vendor/zebu/test/exercise.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,918 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: exercise.lisp +; Description: +; Author: Joachim H. Laubsch +; Created: 26-Mar-92 +; Modified: Wed Jan 13 13:41:01 1999 (Joachim H. Laubsch) +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "CL-USER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; pathnames +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(unless (boundp '*ZEBU-directory*) + (setq *ZEBU-directory* + (make-pathname :directory (butlast (pathname-directory *LOAD-TRUENAME*))) + )) + +(setq *ZEBU-binary-directory* + (make-pathname :directory (append (pathname-directory *ZEBU-directory*) + (list "binary")))) + +(defparameter *ZEBU-test-directory* + (make-pathname :directory (append (pathname-directory *ZEBU-directory*) + (list "test")))) + +(defparameter *ZEBU-test-binary-directory* + (make-pathname :directory (append (pathname-directory *ZEBU-test-directory*) + (list "binary")))) + +(defparameter *ZEBU-compile-domain* + #+(or :ALLEGRO :HARLEQUIN-PC-LISP) nil + #-(or :ALLEGRO :HARLEQUIN-PC-LISP) t) + +#+DEFSYS +(let ((*default-pathname-defaults* *ZEBU-directory*)) + (require "ZEBU-sys") + (ds:compile-system 'Zebu-compiler) + (ds:load-system 'Zebu-compiler) + (ds:load-system 'Zebu-rr) + (use-package (find-package "ZEBU") + (find-package "CL-USER")) +) + +#-DEFSYS +(let ((*default-pathname-defaults* *ZEBU-directory*)) + (load (make-pathname :name "ZEBU-init" :type "lisp")) + (zb:zebu-compiler :compiled *ZEBU-compile-domain*) + (zb:zebu-rr :compiled *ZEBU-compile-domain*) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ex1 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#+DEFSYS +(progn (ds:compile-module "ex1") (ds:load-module "ex1")) +#-DEFSYS +(progn + (zebu-compile-file (merge-pathnames + (make-pathname :name "ex1" :type "zb") *ZEBU-test-directory*) + :output-file + (merge-pathnames + (make-pathname :name "ex1" :type "tab") + *ZEBU-test-binary-directory*) + :compile-domain *ZEBU-compile-domain*) + + (zb:zebu-load-file (merge-pathnames + (make-pathname :name "ex1" :type "tab") + *ZEBU-test-binary-directory*))) +(setq zebu:*current-grammar* (find-grammar "ex1")) +(format t "Grammar: ~S" zebu:*current-grammar*) + +(let ((l '(1 "+" a foo bar))) + (multiple-value-bind (v rest) + (list-parser l :junk-allowed t) + (unless (and (equal v '(+OP (EXPRESSION (TERM (FACTOR 1))) + (TERM (FACTOR A)))) + (eq rest (nthcdr 3 l))) + (warn "list-parser broken")))) + +(handler-case (equal (list-parser '(1 "+" a ) ) + (read-parser "1 + a")) + (error () 'ok) + (:no-error (&rest args) args)) + +(if (and + (equal (read-parser "1 + a") + '(+OP (EXPRESSION (TERM (FACTOR 1))) + (TERM (FACTOR A)))) + (equal (read-parser "1 + a") (read-parser "1 + a dd" :junk-allowed t)) + (equal (list-parser '(1 "+" a foo bar) :junk-allowed t) + (read-parser "1 + a foo bar" :junk-allowed t)) + (equal (read-parser ".1 + 1/3") (read-parser "0.1 + 1/3")) + (equal (read-parser "1 + a") (list-parser '(1 "+" a))) + (equal (read-parser "1 + 1") (list-parser '(1 "+" 1))) + (equal (read-parser "1 + x * y") (list-parser '(1 "+" x "*" y))) + (equal (read-parser "(1 + x) * y") (list-parser '("(" 1 "+" x ")" "*" y)))) + (print 'ok) + (warn "error parsing with grammar ex1")) + +(zb:FILE-PARSER (merge-pathnames "sample-ex1" *ZEBU-test-directory*) + :grammar (zb:find-grammar "ex1")) + +(zebu::cruise-follow-sets) +(zebu::print-productions) + +(compile-slr-grammar + (merge-pathnames "ex1a.zb" *ZEBU-test-directory*) + :output-file (merge-pathnames "ex1a.tab" *ZEBU-test-binary-directory*)) +(zb:zebu-load-file (merge-pathnames "ex1a.tab" *ZEBU-test-binary-directory*)) + +(unless (zb:read-parser "" :grammar (find-grammar "ex1a")) + (warn "error with grammar ex1a, given an empty string")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; meta-grammar test +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(unless (equal (zb::grammar-identifier-start-chars (zb:find-grammar "zebu-mg")) + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + (warn "zebu-mg")) + +(zb:read-parser "Program := KB-domain: [(-stmts KB-Sequence)];" + :grammar (zb:find-grammar "zebu-mg")) + +(zb:read-parser "Program := [(-stmts KB-Sequence)];" + :grammar (zb:find-grammar "zebu-mg")) + +(zb:read-parser "Arith-exp := Kb-domain : [];" + :grammar (zb:find-grammar "zebu-mg")) + +(zb:read-parser "Factor := Arith-exp : [(-value)];" + :grammar (zb:find-grammar "zebu-mg")) + +(zb:read-parser "Program --> \"begin\" Stmts \"end\" + { Program: [(-stmts Stmts) + (-label \"bar\")] } ;" + :grammar (zb:find-grammar "zebu-mg")) + +(unless (equalp + (zb:read-parser "Program --> \"begin\" Stmts \"end\" + { Program: [(-stmts Stmts)] } ;" + :grammar (zb:find-grammar "zebu-mg")) + '#S(ZEBU::ZB-RULE + -NAME PROGRAM + -PRODUCTIONS (#S(ZEBU::PRODUCTION-RHS + -SYNTAX ("begin" STMTS "end") + -SEMANTICS #S(ZEBU::FEAT-TERM + -TYPE PROGRAM + -SLOTS (#S(ZEBU::LABEL-VALUE-PAIR + -LABEL -STMTS + -VALUE STMTS))) + -BUILD-FN NIL)))) + (warn "zebu-mg 1")) + +(with-open-file (s (merge-pathnames "arith.zb" *ZEBU-test-directory*)) + (read s) + (zb::file-parser-aux s #'error t (zb:find-grammar "zebu-mg") t)) + + +#+DEFSYS (ds:compile-module "arith") +#-DEFSYS +(zebu-compile-file (merge-pathnames "arith" *ZEBU-test-directory*) + :output-file (merge-pathnames + "arith" *ZEBU-test-binary-directory*) + :compile-domain *ZEBU-compile-domain*) + +(compile-file + (merge-pathnames (make-pathname :name "ar-dom" + :type (car *load-source-pathname-types*)) + *ZEBU-test-directory*) + :output-file (merge-pathnames + "ar-dom" *ZEBU-test-binary-directory*)) + +(defun PRINT-FACTOR (item STREAM LEVEL) + (FORMAT STREAM "~a" (factor--value item))) +#+DEFSYS +(ds:load-module "arith") +#-DEFSYS +(zebu-load-file (merge-pathnames (make-pathname :name "arith" :type "tab") + *ZEBU-test-binary-directory*)) +(zebu::print-actions "arith") + +(unless (and (equalp (list-parser '(ned "+" jed) + :grammar (zb:find-grammar "arith")) + (read-parser "ned + jed" + :grammar (zb:find-grammar "arith"))) + + (equalp (read-parser "(ned + jed) * 4" + :grammar (zb:find-grammar "arith")) + '#S(Mult-OP + -ARG1 #S(FACTOR + -VALUE #S(Plus-OP -ARG1 #S(FACTOR -VALUE NED) + -ARG2 #S(FACTOR -VALUE JED))) + -ARG2 #S(FACTOR -VALUE 4)))) + (warn "arith did not compile correctly")) + +(defun print-factor (item stream level) + (declare (ignore level)) + (let ((v (factor--value item))) + (if (or (symbolp v) (numberp v)) + (format stream "~a" v) + (format stream "(~a)" v)))) + +(unless (string= (with-output-to-string (s) + (prin1 + (read-parser "(ned + jed) * 4" + :grammar (zb:find-grammar "arith")) + s)) + "(NED + JED) * 4") + (warn "printing for arith failed")) + +;; mini-la +(let ((zebu:*allow-conflicts* t) + (*generate-domain* t)) + (compile-slr-grammar + (merge-pathnames "mini-la.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames "mini-la.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + ) +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames "mini-la.tab" *ZEBU-TEST-BINARY-DIRECTORY*))) + +(unless (typep (zb::read-parser "begin a end" :grammar (zb:find-grammar "mini-la")) + 'program) + (warn "failed to parse with mini-la: 1")) + +(unless (typep (zb::read-parser "begin A; B ; C end" + :grammar (zb:find-grammar "mini-la")) + 'program) + (warn "failed to parse with mini-la: 2")) + +(unless (typep (zb::read-parser "begin A; begin B1; B2 end ; C end" + :grammar (zb:find-grammar "mini-la")) + 'program) + (warn "failed to parse with mini-la: 3")) + +(let ((s " begin F({1,2,4}) end")) + (equal (format nil "~s" (zb::read-parser s)) + s) + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ex6_2 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*)) + (zebu-compile-file "ex6_2.zb" + :output-file (merge-pathnames "ex6_2.tab" *ZEBU-TEST-BINARY-DIRECTORY*) + :compile-domain *ZEBU-compile-domain*) + (setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames "ex6_2.tab" *ZEBU-TEST-BINARY-DIRECTORY*))) + ) +(unless (and (let ((zb:*preserve-case* t)) + (string= (format nil "~s" (read-parser "foo = 0")) + "foo = 0")) + (eq (type-of (read-parser "**foo = ***x")) 'ASSIGNMENT) + (equalp (ASSIGNMENT--lhs + (read-parser "**foo = ***x")) + (read-parser "**foo"))) + (warn "Grammar ex6_2 did not compile correctly")) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ex2 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#+DEFSYS +(progn (compile-module "ex2") (load-module "ex2")) + +#-DEFSYS +(progn + (zebu-compile-file (merge-pathnames + (make-pathname :name "ex2" :type "zb") *ZEBU-test-directory*) + :output-file + (merge-pathnames + (make-pathname :name "ex2" :type "tab") + *ZEBU-test-binary-directory*) + :compile-domain *ZEBU-compile-domain* + :verbose t) + + (zb:zebu-load-file (merge-pathnames + (make-pathname :name "ex2" :type "tab") + *ZEBU-test-binary-directory*))) + +(setq zebu:*current-grammar* (find-grammar "ex2")) +(format t "Grammar: ~S" zebu:*current-grammar*) + +(zebu::print-productions) +(zebu::cruise-follow-sets) +(zebu::print-actions (zebu::grammar-name zebu:*current-grammar*)) + +(and + (equal (read-parser "G") (list-parser '(G))) + (equal (read-parser "(G)") (list-parser '( "(" G ")" ))) + (equal (read-parser "(((P)))") '((((P))))) + (equal (read-parser "(F + 3 + 1)") '((F "+" 3 "+" 1))) + (equal (read-parser "(F + 3 * (2 + 1))") '((F "+" 3 "*" (2 "+" 1)))) + (equal (read-parser "(F + 3) * (2 + 1)") '((F "+" 3) "*" (2 "+" 1))) + (equal (read-parser "((F + 3) * 2) + 1") '(((F "+" 3) "*" 2) "+" 1)) + (equal (list-parser '(ned "+" "(" jed "*" fred ")")) + '(NED "+" (JED "*" FRED))) + (print 1)) + +(and + (let (zebu:*current-grammar*) + (equal (read-parser "ned + jed" :grammar (find-grammar "ex2")) + (list-parser '(ned "+" jed ) :grammar (find-grammar "ex2")))) + + (equal (read-parser "ned + jed" :grammar (find-grammar "ex2")) + (list-parser '(ned "+" jed ) :grammar (find-grammar "ex2"))) + (print 2)) + +#+DEFSYS +(progn (compile-module "ex3") (load-module "ex3")) +#-DEFSYS +(progn + (zebu-compile-file (merge-pathnames + (make-pathname :name "ex3" :type "zb") *ZEBU-test-directory*) + :output-file + (merge-pathnames + (make-pathname :name "ex3" :type "tab") + *ZEBU-test-binary-directory*) + :compile-domain *ZEBU-compile-domain*) + + (zb:zebu-load-file (merge-pathnames + (make-pathname :name "ex3" :type "tab") + *ZEBU-test-binary-directory*))) + +(and + (equal (read-parser "b" :grammar (find-grammar "ex3")) "b") + (null (read-parser "" :grammar (find-grammar "ex3"))) + (print 3)) + +#+DEFSYS +(progn + (compile-module "useless") + (load-module "useless") + (setq zebu:*current-grammar* (zb:find-grammar "useless")) + ) + +#+DEFSYS +(progn (compile-module "lr4-21") (load-module "lr4-21")) + +#-DEFSYS +(progn + (zebu-compile-file (merge-pathnames + (make-pathname :name "lr4-21" :type "zb") *ZEBU-test-directory*) + :output-file + (merge-pathnames + (make-pathname :name "lr4-21" :type "tab") + *ZEBU-test-binary-directory*) + :compile-domain *ZEBU-compile-domain*) + + (zb:zebu-load-file (merge-pathnames + (make-pathname :name "lr4-21" :type "tab") + *ZEBU-test-binary-directory*))) + +(setq zebu:*current-grammar* (zb:find-grammar "lr4-21")) +(read-parser "foo = 0") +(read-parser "foo = x") + +(read-parser "*foo = x") +(read-parser "*0 = x") +(read-parser "**foo = ***x") + + +(zb:zebu-load-file + (compile-slr-grammar (merge-pathnames "ex4.40.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames + "ex4.40.tab" *ZEBU-TEST-BINARY-DIRECTORY*))) +; this should print warnings +; The following non-terminals where defined but not used: D E +(equal (zb:read-parser "b" :grammar (find-grammar "ex4.40")) + "b") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Propositional Calculus +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(let ((zebu:*allow-conflicts* t) + (*generate-domain* t)) + (compile-lalr1-grammar + (merge-pathnames "pc1.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames "pc1.tab" *ZEBU-TEST-BINARY-DIRECTORY*) + :verbose t) + (load (merge-pathnames "pc1-dom.lisp" *ZEBU-TEST-DIRECTORY*)) + (load (merge-pathnames "pc1-p.lisp" *ZEBU-TEST-DIRECTORY*)) + (zebu-load-file (merge-pathnames "pc1.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + (setq zebu:*current-grammar* (zb:find-grammar "pc1")) + ) + +(unless (and + (eq (type-of (read-parser "P")) 'PROPOSITIONAL-VARIABLE) + (type-of (read-parser "P and Q")) + (string= (format nil "~s" (read-parser "P and Q")) + "P and Q")) + (warn "pc1 didn't compile correctly")) + +(read-parser "P and Q and R") +(read-parser "P and Q or R and S") +(read-parser "(P and Q) or R and S") +(read-parser "P and (Q or R) and S") +(string= (format nil "~s" (read-parser "P(a: 1 b:S)")) + "P(A: 1 B: S)") +(let ((zb:*preserve-case* t)) + (unless (string= (format nil "~s" (read-parser "P(a: 1 b:S)")) + "P(a: 1 b: S)") + (warn "Printing with grammar pc1 failed"))) + +(let ((zb:*preserve-case* nil)) + (unless (string= (format nil "~s" (read-parser "walks(agent: John)")) + "WALKS(AGENT: JOHN)") + (warn "Printing with grammar pc1 failed"))) + +(zebu::print-actions "pc1") +(zebu::print-productions) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dangling else +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(let ((zebu:*allow-conflicts* t) (zebu:*warn-conflicts* t)) + (zebu-load-file + (compile-lalr1-grammar + (merge-pathnames "dangelse.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames "dangelse.tab" + *ZEBU-TEST-BINARY-DIRECTORY*)))) + +(unless (equal (read-parser "if f then if g then h else i" + :grammar (find-grammar "dangelse")) + '("if" F "then" ("if" G "then" H "else" I))) + (warn "error in dangelse grammar")) + +(defpackage "ZEBU-TEST" + #-LUCID (:use "COMMON-LISP") + #+LUCID (:use "LUCID-COMMON-LISP") + ) + +#+DEFSYS +(progn (compile-module "pc2") (load-module "pc2") + ) + +#-DEFSYS +(zebu-load-file + (compile-lalr1-grammar + (merge-pathnames "pc2.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames "pc2.tab" + *ZEBU-TEST-BINARY-DIRECTORY*))) + +(def-tree-attributes Atomic-Wff + Atomic-Wff--predicate + ) + +(def-tree-attributes Role-Argument-Pair + Role-Argument-Pair--Role + Role-Argument-Pair--Argument) + +(def-tree-attributes Boolean-And + Boolean-Expr--rand1 + Boolean-Expr--rand2) + +(zebu-load-file + (merge-pathnames "pc1.tab" + *ZEBU-TEST-BINARY-DIRECTORY*)) + + +(or (kb-equal (zb:read-parser "walks(agent: John)" + :grammar (zb:find-grammar "pc1")) + (zb:read-parser "walks(agent: John)" + :grammar (zb:find-grammar "pc2"))) + (warn "error in grammar pc2: 1")) + +(def-tree-attributes Atomic-Wff + Atomic-Wff--Role-Argument-Pairs + ) + +(and (kb-equal (zb:read-parser "walks(agent: John)" :grammar (zb:find-grammar "pc1")) + (zb:read-parser "walks(agent: Joe)" :grammar (zb:find-grammar "pc2"))) + (warn "error in grammar pc2: 2")) + +(or (kb-equal (zb:read-parser "walks(agent: John) and talks(agent: John)" + :grammar (zb:find-grammar "pc1")) + (zb:read-parser "walks(agent: John) and talks(agent: John)" + :grammar (zb:find-grammar "pc2"))) + (warn "error in grammar pc2: 3")) + +(unless (typep (zb:read-parser "walks(agent: John) and talks(agent: John) and Q" + :grammar (zb:find-grammar "pc2")) + 'BOOLEAN-AND) + (warn "error in grammar pc2: 4")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; recompile NLL grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#+(and DEFSYS (not (or MCL cmu))) +(let ((nll-sys (probe-file (merge-pathnames + "NLL-sys.l" + (make-pathname :directory + (append (butlast (pathname-directory + *ZEBU-directory*)) + (list "nll"))))))) + (when nll-sys + (load nll-sys) + (let (zebu:*warn-conflicts* (zebu:*allow-conflicts* t)) + (compile-module "nll-grammar")) + (load-system 'NLL-test) ) + + (load-module "test-nll-syntax-1") + (load-module "test-nll-syntax-2") + (load-module "nll-simplify-test-1") + (load-module "nll-simplify-test-2") + (load-module "drt-to-lgq-test")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; avm grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*)) + (zb:zebu-compile-file "avm.zb" + :output-file (merge-pathnames + "avm.tab" *ZEBU-TEST-BINARY-DIRECTORY*) + :compile-domain *ZEBU-compile-domain*) + + (load (merge-pathnames + (make-pathname :name "avm-p" + :type (car *load-source-pathname-types*))))) + +(zb:zebu-load-file + (merge-pathnames "avm.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + +(unless (and + (equalp (zb:read-parser "[(s1 v1) (s2 v2)]" :grammar (find-grammar "avm")) + '#S(FEAT-TERM + -TYPE NIL + -SLOTS (#S(LABEL-VALUE-PAIR -LABEL S1 -VALUE V1) + #S(LABEL-VALUE-PAIR -LABEL S2 -VALUE V2)))) + (equalp (zb:read-parser "[(s1 v1) (s2 %1= v2) (s3 %1)]" + :grammar (find-grammar "avm")) + '#S(FEAT-TERM + -TYPE NIL + -SLOTS (#S(LABEL-VALUE-PAIR -LABEL S1 -VALUE V1) + #S(LABEL-VALUE-PAIR + -LABEL S2 + -VALUE #S(TAGGED-TERM + -TERM V2 + -TAG #S(GENERAL-VAR -NAME 1))) + #S(LABEL-VALUE-PAIR + -LABEL S3 + -VALUE #S(GENERAL-VAR -NAME 1))))) + (equalp (zb:read-parser "type: foo [(s1 v1) (s2 %1= v2) (s3 %1)]" + :grammar (find-grammar "avm")) + '#S(FEAT-TERM -TYPE FOO + -SLOTS (#S(LABEL-VALUE-PAIR -LABEL S1 -VALUE V1) + #S(LABEL-VALUE-PAIR -LABEL S2 + -VALUE #S(TAGGED-TERM -TERM V2 + -TAG #S(GENERAL-VAR -NAME 1))) + #S(LABEL-VALUE-PAIR -LABEL S3 + -VALUE #S(GENERAL-VAR -NAME 1))))) + (equalp (zb:read-parser "%0 = type: foo [(s1 %0) (s2 %1= v2) (s3 %1)]" + :grammar (find-grammar "avm")) + '#S(TAGGED-TERM + -TERM #S(FEAT-TERM + -TYPE FOO + -SLOTS (#S(LABEL-VALUE-PAIR + -LABEL S1 + -VALUE #S(GENERAL-VAR -NAME 0)) + #S(LABEL-VALUE-PAIR + -LABEL S2 + -VALUE #S(TAGGED-TERM + -TERM V2 + -TAG #S(GENERAL-VAR -NAME 1))) + #S(LABEL-VALUE-PAIR + -LABEL S3 + -VALUE #S(GENERAL-VAR -NAME 1)))) + -TAG #S(GENERAL-VAR -NAME 0)))) + (warn "avm grammar did not compile correctly")) + + +(let ((*load-verbose* t)) + (zb:zebu-compile-file + (merge-pathnames "avm1.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames "avm1.tab" *ZEBU-TEST-BINARY-DIRECTORY*) + :compile-domain *ZEBU-compile-domain*)) + +;;(zebu::print-actions "avm1") +(zb:zebu-load-file + (merge-pathnames "avm1.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) +(zb:read-parser "[(s1 v1) (s2 v2)]" :grammar (find-grammar "avm1")) +(zb:read-parser "foo: [(s1 v1) (s2 %1= v2) (s3 %1)]" + :grammar (find-grammar "avm1")) +(zb:read-parser "foo: [(s1 v1) (s2 %1= v2) (s3 %1)]" + :grammar (find-grammar "avm1")) +(zb:read-parser "foo: []" + :grammar (find-grammar "avm1")) +(zb:read-parser " []" + :grammar (find-grammar "avm1")) +(zb:read-parser " [( s1 \"foo\" )]" + :grammar (find-grammar "avm1")) +(zb:read-parser " [( s1 \"foo\\\"bar\" )]" + :grammar (find-grammar "avm1")) +(zb:read-parser "foo : [(s1 [(s1 v1)]) (s2 %1= v2) (s3 %1)]" + :grammar (find-grammar "avm1")) + +(let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*)) + (zb:file-parser "sample-avm1" :grammar (find-grammar "avm1"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fs-grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(zebu-compile-file (merge-pathnames + (make-pathname :name "fsg" :type "zb") *ZEBU-test-directory*) + :output-file + (merge-pathnames + (make-pathname :name "fsg" :type "tab") + *ZEBU-test-binary-directory*) + :compile-domain *ZEBU-compile-domain*) +(zebu-load-file + (merge-pathnames "fsg.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + +(read-parser " (:type ATOMIC-WFF) [(PRED walk) (AGENT peter)] " + :grammar (find-grammar "tfs-g2")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; tdl grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(zebu-compile-file (merge-pathnames + (make-pathname :name "hh-tdl" :type "zb") *ZEBU-test-directory*) + :output-file + (merge-pathnames + (make-pathname :name "hh-tdl" :type "tab") + *ZEBU-test-binary-directory*) + :compile-domain *ZEBU-compile-domain*) +(zebu-load-file + (merge-pathnames "hh-tdl.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) +(file-parser (merge-pathnames + (make-pathname :name "hh-test" :type "tdl") *ZEBU-test-directory*) + :grammar (find-grammar "hh-tdl")) + +(read-parser + "index := *avm* & + [ PERSON person, + NUMBER number, + GENDER gender]." + :grammar (find-grammar "hh-tdl")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Regular Expression Compiler +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(let ((*load-verbose* t)) + (load (merge-pathnames "regextst.lisp" *ZEBU-TEST-DIRECTORY*)) + + (zb:zebu-compile-file + (merge-pathnames "pb.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames + "pb.tab" + *ZEBU-TEST-BINARY-DIRECTORY*) + :compile-domain *ZEBU-compile-domain*)) + +(zb:zebu-load-file + (merge-pathnames "pb.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + +(unless (equal (zb:read-parser "FOO : bar." + :grammar (find-grammar "pb")) + '("FOO" BAR)) + (warn "Didn't parse pb grammar expression.")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Phone-and-E-Mail +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*) + (*load-verbose* t)) + (zb:zebu-compile-file "lieber.zb" + :output-file (merge-pathnames + "lieber.tab" + *ZEBU-TEST-BINARY-DIRECTORY*) + :compile-domain *ZEBU-compile-domain*)) + +(defclass e-mail-address () + ((person :initarg :person :accessor person) (host :initarg :host :accessor host))) + +(defclass host () ((domain-path :initarg :domain-path :accessor domain-path))) + +(defclass phone-number () + ((area-code :initarg :area-code :accessor area-code) (exchange :initarg :exchange :accessor exchange) + (extension :initarg :extension :accessor extension))) + +(zb:zebu-load-file + (merge-pathnames "lieber.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + +(find-grammar "Phone-and-E-Mail") + + +;; This doesn't work... +(read-parser + "My name is Henry, my address is lieber at media.mit.edu and you can call me at (617) 253-0315" + :grammar (find-grammar "Phone-and-E-Mail")) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BibTeX +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#+HP300 +(let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*) + (*load-verbose* t)) + (zb:zebu-compile-file "bibtex.zb" + :output-file (merge-pathnames + "bibtex.tab" *ZEBU-TEST-BINARY-DIRECTORY*) + :compile-domain *ZEBU-compile-domain*)) + +#+HP300 +(let ((*default-pathname-defaults* *ZEBU-TEST-BINARY-DIRECTORY*)) + (zb:zebu-load-file "bibtex.tab")) + +#+HP300 +(read-parser "@TechReport{allen81a, +key\"allen81a\", +author \"ALLEN, J.F.\", +title \"Maintaining Knowledge About Temporal Intervals, TR 86\", +institution \"University of Rochester, Department of Computer Science\", +year \"1981\"}" :grammar (find-grammar "bibtex")) +#+HP300 +(progn + (file-parser "~/notes/lit/bib/time.bib" :grammar (find-grammar "bibtex") + :print-parse-errors t :verbose nil) + + (file-parser "~/notes/lit/bib/functional-lang.bib" :grammar (find-grammar "bibtex") + :print-parse-errors t :verbose nil) + + + (file-parser "~/notes/lit/bib/cs.bib" :grammar (find-grammar "bibtex") + :print-parse-errors t :verbose nil) + + (file-parser "~/notes/lit/bib/planning.bib" :grammar (find-grammar "bibtex") + :print-parse-errors t :verbose nil)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; zebra-grammar.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#+HP300 +(defvar *ZEBRA-DIRECTORY* + (let ((d (pathname-directory *ZEBU-TEST-DIRECTORY*))) + (make-pathname :directory (append (subseq d 0 (- (length d) 2)) + (list "zebra" "zebra-release"))))) +#+HP700 +(defvar *ZEBRA-DIRECTORY* + (let ((d (pathname-directory *ZEBU-TEST-DIRECTORY*))) + (make-pathname :directory (list "zebra" "zebra-release")))) + + + +#+(OR :HP300 :HP700) +(when (and (boundp '*ZEBRA-DIRECTORY*) (probe-file *ZEBRA-DIRECTORY*)) + (let ((*default-pathname-defaults* *ZEBRA-DIRECTORY*) + (*load-verbose* t)) + (load "ZEBRA-system")) + ) + +#+(OR :HP300 :HP700) +(progn +(compile-system "ZEBRA") +(load-system "ZEBRA") + +(let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*) + (*load-verbose* t)) + (zb:zebu-compile-file "zebra-grammar.zb" + :output-file (merge-pathnames + "zebra-grammar.tab" + *ZEBU-TEST-BINARY-DIRECTORY*) + :compile-domain *ZEBU-compile-domain*)) + +(let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*) + (*load-verbose* t)) + (zb:zebu-load-file (merge-pathnames "zebra-grammar.tab" + *ZEBU-TEST-BINARY-DIRECTORY*))) + +(zb:read-parser "Rule string2terminal := + #1 stringp(#1) --> terminal:[(-string #1)];" + :grammar (zb:find-grammar "zebra-grammar")) + +(defun zebra-read-string (s) + (zb:read-parser s :grammar (zb:find-grammar "zebra-grammar"))) + +(zebra-read-string "Rule string2terminal := + #1 stringp(#1) --> terminal:[(-string #1)];") +(zebra-read-string "Rule R1 := bar:[(-slot {...})] --> baz:[(-slot {a,b})]; ") +(zebra-read-string "rule t1 := a:[] --> test:[];") +(zebra-read-string "rule t1 := a --> test:[];") +(zebra-read-string "rule t1 := a --> [test];") +(zebra-read-string "rule t1 := a --> b;") + +(setq zebu:*current-grammar* (zb:find-grammar "zebra-grammar")) +;;(zebu::print-collection nil) +(zebu::print-productions) + +(let ((zb:*preserve-case* t)) + (zebra-read-string "Rule t1:=a --> test;")) + +(let ((zb:*preserve-case* t) + (s " Rule t1:=a --> test;")) + (string= s (format nil "~a" (zebra-read-string s)))) + +;;(zb:file-parser (merge-pathnames "zebra-parser.za" *ZEBU-TEST-DIRECTORY*)) +) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; time +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#+(and LUCID HP300) +(let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*)) + (zb:zebu-load-file + (zb:zebu-compile-file "time.zb" + :output-file (merge-pathnames + "time.tab" *ZEBU-TEST-BINARY-DIRECTORY*) + :compile-domain *ZEBU-compile-domain*)) + + ) +#+(and LUCID HP300) +(progn + (zebu::print-actions "time") + (zebu::print-productions)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Kleene+ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(let ((zebu:*allow-conflicts* t) + (*generate-domain* t)) + (compile-slr-grammar (merge-pathnames "ex5.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames "ex5.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + ) +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames "ex5.tab" *ZEBU-TEST-BINARY-DIRECTORY*))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; circular print +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(let ((zebu:*allow-conflicts* t) + (*generate-domain* t)) + (compile-slr-grammar (merge-pathnames "ex7.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames "ex7.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + ) +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames "ex7.tab" *ZEBU-TEST-BINARY-DIRECTORY*))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Kleene + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(let ((*generate-domain* t)) + (compile-slr-grammar (merge-pathnames "ex8.zb" *ZEBU-TEST-DIRECTORY*) + :output-file (merge-pathnames "ex8.tab" *ZEBU-TEST-BINARY-DIRECTORY*)) + ) +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames "ex8.tab" *ZEBU-TEST-BINARY-DIRECTORY*))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bug-exp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-load-test-file (file) + (let ((*default-pathname-defaults* *ZEBU-TEST-DIRECTORY*)) + (zb:zebu-load-file + (zb:zebu-compile-file (format nil "~a.zb" file) + :output-file (merge-pathnames + (format nil "~a.tab" file) + *ZEBU-TEST-BINARY-DIRECTORY*) + :compile-domain *ZEBU-compile-domain*)) + )) + +(let () + (compile-load-test-file "bug-exp") + (compile-load-test-file "bug-exp1") + (compile-load-test-file "bug-exp2") + (compile-load-test-file "bug-exp3") + ) + +(equal (read-parser "STRING (30)" + :grammar (zb:find-grammar "bug-exp")) + (read-parser "STRING (30)" + :grammar (zb:find-grammar "bug-exp1"))) + +(equal (read-parser "STRING (30)" + :grammar (zb:find-grammar "bug-exp2")) + (read-parser "STRING (30)" + :grammar (zb:find-grammar "bug-exp3"))) + +(equal (let ((*preserve-case* t)) + (read-parser "fooBar" + :grammar (zb:find-grammar "bug-exp3"))) + "fooBar") + +;;(debug-parser) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Monitoring the Zebu compiler (in Lucid CL) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; in fresh CL: +#|| +(set-working-directory *ZEBU-directory*) +(load "ZEBU-sys.lisp") +(compile-system 'Zebu-compiler) +(with-monitored-definitions (load-system 'Zebu-compiler)) +(set-working-directory "../nll/") +(load "NLL-sys.lisp") +(start-monitoring) +(time (compile-module "nll-grammar")) +(summarize-monitors :number-of-calls t) + +(start-monitoring) +(time (compile-module "ex1")) +(SUMMARIZE-MONITORS) + +(reset-monitors) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of exercise.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/fsg.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/fsg.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,224 @@ +;;; -*- Mode: Fundamental; Syntax: ZEBU; Package: NLL -*- + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; file: fsg.zb +;;; module: TFS-2 +;;; version: 2.0, Zebu 3.2.8. with Meta Grammar +;;; written by: Karsten Konrad (konrad at dfki.uni-sb.de) +;;; last update: 7-Sep-1994 +;;; updated by: KaKo +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; author | date | modification +;;; ------------------|-------------|------------------------------------------ +;;; | | +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Grammar for Typed Feature Structures (TFS) using MetaGrammar of Zebu. +;;; +;;; The grammar's syntax is according to UDiNe (Backofen). +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(:name "tfs-g2" + :grammar "zebu-mg" + :identifier-continue-chars + ":$+-_*.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :identifier-start-chars + "$+-_*.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :domain-file "tfs-d2" + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Domain Definition +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +fs-object := kb-domain:[(-extras)]; + +feat-term := fs-object:[]; + +;; type expressions for typed terms + +fs-type-expr := fs-object:[]; + +fs-type := fs-type-expr:[(-type)(-sort-p)]; +fs-atomar := fs-type-expr:[(-value)]; +fs-type-conj := fs-type-expr:[(-types)]; +fs-type-disj := fs-type-expr:[(-types)]; +fs-type-neg := fs-type-expr:[(-type)]; + +;; other objects + +label-value-pair := fs-object:[(-label)(-value)] + << print-function: print-label-value-pair >>; + +neg-var := fs-object:[(-number)]; +neg-vars := fs-object:[(-members)]; + +fs-var := feat-term:[(-number)(-var-bound)(-neg-vars)]; + +tagged-term := feat-term:[(-tag)(-term)]; + +typed-fs-term := feat-term:[(-type)(-conj)]; + +fs-atom := feat-term:[(-value)] + << print-function: print-fs-atom >>; + +negative-atoms := feat-term:[(-atoms)]; + +fs-conj-term := feat-term:[(-lvps)] + << print-function: print-fs-conj-term >>; + +fs-disj-term := feat-term:[(-members)] + << print-function: print-fs-disj-term >>; + +fs-list := feat-term:[(-first)(-rest)]; + +empty-fs-list := feat-term:[]; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Syntax Rules +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +Feature-Term --> + Untagged-Term | + Tagged-Term | + FS-Var; + +Tagged-Term --> + FS-Var "=" Untagged-Term + {Tagged-Term:[(-tag FS-VAR)(-term Untagged-Term)]}; + +Untagged-Term --> + Pos-Untagged-Term | + Negative-Atoms; + +Negative-Atoms --> + "-(" FS-Atom + " " ")" + {Negative-Atoms:[(-atoms FS-Atom+)]}; + +Pos-Untagged-Term --> + Typed-Fs-Term | + FS-Conj-Term | + FS-Disj-Term | + FS-List | + FS-Atom; + +Typed-Fs-Term --> + Type-Expr Fs-Conj-Term + {Typed-Fs-Term:[(-type Type-Expr) + (-conj Fs-Conj-Term)]}; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Lists +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +FS-List --> + "nil" + {empty-fs-list:[]} | + "<" ">" + {empty-FS-List:[]} | + "<" Feature-Term ">" + {FS-List:[(-first Feature-Term) + (-rest empty-FS-List)]} | + "<" Feature-Term FS-List-Rest ">" + {FS-List:[(-first Feature-Term) + (-rest FS-List-Rest)]}; + +FS-List-Rest --> + Feature-Term.1 "." Feature-Term.2 + {FS-List:[(-first Feature-Term.1) + (-rest Feature-Term.2)]} | + Feature-Term FS-List-Rest + {FS-List:[(-first Feature-Term) + (-rest FS-List-Rest)]} | + Feature-Term + {FS-List:[(-first Feature-Term) + (-rest Empty-FS-List)]}; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Conj Terms +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +FS-Conj-Term --> + "[" Label-Value-Pair * " " "]" + {FS-Conj-Term:[(-lvps Label-Value-Pair*)]}; + +FS-Disj-Term --> + "{" Feature-Term + "," "}" + {FS-Disj-Term:[(-members Feature-Term+)]}; + + +FS-Atom --> + IDENTIFIER + {FS-Atom:[(-value IDENTIFIER)]} | + NUMBER + {FS-Atom:[(-value NUMBER)]} | + STRING + {FS-Atom:[(-value STRING)]}; + + +Label-Value-Pair --> + "(" IDENTIFIER Feature-Term ")" + {Label-Value-Pair:[(-label IDENTIFIER) + (-value Feature-Term)]}; + +FS-Var --> + "%" Number + {Fs-Var:[(-number Number)]} | + "%" Number Neg-Vars + {Fs-Var:[(-number Number) + (-neg-vars Neg-Vars)]}; + +Neg-Vars --> + "(" Neg-Var + " " ")" + {Neg-Vars:[(-members Neg-Var+)]}; + +Neg-Var --> + "-" "%" Number + {Neg-Var:[(-number Number)]}; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; TDL Types +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +Atomar --> + "(" ":atom" Identifier ")" + {FS-Atomar:[(-value Identifier)]} | + "(" ":atom" Number ")" + {FS-Atomar:[(-value Number)]} | + "(" ":atom" String ")" + {FS-Atomar:[(-value String)]}; + +Conjunction --> + "(" ":and" TYPE + " " ")" + {FS-Type-Conj:[(-types TYPE+)]}; + +Disjunction --> + "(" ":or" TYPE + " " ")" + {FS-Type-Disj:[(-types TYPE+)]}; + +Negation --> + "(" ":not" TYPE ")" + {FS-Type-Neg:[(-type TYPE)]}; + +;; Type can be printed with (:type ) or +;; ugly syntax convention, but no problem on this side. +;; (replaced by syntax transformation) + +Type-Expr --> + "(" ":type" Type ")" + {FS-Type:[(-type Type)]} | + "(" ":type" Type ":sort-p" Identifier ")" + {FS-Type:[(-type Type)(-sort-p Identifier)]} | + Type; + +Type --> + Identifier | + Conjunction | + Disjunction | + Negation | + Atomar; + + + \ No newline at end of file Added: vendor/zebu/test/g0.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/g0.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,34 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: g0.zb +; Description: Zebu Grammar: Simple Expressions +; Author: Joachim H. Laubsch +; Language: CL +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "G0") + +(defrule Program := ( "begin" Stmts "end" ) ) + +(defrule Stmts := ( SimpleStmt ";" Stmts) + := ( "begin" Stmts "end" ";" Stmts ) + := () ) +(defrule SimpleStmt := Identifier) + +#|| +(set-working-directory *ZEBU-test-directory*) +(let ((*load-verbose* t)) + (compile-slr-grammar "g0.zb")) +(setq zebu:*current-grammar* + (zebu-load-file "g0.tab")) +(progn (format t "symbols: ") (terpri) (zebu::cruise-symbols-2)) +(zebu::print-collection t) +(zb::cruise-first-sets) +(zb::cruise-follow-sets) +(zb::read-parser "begin A; B; end") + +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of g0.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/g1.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/g1.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,36 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: g1.zb +; Description: Grammar Example g1 from Fischer&LeBlanc +; Author: Joachim H. Laubsch +; Language: Zebu +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "g1") + +(defrule S := E) + +(defrule E := (E "+" Term) + := Term) + +(defrule Term := Identifier + := ( "(" E ")" ) ) + +#|| +(setf (SYSTEM::environment-variable "zebutest") "~/hpnlrw/zebu/test") + +(let ((*load-verbose* t)) + (compile-slr-grammar + (merge-pathnames "g1.zb" *ZEBU-test-directory*))) + +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames "g1.tab" *ZEBU-test-directory*))) +(progn (format t "symbols: ") (terpri) (zebu::cruise-symbols-2)) +(zebu::print-collection t) +(zebu::calculate-first-sets) +(setq $i (third (zb::oset-item-list zb::f-i-set))) +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of g1.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/g2.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/g2.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,36 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: g1.zb +; Description: Zebu Grammar Example with useless nonterminals +; Author: Joachim H. Laubsch +; Language: CL +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "g1") + +(defrule S := A + := B) + +(defrule A := "a") + +(defrule B := (B "b") ) + +(defrule C := "c") + +#|| +(setf (SYSTEM::environment-variable "zebutest") "~/hpnlrw/zebu/test") +(let ((*load-verbose* t)) + (compile-slr-grammar + (merge-pathnames "g1.zb" *ZEBU-test-directory*))) +;;; Warning: The following non-terminals where defined but not used: C + +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames "g1.tab" *ZEBU-test-directory*))) +(progn (format t "symbols: ") (terpri) (zebu::cruise-symbols-2)) +(zebu::print-collection t) + +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of g1.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/hh-tdl.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/hh-tdl.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,93 @@ +(:name "hh-tdl" + :grammar "zebu-mg" + :package "CL-USER" + :identifier-continue-chars + "$*-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :identifier-start-chars + "$*-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" +) +;; ENRICH 'lex-cats' !!! (to handle '*avm*'...) +;; :lex-cats ((Identifier "[A-z]+")) +;; + +;; Domain definition +;; skip 'options,' optional expressions to begin + +;; REORGANIZE W.R.T. KB-DOMAIN ??? +;; (ISN'T THIS OPTIONAL ANYWAY ??) +;; CREATE GLOBAL HIERARCHY??? (how to break down?) + +Type-Feat := kb-domain: []; + +Type-Def := Type-Feat: [(-type Identifier) (-def)]; +;; 1st restricted, 2nd generic ?!! +;; return what, where? +;; are these things nested?? + +AVM-Def := Type-Feat: [(-body)]; +;; unique labels? case sensitivity?? + +Disjunction := Type-Feat: [(-terms)]; + Disj-Inc := Disjunction: []; + Disj-Exc := Disjunction: []; +;; (dis)advantages of specificity? + +Conjunction := Type-Feat: [(-terms)]; + +Feature-Term := Type-Feat: [(-terms)]; + +Attr-Val := Type-Feat: [(-attr-path) (-val)]; + + + +;; Productions + + +Type-Def --> Type AVM-Def "." + {Type-Def: [(-type Type) + (-def AVM-Def)]}; + +;; | Type Subtype-Def "." +;; {Type-Def: [(-type Type) +;; (-def Subtype-Def)]}; + + +AVM-Def --> ":=" Body + {AVM-Def: [(-body Body)]}; + +Body --> Disjunction; +;;currently transparent, soon to include the following... +;; {Body: [(-disj Disjunction) +;; (-const Constraint+)]} + +Disjunction --> Conjunction+ "|" + {Disj-Inc: [(-terms Conjunction+)]} | + Conjunction+ "^" + {Disj-Exc: [(-terms Conjunction+)]}; +;; "+" vs. "*" ? +;; tricky tricky! + +Conjunction --> Term+ "&" + {Conjunction: [(-terms Term+)]}; + +Term --> Type | + Feature-Term; + +Feature-Term --> "[" Attr-Val* "," "]" + {Feature-Term: [(-terms Attr-Val*)]}; +;; "*" vs. "+" ? +;; tricky tricky! + +Attr-Val --> Attribute+ "." + {Attr-Val: [(-attr-path Attribute+) + (-val NIL)]} + + | Attribute+ "." Disjunction + {Attr-Val: [(-attr-path Attribute+) + (-val Disjunction)]}; +;; what about paths -- sufficiently general?? + +Type --> Identifier; + +Attribute --> Identifier; + \ No newline at end of file Added: vendor/zebu/test/hh-test.tdl ============================================================================== --- (empty file) +++ vendor/zebu/test/hh-test.tdl Wed Oct 17 09:04:46 2007 @@ -0,0 +1,6 @@ +index := *avm* & + [ PERSON person, + NUMBER number, + GENDER gender]. + + \ No newline at end of file Added: vendor/zebu/test/lex1.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/lex1.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,80 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: lex1.zb +; Description: Zebu Grammar: Simple Expressions +; Author: Joachim H. Laubsch +; Language: CL +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "lex1" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-start-chars + "-abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + ) + +;; Domain definition + +Program := [(-stmts kb-sequence)]; +Combination := [(-function) (-arg)]; +Quantity := [(-dim) (-val)]; +Dimension := [(-val)]; + +;; rules + +Program --> "begin" Stmt+ " " "end" + { Program: [(-stmts Stmt+)] } ; + +Stmt --> Identifier | Quantity | Appl | Program ; + +Appl --> Identifier "(" Arg* " " ")" + {Combination: [(-function Identifier) (-arg Arg*)]}; + +Arg --> Identifier | Number | Appl | Quantity ; + +Quantity --> "<" Dimension "." Number ">" + {Quantity: [(-dim Dimension) (-val Number)]}; + +Dimension --> "#" Identifier + {Dimension: [(-val Identifier)]} ; + +#|| +(set-working-directory *ZEBU-test-directory*) +(let ((*load-verbose* t)) + (zb:compile-slr-grammar "lex1.zb" + :output-file (merge-pathnames + "binary/lex1.tab" + *ZEBU-test-directory*) + :verbose t)) +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames + "binary/lex1.tab" *ZEBU-test-directory*) + :verbose t)) + +(zb::read-parser "begin <#k . 1> end") +(zb::read-parser "begin <#k . .1> end") +(zb::read-parser "begin <#K . 2.1> end") + +(zebu::print-collection t) +(zb::cruise-first-sets) +(zb::cruise-follow-sets) +(zebu::print-productions) +(zebu::print-actions "lex1") + +(zb::read-parser "begin A end") +(zb::read-parser "begin A B C end") +(zb::read-parser "begin A begin B1 B2 end C end") +(zb::read-parser "begin f() end") +(zb::read-parser "begin f(a) end") +(zb::read-parser "begin f(1) end") +(zb::read-parser "begin A f(1) end") +(zb::read-parser "begin f(1 2) end") +(zb::read-parser "begin f(1) A end") +(zb::read-parser "begin f(g(a)) A end") +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of lex1.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/lieber.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/lieber.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,82 @@ +;; This is a Zebu grammmar that recognizes phone numbers and e-mail addresses in free text. +;; Henry Lieberman 2 February 1995 + +(:name "Phone-and-E-Mail" + :identifier-start-chars "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!#%*^&:;,?/|\\~`+='" + :identifier-continue-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") +;; + +(defrule Words + := () + := (Word) + :build (:form (list Word)) + := (Word Words) + :build (:form (cons Word Words)) + ) + +(defrule Word + := Identifier + := Number + := Phone-Number + := E-Mail-Address) + +(defrule Phone-Number + ;; Example: 253-0315 + := (Number.1 "-" Number.2) + :build (:form (make-instance 'phone-number :exchange Number.1 :extension Number.2)) + ;; Example: (617) 253-0315 + := ("(" Number ")" Phone-Number) + :build (:form (make-instance 'phone-number + :area-code Number + :exchange (exchange Phone-Number) + :extension (extension Phone-Number)))) + +;; I didn't put anything about restricting to seven digits, etc. + +(defrule Host + ;; Example: media.mit.edu + := (Identifier) + :build (:form (make-instance 'host :domain-path (list Identifier))) + := (Identifier "." Host) + :build (:form (make-instance 'host :domain-path (cons Identifier (domain-path Host))))) + +(defrule E-Mail-Address + ;; Example: lieber at media.mit.edu + := (Identifier "@" Host) + :build (:form (make-instance 'e-mail-address :person Identifier :host Host))) + + + +#|| + + +(defclass e-mail-address () + ((person :initarg :person :accessor person) (host :initarg :host :accessor host))) + +(defclass host () ((domain-path :initarg :domain-path :accessor domain-path))) + +(defclass phone-number () + ((area-code :initarg :area-code :accessor area-code) (exchange :initarg :exchange :accessor exchange) + (extension :initarg :extension :accessor extension))) + +(compile-and-load-grammar "Phone-and-E-Mail") ;; in file Phone-and-E-Mail.zb + + +;; This doesn't work... +(read-parser + "My name is Henry, my address is lieber at media.mit.edu and you can call me at (617) 253-0315" + :grammar (find-grammar "Phone-and-E-Mail")) + +;; Having trouble with . and @ characters ... + +;; But this does... +(read-parser + "My name is Henry, my address is lieber @ media . mit . edu and you can call me at (617) 253-0315" + :grammar (find-grammar "Phone-and-E-Mail")) + + +||# + + + + \ No newline at end of file Added: vendor/zebu/test/lr4-21.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/lr4-21.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,46 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: lr4-21.zb +; Description: grammar (4.21) on page 231 of Dragon +; Author: Joachim H. Laubsch +; Created: 20-Mar-91 +; Modified: Thu Oct 2 12:57:09 1997 (Joachim H. Laubsch) +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1991, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "lr4-21" + :domain-file "lr4-dom" + :package "CL-USER" + :grammar "null-grammar" + :identifier-start-chars "$-?abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars "$-_?.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890") + +(defrule S + := (L "=" R) + :build (list 'S L "=" R) + + := R + :build (list 'S R)) + +(defrule L + := ("*" R) + :build (list 'L "*" R) + + := IDENTIFIER) + +(defrule R + := NUMBER + :build (list 'R NUMBER) + + := L + :build (list 'R L)) + + + + \ No newline at end of file Added: vendor/zebu/test/mini-la.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/mini-la.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,88 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: mini-la.zb +; Description: Zebu Grammar: Simple Expressions +; Author: Joachim H. Laubsch +; Language: CL +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "mini-la" + :domain-file "minl-dom" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-start-chars + "-abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + ) + +;; Domain definition + +Program := [(-stmts kb-sequence)]; +Combination := [(-function) (-args kb-sequence)]; +Tuple := [(-members kb-sequence)]; +Za-Set := [(-members Za-Set-Part)]; +Za-Set-Part := Za-List:[(-arg)(-nextargs)]; + +;; Rules + +Program --> "begin" Stmt+ ";" "end" + { Program: [(-stmts Stmt+)] } ; + +Stmt --> Identifier | Appl | Program ; + +Appl --> Identifier "(" Arg* "," ")" + {Combination: [(-function Identifier) (-args Arg*)]}; + +Arg --> Identifier | Number | Appl | Tuple | Set ; + +Tuple --> "<" Arg+ " " ">" + { Tuple: [(-members Arg+)] }; + +Set --> "{" Set-Arg-Seq "}" { Za-Set: [(-members Set-Arg-Seq)]}; + +Set-Arg-Seq --> + List-Arg "," Set-Arg-Seq + {Za-Set-Part:[(-arg List-Arg) + (-nextargs Set-Arg-Seq)]} | + List-Arg + {Za-Set-Part:[(-arg List-Arg)]}; + +List-Arg --> Arg; + +#|| +(set-working-directory *ZEBU-test-directory*) +(let ((*load-verbose* t)) + (zb:compile-slr-grammar "mini-la.zb" + :output-file (merge-pathnames + "binary/mini-la.tab" + *ZEBU-test-directory*))) +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames + "binary/mini-la.tab" *ZEBU-test-directory*))) + +(zebu::print-collection t) +(zb::cruise-first-sets) +(zb::cruise-follow-sets) +(zebu::print-productions) +(zebu::print-actions "mini-la") + +(zb::read-parser "begin A; B ; C end") +(zb::read-parser "begin A; begin B1; B2 end ; C end") +(zb::read-parser "begin f() end") +(zb::read-parser "begin f(a) end") +(zb::read-parser "begin f(1) end") +(zb::read-parser "begin A; f(1) end") +(zb::read-parser "begin f(1,2) end") +(zb::read-parser "begin f(1,2,g(3,4,5)) end") +(zb::read-parser "begin f(1); A end") +(zb::read-parser "begin f(g(a)); A end") +(zb::read-parser "begin f(g(a)); A; f(1,2,g(3,4,5)) end") +(zb::read-parser "begin end(begin) end") +(zb::read-parser "begin end() end") +(zb::read-parser "begin a(&&) end; ") +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of mini-la.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/mini.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/mini.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,66 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: mini.zb +; Description: Zebu Grammar: Simple Expressions +; Author: Joachim H. Laubsch +; Language: CL +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "mini" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-start-chars + "-abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + ) + +;; Domain definition + +Program := [(-stmts kb-sequence)]; +Combination := [(-function) (-arg)]; + +;; rules + +Program --> "begin" Stmt+ " " "end" + { Program: [(-stmts Stmt+)] } ; + +Stmt --> Identifier | Appl | Program ; + +Appl --> Identifier "(" Arg* " " ")" + {Combination: [(-function Identifier) (-arg Arg*)]}; + +Arg --> Identifier | Number | Appl ; +#|| +(set-working-directory *ZEBU-test-directory*) +(let ((*load-verbose* t)) + (compile-slr-grammar "mini.zb" + :output-file (merge-pathnames + "binary/mini.tab" + *ZEBU-test-directory*))) +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames + "binary/mini.tab" *ZEBU-test-directory*))) + +(zebu::print-collection t) +(zb::cruise-first-sets) +(zb::cruise-follow-sets) +(zebu::print-productions) +(zebu::print-actions "mini") + +(zb::read-parser "begin A end") +(zb::read-parser "begin A B C end") +(zb::read-parser "begin A begin B1 B2 end C end") +(zb::read-parser "begin f() end") +(zb::read-parser "begin f(a) end") +(zb::read-parser "begin f(1) end") +(zb::read-parser "begin A f(1) end") +(zb::read-parser "begin f(1 2) end") +(zb::read-parser "begin f(1) A end") +(zb::read-parser "begin f(g(a)) A end") + +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of mini.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/pb.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/pb.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,14 @@ + +(:grammar "null-grammar" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :lex-cats ( + (node-name "[A-Z]+") + )) + +(defrule datr-theorem + := (node-name ":" identifier ".") + :build(:form + (list node-name identifier))) + + \ No newline at end of file Added: vendor/zebu/test/pc.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/pc.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,41 @@ +; -*- mode: Lisp -*- --------------------------------------------------- ; +; File: pc.zb +; Description: propositional calculus +; Author: Joachim H. Laubsch +; Created: 15-Aug-91 +; Modified: Thu Oct 2 12:57:16 1997 (Joachim H. Laubsch) +; Language: Lisp +; Package: USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1991, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "pc" + :domain-file "pc-dom" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890") + +(defrule Formula + := Propositional-variable + := Boolean-Expr + := ( "(" Formula ")" ) + :build (progn Formula) + ) + +(defrule Propositional-Variable + := Identifier) + +(defrule Boolean-Expr + := (Formula.1 Boolean-Op Formula.2) + :build (list Boolean-Op Formula.1 Formula.2) + ) + +(defrule Boolean-Op + := "and" + := "or" + ) + \ No newline at end of file Added: vendor/zebu/test/pc1-p.lisp ============================================================================== --- (empty file) +++ vendor/zebu/test/pc1-p.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,56 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: pc1-p.lisp +; Description: +; Author: Joachim H. Laubsch +; Created: 13-Apr-92 +; Modified: Thu Oct 2 12:57:16 1997 (Joachim H. Laubsch) +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "CL-USER") + +(defun PRINT-PROPOSITIONAL-VARIABLE (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "~S" + (PROPOSITIONAL-VARIABLE--name ITEM))) + +(defun PRINT-BOOLEAN-OR (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "~S or ~S" + (BOOLEAN-EXPR--RAND1 ITEM) + (BOOLEAN-EXPR--RAND2 ITEM))) + +(defun PRINT-BOOLEAN-AND (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "~S and ~S" + (BOOLEAN-EXPR--RAND1 ITEM) + (BOOLEAN-EXPR--RAND2 ITEM))) + +(defun print-atomic-wff (item stream level) + (declare (ignore level)) + (format stream + "~a(~a)" + (atomic-wff--predicate item) + (atomic-wff--role-argument-pairs item))) + +(defun print-role-argument-pair (item stream level) + (declare (ignore level)) + (format stream + "~a: ~a" + (role-argument-pair--role item) + (role-argument-pair--argument item))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; end of pc1-p.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/pc1.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/pc1.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,104 @@ +; -*- mode: Lisp -*- --------------------------------------------------- ; +; File: pc1.zb +; Description: propositional calculus +; Author: Joachim H. Laubsch +; Created: 15-Aug-91 +; Modified: Thu Oct 2 12:57:17 1997 (Joachim H. Laubsch) +; Language: Lisp +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1991, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "pc1" + :domain-file "pc1-dom" + :grammar "null-grammar" + :package "CL-USER" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :domain + (kb-domain + :subtype (Formula + :subtype (Propositional-variable + :slots (-name)) + :subtype (P-Formula :slots (-content)) + :subtype (Boolean-Expr + :slots ((-rand1 Formula) + (-rand2 Formula)) + :subtype Boolean-Or + :subtype Boolean-And) + :subtype (Atomic-Wff :slots + (-predicate + (-Role-Argument-Pairs KB-sequence)))) + :subtype (Role-Argument-Pair :slots (-Role -Argument))) + ) + +;; productions + +(defrule formula + := Propositional-variable + + := Boolean-Expr + + := ( "(" Formula ")" ) + :build (:form (progn Formula)) + + := Atomic-Wff + ) + +(defrule Propositional-Variable + := Identifier + :build (:type Propositional-variable + :map ((Identifier . :-name))) + ) + +(defrule Boolean-Expr + := (Formula.1 "and" Formula.2) + :build (:type Boolean-And + :map ((Formula.1 . :-rand1) + (Formula.2 . :-rand2))) + + := (Formula.1 "or" Formula.2) + :build (:type Boolean-Or + :map ((Formula.1 . :-rand1) + (Formula.2 . :-rand2))) + ) + +(defrule Atomic-Wff + := (Identifier "(" Role-Argument-Pairs ")") + :build (:type Atomic-Wff + :map ((Identifier . :-predicate) + (Role-Argument-Pairs . :-Role-Argument-Pairs)) + )) + +(defrule Role-Argument-Pairs + := () + + := (Role-Argument-Pair Role-Argument-Pairs) + :build (:type KB-Sequence + :map ((Role-Argument-Pair . :first) + (Role-Argument-Pairs . :rest))) + ) + +(defrule Role-Argument-Pair + := (Identifier ":" Term) + :build (:type Role-Argument-Pair + :map ((Identifier . :-Role) + (Term . :-Argument))) + ) + +(defrule Term + := Identifier + := Number) + +#|| +(set-working-directory *ZEBU-test-directory*) +(zebu-compile-file "pc1.zb" :output-file "binary/pc1.tab") +(zebu-load-file "binary/pc1.tab") + +||# + \ No newline at end of file Added: vendor/zebu/test/pc2.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/pc2.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,100 @@ +; -*- mode: CL -*- --------------------------------------------------- ; +; File: pc2.zb +; Description: Propositional Calculus Grammar with AVM Semantics +; Author: Joachim H. Laubsch +; Created: 15-Aug-91 +; Modified: Thu Oct 2 12:57:21 1997 (Joachim H. Laubsch) +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1991, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "pc2" + :domain-file "pc2-dom" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :domain-file "pc2-domain" + ) + +;; Domain definition + +Formula := kb-domain: []; + + Propositional-variable := Formula: [ (-name) ]; + P-Formula := Formula: [ (-content) ]; + Boolean-Expr := Formula: [ (-rand1 Formula) (-rand2 Formula)]; + Boolean-Or := Boolean-Expr: []; + Boolean-And := Boolean-Expr: []; + Atomic-Wff := Formula: [ (-predicate) + (-Role-Argument-Pairs + kb-sequence) ]; + +Role-Argument-Pair := kb-domain: [(-Role) (-Argument)]; + +;; Productions + +Formula --> Propositional-variable + | Boolean-Expr + | "(" Formula ")" { P-Formula:[(-content Formula)] } + | Atomic-Wff ; + +Propositional-Variable + --> Identifier {Propositional-variable: [(-name Identifier)]} ; + +Boolean-Expr --> Formula.1 "and" Formula.2 + {Boolean-And: + [(-rand1 Formula.1) + (-rand2 Formula.2)]} + + | Formula.1 "or" Formula.2 + {Boolean-Or: + [(-rand1 Formula.1) + (-rand2 Formula.2)]}; + +Atomic-Wff --> Identifier "(" Role-Argument-Pairs ")" + { Atomic-Wff: + [(-predicate Identifier) + (-Role-Argument-Pairs Role-Argument-Pairs)] }; + +Role-Argument-Pairs --> + + | Role-Argument-Pair Role-Argument-Pairs + { KB-sequence: + [(first Role-Argument-Pair) + (rest Role-Argument-Pairs)] } ; + +Role-Argument-Pair --> Identifier ":" Term + {Role-Argument-Pair: + [(-Role Identifier) + (-Argument Term)]}; + +Term --> Identifier | Number ; + +#|| +(set-working-directory *ZEBU-test-directory*) +(zb:compile-slr-grammar "pc2.zb" + :output-file (merge-pathnames + "binary/pc2.tab" + *ZEBU-test-directory*)) +(zb:zebu-load-file (merge-pathnames "binary/pc2.tab" *ZEBU-test-directory*)) +(zebu::print-actions "pc2") + +(zb:read-parser "walks(agent: John)" :grammar (zb:find-grammar "pc2")) + +(zb:read-parser "walks(agent: John time: 12)" :grammar (zb:find-grammar "pc2")) + +(zb:read-parser "(walks(agent: John))" :grammar (zb:find-grammar "pc2")) + +(zb:read-parser "walks(agent: John) and talks(agent: John)" :grammar (zb:find-grammar "pc2")) + +(zb:read-parser "walks(agent: John) and talks(agent: John) and Q" :grammar (zb:find-grammar "pc2")) + +||# + \ No newline at end of file Added: vendor/zebu/test/pc3.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/pc3.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,102 @@ +; -*- mode: CL -*- --------------------------------------------------- ; +; File: pc3.zb +; Description: Propositional Calculus Grammar with AVM Semantics +; Author: Joachim H. Laubsch +; Created: 15-Aug-91 +; Modified: Thu Oct 2 12:57:22 1997 (Joachim H. Laubsch) +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1991, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "pc3" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :domain-file "pc3-domain" + :domain + (kb-domain + :subtype (Formula + :subtype (Propositional-variable + :slots (-name)) + :subtype (P-Formula :slots (-content)) + :subtype (Boolean-Expr + :slots ((-rand1 Formula) + (-rand2 Formula)) + :subtype Boolean-Or + :subtype Boolean-And)) + :subtype (Atomic-Wff :slots (-predicate + (-Role-Argument-Pairs KB-Sequence))) + :subtype (Role-Argument-Pair :slots (-Role -Argument)) + ) + ) + +Formula --> Propositional-variable + | Boolean-Expr + | "(" Formula ")" { type: P-Formula + [(-content Formula)] } + | Atomic-Wff ; + +Propositional-Variable + --> Identifier { type: Propositional-variable + [(-name Identifier)] } ; + +Boolean-Expr --> Formula.1 "and" Formula.2 + { type: Boolean-And + [(-rand1 Formula.1) + (-rand2 Formula.2)] } + + | Formula.1 "or" Formula.2 + { type: Boolean-Or + [(-rand1 Formula.1) + (-rand2 Formula.2)] } ; + +Atomic-Wff --> Identifier "(" Role-Argument-Pairs ")" + { type: Atomic-Wff + [(-predicate Identifier) + (-Role-Argument-Pairs Role-Argument-Pairs)] } ; + +Role-Argument-Pairs --> Role-Argument-Pair * " " ; + +Role-Argument-Pair --> Identifier ":" Term + { type: Role-Argument-Pair + [(-Role Identifier) + (-Argument Term)] } ; + +Term --> Identifier | Number ; + +#|| +(set-working-directory *ZEBU-test-directory*) +(zb:compile-lalr1-grammar "pc3.zb" + :output-file (merge-pathnames + "binary/pc3.tab" + *ZEBU-test-directory*)) +(zb:zebu-load-file (merge-pathnames "binary/pc3.tab" + *ZEBU-test-directory*)) +(zebu::print-actions "pc3") +(zebu::print-productions) + +(zb:read-parser "walks()" + :grammar (zb:find-grammar "pc3")) + +(zb:read-parser "walks(agent: John)" :grammar (zb:find-grammar "pc3")) + +(zb:read-parser "(walks(agent: John))" :grammar (zb:find-grammar "pc3")) + +(zb:read-parser "walks(agent: John) and talks(agent: John)" + :grammar (zb:find-grammar "pc3")) + +(zb:read-parser "walks( time: 12 agent: John)" + :grammar (zb:find-grammar "pc3")) + +(zb:read-parser "walks(agent: John time: 12) and talks(agent: John time: 13) and Q" + :grammar (zb:find-grammar "pc3")) + +||# + \ No newline at end of file Added: vendor/zebu/test/regextst.lisp ============================================================================== --- (empty file) +++ vendor/zebu/test/regextst.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,191 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: regextst.lisp +; Description: some tests for the regular expression compiler +; Author: Joachim H. Laubsch +; Created: 9-Feb-93 +; Modified: Thu Oct 2 12:57:23 1997 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1993, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +(setq *regex-debug* nil) +(defun match-beginning (n) + (first (AREF *REGEX-GROUPS* n))) + +(defun match-end (n) + (second (AREF *REGEX-GROUPS* n))) + +(defun regex-test (n pat string result &key invert) + (let ((form (regex-compile pat)) + *print-circle*) + (princ ".") + (if (eval `(let ((START 0) (END ,(LENGTH STRING)) (STRING ,string)) + . ,form)) + (let ((matched-string (subseq string 0 (match-end 0)))) + (if (string= matched-string result) + (if invert + (warn "In ~S ~A did not match correctly" n pat) + t) + (if invert + t + (warn "In ~S ~A did not match correctly~%Only ~S was matched!" + n pat matched-string)))) + (if invert + t + (warn "In ~S ~A did not compile correctly" n pat))))) + +(regex-test 1 "\\(na\\)x+\\1" "naxna" "naxna") +(regex-test 2 "\\(na\\)x+\\1" "naxna123" "naxna") + +(regex-test 3 "\\(na\\)x+" "naxxos" "naxx") +(regex-test 4 "\\(na\\)x+" "naxos" "nax") +(regex-test 5 "\\(na\\)x+" "naos" "na" :invert t) + +(regex-test 6 "\\(na\\)x*" "naxxos" "naxx") +(regex-test 7 "\\(na\\)x*" "naxos" "nax") +(regex-test 8 "\\(na\\)x*" "naos" "na") + +(regex-test 9 "[0-9]+" "123ab" "123") +(regex-test 10 "[a-zA-Z]+" "aAbb123" "aAbb") +(regex-test 11 "[0-9a-z]+" "1234&&*" "1234") +(regex-test 12 "[0-9a-z]+" "1234a&&*" "1234a") + +(regex-test 13 "[0-9a-zA-Z]+" "a1234a" "a1234a") +(regex-test 14 "[0-9a-zA-Z&]+" "aAbb123&&*" "aAbb123&&") + +(regex-test 15 "[0-9]+\\.[0-9]*" "0.123cm" "0.123") + +(regex-test 16 "{[^}\\n]*}" + "{M.D. Harrison and A. Monk (Ed.)} \n\t foo: 2" + "{M.D. Harrison and A. Monk (Ed.)}") + +(regex-test 17 "{[^}\\n]*}" + "{M.D. Harrison and +A. Monk (Ed.)} \n\t foo: 2" + "{M.D. Harrison and A. Monk (Ed.)}" :invert t) + + +(regex-test 18 "{[^}\\n]*}" + "{M.D. Harrison and {A. Monk} (Ed.)} \n\t foo: 2" + "{M.D. Harrison and {A. Monk} (Ed.)}" :invert t) + +(regex-test 19 "ca?r" "car" "car") + +(regex-test 20 "ca?r" "cr" "cr") + +(regex-test 21 "c[ad]+r" "caaar" "caaar") + +(regex-test 22 "c[ad]+r" "caaar aa1" "caaar") + +(regex-test 23 "c[ad]+r$" "caaar" "caaar") + +(regex-test 24 ".*" "" "") + +(regex-test 25 ".*" "aa" "aa") + +(regex-test 26 ".*" "aa" "aa") + +(regex-test 27 "c[ad]?r" "cr" "cr") + +(regex-test 28 "c[ad]?r" "car" "car") + +(regex-test 29 "c[ad]?r" "cdr" "cdr") + +(regex-test 30 "c[0-9]?r" "cr" "cr") + +(regex-test 31 "c[0-9]?r" "c9rxx" "c9r") + +(regex-test 32 "c[0-9]?r" "crxx" "cr") + + +;;(regex-test 27 "a\\|b" "a" "a") + +(regex-test 33 "ab.yz" "ab yz" "ab yz") + +(regex-test 34 "ab.yz" "ab +yz" "ab" :invert t) + +(regex-test 35 "\\(abc\\)\\1" "abcabc" "abcabc") + +(regex-test 36 "\\(abc\\)\\1x*\\(def\\)y*\\2" "abcabcxxxxdefyyyyyyydef$%%%%%" + "abcabcxxxxdefyyyyyyydef") + +;;(regex-test 37 "a|bc*" "a" "a") + +(let ((fn (def-regex-parser 'Natural_Number "[0-9]+"))) + (pprint fn) + (compile (eval fn))) + +(defun regex-test1 (number fn input output &optional invert) + (let* ((match (funcall fn input)) + (result (subseq input (match-beginning 0) (match-end 0))) + (test (and match + (> match 0) + (= (parse-integer result) output)))) + (if (if invert (not test) test) + (princ ".") + (warn "wrong match in ~d: ~a found" number result)) + (values))) + +(regex-test1 40 'Natural_Number "111" 111) + +(regex-test1 41 'Natural_Number "111 af" 111) + +(regex-test1 42 'Natural_Number "a111z" 0 t) + +(let ((fn (def-regex-parser 'Natural_Number* "[0-9]*"))) + ;; (pprint fn) + (eval fn)) + +(regex-test1 43 'Natural_Number* "111" 111) +(regex-test1 44 'Natural_Number* "111 af" 111) +(regex-test1 45 'Natural_Number* "a111z" 0 t) + +(unless (equal (Natural_Number "11aab" 0 4) 2) + (warn "No match")) + +(unless (equal (Natural_Number "11aab" 1 4) 2) + (warn "No match")) + +(when (equal (Natural_Number "1aab" 1 4) 2) + (warn "wrong match")) + +(let ((fn (def-regex-parser 'd_seq "d+"))) + (eval fn)) + +(let ((fn (def-regex-parser 'd_seq* "d*"))) + (eval fn)) + +(eval (def-regex-parser 'Rest_of_line ".+\$")) +(let* ((s "abcdef") (n (length s))) + (unless (equal (REST_OF_LINE s 1 n) n) + (warn "Rest_of_line did not compile correctly"))) + +(eval (def-regex-parser 'Quotation-Rx "'[^']+'")) +(Quotation-Rx "'System 0x40147bb8 [sys_specs_Mfake]' provides no alternatives for allocating resource 'max_cpu_Rspu'") + +(eval (def-regex-parser 'NatNumber "-?[0-9]+[^a-zA-Z/$+_.:]")) +(eval (def-regex-parser 'NatNumber "-?[0-9]+[^a-zA-Z]")) + +(NATNUMBER "32mb_mem_array") + +(regex-test 50 "[A-Z]+" "ABCY" "ABCY") + +(regex-test 51 "[0-9]+\\.[0-9]*\\(e[+-]?[0-9]+\\)" "12.3e4 k" "12.3e4") +(regex-test 52 "[0-9]+\\.[0-9]*\\(e[+-]?[0-9]+\\)" "12.3e-4 k" "12.3e-4") +;;(regex-test 53 "[0-9]+\\.[0-9]*\\(e[+-]?[0-9]+\\)?" "12.3 k" "12.3") + +(let ((fn (def-regex-parser 'foo "\\(a\\)\\1"))) + (pprint fn) + (eval fn)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of regextst.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/sample-avm1 ============================================================================== --- (empty file) +++ vendor/zebu/test/sample-avm1 Wed Oct 17 09:04:46 2007 @@ -0,0 +1,28 @@ +[(s1 v1) (s2 v2)] + +foo: [(s1 v1) (s2 %1= v2) (s3 %1)] + +[] + +[( s1 "foo" )] + +foo: [(s1 "foo") + (s2 %1= "bar") + (s3 %1)] + +foo: [(s1 "foo") + (s2 %1= "bar") + (s3 "baz\"2")] + +[( s1 "foo +bar" )] + +[( s1 "foo +\" +\\" +\\\" +bar +" )] + +[( s1 "h\"atten Sie gerne Umlaute?")] + \ No newline at end of file Added: vendor/zebu/test/sample-ex1 ============================================================================== --- (empty file) +++ vendor/zebu/test/sample-ex1 Wed Oct 17 09:04:46 2007 @@ -0,0 +1,9 @@ +1 + a +1/3 1.333 + +.1 + 1/3 +1 + x * y + +(1 + + x) * y + \ No newline at end of file Added: vendor/zebu/test/sb-tr.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/sb-tr.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,105 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: sb-tr.zb +; Description: simple test of sb trace subgrammar +; Author: Joachim H. Laubsch +; Created: 3-Sep-93 +; Modified: Thu Oct 2 12:57:28 1997 (Joachim H. Laubsch) +; Language: CL +; Package: USER +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1993, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "sb-tr" + :package "CL-USER" + :string-delimiter #\" + :identifier-start-chars + "_-abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :identifier-continue-chars + "/$-+_.:abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + :intern-identifier nil + :case-sensitive t + :lex-cats ((Hex "0x[0-9a-f]+") + (Int "-?[0-9]+") + (Quotation-Rx "'[^']+'") + (Resource-attr "([0-9]+,[0-9]+,[0-9]+)") + )) + +;; rules + +(defrule Mapping_trace + := ("Compute" Identifier.0 "mapping for" Identifier.1 List PCM-Component "...") + + := ("Seed instance:" PCM-Class_Component) + + := PCM-Class_Component + + := (PCM-Class_Component List) + + := Option_instance + ) + +(defrule Option_instance + := ("Instance" Hex "of Option [required]") + + := ("Instance" Hex "of Option" "[" Identifier "]") + ) + +(defrule Product_Id + := (Token-Seq Hex) + := Identifier) + +(defrule PCM-Component + := ( "[" Identifier Hex "]") + ) + +(defrule PCM-Class_Component + := (Product_Id "[" Identifier "]") + + := (Product_Id "{" Token-Seq "}") + + := Product_Id + ) + +(defrule List + := ( "(" Token-Seq ")" ) + ) + +(defrule Token-Seq + := Token + + := (Token Token-Seq) + ) + +(defrule Token + := Int + + := Identifier) + +#|| +(set-working-directory *ZEBU-test-directory*) +(let ((*warn-conflicts* t)) + (compile-slr-grammar "sb-tr.zb")) +(zb:zebu-load-file "sb-tr.tab") + +(zb:read-parser "dummy_os 0x41167300" :grammar (find-grammar "sb-tr")) +(zb:read-parser "dummy_os 0x41167300 [Dummy_OS]" + :grammar (find-grammar "sb-tr")) +(zb:read-parser "dummy_os 0x41167300 {Dummy OS}" + :grammar (find-grammar "sb-tr")) +(zb:read-parser "999.0 HP-UX 0x41167398 {HP-UX 9.0} (reference)" + :grammar (find-grammar "sb-tr")) +(let ((*warn-conflicts* t)) + (compile-lalr1-grammar "sb-tr.zb" :output-file "/tmp/sb-tr-lalr1.tab")) +(zb:zebu-load-file "/tmp/sb-tr-lalr1.tab") + + +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of sb-tr.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/test/simple.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/simple.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,35 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: simple.zb +; Description: Zebu Grammar: Simple Expressions +; Author: Joachim H. Laubsch +; Language: CL +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "simple") + +(defrule E := ( Prefix "(" E ")" ) + := ( "V" Tail ) ) + +(defrule Prefix := "F" + := ()) + +(defrule Tail := ( "+" E) + := ()) + +#|| +(set-working-directory *ZEBU-test-directory*) +(let ((*load-verbose* t)) + (compile-slr-grammar "simple.zb")) +(setq zebu:*current-grammar* + (zebu-load-file "simple.tab")) +(progn (format t "symbols: ") (terpri) (zebu::cruise-symbols-2)) +(zebu::print-collection t) +(zb::cruise-first-sets) +(zb::cruise-follow-sets) +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of simple.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + \ No newline at end of file Added: vendor/zebu/test/tl1.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/tl1.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,38 @@ +; -*- mode: Lisp -*- +; +; Zebu grammar describing TL1 syntactic structure. +; + +(:name "tl1" :grammar "zebu-mg") + +;; +;; Domain description... +;; + +command := [(opcode) (param-blocks kb-sequence)]; +parameter-block := [(contents kb-sequence)]; +name-value-pair := [(name) (value)]; + +command --> opcode parameter-block* ":" ";" + { command: [(opcode opcode) + (param-blocks parameter-block*)] }; + + +;;opcode --> identifier "-" identifier; +opcode --> identifier; + +parameter-block --> parameter-list + { parameter-block: [(contents parameter-list)] }; + +parameter-list --> parameter { kb-sequence: [(first parameter)] } + | parameter "," parameter-list + { kb-sequence: [(first parameter) (rest parameter-list)] }; + +parameter --> name { name-value-pair: [(name name)] } + | name "=" value { name-value-pair: [(name name) (value value)]}; + +name --> identifier; + +value --> identifier | number | string; + + \ No newline at end of file Added: vendor/zebu/test/useless.zb ============================================================================== --- (empty file) +++ vendor/zebu/test/useless.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,37 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: useless.zb +; Description: Zebu Grammar Example with useless nonterminals +; Author: Joachim H. Laubsch +; Language: CL +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "useless") + +(defrule S := A + := B) + +(defrule A := "a") + +(defrule B := (B "b") ) + +(defrule C := "c") + +#|| +(setf (SYSTEM::environment-variable "zebutest") "~/hpnlrw/zebu/test") +(let ((*load-verbose* t)) + (compile-slr-grammar + (merge-pathnames "useless.zb" *ZEBU-test-directory*))) +;;; Warning: The following non-terminals where defined but not used: C + +(setq zebu:*current-grammar* + (zebu-load-file (merge-pathnames "useless.tab" + *ZEBU-test-directory*))) +(progn (format t "symbols: ") (terpri) (zebu::cruise-symbols-2)) +(zebu::print-collection t) + +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of useless.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + \ No newline at end of file Added: vendor/zebu/zebra-debug.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebra-debug.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,73 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebra-debug.lisp +; Description: Translating KB-Objects into readable lists +; Author: Karsten Konrad +; Created: 6-Apr-93 +; Modified: Wed Aug 3 12:48:51 1994 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1993, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PostScript Graph of the Kb-domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; psgraph (from CMU) and Ghostview from FSF are needed +#+LUCID +(defun show-kb-hierarchy (&optional (file "/tmp/kb-classes.ps")) + (let ((start 'kb-domain)) + (with-open-file (*standard-output* file :direction :output) + (psgraph start + #'zb:KB-subtypes + #'(lambda (x) (list (string x))) + t nil #'eq)) + (shell (format + nil + "ghostview -display ~a -notitle -nolabels -nolocator ~a &" + (environment-variable "DISPLAY") file)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Als Zugabe eine Funktion, die ein Kb-Objekt in eine vollstaendige +; Liste uebersetzt; man sieht dann mal, was alles in der Struktur +; steht. Vor allem zum Debuggen von Transformationen ist das +; sehr hilfreich. + +(require "zebu-kb-domain") +(require "zebu-tree-attributes") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Translating KB-Objects into readable lists +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun kb-tree2list (kb-object) + "translates a kb-object to a list which should contain + all relevant information." + (cond ((kb-domain-p kb-object) + (cons (type-of kb-object) (kb-kids2list kb-object))) + ((consp kb-object) + (mapcar #'kb-tree2list kb-object)) + (t kb-object))) + +(defun kb-kids2list (kb-object) + "conses reader-fn and childs into a description list" + (let ((childs nil) + (ta (KB-tree-attributes (type-of kb-object)))) + (when ta + (dolist (reader (the list (first ta))) + (push (list reader + (kb-tree2list (funcall reader kb-object))) childs)) + (nreverse childs)))) + +(defun print-readform (kb-object) + "prints a kb-object in a readable form" + (pprint (kb-tree2list kb-object))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebra-debug.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-actions.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-actions.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,63 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-actions.l +; Description: Functions used in ZEBU grammar actions +; Author: Joachim H. Laubsch +; Created: 11-Jul-91 +; Modified: Thu Mar 7 09:13:39 1996 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1991, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +(provide "zebu-actions") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Functions used in ZEBU grammar actions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline EMPTY-SEQ SEQ-CONS EMPTY-SET SET-CONS K-4-3)) + +(defun identity* (&rest x) x) + +(defun EMPTY-SEQ () ()) +(defun SEQ-CONS (a seq) (cons a seq)) + +(defun EMPTY-SET () ()) +(defun SET-CONS (a set) (adjoin a set)) + +(defun K-4-3 (ignore dummy1 result dummy2) + ;; a K (constant) function of 4 arguments that returns the third + (declare (ignore ignore dummy1 dummy2)) + result) + +(defun K-2-1 (result dummy) + ;; a K (constant) function of 2 arguments that returns the first + (declare (ignore dummy)) + result) + +(defun K-2-2 (dummy result) + ;; a K (constant) function of 2 arguments that returns the 2nd + (declare (ignore dummy)) + result) + +(defun K-3-2 (dummy1 result dummy2) + ;; a K (constant) function of 3 arguments that returns the 2nd + (declare (ignore dummy1 dummy2)) + result) + +(defun CONS-1-3 (a ignore b) + (declare (ignore ignore)) + (cons a b)) + +(defun CONS-2-3 (ignore a b) + (declare (ignore ignore)) + (cons a b)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-actions.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-asdf-setup.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-asdf-setup.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,32 @@ + +(in-package :asdf) + +(defclass zebu-source-file (source-file) ()) + +(defmethod source-file-type ((c zebu-source-file) (s module)) "zb") + +(defmethod perform ((operation compile-op) (c zebu-source-file)) + (zebu:zebu-compile-file (component-pathname c))) + +(defmethod perform ((o load-op) (c zebu-source-file)) + (let* ((co (make-sub-operation o 'compile-op)) + (output-files (output-files co c))) + (setf (component-property c 'last-loaded) + (file-write-date (car output-files))) + (zb:zebu-load-file (car output-files)))) + +(defmethod output-files ((operation compile-op) (c zebu-source-file)) + (list (merge-pathnames (component-pathname c) + (make-pathname :type "tab")) + ;; FIXME: The following is not always right: the name of the + ;; domain file can be given as an option to the grammar. Look + ;; at the function zebu::dump-domain-file to find out how the + ;; name is constructed in the general case. + (merge-pathnames (make-pathname + :name (concatenate 'string (pathname-name + (component-pathname c)) + "-domain")) + (make-pathname + :type (car zebu::*load-binary-pathname-types*))) + )) + Added: vendor/zebu/zebu-aux.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-aux.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,246 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-aux.lisp +; Description: Functions and structures common to compiler and driver +; Author: Joachim H. Laubsch +; Created: 11-Oct-90 +; Modified: Wed Dec 9 12:22:24 1998 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 7-Apr-92 (Joachim H. Laubsch) +; many efficiency improvements throughout based on using Lucid's monitor +; facility. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +(provide "zebu-aux") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#-LUCID (declaim (special *load-source-pathname-types* + *load-binary-pathname-types*)) +#+(or MCL Allegro CLISP) +(setq *load-source-pathname-types* '("lisp" NIL) + *load-binary-pathname-types* '("fasl")) + +#+(and :SUN :LUCID) +(setq *load-binary-pathname-types* '("sbin")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Global Variables (shared by runtime system and compiler) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#-LUCID +(defvar *KEYWORD-PACKAGE* (find-package "KEYWORD")) + +(defvar *generate-domain* t + "If true while Zebu compiling a grammar, generate the hierarchy +otherwise the domain-hierarchy is written by the user.") + +(defvar *ZEBU-PACKAGE* (find-package "ZEBU")) + +(defvar *open-categories* '("IDENTIFIER" "NUMBER" "STRING")) + +(declaim (special *NULL-Grammar*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Functions common to runtime and compiler +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun list->vector (l) + (let* ((len (length l)) + (v (make-sequence 'vector len))) + (declare (vector v)) + (dotimes (i len v) + (setf (svref v i) (pop l))))) + +(deftype IDENTIFIER () '(and symbol (not null))) + +(defun identifierp (x) + (typep x 'IDENTIFIER)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Lexical analysis (regex) Run/Compile time data structures +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Declare the global variables for storing the paren index list. +;;; +(defvar *regex-groups* (make-array 10)) +(defvar *regex-groupings* 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; External representation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *zb-rules*) ; alist of rule-names and zb-rule structs + +(defstruct zb-rule + -name + -productions) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal Representation of Productions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; About the internal representation of productions: +;;; production-index: (0 .. Number of productions - 1) +;;; lhs: a g-symbol +;;; rhs: a list of g-symbols +;;; production-length: the length of rhs + +(defstruct (production (:conc-name nil)) + lhs + rhs + production-index + production-length) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; check the first form of a grammar file +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; this applies to a .zb as well as a .tab file + +(declaim (special *compiler-grammar* *identifier-continue-chars* + *identifier-start-chars*)) + +(defun check-grammar-options (options filename compiling + &aux g-name compiler?) + ;; FILENAME is of type path + ;; check the list of options for plausibility + ;; on package conflict, Nil is returned to catch point: read-grammar-options + ;; we must then read the options again with *package* set correctly + (unless (and (listp options) (not (null options))) + (error "~S is not a valid Options List for a Zebu grammar!" options)) + (flet ((wrng-make-grammar-arglist (key) + (error "~S is not a defined keyword for make-grammar." key))) + (do ((gg options (cddr gg))) ((null gg)) + (let ((key (car gg)) (val (cadr gg))) + (if (keywordp key) + (case key + (:NAME (setq g-name val)) + (:PACKAGE + (let ((p (find-package val))) + (if p + (progn + (use-package "ZEBU" p) + (unless (eq *package* p) + (setq *package* p) + (throw 'read-grammar-options nil))) + (error + "Package ~s should be defined before ~:[loading~;compiling~] ~S" + val compiling filename)))) + (:GRAMMAR (let ((g (find-grammar val))) + (setq compiler? t) + (if g + (setq *compiler-grammar* g) + (warn "Grammar ~S is not loaded" val)))) + (:IDENTIFIER-CONTINUE-CHARS + (setf *identifier-continue-chars* val)) + (:IDENTIFIER-START-CHARS + (setf *identifier-start-chars* val)) + ((:STRING-DELIMITER :SYMBOL-DELIMITER :FILE :DOMAIN + :LEX-CATS :WHITE-SPACE :DOMAIN-FILE + :INTERN-IDENTIFIER :CASE-SENSITIVE)) + (t (wrng-make-grammar-arglist key))) + (wrng-make-grammar-arglist key)))) + (unless g-name + (setq g-name (pathname-name filename) + options (list* ':NAME g-name options))) + (when (and compiling (not compiler?)) + (warn "Compiling with :GRAMMAR \"null-grammar\". +To use the meta grammar use: :GRAMMAR \"zebu-mg\" in options list!") + (setq *compiler-grammar* *NULL-Grammar*)) + (when compiling + (setq options (list* ':FILE (namestring filename) options))) + options)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The Root of the Domain Hierarchy +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defstruct (kb-domain (:constructor nil))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal representation of the domain hierarchy as a tree +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct (type-tree-node + (:print-function + (lambda (item stream level) + (declare (ignore level)) + (format stream "[[~s]]" + (type-tree-node--label item))))) + -label + -subtypes + -supertype ; back link + -slots + ) + +(defvar *domain-type-hierarchy*) ; a backlinked tree +(defvar *domain-HT* (make-hash-table)) ; a dictionary label --> node + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Map Domain def into Hashtable +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(declaim (special *domain-HT* *open-categories*)) +(defvar *lex-cats* nil) +;----------------------------------------------------------------------------; +; prepare-domain +;--------------- +; convert a domain D (as read from a grammar file) into the tree representation +; +(defun prepare-domain (domain) + (clrhash *domain-HT*) + (let* ((top (new-domain-node ':TOP nil nil))) + (setf *domain-type-hierarchy* top + (type-tree-node--subtypes top) + (list* + (new-domain-node 'kb-sequence top '(first rest)) + (new-domain-node 'kb-domain top '()) + (nconc (mapcar #'(lambda (s) + (new-domain-node (intern s) top nil)) + *open-categories*) + (mapcar #'(lambda (c) (new-domain-node (car c) top nil)) + *lex-cats*)))) + (when domain + (add-to-domain domain top) + domain))) + +(defun add-to-domain (node point) + (if (consp node) + (let* ((label (car node)) + (slots (cadr (member ':slots node))) + (new-point (new-domain-node label point slots))) + (push new-point (type-tree-node--subtypes point)) + (do ((args (cdr node) (cddr args))) + ((null args)) + (when (eq (car args) ':subtype) + (add-to-domain (cadr args) new-point)))) + (let ((new-point (new-domain-node node point nil))) + (push new-point (type-tree-node--subtypes point))))) + +(defun new-domain-node (label supertype slots) + (let ((new (make-type-tree-node + :-label label :-supertype supertype :-slots slots))) + (setf (gethash label *domain-HT*) new))) + +#|| +(prepare-domain '(cl-user::arith-exp + :subtype (cl-user::factor :slots (-value)) + :subtype (cl-user::*-op :slots (-arg1 -arg2)) + :subtype (cl-user::+-op :slots (-arg1 -arg2)) + :subtype (cl-user::expression :slots (-value)))) +||# + +(defun def-kb-domain-type (type super slots) + (let* ((super-nd (or (gethash super *domain-HT*) + (new-domain-node + super (gethash ':top *domain-HT*) '()))) + (type-nd (or (gethash type *domain-HT*) + (new-domain-node type super-nd slots)))) + (pushnew type-nd (type-tree-node--subtypes super-nd)) + type-nd)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-aux.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-closure.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-closure.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,183 @@ +; -*- mode: CL -*- ------------------------------------------------- ; +; File: zebu-closure.lisp +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 31-Oct-90 +; Modified: Tue Aug 2 16:11:09 1994 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Calculate the closure of an lr(0) set of items +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun closure (I) + (declare (type oset I)) + (let ((eset + (make-oset :order-fn #'item-order-function) + )) + ;; I is an oset of items. + ;; This is non-destructive. + ;; See Fig. 4.33 of Dragon + (labels ((closure-insert-item! (item) + ;; Add an item to an oset of items. Add his pals too if he wasn't + ;; there already. + (when (oset-insert! item eset) + (unless (dot-at-right-end? item) + (dolist (production + (the list + (g-symbol-own-productions + (symbol-after-dot item))) + nil) + (let ((new (new-item production))) + (closure-insert-item! new))) + )))) + (dolist (x (oset-item-list I)) (closure-insert-item! x)) + eset))) + +#|| +(defun closure (I) + (declare (type oset I)) + (let ((eset (make-oset :order-fn #'item-order-function))) + ;; I is an oset of items. + ;; This is non-destructive. + ;; See Fig. 4.33 of Dragon + (labels ((closure-insert-item! (item) + ;; Add an item to an oset of items. Add his pals too if he wasn't + ;; there already. + (when (oset-insert! item eset) + (unless (dot-at-right-end? item) + (dolist (production (g-symbol-own-productions + (symbol-after-dot item))) + (closure-insert-item! + (the item (new-item production)))))))) + (dolist (x (oset-item-list I)) (closure-insert-item! x)) + eset))) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Calculate the lr(1) closure of a set of lr(1) items. +;;; Currently, find the closure of a set of one lr(1) item. +;;; +;;; An lr(1) item data structure with a set of lookaheads +;;; actually stands for a set of lr(1) items which are the +;;; same except for each having one lookahead from the set. + +(defun single-item-closure-1 (lr0-item look-ahead) + (let ((eset (make-oset :order-fn #'item-order-function))) + (closure-1-insert-item! lr0-item look-ahead eset) + eset)) + + +;;; Destructively take the lr(1) closure of an item set +;;; (actually an oset of items... not an item-set structure). +;;; Empty out the set and re-insert the contents with closures. + +(defun closure-1! (item-set) + (let ((item-list (oset-item-list item-set))) + (setf (oset-item-list item-set) nil) + (dolist (item item-list) + (let ((the-look-aheads (item-look-aheads item))) + (setf (item-look-aheads item) + (make-oset :order-fn #'g-symbol-order-function)) + (dolist (look-ahead (oset-item-list the-look-aheads)) + (closure-1-insert-item! item look-ahead item-set)))))) + +;----------------------------------------------------------------------------; +; closure-1-insert-item! +;----------------------- +; See Dragon Fig. 4.38 +; + +(defun closure-1-insert-item! (lr0-item look-ahead item-set) + (declare (type item lr0-item)) + (labels ((closure-1-insert-item-aux (lr0-item look-ahead) + (multiple-value-bind (item-not-there-already the-item) + (oset-insert-2! lr0-item item-set) + (when (or (oset-insert! look-ahead (item-look-aheads the-item)) + item-not-there-already) + ;; Item wasn't already there with that lookahead + ;; so insert his buddies too. + (unless (dot-at-right-end? lr0-item) + (let* ((prod (item-production lr0-item)) + (rhs (rhs prod)) + (after-dot-rhs + (nthcdr (the fixnum (item-after-dot lr0-item)) + (the cons rhs))) + (gs-list (oset-item-list + (first-seq-1 + ;; This gets the list corresponding to the + ;; part of the item beyond the symbol after + ;; the dot. + (cdr (the cons after-dot-rhs)) + look-ahead)))) + (dolist (prod (g-symbol-own-productions + (car (the cons after-dot-rhs)))) + (dolist (gs gs-list) + (let ((new (new-item prod))) + (closure-1-insert-item-aux new gs)))))))))) + (closure-1-insert-item-aux lr0-item look-ahead))) + +#| +(defun closure-1-insert-item! (lr0-item look-ahead item-set) + (declare (type item lr0-item)) + (labels ((closure-1-insert-item-aux (lr0-item look-ahead) + (multiple-value-bind (item-not-there-already the-item) + (oset-insert-2! lr0-item item-set) + (when (or (oset-insert! look-ahead (item-look-aheads the-item)) + item-not-there-already) + ;; Item wasn't already there with that lookahead + ;; so insert his buddies too. + (unless (dot-at-right-end? lr0-item) + (let* ((prod (item-production lr0-item)) + (rhs (rhs prod)) + (after-dot-rhs + (nthcdr (the fixnum (item-after-dot lr0-item)) + (the cons rhs))) + (gs-list (oset-item-list + (first-seq-1 + ;; This gets the list corresponding to the + ;; part of the item beyond the symbol after + ;; the dot. + (cdr (the cons after-dot-rhs)) + look-ahead)))) + (dolist (prod (g-symbol-own-productions + (car (the cons after-dot-rhs)))) + (dolist (gs gs-list) + (closure-1-insert-item-aux + (new-item prod) gs))))))))) + (closure-1-insert-item-aux lr0-item look-ahead))) +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test: +#|| +(set-working-directory *ZEBU-test-directory*) +(zb::load-grammar "ex1.zb") +(zb::compile-slr-grammar "ex1.zb") +(zebu-load-file "ex1.tab") +(calculate-empty-string-derivers) +(calculate-first-sets) +(setq f-item (new-item (car (reverse *productions*)))) +(setq f-i-set (single-item-closure-1 + f-item *the-end-g-symbol*)) +(item-list-print (oset-item-list f-i-set)) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of closure1.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-compile-mg.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-compile-mg.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,31 @@ +; -*- mode: Lisp -*- --------------------------------------------------- ; +; File: zebu-compile-mg.lisp +; Description: Compile and load the metagrammar during load process +; Author: Rudi Schlatte +; Created: 2000-03-26 +; Time-stamp: <00/03/26 15:14:11 rschlatt> +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; This is only needed for mk:defsystem (or until I figure out +; how to compile arbitrary file types with custom compilers +; in defsystem, which is all that happens here) +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package #:ZEBU) + +(eval-when (:compile-toplevel) + (ignore-errors + (delete-file (merge-pathnames "zebu-mg.tab" *compile-file-truename*)) + (delete-file (merge-pathnames "zmg-dom.lisp" *compile-file-truename*))) + (zebu-compile-file + (merge-pathnames "zebu-mg.zb" *compile-file-truename*))) + + +(eval-when (:load-toplevel) + (zebu-load-file + (merge-pathnames "zebu-mg.tab" *load-truename*))) Added: vendor/zebu/zebu-compile.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-compile.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,103 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-compile.lisp +; Description: apply the grammar-compiler +; Author: Joachim H. Laubsch +; Created: 6-Nov-90 +; Modified: Tue Aug 2 16:20:04 1994 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 25-Apr-91 (Joachim H. Laubsch) +; introduced *WARN-CONFLICTS* to shut up warnings + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ZEBU") + +;; whether warnings about action-conflicts are printed at compile time +(defvar *warn-conflicts* nil) +(defvar *compiler-grammar* *null-grammar* + "The grammar that the Zebu Compiler uses when reading a grammar. +By default this is the Null-Grammar.") + +(defun zebu-compile-file (grammar-file + &key (grammar *null-grammar*) + output-file + verbose + (compile-domain t)) + "Compiles the LALR(1) grammar in file GRAMMAR-FILE." + (assert (probe-file (setq grammar-file + (merge-pathnames grammar-file + (merge-pathnames + (make-pathname :type "zb"))))) + (grammar-file) + "Cannot find grammar file: ~A" grammar-file) + (setq output-file + (let ((tab (make-pathname :type "tab"))) + (if output-file + (merge-pathnames (pathname output-file) tab) + (merge-pathnames tab grammar-file)))) + (when (probe-file output-file) (delete-file output-file)) + (format t "~%; Zebu Compiling (Version ~A)~%; ~S to ~S~%" + *zebu-version* grammar-file output-file) + (let ((*warn-conflicts* verbose)) + (compile-lalr1-grammar grammar-file + :output-file output-file + :grammar grammar + :verbose verbose + :compile-domain compile-domain))) + + +;----------------------------------------------------------------------------; +; compile-from-command-line +;-------------------------- +; call zebu-compile-file with a command-line-argument +; +#+LUCID +(defun compile-from-command-line () + (let ((*default-pathname-defaults* + (make-pathname :directory + (pathname-directory (working-directory)) + :type "zb")) + (ifile (command-line-argument 1)) + ofile + verbose + compile-domain) + (if (null ifile) + (Warn "No input file specified!") + (progn + (do* ((a 2 (1+ a)) + (arg (command-line-argument a) (command-line-argument a))) + ((null arg)) + (cond ((equalp arg "-v") (setq verbose t)) + ((equalp arg "-d") (setq compile-domain t)) + ((equalp arg "-r") (load (command-line-argument (incf a)))) + ((= a 2) (setq ofile arg)))) + (apply #'zebu-compile-file ifile + :verbose verbose + :compile-domain compile-domain + (when ofile + `(:output-file ,ofile))))) + (terpri) + (quit))) + + +;----------------------------------------------------------------------------; +; zebu-top +;--------- +; interactive compiler invocation + +(defun zebu-compile-top () + (format t "~&Enter the name of a Zebu Grammar file to compile: ") + (let ((ifile (read-line t))) + (zebu-compile-file ifile))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-compile.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-compiler.asd ============================================================================== --- (empty file) +++ vendor/zebu/zebu-compiler.asd Wed Oct 17 09:04:46 2007 @@ -0,0 +1,81 @@ +;;; -*- Lisp -*- + +;;;(in-package "CL-USER") + +(asdf:defsystem #:zebu-compiler + ;; Compile time system for LALR(1) parser: Converts a grammar to a + ;; parse table + :depends-on ("zebu") + :components + ((:file "zebu-regex") + (:file "zebu-oset") + (:file "zebu-kb-domain") ; not explicitly in ZEBU-sys.lisp + (:file "zebu-g-symbol" + :in-order-to ((compile-op (load-op "zebu-oset")))) + (:file "zebu-loadgram" + :in-order-to ((compile-op (load-op "zebu-g-symbol") + (load-op "zebu-oset")))) + (:file "zebu-generator" + :in-order-to ((compile-op (load-op "zebu-loadgram") + (load-op "zebu-kb-domain")))) + (:file "zebu-lr0-sets" + :in-order-to ((compile-op (load-op "zebu-g-symbol") + (load-op "zebu-loadgram")))) + (:file "zebu-empty-st" + :in-order-to ((compile-op (load-op "zebu-loadgram")))) + (:file "zebu-first" + :in-order-to ((compile-op (load-op "zebu-loadgram") + (load-op "zebu-oset"))) + ;; :recompile-on "zebu-oset" + ) + (:file "zebu-follow" + :in-order-to ((compile-op (load-op "zebu-loadgram") + (load-op "zebu-first")))) + (:file "zebu-tables" + :in-order-to ((compile-op (load-op "zebu-g-symbol") + (load-op "zebu-loadgram") + (load-op "zebu-lr0-sets")))) + (:file "zebu-printers" + :in-order-to ((compile-op (load-op "zebu-loadgram") + (load-op "zebu-lr0-sets") + (load-op "zebu-tables")))) + (:file "zebu-slr") + (:file "zebu-closure" + :in-order-to ((compile-op (load-op "zebu-oset") + (load-op "zebu-g-symbol") + (load-op "zebu-first")))) + (:file "zebu-lalr1" + :in-order-to ((compile-op (load-op "zebu-oset") + (load-op "zebu-lr0-sets") + (load-op "zebu-follow")))) + (:file "zebu-dump" + :in-order-to ((compile-op (load-op "zebu-loadgram") + (load-op "zebu-slr") + (load-op "zebu-lalr1")))) + (:file "zebu-compile" + :in-order-to ((compile-op (load-op "zebu-dump")))) + (:file "zebu-compile-mg" + :in-order-to ((compile-op (load-op "zebu-compile") + (load-op "zebu-dump") + (load-op "zebu-empty-st") + (load-op "zebu-closure") + (load-op "zebu-tables") + (load-op "zebu-generator")) + ((load-op (compile-op "zebu-compile-mg") + (load-op "zebu-compile") + (load-op "zebu-dump") + (load-op "zebu-empty-st") + (load-op "zebu-closure") + (load-op "zebu-tables") + (load-op "zebu-generator"))))) + (:file "zmg-dom" + :in-order-to ((compile-op (load-op "zebu-compile-mg")))) + (:file "zebu-kb-domain" + :in-order-to ((compile-op (load-op "zmg-dom")))) + ;;; Hook it into asdf + (:file "zebu-asdf-setup" + :in-order-to ((compile-op (load-op "zebu-kb-domain")))))) + + + + Added: vendor/zebu/zebu-compiler.system ============================================================================== --- (empty file) +++ vendor/zebu/zebu-compiler.system Wed Oct 17 09:04:46 2007 @@ -0,0 +1,52 @@ +;;; -*- Lisp -*- + +;;;(in-package "CL-USER") + +(mk:defsystem "zebu-compiler" + :source-pathname "/users/students/rschlatt/lisp/zebu-3.5.5/" + :binary-pathname "/users/students/rschlatt/lisp/zebu-3.5.5/binary/" + ;;:package "ZEBU" + :depends-on ("zebu") + :components + ((:file "zebu-regex") + (:file "zebu-oset") + (:file "zebu-kb-domain") ; not explicitly in ZEBU-sys.lisp + (:file "zebu-g-symbol" + :depends-on ("zebu-oset")) + (:file "zebu-loadgram" + :depends-on ("zebu-g-symbol" "zebu-oset")) + (:file "zebu-generator" + :depends-on ("zebu-loadgram" "zebu-kb-domain")) + (:file "zebu-lr0-sets" + :depends-on ("zebu-g-symbol" "zebu-loadgram")) + (:file "zebu-empty-st" + :depends-on ("zebu-loadgram")) + (:file "zebu-first" + :depends-on ("zebu-loadgram" "zebu-oset")) + (:file "zebu-follow" + :depends-on ("zebu-loadgram" "zebu-first")) + (:file "zebu-tables" + :depends-on ("zebu-g-symbol" "zebu-loadgram" + "zebu-lr0-sets")) + (:file "zebu-printers" + :depends-on ("zebu-loadgram" "zebu-lr0-sets" + "zebu-tables")) + (:file "zebu-slr") + (:file "zebu-closure" + :depends-on ("zebu-oset" "zebu-g-symbol" "zebu-first")) + (:file "zebu-lalr1" + :depends-on ("zebu-oset" "zebu-lr0-sets" "zebu-follow")) + (:file "zebu-dump" + :depends-on ("zebu-loadgram" "zebu-slr" "zebu-lalr1")) + (:file "zebu-compile" + :depends-on ("zebu-dump")) + (:file "zebu-compile-mg" + :depends-on ("zebu-compile")) + (:file "zmg-dom" + :depends-on ("zebu-compile-mg")) + (:file "zebu-kb-domain" + :depends-on ("zmg-dom")))) + + + + Added: vendor/zebu/zebu-driver.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-driver.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,1081 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-driver.lisp +; Description: Conversion to CL of the original Scheme program (by W. M Wells) +; Author: Joachim H. Laubsch +; Created: 10-Oct-90 +; Modified: Thu Oct 2 09:58:20 1997 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 26-Jul-95 (Joachim H. Laubsch) +; a user defined category, that can also be read as a keyword is +; only identified if it is longer than a keyword +; 25-Apr-94 (Joachim H. Laubsch) +; implemented state-sensitive token look-ahead +; 17-Aug-93 (Joachim H. Laubsch) +; read-parser recognizes numbers: integer, ratio and float +; * [ "." + ] +; + "/" + +; the boolean id-allows-start-digit determines for a grammar whether an +; identifier may start with a digit. +; 22-Feb-93 (Joachim H. Laubsch) +; if the grammar's intern-identifier attribute is true (default), an +; Identifier will be represented as a symbol, otherwise a string +; 2-Feb-93 (Joachim H. Laubsch) +; introduce the variable *case-sensitive* to deal with grammars whith +; case-sensitive keywords +; 13-Jan-93 (Joachim H. Laubsch) +; rewrote recognize-token so that (in ALL cases) keys that could start an +; identifier will not be recognized as keys, but as identifiers. +; 27-Nov-92 (Joachim H. Laubsch) +; Added Variable *preserve-case* +; "If true, the case of an identifier will be preserved (default false)." +; 29-Sep-92 (Joachim H. Laubsch) +; a one-character keyword is considered a token iff it is not +; in identifier-start-chars or if the next character is not in +; identifier-continue-chars +; 21-Jul-92 (Joachim H. Laubsch) +; improved handling of NUMBER and IDENTIFIER in next-token +; 27-Apr-92 (Joachim H. Laubsch) +; introduce *COMMENT-START*, a character that causes everything following +; until the end-of-line to be ignored +; introduce *COMMENT-BRACKETS*, a list of pairs of strings that designate +; everything between them as to be ignored +; 22-Apr-92 (Joachim H. Laubsch) +; define FILE-PARSER, a function like READ-PARSER that takes input +; from a file instead of from a string +; introduced :junk-allowed as argument to READ-PARSER with same meaning +; as that keyword in READ-FROM-STRING +; analogously in LIST-PARSER +; 15-Apr-92 (Joachim H. Laubsch) +; introduce *IDENTIFIER-START-CHARS* +; 30-Oct-91 (Joachim H. Laubsch) +; improved error checking in case a grammar does not use NUMBER, but the +; parser will be given strings containing NUMBERs +; 16-Jul-91 (Joachim H. Laubsch) +; Added a facility to deal with multiple grammars +; lr-parse takes a third argument, a grammar +; READ-PARSER and LIST-PARSER take a :grammar keyword argument, defaulting to +; *current-grammar* +; 26-Jun-91 (Joachim H. Laubsch) +; Added a proposal to distinguish String and Symbol-tokens in lexical analysis +; of read-parser. See comments with section +; *string-delimiter*, *symbol-delimiter* +; 25-Apr-91 (Joachim H. Laubsch) +; fixed bug in read-parser which caused scanner to break if a number was the +; last constituent of a string +; 26-Mar-91 (Joachim H. Laubsch) +; in the case where a keyword is found, but no action defined, we +; assume it must be an identifier. If there is an action entry for +; an identifier, that identifier is interned from the keyword string read +; 26-Mar-91 (Joachim H. Laubsch) +; make read-parser read these types of numbers: integer, float, rational +; 1-Mar-91 (Joachim H. Laubsch) +; made various simple changes, based on monitoring results to speed up +; READ-PARSER by a factor of 10 +; 30-Jan-91 (Joachim H. Laubsch) +; introduce variable: *string-delimiter* +; 17-Jan-91 (Joachim H. Laubsch) +; introduced String syntax: "Fred Jones" is a nll-constant +; 11-Dec-90 (Joachim H. Laubsch) +; introduced the ZEBU package, and imported its exported symbols into USER +; 7-Dec-90 (Joachim H. Laubsch) +; if a keyword ending in a symbol-continue-char is followed by a +; symbol-continue-char a keyword token is NOT recognized (but an identifier) +; except if there would have been a single character keyword recognizing the +; same initial substring. E.g. ?u?foo1 is tokenized as ?u?, foo1, because +; there is the shorter keyword alternative: ?, u?foo1 +; The principle is to give priority to the longest possible keyword. +; (Note that agt007 or agt?x are recognized as identifiers) +; 27-Nov-90 (Joachim H. Laubsch) +; Lexical Analysis (recognize-token) will recognize any keyword of the +; language. If lr-parse is given a token that is a keyword, it may not have +; an action for it, but if this same token were regarded as an identifier, +; there would be one. Instead of reporting an error, lr-parse will now look +; first for the identifier-action. +; It would be best, if lr-parse could predict, whether an identifier is legal +; in the current state and then direct recognize-token appropriately. I should +; come back to this, and implement that. It would also save time. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Written by William M. Wells. This is an example lr parser driver +;;; which uses parse table files generated by Zebu. + +(in-package "ZEBU") + +(provide "zebu-driver") +(require "zebu-loader") +;;; +;;; A rudimentary lr parser driver. +;;; It has provisions for applying client supplied procedures which are +;;; associated with productions in the grammar. +;;; +;;; +;;; This code is independent of the parse table generating system, +;;; and basically stand alone, although +;;; it needs some macros defined in other files. +;;; +(defvar *CURRENT-GRAMMAR* *NULL-Grammar*) + +(defvar *terminal-alist-SEQ*) + +(defvar *lexer-debug* nil) +(eval-when (compile) + (setq *lexer-debug* nil)) + +#| +(setq *lexer-debug* t) +|# + +(defmacro if-debugging-lexer (then &optional else) + `,(if *lexer-debug* then else)) + +(if-debugging + (defmacro say-looking-at () + '(format t "~%Looking-at: ~S . ~a {~s}" + input-symbol-instantiation + (let ((a (svref (grammar-lexicon grammar) input-symbol-index))) + (if (symbolp a) (format nil "<~a>" (symbol-name a)) a)) + input-symbol-index))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (upcased-subseq string from to) == (string-upcase (subseq string from to)) +;; but avoids a copy +(defun upcased-subseq (string beg end) + (declare (simple-string string) (fixnum beg end)) + (let* ((size (- end beg)) + (R (make-sequence 'simple-string size)) + (stringi beg)) + (declare (simple-string R) (fixnum stringi)) + (dotimes (index size) + (setf (schar R index) (char-upcase (the character (schar string stringi)))) + (incf stringi)) + R)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The LR parser itself +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; symbol-stack and state-stack are the standard things for an lr parser. +;;; the client lambdas and stack are used in the following fashion: +;;; +;;; When a shift action occurs, the instantiation of the input symbol +;;; is pushed onto the client stack. +;;; +;;; When a reduce action occurs, as many items as are on the lhs +;;; of the associated production are popped from the client stack +;;; and the corresponding client lambda is applied to the popped +;;; items. The result of the application is then pushed onto the +;;; client stack. One may of course do whatever one wishes by side +;;; effect. + +;;; when junk-allowed, 2 values are returned: +;;; the object found so far +;;; the value returned by last-pos-fn +;;; last-pos-fn should be defined as a function that returns the place +;;; before the token just returned by next-token-fn + +;;; when more-allowed, no "" error is issued but +;;; more-fn is called to extend the token-stream that next-token-fn is +;;; using. + +(defun lr-parse (next-token-fn error-fn grammar + &optional junk-allowed last-pos-fn + &aux symbol-stack client-stack state-stack + action-table-top state-stack-top) + (declare #+(or :MCL :ANSI-COMMON-LISP) + (dynamic-extent symbol-stack client-stack state-stack) + (type (or cons null) symbol-stack client-stack state-stack) + (type grammar grammar) + (type (function (simple-vector) (values t fixnum)) next-token-fn) + (type (function (string) error) error-fn)) + (let ((start-state (grammar-lr-parser-start-state-index grammar)) + (production-info (grammar-production-info grammar)) + (action-table (grammar-action-table grammar)) + (goto-table (grammar-goto-table grammar)) + (client-lambdas (grammar-client-lambdas grammar)) + (end-symbol-index (grammar-end-symbol-index grammar)) + action-entry) + (declare (fixnum end-symbol-index) + (simple-vector action-table goto-table)) + (push start-state state-stack) + (setf state-stack-top start-state + action-table-top (svref action-table start-state)) + (multiple-value-bind (input-symbol-instantiation input-symbol-index) + (funcall next-token-fn action-table-top) + (if-debugging (say-looking-at)) + (setf action-entry (vec-bs-assoc (the fixnum input-symbol-index) + action-table-top)) + (loop + (when (null action-entry) + (if (eq input-symbol-index end-symbol-index) + (funcall error-fn + (undef-action-error input-symbol-instantiation + input-symbol-index + action-table-top + grammar)) + (unless (and junk-allowed + ;; assume that EOF was seen + (setq action-entry + (vec-bs-assoc + end-symbol-index action-table-top))) + (or (let ((idx (grammar-identifier-index grammar))) + (and (setf action-entry (vec-bs-assoc idx action-table-top)) + (stringp input-symbol-instantiation) + (not (string= + (the string input-symbol-instantiation) "")) + (identifier-start-char-p + (schar input-symbol-instantiation 0)) + (not (find-if-not #'identifier-continue-char-p + input-symbol-instantiation + :start 1)) + (setq input-symbol-instantiation + (if (grammar-intern-identifier grammar) + (intern + (if *preserve-case* + (the string input-symbol-instantiation) + (string-upcase + (the string input-symbol-instantiation)))) + input-symbol-instantiation) + input-symbol-index idx))) + (funcall error-fn + (undef-action-error input-symbol-instantiation + input-symbol-index + action-table-top + grammar)))))) + ;; there should always be a non null action-entry !! + (let ((ae-cdr (cdr (the cons action-entry)))) + (case (car (the cons ae-cdr)) + (:S ; Shift. + (setf state-stack-top (cadr ae-cdr) ; new-state + action-table-top (svref action-table state-stack-top)) + (push state-stack-top state-stack) + (if-debugging (format t "~%Shift to ~S" state-stack-top)) + (push input-symbol-index symbol-stack) + (push input-symbol-instantiation client-stack) + (multiple-value-setq + (input-symbol-instantiation input-symbol-index) + (funcall next-token-fn action-table-top)) + (if-debugging (say-looking-at)) + (setf action-entry (vec-bs-assoc (the fixnum input-symbol-index) + action-table-top))) + (:R ; Reduce. + (let* ((prod-index (cadr ae-cdr)) + (p (svref production-info prod-index)) + ;; p = . + (prod-lhs (car (the cons p))) + (prod-ln (cdr (the cons p))) + (client-lambda (svref client-lambdas prod-index))) + (if-debugging (format t "~%Reduce ~S" prod-index)) + ;; optimize simple cases + (case prod-ln + (0 ; Apply the client lambda and store the result. + (if-debugging (format t "~%; Calling ~S" client-lambda)) + (push (funcall client-lambda) client-stack) + (if-debugging + (let ((R (car client-stack))) + (format t "~%; -> ~S : ~S" R (type-of R))))) + (1 ; Apply the client lambda and store the result. + (when client-lambda + (if-debugging (format t "~%; Applying ~S to ~S" + client-lambda (car client-stack))) + (setf (car client-stack) + (funcall client-lambda (car client-stack))) + (if-debugging + (let ((R (car client-stack))) + (format t "~%; -> ~S : ~S" R (type-of R))))) + (setq symbol-stack (cdr symbol-stack) + state-stack (cdr state-stack) + )) + (2 ; Apply the client lambda and store the result. + (if-debugging (format t "~%; Applying ~S to ~{ ~s~}" + client-lambda (subseq client-stack 0 2))) + (when client-lambda + (let* ((arg2 (pop client-stack)) + (R (funcall client-lambda + (car client-stack) + arg2))) + (setf (car client-stack) R))) + (setq symbol-stack (cddr symbol-stack) + state-stack (cddr state-stack)) + (if-debugging + (let ((R (car client-stack))) + (format t "~%; -> ~S : ~S" R (type-of R))))) + (t (let (constituents) + (dotimes (i prod-ln) + (setq symbol-stack (cdr symbol-stack) + state-stack (cdr state-stack)) + (push (pop client-stack) constituents)) + ;; Apply the client lambda and store the result. + (if-debugging (format t "~%; Applying ~S to ~S" + client-lambda constituents)) + (push (apply client-lambda ; action + constituents) + client-stack) + (if-debugging + (let ((R (car client-stack))) + (format t "~%; -> ~S : ~S" R (type-of R))))))) + (push prod-lhs symbol-stack) ; Push lhs of production. + (let ((goto (cdr (the cons + (vec-bs-assoc + prod-lhs + (svref goto-table (car state-stack))))))) + (if (null goto) + (funcall error-fn "table error? goto not defined!")) + (push goto state-stack) + (setf state-stack-top goto ; new-state + action-table-top (svref action-table state-stack-top) + action-entry (vec-bs-assoc + (the fixnum input-symbol-index) + action-table-top)) + ))) + (:A + ;; Accept on END symbol. + (if-debugging (format t "~%Accepting")) + ;; (break "Accept ~s" input-symbol-index) + (if junk-allowed + (return + (values (car client-stack) + (when last-pos-fn (funcall last-pos-fn)))) + (if (= input-symbol-index end-symbol-index) + (return + (values (car client-stack) + (when last-pos-fn (funcall last-pos-fn)))) + (if (eq input-symbol-instantiation T) + (funcall error-fn "Unexpected token") + (funcall error-fn "extra input?"))))) + (T (funcall error-fn + (format nil + "Bogus action: ~S" (car ae-cdr)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Errors +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun possible-tokens (expected lexicon) + (if expected + (let ((tokenL (map 'list + #'(lambda (action) + (let ((a (svref lexicon (car action)))) + (if (symbolp a) + (format nil "<~a>" (symbol-name a)) + (format nil "~s" a)))) + expected))) + (format + nil "~%Expected~:[ one of~;~]:~{ ~a~}~%" + (= 1 (length tokenL)) tokenL)) + "")) + +(defun unrecognized-token-error (string pos expected grammar) + (let ((lexicon (grammar-lexicon grammar))) + (concatenate 'string + (format nil "Unrecognized Token at: ~s" + (subseq string pos)) + (possible-tokens expected lexicon)))) + +(defun undef-action-error (token index expected grammar) + (let* ((lexicon (grammar-lexicon grammar)) + (type (if index + (let ((e (svref lexicon index))) + (if (symbolp e) + (format nil "<~a>" (symbol-name e)) + "KEY"))))) + (format + nil "Syntax error (action not defined for token: ~S~@[ a ~a~])~a" + token type (possible-tokens expected lexicon)))) + + +;;; A function for looking up table entries using binary search +;;; the vector elements are the assoc key and should be in increasing order. +#|| +(defun vec-bs-assoc (num vec) + (declare (type fixnum num) (type vector vec)) + (labels ((vec-bs-assoc-aux (start end) + (declare (type fixnum start end)) + (let ((start-entry (svref vec start))) + (declare (type cons start-entry)) + (cond ((= num (the fixnum (car start-entry))) start-entry) + ((= start end) nil) + (T (let ((mid (floor (+ start end) 2))) + (declare (type fixnum mid)) + (if (> num (the fixnum (car (svref vec mid)))) + (vec-bs-assoc-aux (1+ mid) end) + (vec-bs-assoc-aux start mid)))))))) + (let ((last (1- (length (the vector vec))))) + (declare (type fixnum last)) + (if (or (< num (the fixnum (car (svref vec 0)))) + (> num (the fixnum (car (svref vec last))))) + nil + (vec-bs-assoc-aux 0 last))))) +||# +#-ALLEGRO +(defun vec-bs-assoc (num vec) + (declare (type fixnum num) (type simple-vector vec)) + (labels ((vec-bs-assoc-aux (start end) + (declare (type fixnum start end)) + (let ((start-entry (svref vec start))) + (declare (type cons start-entry)) + (cond ((= num (the fixnum (car start-entry))) start-entry) + ((= start end) nil) + (T (let ((mid (floor (+ start end) 2))) + (declare (type fixnum mid)) + (if (> num (the fixnum (car (svref vec mid)))) + (vec-bs-assoc-aux (1+ mid) end) + (vec-bs-assoc-aux start mid)))))))) + (let ((vln (length vec))) + (declare (type fixnum vln)) + (if (zerop vln) + nil + (let ((last (1- vln))) + (declare (type fixnum last)) + (if (zerop last) + (let ((entry (svref vec last))) + (declare (cons entry)) + (when (= num (the fixnum (car entry))) + entry)) + (vec-bs-assoc-aux 0 last))))))) + +#+ALLEGRO +; konrad at dfki.uni-sb.de writes: +; man kann den Speicherbedarf von Zebu muehelos um mehr als 40% +; reduzieren, wenn man in zebu-driver die Definition von vec-bs-aux in +; folgendes veraendert: + +(progn + (defparameter *bs-vec* nil) + (defparameter *bs-num* nil) + + (defun vec-bs-assoc-aux (start end) + (declare (type fixnum start end)) + (let ((start-entry (svref *bs-vec* start))) + (declare (type cons start-entry)) + (cond ((= *bs-num* (the fixnum (car start-entry))) start-entry) + ((= start end) nil) + (T (let ((mid (floor (+ start end) 2))) + (declare (type fixnum mid)) + (if (> *bs-num* (the fixnum (car (svref *bs-vec* mid)))) + (vec-bs-assoc-aux (1+ mid) end) + (vec-bs-assoc-aux start mid))))))) + + (defun vec-bs-assoc (num vec) + (declare (type fixnum num) (type simple-vector vec)) + (setq *bs-vec* vec *bs-num* num) + (vec-bs-assoc-aux 0 (1- (length vec)))) + ) + + +;;; Figure out to which element of the lexicon a token corresponds. +;;; This gets a little complicated for terminal symbols which can +;;; vary at parsing time, for example, identifiers and numbers. The way +;;; these "preterminals" are handled in this driver is as follows: +;;; If a token passes the CL test PARSE-NUMBER, and the argument number-index +;;; isn't false, then number-index is treated as representing its category. +;;; Otherwise, if the token appears exactly in the lexicon, then it is +;;; given the category of the lexicon item. Otherwise it is assumed +;;; to be an instance of the terminal IDENTIFIER, whose presence in the +;;; lexicon is indicated by a non false value for the id-index argument. +;;; If the token isn't explicitly in the lexicon, and id-index is false, +;;; then an error is signalled. +;;; + + +;;; number-index should be the index of the grammar symbol which stands +;;; for numbers, otherwise it should be false if numbers don't appear +;;; in the grammar. +;;; +;;; id-index should be the index of the grammar symbol which stands +;;; for identifiers, otherwise it should be false if identifiers don't +;;; appear in the grammar. + + +(defun categorize (token grammar) + (let ((category + (if (numberp token) + (progn (if-debugging + (assert (grammar-number-index grammar) () + "A number was seen in the token stream")) + (grammar-number-index grammar)) + (let ((terminal-associations + (elt (grammar-terminal-alist-SEQ grammar) + (char-code (let ((c (schar (string token) 0))) + (declare (character c)) + (if (grammar-case-sensitive grammar) + c + (char-downcase c))))))) + (if terminal-associations + (let ((terminal-association (assoc token terminal-associations + :test #'equal))) + (if terminal-association + (cdr terminal-association) + (grammar-identifier-index grammar))) + (grammar-identifier-index grammar)))))) + (values token category))) + +(declaim (inline end-of-tokens-category)) +(defun end-of-tokens-category (grammar) + (values Nil (grammar-end-symbol-index grammar))) + +(declaim (inline unrecognized-token-category)) +(defun unrecognized-token-category (grammar) + (values T (grammar-end-symbol-index grammar))) + +;;; This implements a parser which gets its tokens from the supplied list. +;;; It uses the parsing engine lr-parse which is defined above. It also +;;; uses the function categorize to classify tokens according to the +;;; lexicon. + +(defun list-parser (token-list &key (grammar *current-grammar*) junk-allowed) + (let ((last-position token-list) + token1 category) + (flet ((list-parser-error (string) + (error "~a~% Remaining tokens: ~S~{ ~S~}" + string token1 token-list))) + (check-type token-list list) + (lr-parse + ;; This lambda is the tokenizer supplied to the parsing engine: + #'(lambda (&optional ignore) + (declare (ignore ignore)) + (if (null token-list) + (end-of-tokens-category grammar) + (progn + (setq last-position token-list) + (multiple-value-setq (token1 category) + (categorize (pop token-list) grammar)) + (if (null category) + (if junk-allowed + (unrecognized-token-category grammar) + (list-parser-error + (format nil "Unrecognized Token ~s" token1))) + (values token1 category))))) + ;; This is the error function supplied to the parsing engine: + #'list-parser-error + grammar + junk-allowed + ;; Function that returns the remaining unparsed token-list + #'(lambda () last-position))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; read-parser +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This implements a parser which gets its tokens from the Lisp function +;;; read. +;;; It uses the parsing engine lr-parse which is defined above. It also +;;; uses the function categorize to classify tokens according to the +;;; lexicon. It will signal the end of input to the parser when it +;;; if it reads the end of file. + +(defun read-parser (string &key + (error-fn #'(lambda (msg) (error "~a" msg))) + (print-parse-errors t) + (grammar *current-grammar*) + (start 0) + junk-allowed + more-allowed + more-fn) + (declare (string string)) + (check-type string string) + (check-type grammar grammar) + (let ((number-index (grammar-number-index grammar)) + (identifier-index (grammar-identifier-index grammar)) + (string-index (grammar-string-index grammar)) + (string-ln (length (the string string))) + (last-pos 0) + (pos start) + (end-symbol-index (grammar-end-symbol-index grammar)) + (*identifier-start-chars-V* (grammar-identifier-start-chars-V grammar)) + (id-allows-start-digit (grammar-id-allows-start-digit grammar)) + (*identifier-continue-chars-V* (grammar-identifier-continue-chars-V grammar)) + (*terminal-alist-SEQ* (grammar-terminal-alist-SEQ grammar)) + (intern-identifier (grammar-intern-identifier grammar)) + (white-space (grammar-white-space grammar)) + (string-delimiter (grammar-string-delimiter grammar)) + (symbol-delimiter (grammar-symbol-delimiter grammar)) + (lex-cat-map (grammar-lex-cat-map grammar)) + (*case-sensitive* (grammar-case-sensitive grammar)) + token find-id? find-string?) + (declare (fixnum string-ln pos last-pos) + (special *identifier-continue-chars-V* + *identifier-start-chars-V*)) + (flet ((white-space-p (char) + (member (the character char) white-space + :test #'char=)) + (digit-seq? (dec end) + (and dec + (or (>= end string-ln) + (and (not id-allows-start-digit) + (not (identifier-continue-char-p + (schar string end))))))) + (new-fraction (num den places) + (values (float (+ num (/ den (expt 10 places)))) + number-index)) + ) + ;; The tokenizer supplied to the parsing engine: + (flet + ((next-token (actionv) + (block next-token + (if-debugging + (format t "~%~a" + (possible-tokens actionv (grammar-lexicon grammar)))) + (loop + ;; skip initial blanks + (setq last-pos pos + pos (or (position-if-not #'white-space-p string + :start pos) + string-ln)) + ;; end of string? + (when (< pos string-ln) (return nil)) + (unless (and more-allowed more-fn) (return nil)) + (setq string + (funcall + more-fn + #'(lambda () + (if (find end-symbol-index actionv + :key #'car) + (return-from next-token + (values nil end-symbol-index)) + (return-from read-parser + (funcall + error-fn + (unrecognized-token-error + "" 0 actionv grammar)))))) + string-ln (length string) + pos 0 + last-pos 0)) + (when (>= pos string-ln) + (if (find end-symbol-index actionv + :key #'car) + (return-from next-token + (values nil end-symbol-index)) + (return-from read-parser + (funcall + error-fn + (unrecognized-token-error + "" 0 actionv grammar))))) + + ;; is an IDENTIFIER also expected + (setf find-id? (and identifier-index + (find identifier-index actionv + :key #'car))) + ;; scan lexical categories (regular expressions) first + (dolist (lex-cat-pair lex-cat-map) + (let ((lex-cat (car lex-cat-pair))) + (when (find lex-cat actionv :key #'car) + (let ((new-pos (funcall (the function (cdr lex-cat-pair)) + string pos string-ln))) + (if-debugging-lexer + (format t "~% calling ~s" (cdr lex-cat-pair))) + (when + (and + new-pos + ;; a match is found, + ;; and it could NOT be a possibly longer identifier + ;; and not possibly a longer keyword + (or + (not find-id?) + (not + (and (< new-pos string-ln) + ;; if a identifier-continue-char doesn't + ;; follow, we also accept + (identifier-continue-char-p + (schar string new-pos)) + ;; the token starts with + ;; an identifier-start-char + (identifier-start-char-p + (schar string pos)) + ;; all of the remaining chars + ;; continue an identifier + (let ((p1 (1+ pos))) + (declare (fixnum p1)) + (or (= p1 new-pos) + (not (find-if-not + #'identifier-continue-char-p + string + :start p1 :end new-pos))))))) + ;; no possibly longer grammar keyword + (multiple-value-bind (token-association token-length) + (recognize-kwd string pos string-ln actionv find-id?) + (if (and token-association + (>= new-pos (+ pos token-length))) + (progn + ;; token recognized + (setq pos (+ pos token-length) + token (car token-association)) + (return-from next-token + (values token (cdr token-association))) + ) + t))) + (let ((instance (subseq string pos new-pos))) + (setq pos new-pos) + (if-debugging + (format t "~%LexToken: ~s : ~s ~s < ~s" instance (car lex-cat-pair) new-pos string-ln)) + (return-from next-token + (values instance lex-cat)))))))) + + ;; read symbol, string, or number + ;; foo : symbol, 'foo' : symbol, "foo" : string, 3/4 : number + ;; recognize a number: * [ "." + ] + ;; + "/" + + (when (and number-index (find number-index actionv :key #'car)) + (multiple-value-bind (number end) + (parse-integer string :start pos :junk-allowed t) + (if (not number) + ;; the case . + (when (and (eql (schar string pos) '#\.) + (DIGIT-CHAR-P (schar string (1+ pos)))) + (multiple-value-bind (dec end) + (parse-integer string + :start (1+ pos) :junk-allowed t) + (when (digit-seq? dec end) + (let ((places (- end (1+ pos)))) + (setq pos end) + (return-from next-token + (new-fraction 0 dec places)))))) + (progn + (when (>= end string-ln) + (setq pos end) + (return-from next-token (values number number-index))) + (let ((c (schar string end)) (p (1+ end))) + (case c + (#\/ (multiple-value-bind (denom end) + (parse-integer string + :start p :junk-allowed t) + (when denom + (setq pos end) + (return-from next-token + (values (/ number denom) number-index)))) + (setq pos end) + (return-from next-token + (values number number-index))) + (#\. (multiple-value-bind (dec end) + (parse-integer string + :start p :junk-allowed t) + (when dec + (let ((places (- end p))) + (setq pos end) + (return-from next-token + (new-fraction number dec places))))) + (setq pos p) + (return-from next-token + (values number number-index))) + (t (when (or (not id-allows-start-digit) + (not (identifier-continue-char-p c))) + (setq pos end) + (return-from next-token + (values number number-index)))))))))) + ;; recognize a grammar keyword + (multiple-value-bind (token-association token-length) + (recognize-kwd string pos string-ln actionv find-id?) + (when token-association + ;; token recognized + (setq pos (+ pos token-length) + token (car token-association)) + (return-from next-token + (values token (cdr token-association))))) + ;; recognize an identifier or string + (setf find-string? (and string-index + (find string-index actionv + :key #'car))) + (when (or find-id? find-string?) + (let ((char (schar string pos)) (c #\space)) + (declare (character char c)) + (flet + ((parse-delimited-id (delimiter symb?) + (block parse-delimited-id + ;; when successful set token and pos!! + (flet ((eof-error () + (return-from read-parser + (funcall + error-fn + (format + nil "Closing ~:[String~;Symbol~] delimiter ~S expected" + symb? delimiter))))) + (when (char= char delimiter) + (do ((p (incf pos) (1+ p)) + (escaped? nil (char= c #\\))) + (nil) + (declare (fixnum p)) + (when (= p string-ln) + (if more-fn + (setq string + (concatenate + 'string + string (string #\Newline) + (funcall more-fn #'eof-error)) + string-ln (length string)) + (eof-error))) + (setq c (schar string p)) + (when (and (char= c delimiter) + (not escaped?)) + (setq token (subseq string pos p) + pos (1+ p)) + (return-from parse-delimited-id t)))))))) + (and find-id? + (parse-delimited-id symbol-delimiter t) + (return-from next-token + (values (intern token) identifier-index))) + (and find-string? + (parse-delimited-id string-delimiter nil) + (return-from next-token + (values token string-index)))) + + ;; Does char start an identifier? + (unless find-id? (funcall error-fn (unrecognized-token-error + string pos actionv grammar))) + (flet ((parse-id () + ;; Any char not in *identifier-continue-chars* terminates + (do ((p (1+ pos) (1+ p))) + ((or (= p string-ln) + (not (identifier-continue-char-p (schar string p)))) + (prog1 (if *preserve-case* + (subseq string pos p) + (upcased-subseq string pos p)) + (setq pos p))) + (declare (fixnum p))))) + (let ((Id-String + (block Identifier + (when (identifier-start-char-p char) + (let ((id1 (parse-id))) + (when (or (= pos string-ln) + (char/= (schar string pos) #\:) + *disallow-packages*) + (return-from Identifier id1)) + ;; more chars follow the ":" ? + (let ((package (find-package id1))) + (unless package + (return-from Identifier id1)) + ;; : ... + (let* ((p (1+ pos)) + (next (schar string p))) + (when (char= next #\:) + (setq next (schar string (incf p)))) + (unless (identifier-start-char-p next) + (return-from Identifier id1)) + (setq pos p) + (return-from next-token + (values + (intern (the simple-string (parse-id)) package) + identifier-index) + ))))) + ;; Symbol in keyword package ? + (when (and (char= char #\:) + (identifier-start-char-p + (schar string (incf pos)))) + (return-from next-token + (values (intern (the simple-string + (parse-id)) + *keyword-package*) + identifier-index)))))) + (when Id-String + (return-from next-token + (values (if intern-identifier + (intern Id-String) Id-String) + identifier-index))))))) + (if (and junk-allowed + (find end-symbol-index actionv :key #'car)) + (return-from next-token (values nil end-symbol-index)) + ;; none of the symbols that we are looking for found + (funcall error-fn (unrecognized-token-error + string pos actionv grammar)))))) + (lr-parse + (if-debugging-lexer ; for testing + #'(lambda (a) + (multiple-value-bind (token id) + (next-token a) + (format t "~%New Token: ~S . ~S Pos: ~S" + token id pos) + (values token id))) + #'next-token) + ;; This is the error function supplied to the parsing engine: + #'(lambda (msg) + (when print-parse-errors + (format t "~%Last token read: ~S~%Remaining: ~A~@[~A ...~]~%" + token + (subseq string pos) + (when more-allowed (funcall more-fn)))) + (funcall error-fn msg)) + grammar + junk-allowed + #'(lambda () last-pos)))))) + +;----------------------------------------------------------------------------; +; recognize-kwd +;-------------- +; +(defun recognize-kwd (string pos string-length actionv find-id?) + ;; Does any of the terminal symbols of the grammar start STRING at POS? + ;; In case it does, it must be the longest one + ;; the ordering of terminal-alist makes sure we find the longest keyword + ;; first + (declare (string string) (fixnum string-length)) + (let ((max-token-length (- string-length (the integer pos)))) + (declare (fixnum max-token-length)) + (flet ((recognize-kwd-aux (ta) + (do ((ta-rest ta (cdr (the cons ta-rest)))) + ((null ta-rest) nil) + ;; (break "recognize-kwd: ~s ~%~s" actionv ta-rest) + (let ((token-association (car (the cons ta-rest)))) + (when (find (cdr token-association) actionv :key #'car) + ;; search only for a legitimite keyword + (let* ((terminal-token (car token-association)) + (token-length (length (the string terminal-token)))) + (declare (fixnum token-length) (string terminal-token)) + (and (>= max-token-length token-length) + (let ((string-end (+ pos token-length))) + (declare (fixnum string-end)) + ;; (break "recognize-kwd 2: ~s ~%~s" terminal-token string) + (and (if *case-sensitive* + (string= terminal-token string + :start2 pos :end2 string-end) + (string-equal terminal-token string + :start2 pos :end2 string-end)) + ;; + ;; If we recognize a keyword, that could start + ;; an identifier, the following char must + ;; not also be a symbol-continue-char. + ;; If it is (e.g. "agent1") and there exists + ;; no shorter key that would accept this, + ;; then we will not recognize the key ("agent") + ;; but this leads us to recognize in "?u?x" the + ;; token "?u?" instead of "?" + + ;; if we are at the end of the string, + ;; we accept + (or (not find-id?) + (not (< string-end string-length)) + ;; if a identifier-continue-char doesn't + ;; follow, we also accept + (not (identifier-continue-char-p + (schar string string-end))) + ;; if the key does not start with + ;; an identifier-start-char we accept + (not (identifier-start-char-p + (schar terminal-token 0))) + ;; if any of the remaining chars of the key + ;; is not a identifier-continue-char, + ;; we also accept + (find-if-not #'identifier-continue-char-p + terminal-token + :start 1)))) + (return (values token-association token-length))))))))) + (recognize-kwd-aux + (svref *terminal-alist-SEQ* + (char-code + (if *case-sensitive* + (the character (schar string pos)) + (char-downcase (the character (schar string pos)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; file-parser +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parse expressions in GRAMMAR reading from FILE +;; returns: a list of the parse-results, i.e. what would have been +;; returned by read-parser + +(defvar *comment-brackets* '(("#|" . "|#")) ) +(defvar *comment-start* #\; ) + +(defun file-parser (file &key + (error-fn #'error) + (print-parse-errors t) + (grammar *current-grammar*) + (verbose *load-verbose*)) + (with-open-file (s (merge-pathnames file) :direction :input) + (file-parser-aux s error-fn print-parse-errors grammar verbose))) + +(defun file-parser-aux (stream error-fn print-parse-errors grammar verbose + &aux R (eof (cons nil nil))) + (labels ((skip-lines (stream end) + ;; ignore lines until end is found + (let ((l (read-line stream nil eof))) + (if (stringp l) + (let ((p (search end l))) + (if p + (let ((l-rest (string-left-trim + '(#\Space #\Tab) + (subseq l (+ p (length end)))))) + (if (string= l-rest "") + (next-line stream) + l-rest)) + (skip-lines stream end))) + l))) + (next-line (stream) ; ignore comments + (let ((l (read-line stream nil eof))) + (when verbose (terpri) (princ l)) + (if (stringp l) + (let ((l-length (length (setq l (string-left-trim + '(#\Space #\Tab) l))))) + (if (zerop l-length) + (next-line stream) + (if (char= *comment-start* (schar l 0)) + (next-line stream) + ;; does this line start a comment + (dolist (comment *comment-brackets* l) + (let* ((start (car comment)) + (start-length (length start))) + (when (and + (>= l-length start-length) + (string= l start :end1 start-length)) + ;; a comment found + (return + (setq l (skip-lines + stream + (cdr comment)))))))))) + l)))) + (do ((line (next-line stream))) + ((eq line eof) (nreverse R)) + (multiple-value-bind (expr rest) + (read-parser line + :error-fn error-fn + :print-parse-errors print-parse-errors + :grammar grammar + :junk-allowed t + :more-allowed t + :more-fn #'(lambda (&optional error-fn) + (setq line (next-line stream)) + (if (eq line eof) + (if error-fn + (funcall error-fn) + (error "Reached end of file ~S while parsing" + stream)) + line))) + ;; (when verbose (let ((*print-structure* t)) (print expr))) + (push expr R) + (when (eq line eof) (return (nreverse R))) + (setq line (if rest + (subseq line rest) + (next-line stream))))))) + +;----------------------------------------------------------------------------; +; debug-parser +;------------- +; +; +(defun debug-parser (&key (grammar t) (lexer nil)) + (setq *grammar-debug* grammar + *lexer-debug* lexer) + (let ((*default-pathname-defaults* + (if (or grammar lexer) + (merge-pathnames + *ZEBU-directory* + (make-pathname :type (first *load-source-pathname-types*))) + (merge-pathnames + (make-pathname + :type (first *load-binary-pathname-types*)) + *ZEBU-binary-directory*)))) + ;; "zebu-loader" needs only to be loaded if the compiler + ;; in-line codes slot accessors and does not keep the function + ;; definitions + #+ALLEGRO (load "zebu-loader") + (load "zebu-driver"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-driver.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-dump.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-dump.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,194 @@ +; -*- mode: CL -*- ------------------------------------------------- ; +; File: dump.l +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 31-Oct-90 +; Modified: Fri Mar 8 14:46:38 1996 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 16-Jul-91 (Joachim H. Laubsch) +; to deal with multiple-grammars, begin a ".tab" file with *GRAMMAR-OPTIONS* +; a keyworded arglist that can be passed to MAKE-GRAMMAR +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. + +;;; +;;; Dump parsing tables and associated stuff into a file. +;;; +;;; The follwing stuff is dumped in parenthesized lists which a lisp reader +;;; should be able to read: +;;; +;;; A keyword argument list for the MAKE-GRAMMAR function. +;;; An ordered (by grammar symbol index) lexicon. +;;; A list of the indices of terminal grammar symbols. +;;; A list of production info, ordered by production index, of lists +;;; containing the index of the lhs grammar symbol and the length +;;; of the rhs of the production. +;;; A sparse list of lists representation of the action function +;;; (eyball one and you'll get the idea...). +;;; A similar representation of the goto function. +;;; The index of the start state. +;;; The index of the end symbol. +;;; A list of the client lambda forms. + +(in-package "ZEBU") +(declaim (special *ACTION-ARRAY* *GOTO-ARRAY* *LR0-START-STATE-INDEX*)) + +(defun dump-tables (grammar-file output-file) + (macrolet ((delete! (item sequence) + `(delete ,item ,sequence :test #'equal))) + (let ((*print-structure* t) + *print-pretty* *print-length* *print-level* *print-circle* + (filename (if output-file + (pathname output-file) + (merge-pathnames + (make-pathname :type "tab") + grammar-file)))) + (format t "~%Dumping parse tables to ~A~%" filename) + (with-open-file (port filename :if-does-not-exist :create + :if-exists :supersede + :direction :output) + ;; 1: Dump options + (format port "~%~S" *grammar-options*) + ;; 2: Dump out an ordered lexicon. + (let ((ln (length *g-symbol-alist*))) + (format port "~%#~S(" ln) + (dolist (pair (reverse *g-symbol-alist*)) + (format port "~S " (car pair))) + (format port ")~%~%")) + ;; 3: Dump a list of the indices of terminal grammar symbols + ;; deal with some special cases... . + (let ((gs-list (delete + '() + (delete! + *empty-string-g-symbol* + (delete! + *augmented-start-g-symbol* + (delete! + *the-end-g-symbol* + (mapcar #'(lambda (gs) + (unless (g-symbol-non-terminal? gs) gs)) + (reverse *symbols*)))))))) + (format port "~%#~S(" (length gs-list)) + (dolist (gs gs-list) + (format port "~S " (g-symbol-index gs))) + (format port ")~%~%")) + ;; 4: productions + ;; For the lr parser, dump a list of info on the productions. + ;; The order of the list follows the productions indices in + ;; the parse tables. Each element is a list of the index of + ;; the lhs grammar symbol and the length of the rhs of the production. + (format port "#~S(" (length *productions*)) + (dolist (prod (reverse *productions*)) + (format port "(~S . ~S)" + (g-symbol-index (lhs prod)) + (production-length prod))) + (format port ")~%") + + ;; 5: Dump out a representation of the action function. + (let ((aa-len (length (the vector *action-array*)))) + (format port "~%#~S(" aa-len) + (dotimes (i aa-len) + (format port "~%~S" (oset-item-list (svref *action-array* i)))) + (format port ")~%")) + + ;; 6: Dump out a representation of the goto function for non-terminals + (let ((ga-len (length (the vector *action-array*)))) + (format port "~%#~S(" ga-len) + (dotimes (i (length *goto-array*)) + (format port "~%(") + (dolist (item (oset-item-list (svref *goto-array* i))) + (format port "~S" item)) + (format port ")")) + (format port ")")) + + ;; 7: Dump the index of the start state. + (print *lr0-start-state-index* port) + (terpri port) + + ;; 8: Dump the index of the end symbol. + (print (g-symbol-index *the-end-g-symbol*) port) + (terpri port) + + ;; 9: Dump out a vector of the client lambdas + (let (*print-pretty*) + (format port "~%#~S(~{~S~%~})" + (length *zb-rules*) + (setq *zb-rules* (nreverse *zb-rules*)))) + ) + filename))) + +;; Set up some convenient ways to process grammars. + +(defun compile-slr-grammar (grammar-file &rest args) + (apply #'compile-zebu-grammar-aux + grammar-file + #'slr-tables-from-grammar + args)) + +(defun compile-lalr1-grammar (grammar-file &rest args) + (apply #'compile-zebu-grammar-aux + grammar-file + #'lalr1-tables-from-grammar + args)) + +(declaim (special *compiler-grammar*)) +(defun compile-zebu-grammar-aux + (grammar-file compiler + &key + (output-file (merge-pathnames + (make-pathname :type "tab") + grammar-file)) + (grammar *null-grammar*) + verbose + (compile-domain t)) + (let ((*compiler-grammar* grammar) + (*package* *package*)) + (setq grammar-file (funcall compiler grammar-file :verbose verbose)) + (when (get-grammar-options-key ':PACKAGE) + (setq *package* (find-package (get-grammar-options-key ':PACKAGE)))) + (let ((domain-file (dump-domain-file grammar-file verbose))) + (when (and compile-domain domain-file) + (compile-file + domain-file + :output-file (merge-pathnames + (make-pathname + :host (pathname-host domain-file) ;; Added by Henry + :name (pathname-name domain-file) + :directory (pathname-directory output-file) + :type (car *load-binary-pathname-types*))) + ))) + (dump-tables grammar-file output-file))) + +;;;;;;;;;;;;; +;;; test: +#|| +(set-working-directory *ZEBU-test-directory*) +(compile-slr-grammar "ex1.zb") +(compile-slr-grammar "ex2.zb") + +;; fails : not slr +(compile-slr-grammar "ex3.zb") +;;(compile-slr-grammar "ex4.zb") + +;; fails : not slr +(compile-slr-grammar "ex6-2.zb") +(compile-lalr1-grammar "ex1.zb") +(compile-lalr1-grammar "ex2.zb") +(compile-lalr1-grammar "ex3.zb") +(compile-lalr1-grammar "ex4.zb") +(compile-lalr1-grammar "ex6-2.zb") + +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of dump.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-empty-st.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-empty-st.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,52 @@ +; -*- mode: CL -*- ------------------------------------------------- ; +; File: empty-st.l +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 31-Oct-90 +; Modified: Tue Jan 26 09:20:23 1993 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Cruise the productions and figure out which ones derive the empty string. + +(defun calculate-empty-string-derivers () + (labels ((string-vanishes (gslist) + (cond ((null gslist) t) + ((not (g-symbol-derives-empty-string (car gslist))) nil) + (T (string-vanishes (cdr gslist))))) + (process-symbol-which-derives-empty-string (gs) + (unless (g-symbol-derives-empty-string gs) + (let (*print-circle*) + (format t "~S derives the empty string~%" gs)) + (setf (g-symbol-derives-empty-string gs) t) + (dolist (prod (g-symbol-rhs-productions gs)) + (if (string-vanishes (rhs prod)) + (process-symbol-which-derives-empty-string (lhs prod))))))) + (dolist (prod *productions*) + (unless (rhs prod) + (process-symbol-which-derives-empty-string (lhs prod)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test: +#|| +(load-grammar (merge-pathnames "ex3.zb" *ZEBU-test-directory*)) +(calculate-empty-string-derivers) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of empty-st.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-first.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-first.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,144 @@ +; -*- mode: CL -*- ------------------------------------------------- ; +; File: zebu-first.l +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 31-Oct-90 +; Modified: Thu Apr 29 10:42:53 1993 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 27-Mar-92 (Joachim H. Laubsch) +; modified empty string handling to not propagate to dependers +; see Fischer LeBlanc, pp 104-106, Grammar G0 +; 25-Mar-92 (Joachim H. Laubsch) +; included warning for non-terminals that do not derive a terminal string +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Calculate the first sets of the grammar symbols. +;;; Basic design from John Bear : +;;; University of Texas at Austin Tech Report GRG 220 +;;; "A Breadth-First Syntactic Component" +;;; I added empty string handling: Sandy Wells. + +(defun calculate-first-sets () + (labels ((calculate-first-sets-aux (prod-lhs prod-rhs) + (declare (cons prod-rhs)) + (let ((rhs-first (car prod-rhs))) + (if (g-symbol-non-terminal? rhs-first) + ;; must be non terminal + ;; X -> Y1 Y2 ... Yn + ;; place a in first-sets(X) if for some i a is in first-sets(Yi) + ;; and for all j s...} + +(defun first-seq (seq) + (declare (type list seq)) + (if (null seq) + (make-oset :order-fn #'g-symbol-order-function) + (let* ((seq1 (car (the cons seq))) + (firsts (g-symbol-first-set seq1))) + (declare (type g-symbol seq1)) + (if (g-symbol-derives-empty-string seq1) + (oset-union + (oset-delete *empty-string-g-symbol* firsts) + (first-seq (cdr seq))) + firsts)))) + +;; a specialization to a sequence SEQ, followed by an element SEQ1 +(defun first-seq-1 (seq seq1) + (declare (type list seq) (type g-symbol seq1)) + (labels ((first-seq-aux (seq) + (if (null seq) + (let ((firsts (g-symbol-first-set seq1))) + (if (g-symbol-derives-empty-string seq1) + (oset-delete *empty-string-g-symbol* firsts) + firsts)) + (let* ((seq1 (car (the cons seq))) + (firsts (g-symbol-first-set seq1))) + (declare (type g-symbol seq1)) + (if (g-symbol-derives-empty-string seq1) + (oset-union + (oset-delete *empty-string-g-symbol* firsts) + (first-seq-aux (cdr seq))) + firsts))))) + (first-seq-aux seq))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test +#|| +(set-working-directory *ZEBU-test-directory*) +(load-grammar "ex2.zb") +(calculate-empty-string-derivers) +(calculate-first-sets) +(cruise-first-sets) +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-first.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-follow.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-follow.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,92 @@ +; -*- mode: CL -*- ------------------------------------------------- ; +; File: zebu-follow.l +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 31-Oct-90 +; Modified: Tue Jan 26 09:21:04 1993 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 20-Mar-91 (Joachim H. Laubsch) +; Improved grammar debugging +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Compute follow on a grammar symbol. + +(defun calculate-follow-sets () + (compute-follow-dependers) + (follow-insert-first-sets)) + + +;;; Called initially on a production with prod being the production and +;;; prod-rhs being the rhs of the production. +;;; Returns true only if the prod-rhs derives the empty string, or is the +;;; empty string. Fills in follow set dependencies by side effect. + +(defun compute-follow-dependers (&aux prod) + (labels ((compute-follow-dependers-aux (prod-rhs) + (if prod-rhs + (let ((rhs-first (car prod-rhs))) + (when (compute-follow-dependers-aux (cdr prod-rhs)) + (oset-insert! rhs-first + (g-symbol-follow-dependers (lhs prod))) + ;; Return indication of whether tail derives empty string. + (g-symbol-derives-empty-string rhs-first))) + t))) + (do ((prods *productions* (cdr prods))) + ((null prods)) + (setq prod (car (the cons prods))) + (compute-follow-dependers-aux (rhs prod))))) + +(defun follow-insert-first-sets () + (labels ((follow-insert-symbol (symbol-to-insert whose-follow-set) + ;; Both arguments are g-symbols. + (if (oset-insert! symbol-to-insert + (g-symbol-follow-set whose-follow-set)) + ;; Do it to his dependers too.. + (dolist (depender (oset-item-list (g-symbol-follow-dependers + whose-follow-set))) + (follow-insert-symbol symbol-to-insert depender)))) + (follow-insert-first-sets-aux (prod-rest) + ;; Called on successive tails of the rhs of each production. + (when prod-rest + (let ((prod-rest2 (cdr prod-rest))) + (when prod-rest2 + ;; prod-rest has at least two items + (dolist (symbol (oset-item-list (first-seq prod-rest2))) + (unless (eq symbol *empty-string-g-symbol*) + (follow-insert-symbol symbol (car prod-rest)))) + (follow-insert-first-sets-aux prod-rest2)))))) + (follow-insert-symbol *the-end-g-symbol* *start-symbol*) + (dolist (prod *productions*) + (follow-insert-first-sets-aux (rhs prod))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test: + +#|| +(set-working-directory *ZEBU-test-directory*) +(load-grammar "ex2.zb") +(compile-slr-grammar "ex2.zb") +(ZEBU-LOAD-FILE "ex2.tab") +(calculate-empty-string-derivers) +(calculate-first-sets) +(calculate-follow-sets) +(cruise-follow-sets) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-follow.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-g-symbol.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-g-symbol.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,107 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-g-symbol.l +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 10-Oct-90 +; Modified: Thu Apr 29 10:49:59 1993 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. + +(in-package "ZEBU") +;;; Grammar symbols are represented by g-symbol structs. +;;; +;;; +;;; print-name is a string. +;;; +;;; index is a unique integer associated with the symbol. +;;; +;;; own-productions is a list of the productions that the symbol +;;; appears on the left side of. +;;; rhs-productions is a list of the productions the symbol appears +;;; on the right side of. +;;; +;;; first-set is the set of terminal grammar symbols which can +;;; legally start a string derived from the symbol. +;;; +;;; first-set-dependers is used in the computation of the first-set. +;;; +;;; derives-empty-string is a quick way of telling if the empty +;;; string is in the first-set of the symbol. +;;; +;;; follow-set is the set of terminal symbols which may appear after +;;; the symbol in strings of the language. +;;; +;;; follow-dependers is the set of grammar symbols whose follow sets +;;; must contain this guys follow set. +;;; sets will be represented by o-sets. +;;; +;;; A hack -- a g-symbol is non-terminal if its own-productions is NOT '(). + +(defstruct (g-symbol (:print-function + (lambda (g-symbol stream depth) + (declare (ignore depth)) + (let ((name (g-symbol-name g-symbol))) + (if (g-symbol-non-terminal? g-symbol) + (format stream "[<~A>]" name) + (format stream "<~A>" name)))))) + name + index + (own-productions '()) + (rhs-productions '()) + (first-set (make-oset :order-fn #'g-symbol-order-function)) + (first-set-dependers (make-oset :order-fn #'g-symbol-order-function)) + (derives-empty-string '()) + (follow-set (make-oset :order-fn #'g-symbol-order-function)) + (follow-dependers (make-oset :order-fn #'g-symbol-order-function))) + + +(declaim (inline g-symbol-non-terminal?)) +(defun g-symbol-non-terminal? (sym) + (not (null (g-symbol-own-productions sym)))) + +(defmacro new-g-symbol (name index) + `(make-g-symbol :name ,name + :index ,index)) + +(declaim (inline g-symbol-order-function)) +(defun g-symbol-order-function (sa sb) + (declare (type g-symbol sa sb)) + (let ((sai (g-symbol-index sa)) (sbi (g-symbol-index sb))) + (declare (fixnum sai sbi)) + (if (<= sai sbi) + (if (< sai sbi) + 'correct-order + 'equal) + 'wrong-order))) + +(declaim (inline g-symbol-add-production)) +(defun g-symbol-add-production (g-symbol production) + (setf (g-symbol-own-productions g-symbol) + (cons production (g-symbol-own-productions g-symbol)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test +#|| +(load "g-symbol") +(defvar g1 (new-g-symbol "foo" 3)) +(defvar g2 (new-g-symbol "goo" 5)) +(g-symbol-order-function g1 g2) +(g-symbol-non-terminal? g1) +(print g1) + +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-g-symbol.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-generator.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-generator.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,1053 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-generator.lisp +; Description: Generate Domain and Print-Functions for the grammar +; Author: Joachim H. Laubsch +; Created: 25-Feb-92 +; Modified: Wed Jan 13 10:16:30 1999 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(IN-PACKAGE "ZEBU") + +(declaim (special + *identifier-continue-chars* + *identifier-start-chars* + *domain-structs* + *domain-types* + *grammar-options* + *lex-cats* + )) + +;----------------------------------------------------------------------------; +; generate-domain-file +;--------------------- +; Generate the DEFSTRUCT calls to define the domain & dump to FILE +; When using the meta-grammar, printers will be compiled too. + +; file is open when generate-domain-file is called. +; return true if anything was written. + +; If DEFSTRUCT is used in the grammar file -- *domain-structs* is not +; () -- the domain does not need to be generated. + +(defun generate-domain-file (file port &aux domain printers) + (unless *domain-structs* + (when (setq domain + (prepare-domain + (or (get-grammar-options-key ':DOMAIN) + ;; set the domain keyword, s.t. at load time + ;; the domain definition is present + (let ((d (process-domain-definition))) + (when d + (nconc *grammar-options* + (list ':DOMAIN d))) + d)))) ; sets *domain-type-hierarchy* + (when (string= (grammar-name *compiler-grammar*) + "zebu-mg") + (format t "~%Generating Print-functions ..") + (setq printers (gen-printers))))) + (format t "~%Writing domain to ~a~%" file) + ;; Dump out hierarchy + (let* ((structs (or (reverse *domain-structs*) + (generate-domain domain printers))) + (CL-pkg #-LUCID (find-package "COMMON-LISP") + #+LUCID (find-package "LUCID-COMMON-LISP")) + (Lisp-pkgs + (cons CL-pkg (package-use-list CL-pkg)))) + (dolist (f structs) + (let ((struct-name (defstruct-name f))) + (when (member (symbol-package struct-name) + Lisp-pkgs) + (warn "~s was chosen as the name of domain type, ~%but the symbol is already defined in the ~s" + struct-name (symbol-package struct-name))) + (pprint f port) + (terpri port) + ;; build the kb-hierarchy even if defstructs are used + (when *domain-structs* + (format port "(ZB::DEF-KB-DOMAIN-TYPE '~s '~s '~s)~%" + struct-name + (defstruct-super f) + (defstruct-slots f))) + )) + structs)) + +(defun defstruct-name (x) + (let ((n (cadr x))) + (if (listp n) (car n) n))) + +(defun defstruct-super (x) + (let ((n (cadr x))) + (when (listp n) + (let ((include (assoc ':include (cdr n)))) + (when include (second include)))))) + +(defun defstruct-slots (x) + (mapcar #'(lambda (sd) (if (listp sd) (car sd) sd)) + (cddr x))) + +;----------------------------------------------------------------------------; +; generate-domain +;---------------- +; Given domain D and an alist PRINTERS with pairs ( . ) +; return a list of DEFSTRUCT calls + +(defun generate-domain (d printers &aux code) + (flet ((parse-slots (l) + (mapcar #'(lambda (s) + (if (atom s) + s + `(,(car s) nil :type (or null ,(cadr s))))) + l))) + (flet ((slots (x) + (do ((xrest x (cddr xrest))) + ((null xrest) nil) + (if (eq (car xrest) ':slots) + (return (parse-slots (cadr xrest)))))) + (make-struct (name include slots constructor?) + `(defstruct (,name + (:include ,include) + ,@(let ((fn (assoc name printers))) + (when fn + `((:print-function ,(cdr fn))))) + ,@(unless constructor? + (list '(:constructor nil))) + ) + , at slots))) + (labels ((generate-domain-aux (sub super args constructor?) + (unless (eq sub super) + (push (make-struct sub super (slots args) constructor?) + code)) + (do ((xrest args (cddr xrest))) ((null xrest)) + (when (eq (car xrest) ':subtype) + (let ((newsub (cadr xrest))) + (if (atom newsub) + (push (make-struct newsub sub nil t) code) + (generate-domain-aux + (car newsub) sub (cdr newsub) t))))))) + (when d + (generate-domain-aux (car d) 'kb-domain (rest d) nil) + (nreverse code)))))) + + +;----------------------------------------------------------------------------; +; process-domain-definition +;-------------------------- +; Transform the list of DOMAIN-TYPEs into the hierarchical structure +; with root KB-DOMAIN, and :SUBTYPE, :SLOTS arcs +(defun process-domain-definition (&aux (R (list 'KB-domain))) + (labels ((find-super (node supertype) + ;; node is the list form of the domain def + (if (null node) + 'Nil + (if (eq (car node) supertype) + node + (do ((n (cdr node) (cddr n))) + ((null n) nil) + (when (eq (car n) ':subtype) + (let ((r (find-super (cadr n) supertype))) + (when r (return r))))))))) + (when (null *domain-types*) + (return-from process-domain-definition nil)) + ;; if there is a supertype in *domain-types* that is + ;; undefined, define it as a subtype of KB-domain + (dolist (node *domain-types*) + (let ((supertype (domain-type--supertype node))) + (unless (or (eq supertype 'KB-domain) + (find supertype *domain-types* + :key #'domain-type--type)) + (push (make-domain-type + :-supertype 'KB-domain + :-type supertype) + *domain-types*)))) + ;; transform the sorted list to the external :DOMAIN notation + (let ((domain-types (copy-list *domain-types*))) + (loop (or domain-types (return R)) + (do ((nodes domain-types (cdr nodes))) + ((null nodes)) + (let* ((node (first nodes)) + (supertype (domain-type--supertype node)) + (type (domain-type--type node)) + (slots (domain-type--slots node)) + (super (find-super R supertype))) + (when super + (nconc super `(:subtype + (,type + ,@(if slots `(:slots ,slots))))) + (setq domain-types (delete node domain-types))))))) + ;; (pprint R) + R)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Generate the print-functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;----------------------------------------------------------------------------; +; Non-terminal-p +;--------------- +; +(defun Non-terminal-p (constituent) + (and (symbolp constituent) (not (assoc constituent *lex-cats*)))) + +;----------------------------------------------------------------------------; +; 1-constituent-production-p +;--------------------------- +; +; +(defun 1-constituent-production-p (syntax) + (= 1 (count-if #'Non-terminal-p syntax)) + ) + +(defun first-nt-constituent (syntax) + (find-if #'Non-terminal-p syntax) + ) + +;; collect for each type the lhs and production-rhs in the alist +;; type-prod-AL ( ( . %1=( %2=( . ) .. )) ..) +;; type-print-fn-AL ( ( . (lambda ..)) ..) +;; Return type-print-fn-AL + +(defun gen-printers (&aux type-prod-AL type-print-fn-AL user-def-types + KB-sequence-print-fn-AL KB-sequence-prods + (print-fn-argl (mapcar #'intern + '("ITEM" "STREAM" "LEVEL")))) + (flet ((memo (type val) + (let ((bdg (assoc type type-prod-AL))) + (if (null bdg) + (push (cons type (list val)) type-prod-AL) + (push val (cdr bdg)))))) + (maphash #'(lambda (key val) (declare (ignore val)) + (unless (or (member key '(:TOP KB-DOMAIN KB-SEQUENCE)) + (member (symbol-name key) + *open-categories* + :test #'string=) + (assoc key *lex-cats*)) + (push key user-def-types))) + *domain-ht*) + ;; for each type, gather a set of productions that produce it + ;; also check that the type and its slots are defined + (dolist (zb-rule *zb-rules*) + (let ((lhs (car zb-rule))) + (dolist (prod (zb-rule--productions (cdr zb-rule))) + (let ((semantics (production-rhs--semantics prod))) + (if (null semantics) + (let ((syntax (production-rhs--syntax prod))) + (when (1-constituent-production-p syntax) + (let ((nt (first-nt-constituent syntax))) + (when (eq (car (infer-type-disj-of-expr nt)) + 'kb-sequence) + (memo 'kb-sequence (cons lhs nt)))))) + (when (and semantics (feat-term-p semantics)) + (let* ((type (feat-term--type semantics)) + (type-node (gethash type *domain-HT*)) + (slots (feat-term--slots semantics))) + ;; warn about inconsistent use of the types + (if (null type-node) + (warn "Type: ~S is not defined in this domain" type) + (dolist (slot slots) + (let ((slot-label (label-value-pair--label slot)) + (slot-value (label-value-pair--value slot))) + (if (KB-legal-slot-p type slot-label) + (let ((slot-type (KB-slot-type + type slot-label))) + (unless (eq slot-type ':TOP) + (unless (every + #'(lambda (sub) + (is-subtype-of sub slot-type)) + (infer-type-disj-of-expr slot-value)) + (warn "~S type restriction of ~S violated by ~S" + slot-type slot-label slot-value) + ;;(break "~%> ~S" prod) + ))) + (warn "Slot: ~S is not defined for ~S" + slot-label type))))) + (memo type (cons lhs prod)) + (for-each-supertype + #'(lambda (node) + (setq user-def-types + (delete (type-tree-node--label node) + user-def-types))) + type))))))))) + (when user-def-types + (warn "Types:~{ ~S~}~% were defined but not used." user-def-types)) + + ;; generate print-function for nonterminals which produce a kb-sequence + (when (setf KB-sequence-prods (assoc 'KB-sequence type-prod-AL)) + (setf type-prod-AL (delete KB-sequence-prods type-prod-AL) + KB-sequence-print-fn-AL + (gen-KB-sequence-printers (cdr KB-sequence-prods)))) + ;; (break "KB-sequence-print-fn-AL ~%~S:" KB-sequence-print-fn-AL) + ;; now generate the print-function for each type + ;; unless one has been predefined (via the << foo >> Syntax) + (dolist (e type-prod-AL type-print-fn-AL) + (let* ((type (car e)) + (domain-type (find type *domain-types* + :key #'domain-type--type)) + (fun (when domain-type + (domain-type-print-function domain-type)))) + ;; (break "domain-type: ~s" domain-type) + (when (and domain-type (not fun)) + (let ((%1 (cdr e)) ; (( . )..) + clauses good-bdgs unused-bdgs) + (dolist (%2 %1) ; ( . ) + (push (gen-print-case %2) clauses)) + ;; = (short-lambda-list syntax binding-list) + (multiple-value-bind (cond-clauses bindings) + (gen-clauses clauses KB-sequence-print-fn-AL) + ;; split bindings in good ones and unused ones + (dolist (b bindings) + (if (null (cdr b)) + (pushnew b unused-bdgs) + (pushnew b good-bdgs))) + (setf fun `(lambda (, at print-fn-argl + ,@(when good-bdgs `(&aux .,good-bdgs))) + (declare (ignore + , at unused-bdgs + .,(if (not good-bdgs) + print-fn-argl + (cddr print-fn-argl)))) + ,(if (cdr cond-clauses) + (progn + ;; last cond-clause has antecedent T + (setf (caar (last cond-clauses)) t) + `(cond ,@(simplify-cond-clauses cond-clauses))) + ;; the condition must be true + (cadar cond-clauses))))))) + (push (cons type fun) type-print-fn-AL)))) + +;;------------------------------------------------------------------------;; +;; gen-KB-sequence-printers +;;------------------------- +;; generate in-line format forms for KB-sequence first: +;; KB-sequence-print-fn-AL: ((Constituent . )..); + +(defun gen-KB-sequence-printers (prods &aux Alist separator) + (dolist (prod prods Alist) + ;; prod = ( . ) | ( . ) + (let ((lhs (car prod)) (rhs (cdr prod))) + ;; (format t "~%~%Prod: ~s ::= ~s" lhs (if (symbolp rhs) rhs (production-rhs--syntax rhs))) + (setq separator (decode-separator (if (symbolp rhs) rhs lhs)) + Alist (add-print-fn + lhs + (if separator + `(let ((*kb-sequence-separator* ,separator)) + (declare (special *kb-sequence-separator*)) + (KB-SEQUENCE-print ,lhs nil nil)) + `(KB-SEQUENCE-print ,lhs nil nil)) + Alist)) + ;; (format t "~%Separator: ~s" separator) + ))) + +(defun decode-separator (name) + ;; return NIL for the default separator + (let* ((s (symbol-name name)) + (s-length (length s)) + (last-char-pos (1- s-length))) + (when (char= (schar s last-char-pos) #\$) + (let ((sep-ln-char (schar s (1- last-char-pos)))) + (when (digit-char-p sep-ln-char) + (let ((sep-length (- (char-int sep-ln-char) (char-int #\0)))) + (subseq s + (- s-length sep-length 2) + (- last-char-pos 1)))))))) + +;----------------------------------------------------------------------------; +; add-print-fn +;------------- +; add the print-function FN for the non-terminal CONSTITUENT to ALIST +; +(defun add-print-fn (CONSTITUENT FN ALIST) + (let ((bdg (assoc CONSTITUENT ALIST))) + (if (null bdg) + (acons CONSTITUENT FN ALIST) + (progn (setf (cdr bdg) + `(if (null ,CONSTITUENT) + "" + ,(if (equal FN "") + (cdr bdg) + FN))) + ALIST)))) + +;----------------------------------------------------------------------------; +; clause +;------- +; +; +(defstruct (clause) + ll syntax bl semantics + ) + +;----------------------------------------------------------------------------; +; gen-print-case +;--------------- +; given: ( . ) +; return: lambda-list of constituents in lhs +; syntax of rhs +; for each var in the lambda-list a path of accessors + +(defun gen-print-case (lhs-rhs-pair) + (let* ((prod (cdr lhs-rhs-pair)) + (syntax (production-rhs--syntax prod)) + (semantics (production-rhs--semantics prod)) + (ll (mapcan #'(lambda (constituent) + (unless (stringp constituent) (list constituent))) + syntax)) + (binding-list + (mapcar + #'(lambda (var) + (let ((p (find-path var semantics))) + (if (null p) + (progn + (warn "~:[Lexical Category~; Non-Terminal~] ~S not used in semantics ~% of ~S." + (Non-terminal-p var) var (car lhs-rhs-pair)) + (list var) + ) + (cons var p)))) + ll))) + (make-clause + :ll ll :syntax syntax :bl binding-list :semantics semantics))) + +;----------------------------------------------------------------------------; +; gen-clauses +;------------ +; Given clauses of the form: +; = +; where binding-list = (( . ) ..) +; return: (1) (( ) ..) +; (2) a lambda-list binding the %u .. variables used to accessors +; derived from the paths. +(defconstant *vars-to-use* '("%R" "%S" "%T" "%U" "%V" "%W" "%X" "%Y" "%Z")) + +(defun gen-clauses (clauses KB-sequence-print-fn-AL + &aux (vars-to-use (mapcar #'intern *vars-to-use*)) + ;; a set of sets with the same print syntax + (partitioning (partition-set #'same-print-syntax clauses)) + alist cond-clauses) + (labels ((memo-path (path) + (let ((bdg (assoc path alist :test #'equal))) + (if bdg + (cdr bdg) + (let ((R (pop vars-to-use))) + (push (cons path R) alist) + R)))) + (make-format (syntax bdgs) + (when syntax + (let ((R `(format ,(intern "STREAM") + ,(apply #'concatenate 'string + (make-format-string-list syntax)) + ,@(mapcan + #'(lambda (const) + (unless (stringp const) + (let ((seq-fn-bdg + (assoc + const + KB-sequence-print-fn-AL)) + (var (let ((bdg (cdr (assoc const bdgs)))) + (when bdg (memo-path bdg))))) + (list + (if seq-fn-bdg + `(let ((,const ,var)) + ,(cdr seq-fn-bdg)) + (or var + (warn "Can't unparse ~s~%~s is unbound in semantics" + syntax const))))))) + syntax)))) + ;; (format t "~%format: ~s ~a -->~% " syntax bdgs) (pprint R) (break "gen-clauses") + R)))) + (dolist (eq-print-set partitioning) + (let (ante (proto (first eq-print-set))) + (dolist (eq-print eq-print-set) + (let ((ll (clause-ll eq-print)) + (bdgs (clause-bl eq-print))) + (pushnew + (if (null ll) + (progn + ;; (break "sem: ~s" (clause-semantics eq-print)) + `(equal ,(intern "ITEM") ,(cons-avm + (clause-semantics eq-print)))) + (let* (type-list ; type-preds that have to hold + (ll-map ; (( . <%var>) ..) + (mapcar #'(lambda (var) + (push (infer-type-predicate var) + type-list) + (cons var + (memo-path + (cdr (assoc var bdgs))))) + ll)) + (conjuncts + (mapcan #'(lambda (lvar type) + (if (consp type) + `((typep ,(cdr lvar) ',type)) + (if (eq type 'T) + ;; delete the variables for which + ;; we could not infer a type + () + `((,type ,(cdr lvar)))))) + ll-map (nreverse type-list)))) + (if (cdr conjuncts) + `(AND . ,conjuncts) + (car conjuncts)))) + ante :test #'equal))) + (setq ante (if (cdr ante) (cons 'OR ante) (car ante))) + (setq cond-clauses + (insert-clause `(,ante + ,(make-format (clause-syntax proto) + (clause-bl proto))) + cond-clauses)))) + (values cond-clauses + (mapcar #'(lambda (pair) ; ( . <%var>) + (list (cdr pair) + (path-to-form (car pair) (intern "ITEM")))) + alist)))) + +(defun path-to-form (path target) + (reduce #'(lambda (a b) (list b a)) + path + :initial-value target)) +;----------------------------------------------------------------------------; +; insert-clause +;-------------- +; insert stronger clause at front +; +(defun insert-clause (clause clauses) + (flet ((conjunction? (x) (and (consp x) (eq (car x) 'AND))) + (conjuncts (x) (rest x)) + (typed-var? (x) (and (consp x) (eq (car x) 'TYPEP))) + (typed-var-nm (x) (cadr x)) + (typed-var-type (x) (cadr (caddr x))) + (ante (x) (car x))) + (flet ((weaker-typed? (ante1 ante2) + (and (typed-var? ante1) + (typed-var? ante2) + (eq (typed-var-nm ante1) (typed-var-nm ante2)) + (kb-subtypep (typed-var-type ante2) + (typed-var-type ante1))))) + (if (null clauses) + (list clause) + (let ((ante1 (ante clause))) + ;; (format t "~%a1: ~S~%a2s: ~{~A~%~}" (ante clause) (mapcar #'ante clauses)) + (if (member ante1 clauses :test #'equal :key #'ante) + ;; the antecedent is already in the clauses + ;; this indicate a many-to-one surface-to-abstract syntax + clauses + (let* ((clause2 (first clauses)) (ante2 (ante clause2))) + (if (conjunction? ante2) + (if (conjunction? ante1) + (if (subsetp ante1 ante2 :test #'weaker-typed?) + (cons clause2 (insert-clause clause (rest clauses))) + (cons clause clauses)) + (if (typed-var? ante1) + (if (find-if #'(lambda (a) (weaker-typed? ante1 a)) + (conjuncts ante2)) + (cons clause2 (insert-clause clause (rest clauses))) + (cons clause clauses)) + (cons clause2 (insert-clause clause (rest clauses))))) + (if (conjunction? ante1) + ;; ((and p q) ..) : p --> ((and p q) p ..) + (if (typed-var? ante2) + (if (find-if #'(lambda (a) (weaker-typed? a ante2)) + (conjuncts ante1)) + (cons clause clauses) + (cons clause2 (insert-clause clause (rest clauses)))) + ;; ante2 is not typed, eg. (IDENTIFIERP %U) + (if (member ante2 (conjuncts ante1) :test #'equal) + (cons clause clauses) + (cons clause2 (insert-clause clause (rest clauses))))) + ;; both are simple + (if (weaker-typed? ante1 ante2) + (cons clause2 (insert-clause clause (rest clauses))) + (cons clause clauses))))))))))) + +;----------------------------------------------------------------------------; +; same-print-syntax +;------------------ +; Given clauses rhs A and B +; where = short-lambda-list syntax binding-list +; return true iff +; the syntax's constants are the same and its variables have the same bdg +(defun same-print-syntax (a b) + (let ((a-syntax (clause-syntax a)) (b-syntax (clause-syntax b))) + (and (equal (length a-syntax) (length b-syntax)) + (every #'(lambda (constituent1 constituent2) + (or (and (symbolp constituent1) (symbolp constituent2)) + (and (stringp constituent1) + (stringp constituent2) + (string= constituent1 constituent2)))) + a-syntax b-syntax) + ;; syntax is the same + (let ((a-bdgs (clause-bl a)) (b-bdgs (clause-bl b))) + ;; do all variables of the lambda-list have the same path? + (every #'(lambda (u v) + (equal (cdr (assoc u a-bdgs)) + (cdr (assoc v b-bdgs)))) + (clause-ll a) + (clause-ll b)))))) + +;----------------------------------------------------------------------------; +; make-format-string-list +;------------------------ +; This converts a rhs of a grammar rule (SYNTAX) to a format string. +; It tries to infer when spaces should be inserted based on the +; parameter *identifier-continue-chars* +; As a "rule of style" if a token has a space to its left (right) it should +; also have one to its right (left), unless the token is the last in syntax. +(defun make-format-string-list (syntax) + (let ((sep-sq (insert-seperator? syntax)) + (a-tok "~a") + (s-tok "~s") + (blank " ") + pre-sep?) + ;; const1 const2 ... constn + ;; sep1 sep1 ... sep1 + ;; enforce the rule of style that a grammar keyword has + ;; blanks on both sides if it has one on either + ;; this algorithm is too cautious, since it does not hurt to + ;; introduce a blank! + (do ((syn-tl syntax (cdr syn-tl)) + (sep-tl sep-sq (cdr sep-tl)) + Acc ; accumulated result + ) + ((null syn-tl) (nreverse Acc)) + (let ((const (car syn-tl)) + (sep? (car sep-tl)) + (preceding-blank? (and Acc (eql (first Acc) blank)))) + (if (stringp const) + (progn + ;;(break "constituent= ~s" const) + (when (and pre-sep? + (not preceding-blank?) + (insert-seperator-before? const)) + (setq preceding-blank? t) (push blank Acc)) + (push (escape-tilde const) Acc) + (when (or sep? + ;; there is a preceding blank, and not at end + (and (cdr syn-tl) + preceding-blank? + (parse-id/number? (second syn-tl)))) + (push blank Acc))) + (let ((firsts (first-terminal (constituent-name const)))) + (if (and (null (rest firsts)) + (string= "STRING" (first firsts))) + (push s-tok Acc) + (push a-tok Acc)) + (when (or sep? + ;; there is a preceding blank, and not at end + (and (cdr syn-tl) + preceding-blank? + (parse-id/number? (second syn-tl)))) + (push blank Acc)))) + (setq pre-sep? sep?) + ;; (format t "~%Acc: |~{~a~}|" (reverse Acc)) + )))) + +(defun escape-tilde (string) + ;; precede each ~ by ~ + (declare (string string)) + (let* ((R "") + (tilde #\~) + (p0 0) + (p1 (position tilde string :test #'eql))) + (declare (fixnum p0)) + (if p1 + (loop (setq R (concatenate + 'string R (subseq string p0 p1) "~~")) + (setq p0 (1+ p1)) + (unless (setq p1 (position tilde string + :start p0 :test #'eql)) + (return-from escape-tilde + (concatenate 'string R (subseq string p0))))) + string))) + +(defun parse-id/number? (const) + (when (stringp const) + (let* ((s const) (n (length s)) state) + (declare (string s)) + (or ; number + (dotimes (i n t) + (let ((c (schar s i))) + (if (null state) + (if (digit-char-p c) + nil + (if (eql c #\.) + (setq state t) + (return nil))) + (if (digit-char-p c) + nil + (return nil))))) + ; id + (setq state nil) + (dotimes (i n t) + (let ((c (schar s i))) + (if (null state) + (if (find c *identifier-start-chars*) + (setq state t) + (return nil)) + (if (find c *identifier-continue-chars*) + nil + (return nil))))))))) + +(defun continues-token? (e) + (declare (string e)) + (or (zerop (length e)) + (let ((c (schar e 0))) + (declare (character c)) + (if (find c *identifier-continue-chars*) + t + (or (digit-char-p c) + (eql c #\.)))))) + +(defun insert-seperator? (s) + ;; -> seq of T/Nil depending on whether the element in s should + ;; be followed by a seperator + (declare (list s)) + (maplist #'(lambda (s-tl) + (let ((e1 (first s-tl))) + (if (null (rest s-tl)) + ;; e1 is the last element + ;; by default no seperator after the last const + nil + ;; compare e1 to next element, e2 + (let ((e2 (second s-tl))) + (if (symbolp e1) + (if (symbolp e2) + t + ;; the following string e2 could continue + ;; the id e1 + (continues-token? (the string e2))) + (let ((ln1 (length e1))) + (if (= 0 ln1) + nil + (if (symbolp e2) + ;; e1 is a string + ;; follow it by space if + ;; it ends neither in white-space + ;; nor in a char not in *identifier-continue-chars* + ;; nor a digit + (insert-seperator-after? e1) + ;; both e1 and e2 are strings + ;; could they parse as a number or an id? + (and (parse-id/number? e1) + (continues-token? (the string e2))))))))))) + s)) + +(defun white-space-p (char) + (let ((w (or (get-grammar-options-key ':white-space) + '(#\Space #\Newline #\Tab)))) + (member (the character char) w :test #'char=))) + +(defun insert-seperator-before? (const) + (or (symbolp const) + (let ((ln (length const))) + (or (zerop ln) + (let ((c0 (schar const 0))) + (if (find c0 *identifier-continue-chars*) + T + (or (digit-char-p c0) + (white-space-p c0)))))))) + +(defun insert-seperator-after? (const) + (or (symbolp const) + (let ((ln (length const))) + (or (zerop ln) + (let ((last-char (schar const (1- ln)))) + (if (white-space-p last-char) + nil + (if (find last-char *identifier-continue-chars*) + T + (digit-char-p last-char)))))))) + +;----------------------------------------------------------------------------; +; simplify-cond-clauses +;---------------------- +; ((and a1 b1) c1) +; ((and a1 b2) c2 ..) .. +; (cond (a1 (cond (b1 c1) (b2 c2))) .. + +(defun simplify-cond-clauses (clauses) + (flet ((conj1 (cl) (second cl)) + (conj2 (cl) (third cl)) + (and? (cl) (and (consp cl) (eq (car cl) 'AND)))) + (let* ((cl1 (first clauses)) + (ante1 (car cl1)) + (rest1 (cdr cl1))) + (if (and (and? ante1) (rest clauses)) + (let* ((cl2 (second clauses)) + (ante2 (car cl2)) + (rest2 (cdr cl2))) + (if (and (and? ante2) (equal (conj1 ante1) (conj1 ante2))) + `((,(conj1 ante1) (cond (,(conj2 ante1) .,rest1) + (,(conj2 ante2) .,rest2))) + .,(cddr clauses)) + clauses)) + clauses)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Type Inference for Non-Terminals +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun type->predicate (type) + (case type + (NUMBER 'numberp) + (IDENTIFIER 'identifierp) + (STRING 'stringp) + (t (intern (concatenate 'string (symbol-name type) "-P") + (symbol-package type))))) + +(defun infer-type-predicate (var &aux (v (constituent-name var))) + (case v + (NUMBER 'numberp) + (IDENTIFIER 'identifierp) + (STRING 'stringp) + (t (let ((type (infer-type v))) + (if (eq type ':TOP) + (let ((domain-top (car (type-tree-node--subtypes + *domain-type-hierarchy*)))) + `(OR + ,(type-tree-node--label domain-top) + NUMBER SYMBOL STRING)) + (if (consp type) + (if (null (rest type)) + (type->predicate (first type)) + (cons 'OR type)) + (if (null type) + 'T + (type->predicate type)))))))) + + +(defun infer-type (v) + (if (member v '(NUMBER IDENTIFIER STRING)) + v + (let ((disj (infer-type-disj v))) + (if (null disj) + (warn "Could not infer type for ~S" v) + disj)))) + +;----------------------------------------------------------------------------; +; is-subtype-of +;-------------- +; +; +(defun is-subtype-of (a b) + (or (eq a b) + (let ((type-nd (gethash a *domain-HT*))) + (when type-nd + (let ((sup (type-tree-node--supertype type-nd))) + (and sup + (is-subtype-of (type-tree-node--label sup) b))))))) + +;----------------------------------------------------------------------------; +; kb-subtypep +;------------ +; disjunctive and conjunctive types are allowed +; +(defun kb-subtypep (a b) + (if (consp a) + (case (first a) + (OR (every #'(lambda (junct) (kb-subtypep junct b)) + (rest a))) + (AND (some #'(lambda (junct) (kb-subtypep junct b)) + (rest a))) + (T nil)) + (if (consp b) + (case (first b) + (OR (some #'(lambda (junct) (kb-subtypep junct a)) + (rest b))) + (AND (every #'(lambda (junct) (kb-subtypep junct a)) + (rest b))) + (T nil)) + (is-subtype-of a b)))) + +(defun check-domain-type (type node) + (unless type + (error "~S is not a defined domain type." node))) + +(defun infer-type-disj (v &aux (nts (list v))) + ;; return a list of the possible types for a non-terminal V + (labels ((infer-type-aux (v disjuncts) + (if (or (member v '(NUMBER IDENTIFIER STRING)) + (assoc v *lex-cats*)) + (adjoin v disjuncts) + (let ((zb-rule (assoc v *zb-rules*)) + (types disjuncts)) + (unless zb-rule + (error "No Rule/Non-terminal named ~s found" v)) + (dolist (prod (zb-rule--productions (cdr zb-rule)) types) + (let ((s (production-rhs--semantics prod))) + (if s + (if (feat-term-p s) + (setq types (adjoin-type-disj + (feat-term--type s) types)) + (dolist (type (infer-type s)) + (setq types (adjoin-type-disj type types)))) + (let ((nt (find-if #'symbolp + (production-rhs--syntax prod)))) + (unless (or (null nt) (member nt nts)) + (push nt nts) + (setq types + (infer-type-aux nt types))))))))))) + (infer-type-aux v nil))) + +(defun adjoin-type-disj (type disj) + (if (find type disj :test #'is-subtype-of) + disj + (cons type (delete-if #'(lambda (a) (is-subtype-of a type)) + disj)))) + + +(defun infer-type-disj-of-expr (x) + (typecase x + (number '(number)) + (string '(string)) + (symbol (infer-type-disj (constituent-name x))))) + +;----------------------------------------------------------------------------; +; find-path +;---------- +; Given a typed feature-structure feat-term, and a variable V occuring +; somewhere as a value of a slot, return a path to it +; return: (1) if you are there () +; (2) if there is no path to v: :FAIL +; (3) if there is some path: the first one found + +(defun find-path (v feat-term) + (labels ((find-path-aux (avl) + (if (atom avl) + (if (feat-term-p avl) + (find-path-list (feat-term--slots avl) + (feat-term--type avl)) + (if (eq v avl) + t + :FAIL)) + :FAIL)) + (find-path-list (avl type) + (dolist (lv-pair avl) + (let ((p (find-path-aux (label-value-pair--value lv-pair)))) + (unless (eq p :FAIL) + (return + (cons (intern + (concatenate + 'string + (symbol-name type) "-" + (symbol-name (label-value-pair--label lv-pair))) + (symbol-package type)) + (if (eq p 't) nil p)))))))) + (find-path-aux feat-term))) + +;----------------------------------------------------------------------------; +; partition-set +;-------------- +; partition SET according to EQUIV-FN +; for equiv-fn holds (equiv-fn x y) = (equiv-fn y x) + +(defun partition-set (equiv-fn set &aux alist) + (do ((x-set set (cdr x-set))) ((null x-set)) + (let ((x (car x-set))) + (push (list x) alist) + (do ((y-set (cdr x-set) (cdr y-set))) ((null y-set)) + (let ((y (car y-set))) + (if (funcall equiv-fn x y) + (let ((found-association (assoc x alist))) + (push y (cdr found-association)))))))) + (labels ((partition-set-aux (alist) + (if (null alist) + '() + (let* ((pair1 (car alist)) + (set1 (reduce #'union + (mapcar + #'(lambda (p) + (let ((found (find-if + #'(lambda (p1) + (member p1 p)) + pair1))) + (when found + (setf alist (delete p alist)) + p))) + (cdr alist)) + :initial-value pair1))) + (cons set1 + (partition-set-aux (cdr alist))))))) + (partition-set-aux alist))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#|| + +(GEN-PRINTERS (find-grammar "ex1a")) +(infer-type 'cl-user::ee) +(infer-type 'cl-user::f) +(infer-type 'cl-user::tt) +(infer-type-predicate 'IDENTIFIER) +(infer-type-predicate 'cl-user::ee) + +(PARTITION-SET #'(lambda (x y) + (eql (schar (string x) 0) + (schar (string y) 0))) + '(a aa aaa b bbb bb c cccc)) + +(PARTITION-SET #'(lambda (x y) + (eql (schar (string x) 0) + (schar (string y) 0))) + '(a b c)) + +;----------------------------------------------------------------------------; +; partition-set-by-selection-fn +;------------------------------ +;;; partition set according to selection-fn + +(defun partition-set-by-selection-fn (selection-fn set &aux alist) + (dolist (item set) + (let* ((key (funcall selection-fn item)) + (found-association (assoc key alist :test #'eql))) + (if found-association + (nconc (cdr found-association) (list item)) + (push (cons key (list item)) alist)))) + (dolist (pair alist) + (setf (car pair) (cadr pair) + (cdr pair) (cddr pair))) + alist) + + +(partition-set-by-selection-fn #'evenp '(1 2 3 4 5 6 7 8)) + + ==> ((2 4 6 8) (1 3 5 7)) +||# + +#|| +;----------------------------------------------------------------------------; +; follow-terminal +;---------------- +; given the name of a grammar-symbol, return the +; list of possibly following strings +(defun follow-terminal (name) + (mapcar #'g-symbol-name + (oset-item-list (g-symbol-follow-set (g-symbol-intern name)))) + ) +||# + +(defun first-terminal (name) + (mapcan #'(lambda (item) + (unless (eq item *empty-string-g-symbol*) + (list (g-symbol-name item)))) + (oset-item-list (g-symbol-first-set (g-symbol-intern name))))) + +#|| +(follow-terminal 'user::ARG) +(first-terminal 'user::ARG*448) +(follow-terminal 'user::ARG*) +(first-terminal 'user::Name) +(first-terminal 'Identifier) + +(intersection (follow-terminal 'user::ARG) (first-terminal 'user::ARG*438)) +(intersection (follow-terminal 'user::stmt) (first-terminal 'user::stmt+)) + +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-generator.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-kb-domain.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-kb-domain.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,155 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-kb-domain.lisp +; Description: +; Author: Joachim H. Laubsch +; Created: 19-Mar-93 +; Modified: Wed Aug 4 20:43:54 1993 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1993, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(IN-PACKAGE "ZEBU") +(require "zebu-aux") +(provide "zebu-kb-domain") +;----------------------------------------------------------------------------; +; for-each-supertype +;------------------- +; Iterate fn over all supertypes of type. Type is the label of a +; type-tree-node in *domain-HT* +; Note that every type is its own supertype. + +(defun for-each-supertype (fn type &optional errorp) + (let ((node (gethash type *domain-HT*))) + (labels ((doit (node) + (when (type-tree-node-p node) + (funcall fn node) + (doit (type-tree-node--supertype node))))) + (if node + (doit node) + (when errorp + (KB-type-error type)))))) + +;----------------------------------------------------------------------------; +; KB-legal-slot-p +;---------------- +; Is slot-label a legal name of a slot of a type named TYPE? +; EXPORTED +(defun KB-legal-slot-p (type slot-label) + (for-each-supertype #'(lambda (node) + (dolist (slot (type-tree-node--slots node)) + (when (eq (if (consp slot) + (car slot) + slot) + slot-label) + (return-from KB-legal-slot-p t)))) + type + t)) + +;----------------------------------------------------------------------------; +; KB-slot-type +;------------- +; slot-label is a KB-legal-slot-p type +; if slot-label has a type restriction ( ) +; this restriction will be returned +; else :TOP wil be returned +; EXPORTED +(defun KB-slot-type (type slot-label) + (for-each-supertype + #'(lambda (node) + (dolist (slot (type-tree-node--slots node)) + (if (consp slot) + (when (eq (car slot) slot-label) + (return-from KB-slot-type (cadr slot))) + (when (eq slot slot-label) + (return-from KB-slot-type :TOP))))) + type + t) + (error "~a is not a slot of ~a" slot-label type) + ) + +;----------------------------------------------------------------------------; +; kb-slots +;--------- +; given a type name, return its slots +; a slot may be a list ( ) +; EXPORTED +(defun kb-slots (type &aux slots) + (for-each-supertype + #'(lambda (n) + (setq slots (append (type-tree-node--slots n) slots))) + type + t) + slots) + +;----------------------------------------------------------------------------; +; kb-supertype +;------------- +; given a type name, return its supertype +; the top type is named :TOP and its supertype is :TOP +; EXPORTED +(defun kb-supertype (type) + (let ((node (gethash type *domain-HT*))) + (if node + (if (eq *domain-type-hierarchy* node) + ':TOP + (type-tree-node--label + (type-tree-node--supertype node))) + (KB-type-error type)))) + +;----------------------------------------------------------------------------; +; kb-subtypes +;------------ +; given a type name, return a list of its subtypes +; EXPORTED +(defun kb-subtypes (type) + (let ((node (gethash type *domain-HT*))) + (if node + (mapcar #'type-tree-node--label + (type-tree-node--subtypes node)) + (KB-type-error type)))) + +(defun KB-type-error (type) + (error "~a is not a KB-type" type)) + +(defun KB-type-name-p (item) + ;; if ITEM is the name of a subtype of KB-domain + (not (null (gethash item *domain-HT*)))) + +#|| test +(zb:compile-slr-grammar (merge-pathnames "arith-exp.zb" + user::*ZEBU-test-directory*) + :output-file (merge-pathnames + "binary/arith-exp.tab" + user::*ZEBU-test-directory*) + :grammar (find-grammar "zebu-mg")) +(zb:zebu-load-file (merge-pathnames "binary/arith-exp.tab" + user::*ZEBU-test-directory*)) +(ds:load-system 'user::Zebu-rr) +(KB-slot-type 'user::Mult-op 'user::-arg1) +(kb-slots 'user::Plus-op) +(kb-slots 'user::Factor) +(kb-supertype 'user::Factor) +(kb-supertype 'user::ARITH-EXP) +(kb-supertype 'KB-DOMAIN) +(kb-supertype 'KB-SEQUENCE) +(kb-supertype ':TOP) + +(kb-subtypes ':TOP) +(KB-type-name-p 'IDENTIFIER) +(KB-type-name-p 'KB-DOMAIN) +(KB-subtypes 'KB-DOMAIN) +(kb-subtypes 'user::ARITH-EXP) +(kb-subtypes 'user::+-OP) +(kb-slots 'user::+-OP) + +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-kb-domain.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-lalr1.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-lalr1.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,288 @@ +; -*- mode: CL -*- ------------------------------------------------- ; +; File: zebu-lalr1.l +; Description: Calculation of LALR(1) sets +; Author: Joachim H. Laubsch +; Created: 31-Oct-90 +; Modified: Fri Mar 8 14:48:03 1996 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Propagate lookaheads +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This is used when we discover that lookaheads propagate from one +;;; lr(0) item set to another during the calculation of lalr(1) sets +;;; of items. Add a link to the dependency digraph and propagate the +;;; lookaheads we already know about. + +(declaim (inline lalr1-add-depender lalr1-add-lookahead)) + +;;; This is used when we discover a lookhead for an lr(0) item set during +;;; the calculation of lalr(1) sets. If the lookahead wasn't already there, +;;; add it, and also add it to the "dependers": those item sets to whom +;;; lookaheads propagate from the item in question. + +(defun lalr1-add-lookahead (symbol item) + (declare (type item item)) + (labels ((lalr1-add-lookahead-aux (item) + (when (oset-insert! symbol (item-look-aheads item)) + ;; Wasn't already there. + (dolist (depender + (the list (oset-item-list + (the oset + (item-look-ahead-dependers item))))) + (lalr1-add-lookahead-aux depender))))) + (lalr1-add-lookahead-aux item))) + +(defun lalr1-add-depender (propagate-to propagate-from) + (if (oset-insert! propagate-to (item-look-ahead-dependers propagate-from)) + (dolist (gs (the list (oset-item-list + (the oset (item-look-aheads propagate-from))))) + (lalr1-add-lookahead gs propagate-to)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Discover and propagate lalr(1) look-aheads among members of lr(0) +;;; collection. + +;;; This algorithm for propagating lalr(1) lookaheads is a straightforward +;;; recursive version of the algorithm sketched in section 6.9 of the (older) +;;; dragon book "Principles of Compiler Design" by A.V. Aho and J.D Ullman. +;;; The major drawback of this algorithm is that it may be somewhat wasteful +;;; of space. With modern address spaces who cares? +;;; Basically, it crawls around on the lr(0) item sets and as it goes, +;;; it discovers both lookaheads which are "spontaneously" generated for +;;; an item set, and item sets to whom lookaheads propagate. The doubly +;;; recursive way of implementing this is similar to the method used +;;; in calculating first sets in first.l + +;;; (New) the names are getting a bit confusing here. This function transforms +;;; the data structure *lr0-item-sets* from being the lr(0) collection to +;;; the lalr(1) collection. + +;; the following is heavily optimized in the inner loop, and therefore hardly +;; intelligible. For reference look at the original Scheme program at the +;; end of this file. + +(declaim (special *LR0-START-STATE-INDEX*)) + +(defun lalr1-do-lookaheads () + ;; Introduce a "dummy" terminal symbol which is used as a hack in + ;; lookahead calculations. + (let ((dummy-g-symbol (new-g-symbol "dummy" -1)) + (lr0-item-sets-item-list (oset-item-list (the oset *lr0-item-sets*))) + (sad-list (list nil))) ; efficiency hack + ;; The dummy symbol is terminal and must be in its own first set. + (oset-insert! dummy-g-symbol (g-symbol-first-set dummy-g-symbol)) + ;; Map over all the kernel items. + (dolist (item-set lr0-item-sets-item-list) + (declare (type item-set item-set)) + (let* ((kernel (item-set-kernel item-set)) + (index (item-set-index item-set)) + (item-set-goto-map (item-set-goto-map item-set)) + (goto-map-odf (oset-order-fn item-set-goto-map)) + (goto-map-item-list (oset-item-list item-set-goto-map))) + (declare (fixnum index)) + (dolist (kernel-item (the list (oset-item-list (the oset kernel)))) + ;; Special case: the end symbol is a lookahead for the start + ;; production. + (if (= *lr0-start-state-index* index) + ;; There had better only be one item in this set! + (lalr1-add-lookahead *the-end-g-symbol* kernel-item)) + ;; Here we use the hack in dragon 6.9 (fig 6.20) of using lr(1) + ;; closure with a dummy grammar symbol to discover propagated + ;; and spontaneous lookaheads for a lr(0) kernel item. The + ;; funny-closure-items are in J' of the figure. + (dolist (funny-closure-item + ;; The set of "funny" closure items. J'. + (the list (oset-item-list + (the oset (single-item-closure-1 + (copy-lr0-item kernel-item) + dummy-g-symbol))))) + (declare (type item funny-closure-item)) + (block funny-closure-item + (let ((funny-closure-item-look-aheads + (item-look-aheads funny-closure-item))) + (when (oset-empty? funny-closure-item-look-aheads) + (return-from funny-closure-item nil)) + (let* ((production (item-production funny-closure-item)) + (production-length (production-length production)) + (item-after-dot (item-after-dot funny-closure-item))) + (declare (fixnum production-length item-after-dot) + (type production production)) + (when (= production-length item-after-dot) + (return-from funny-closure-item nil)) + (let* ((goto-item-proto (make-item + :production production + :after-dot (1+ item-after-dot))) + (set (item-set-kernel + (cdr (or (progn + ;; instead of CONSing we reuse SAD-LIST + (setf (car (the CONS sad-list)) + (nth item-after-dot + (the list (rhs production)))) + (dolist (item goto-map-item-list) + (when (eq 'equal + (funcall goto-map-odf + sad-list item)) + (return item)))) + (error "Failed to find the goto set"))))) + (odf (oset-order-fn set)) + ;; Here we go to some expense to locate the goto set + ;; for an item. + ;; These should be pre-computed and cached instead. + (goto-item + (dolist (item (oset-item-list set) + (error "Failed to find goto item")) + (when (eq 'equal + (funcall odf goto-item-proto item)) + (return item))))) + (dolist (lookahead + (oset-item-list + (the oset funny-closure-item-look-aheads))) + (if (eq lookahead dummy-g-symbol) + ;; Discovered lookahead propagation. + (lalr1-add-depender goto-item kernel-item) + ;; Discovered lookahead. + (lalr1-add-lookahead lookahead goto-item)))))))))) + (princ ".")) + ;; NEW STUFF HERE: 1-27-88 + (terpri) + (dolist (item-set lr0-item-sets-item-list) + (declare (type item-set item-set)) + (closure-1! (item-set-closure item-set)) + (princ ".")))) + + +;;; This should be primitive, and not insert if not there. +;;; Third arg is error msg +;;; result is eq to member of the set. + +(defun oset-find (element set) + (let ((odf (oset-order-fn set))) + (dolist (item (oset-item-list set)) + (when (eq 'equal (funcall odf element item)) + (return item))))) + +(defun copy-lr0-item (i) + (make-item :production (item-production i) + :after-dot (item-after-dot i))) + +;;; Do all needed to generate parse tables starting with a lisp syntax +;;; grammar. (doesn't write out a table file) + +(defun lalr1-tables-from-grammar (file-name &rest args) + (apply #'load-grammar file-name args) + (calculate-empty-string-derivers) + (calculate-first-sets) + (calculate-follow-sets) + (make-lr0-collection) + (lalr1-do-lookaheads) + (build-parse-tables t) + file-name) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Original Scheme Algorithm +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#|| +(define (lalr1-do-lookaheads) + ;; Introduce a "dummy" terminal symbol which is used as a hack in + ;; lookahead calculations. + (let ((dummy-g-symbol (new-g-symbol "dummy" -1))) + ;; The dummy symbol is terminal and must be in its own first set. + (oset-insert! dummy-g-symbol (g-symbol-first-set dummy-g-symbol)) + ;; Map over all the kernel items. + (oset-for-each + (lambda (item-set) + (oset-for-each + (lambda (kernel-item) + ;; Special case: the end symbol is a lookahead for the start + ;; production. + (if (equal? lr0-start-state-index (item-set-index item-set)) + ;; There had better only be one item in this set! + (lalr1-add-lookahead the-end-g-symbol kernel-item)) + + ;; Here we use the hack in dragon 6.9 (fig 6.20) of using lr(1) + ;; closure with a dummy grammar symbol to discover propagated + ;; and spontaneous lookaheads for a lr(0) kernel item. The + ;; funny-closure-items are in J' of the figure. + + (oset-for-each + (lambda (funny-closure-item) + (if + (not (oset-empty? (item-look-aheads funny-closure-item))) + (begin + (let ((goto-item-proto (advance-dot funny-closure-item))) + (if goto-item-proto + (begin + ;; Here we go to some expense to locate the goto set + ;; for an item. + ;; These should be pre-computed and cached instead. + (let ((goto-item + (oset-find + goto-item-proto + (item-set-kernel + (find-goto-set + item-set + (symbol-after-dot funny-closure-item))) + "internal error - failed to find goto item"))) + (oset-for-each + (lambda (lookahead) + (if (eq? lookahead dummy-g-symbol) + ;; Discovered lookahead propagation. + (lalr1-add-depender goto-item kernel-item) + ;; Discovered lookahead. + (lalr1-add-lookahead lookahead goto-item))) + (item-look-aheads funny-closure-item))))))))) + ;; The set of "funny" closure items. J'. + (single-item-closure-1 (copy-lr0-item kernel-item) + dummy-g-symbol))) + (item-set-kernel item-set)) + (display ".")) + lr0-item-sets)) + + ;; NEW STUFF HERE: 1-27-88 + (newline) + (oset-for-each + (lambda (item-set) + (closure-1! (item-set-closure item-set)) + (display ".")) + lr0-item-sets + )) +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test +#|| +(set-working-direct *ZEBU-test-directory*) +(lalr1-tables-from-grammar "ex6_2.zb") + +(progn + (lalr1-tables-from-grammar "ex4.zb") + (princ "symbols: ") (terpri) + (cruise-symbols-2) + (princ "productions: ") (terpri) + (print-productions) + (princ "lr0 item sets: ") (terpri) + (print-collection nil) + (princ "lalr(1) tables: ") (terpri) + (cruise-parse-tables) + ) +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-lalr1.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-loader.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-loader.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,502 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-loader.l +; Description: load a ZEBU grammar table +; Author: Joachim H. Laubsch +; Created: 6-Nov-90 +; Modified: Thu Oct 2 12:00:10 1997 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 13-Jan-93 (Joachim H. Laubsch) +; implemented terminal-alist access via the vector terminal-alist-SEQ +; 5-Nov-91 (Joachim H. Laubsch) +; removed dependency on LUCID in the use of backquoted expressions +; in semantic actions +; 16-Jul-91 (Joachim H. Laubsch) +; Added a facility to deal with multiple grammars +; lr-parse takes a third argument, a grammar +; READ-PARSER and LIST-PARSER take a :grammar keyword argument, defaulting to +; *current-grammar* +; in order to use several grammars we need several +; *IDENTIFIER-CONTINUE-CHARS*, *IDENTIFIER-START-CHARS* +; +; 1-Mar-91 (Joachim H. Laubsch) +; did monitoring, found that 75% of the time is in the lexer. +; rewrote ZEBU::RECOGNIZE-TOKEN to use a hashtable of terminal-tokens +; this sped up this function by a factor of 35. Speed-up of READ-PARSER: 3.5 +; 11-Dec-90 (Joachim H. Laubsch) +; Introduce the ZEBU package +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +(provide "zebu-loader") + +;;; The following data structures are loaded from a parse table file by the +;;; function which follows. +;;; +;;; lexicon is a vector of strings or lisp symbols , indexed by the +;;; "grammar symbol indices", which are the instantiations of +;;; the grammar symbols. +;;; +;;; terminal-indices is a list of the grammar symbol indices indicating +;;; which among them are terminal symbols. +;;; +;;; production-info is a vector, indexed by the production indices. +;;; Each item is a cons: the cars index the symbols +;;; which are the lhs of the productions, the cdrs indicate the +;;; lengths of the productions. +;;; +;;; action-table is a vector indexed by the state indices. +;;; Each state's entry is a vector whose elements represent +;;; defined entries in the action parsing function. These entries are 3 element +;;; lists whose first elements are the indices of the grammar symbol argument +;;; to the action parsing function. The second elements in the lists are an +;;; encoding of the action function: 's for shift, 'r for reduce, 'a for +;;; accept. The third elements are production or next state indices as +;;; approprite. The three element lists appear in their surrounding +;;; vectors sorted on their cars. +;;; +;;; goto-table is arranged similar to action-table but has two element +;;; lists instead of three. The second element of each list are the +;;; index of the state to goto. +;;; +;;; end-symbol-index holds the index of the end symbol. +;;; +;;; terminal-alist associates terminal symbol instantiations with +;;; their indices. +;;; +;;; client-lambdas are a vector of procedures, indexed by production index, +;;; which correspond to productions in the grammar. The client lambdas are +;;; what the parser calls to do syntax directed something by side effect. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Zebu Grammar Struct +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; helps define the function that computes whether a character can continue +;; a symbol + +(defvar *identifier-continue-chars* + "$-_*.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890?" + "Characters that may occur in an identifier. Set this before calling zebu-load-file.") + +(defvar *identifier-start-chars* "$-*?abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + "Characters that may start an identifier.") + +;----------------------------------------------------------------------------; +; *string-delimiter*, *symbol-delimiter* +;--------------------------------------- +;; An NLL-constant can now be a string or a symbol. A string is surrounded +;; by double-quotes (#\"), as in: P(arg1: \"|Jon Doe's Deli|\") +;; A symbol is surrounded by single-quotes (#\'), as in: +;; P(arg1: 'Jon Doe') +;; or P(arg1: '|Jon Doe|') +;; By default, the single-quotes may be omitted at parsing in case the +;; symbol contains only characters which are in +;; (grammar-identifier-continue-chars *current-grammar*) +;; as in P(arg1: Jon_Doe) +;; Either set these variables before the grammar is loaded +;; or supply the initial values explicitely in the .grm file +;; e.g. (:name "nll" :string-delimiter #\" :symbol-delimiter #\') +(defvar *string-delimiter* #\" + "Delimits a lexical token, considered as a STRING.") + +(defvar *symbol-delimiter* #\' + "Delimits a lexical token, considered as a SYMBOL.") + +(defvar *preserve-case* nil + "If true, the case of an identifier will be preserved (default false).") + +(defvar *case-sensitive* nil + "If true, the case of a keyword matters otherwise case is ignored when \ +looking for the next token (default false).") + +(defvar *disallow-packages* nil + "If false, Zebu parses identifiers as symbols possibly qualified by a package") + +;----------------------------------------------------------------------------; +; grammar +;-------- +; +(defstruct (grammar (:print-function print-grammar)) + name + lexicon + terminal-indices + production-info + action-table + goto-table + lr-parser-start-state-index + end-symbol-index + client-lambdas + identifier-index + string-index + (number-index nil) + (identifier-continue-chars *identifier-continue-chars* :type string) + (identifier-continue-chars-V (make-array char-code-limit :element-type 'bit + :initial-element 0)) + (identifier-start-chars *identifier-start-chars* :type string) + (identifier-start-chars-V (make-array char-code-limit :element-type 'bit + :initial-element 0)) + ;; a vector to be indexed by the char-code of the first character of a key + ;; each element contains an alist of pairs: (,terminal-token . ,index) + (terminal-alist-SEQ (make-sequence 'vector + char-code-limit + :initial-element nil)) + (case-sensitive *case-sensitive*) + (string-delimiter *string-delimiter* :type character) + (symbol-delimiter *symbol-delimiter* :type character) + file + (package *package*) + grammar ; the grammar used to parse the + ; grammar being defined + ; defaults to the null-grammar + ; but you can use the meta-grammar + (zb-rules ()) + (domain ()) + domain-file + (lex-cats ()) ; an alist of cateory name and + ; regular expressions + (lex-cat-map ()) ; an alist of index and reg-ex function + (white-space '(#\Space #\Newline #\Tab)) + (intern-identifier t) ; Identifier is represented as symbol + (id-allows-start-digit nil) ; An Identifier may start with a digit + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Null Grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar *NULL-Grammar* (make-grammar :name "null-grammar")) + +(defun print-grammar (item stream level) + (declare (ignore level)) + (format stream "" (grammar-name item))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; register a grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar *all-grammars* + (list (cons (grammar-name *NULL-Grammar*) *NULL-Grammar*))) + +(defun find-grammar (name) + (cdr (assoc (string name) *all-grammars* :test #'equal))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Lexical Analysis Info +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar *identifier-continue-chars-V*) +(declaim (inline identifier-continue-char-p)) +(defun identifier-continue-char-p (char) + (declare (character char)) + (= 1 (sbit *identifier-continue-chars-V* (char-code char)))) + +(defvar *identifier-start-chars-V*) +(declaim (inline identifier-start-char-p)) +(defun identifier-start-char-p (char) + (declare (character char)) + (= 1 (sbit *identifier-start-chars-V* (char-code char)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Lex-Cats +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline add-to-lex-cat-map)) +;; preserve the order of the definition + +;; from marc at rose.de +;; the (index . (symbol-function terminal-token)) will be inserted +;; according to the order in *lex-cats* = (grammar-lex-cats grammar) + +(defun add-to-lex-cat-map (index terminal-token grammar + &aux (lower (cdr (member terminal-token + (grammar-lex-cats grammar) + :key #'car)))) + (setf (grammar-lex-cat-map grammar) + (merge 'list (list (cons index (symbol-function terminal-token))) + (grammar-lex-cat-map grammar) + #'(lambda (&rest r) + (not (member (car r) lower + :key #'(lambda (x) + (symbol-function (car x)))))) + :key #'cdr))) + +;(defun add-to-lex-cat-map (index terminal-token grammar) +; (setf (grammar-lex-cat-map grammar) +; (nconc (grammar-lex-cat-map grammar) +; (list (cons index (symbol-function terminal-token)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Debugging +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *grammar-debug* nil + "If TRUE at compile or load time, the parser emits traces, else not.") + +(defmacro if-debugging (&rest x) + `(progn . ,(if *grammar-debug* + x + 'nil))) + +(eval-when (compile) + (setq *grammar-debug* nil)) + +#|| +(eval-when (eval) + (setq *grammar-debug* T)) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Read in a set of parse tables as written by (dump-tables) . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun zebu-load-file (filename &key (verbose t) + &aux lexicon terminal-indices (*package* *package*)) + ;; returns a grammar and registers this grammar on *all-grammars* + (let ((path (probe-file (merge-pathnames + filename + (merge-pathnames (make-pathname :type "tab"))))) + (*load-verbose* verbose)) + (if path + (when verbose + (format t "~%Loading ~s" (namestring path))) + (error "File not found: ~S" filename)) + (unless (equalp (pathname-type path) "tab") + (let ((name (pathname-name path))) + (cerror "~S is now compiled." + "~S is not a Zebu output!~%;;; Compile ~S first!" + name filename name) + (setf path (merge-pathnames (make-pathname :type "tab") path) + filename (namestring path)))) + (with-open-file (port path :direction :input) + (let ((options ; 1: read grammar-options + (catch 'read-grammar-options + (check-grammar-options (read port) path nil)))) + (unless options + (close port) + (setq port (open path :direction :input)) + (setq options + (catch 'read-grammar-options + (check-grammar-options (read port) path nil)))) + (let* ((g (apply #'make-grammar options)) + (terminal-alist-SEQ (grammar-terminal-alist-SEQ g))) + (declare (type grammar g)) + (prepare-domain (grammar-domain g)) + ;; 1a: load the domain file + (let ((grammar-domain-file (grammar-domain-file g))) + (when grammar-domain-file + (let ((grammar-domain-file-name + (pathname-name (pathname grammar-domain-file)))) + (or (block find-domain-file + (dolist (type (append *load-binary-pathname-types* + *load-source-pathname-types*)) + (dolist (domain-path (list path (grammar-file g))) + (let ((domain-file + (merge-pathnames + (make-pathname + :name grammar-domain-file-name + :type type) + domain-path))) + (when (probe-file domain-file) + (when *load-verbose* + (format t "~%Loading domain file ~s" + (namestring domain-file))) + (return-from find-domain-file + (load domain-file))))))) + (warn "No domain file found"))))) + + ;; 2: read grammar-lexicon + (setf (grammar-lexicon g) (setf lexicon (read port)) + ;; 3: read grammar-terminal-indices + (grammar-terminal-indices g) (setf terminal-indices (read port)) + ;; 4: read grammar-production-info + (grammar-production-info g) (read port)) + (let ((old-grammar (assoc (grammar-name g) *all-grammars* + :test #'string=))) + (if old-grammar + (setf (cdr old-grammar) g) + (setf *all-grammars* (acons (grammar-name g) g *all-grammars*)))) + + ;; 5: read grammar-action-table + (setf (grammar-action-table g) + (vectorize-vector-of-lists (read port))) + + ;; 6: read grammar-goto-table + (setf (grammar-goto-table g) (vectorize-vector-of-lists (read port)) + ;; 7: read grammar-lr-parser-start-state-index + (grammar-lr-parser-start-state-index g) (read port) + ;; 8: read grammar-end-symbol-index + (grammar-end-symbol-index g) (read port) + ;; 9: read grammar-client-lambdas + (grammar-client-lambdas g) (read-parser-actions port g)) + + ;; IDENTIFIER-START-CHARS + (let ((identifier-start-chars-V + (grammar-identifier-start-chars-V g)) + (identifier-start-chars (grammar-identifier-start-chars g))) + (dotimes (i (length identifier-start-chars)) + (let ((c (schar identifier-start-chars i))) + (declare (character c)) + (setf (sbit identifier-start-chars-V (char-code c)) + 1) + (when (digit-char-p c) + (setf (grammar-id-allows-start-digit g) t))))) + + ;; IDENTIFIER-CONTINUE-CHARS + (let ((identifier-continue-chars-V + (grammar-identifier-continue-chars-V g)) + (identifier-continue-chars + (grammar-identifier-continue-chars g))) + (dotimes (i (length identifier-continue-chars)) + (setf (sbit identifier-continue-chars-V + (char-code + (the character + (schar identifier-continue-chars i)))) + 1))) + + ;; sort the terminal-alist so that terminals with the same + ;; initial string are sorted by decreasing length + ;; i.e. if "?" and "?u?" are both terminals, then "?u?" + ;; should be found first. + ;; This can simply be achieved by sorting according to + ;; ascending key length. + (dotimes (i (length (the simple-vector terminal-indices))) + (let* ((index (svref terminal-indices i)) + (terminal-token (svref lexicon index))) + (declare (type (or symbol string) terminal-token)) + (typecase terminal-token + (string + (let ((char1-code + (char-code (let ((c (schar terminal-token 0))) + (declare (character c)) + (if (grammar-case-sensitive g) + c + (char-downcase c))))) + (token-association `(,terminal-token . ,index))) + ;; keep a table indexed by char-code of first-char + ;; of the terminal tokens + (let ((bucket (elt terminal-alist-SEQ char1-code))) + (setf (elt terminal-alist-SEQ char1-code) + (if bucket + (sort (cons token-association bucket) + #'(lambda (a b) (declare (string a b)) + (> (length a) (length b))) + :key #'car) + (list token-association)))))) + (symbol + (let ((terminal-token-name (symbol-name terminal-token))) + (declare (string terminal-token-name)) + (cond ((string= terminal-token-name "IDENTIFIER") + (setf (grammar-identifier-index g) index)) + ((string= terminal-token-name "STRING") + (setf (grammar-string-index g) index)) + ((string= terminal-token-name "NUMBER") + (setf (grammar-number-index g) index)) + ;; for lexical categories: remember index + ((assoc terminal-token (grammar-lex-cats g)) + (add-to-lex-cat-map index terminal-token g)) + (t (warn "If ~S is a terminal it should be a string, not a symbol.~%If it's a non-terminal it's undefined." + terminal-token)))))))) + g))))) + +(defun read-parser-actions (port grammar) + ;; zb-rules = [( . ) ...] + (let ((zb-rules (read port)) + (actions (make-sequence + 'vector + (length (grammar-production-info grammar)))) + (actions-idx 1)) + (setf (svref actions 0) :PLACE-HOLDER) + (dotimes (i (length zb-rules)) + (let ((pair (svref zb-rules i))) + (let ((zb-rule (cdr pair))) + (dolist (prod (zb-rule--productions zb-rule)) + (let ((action (production-rhs--build-fn prod))) + (setf (svref actions actions-idx) + (if (symbolp action) + (if (or (eq action 'identity) (null action)) + nil + (if (fboundp action) + (symbol-function action) + (progn + (warn "At parse time, ~S should be defined." + action) + action))) + action + ;; (if (fboundp 'compile) + ;; (compile nil action) + ;; (eval `(function ,action))) + )) + (incf actions-idx)))))) + (setf (grammar-zb-rules grammar) zb-rules) + actions)) + +(defun vectorize-vector-of-lists (V &aux alist) + (declare (simple-vector V) (dynamic-extent alist)) + (dotimes (i (length V) V) + (let* ((sublist (svref V i)) + (pair (assoc sublist alist :test #'equal))) + (if pair + (setf (svref v i) (cdr pair)) + (let ((subV (list->vector sublist))) + (setf (svref v i) subV) + (push (cons sublist subV) alist)))))) + + +;----------------------------------------------------------------------------; +; load-from-command-line (for UNIX) +;---------------------------------- +; Load a compiled grammar from a command line argument: +; Zebu-Parser ex1.tab +; Zebu-Parser -l +; -e "
" +; -quit +#+LUCID +(defun load-from-command-line () + (let ((*default-pathname-defaults* + (make-pathname :directory + (pathname-directory (working-directory)))) + (help "Zebu-Parser [-zb] [-l ]* + [-e ]* [-quit]")) + (handler-case + (do* ((i 1 (1+ i)) + (arg (command-line-argument i) (command-line-argument i)) + (val (command-line-argument (1+ i)) + (command-line-argument (1+ i)))) + ((null arg) + (when (= i 1) + (progn (warn "~a" help) (quit)))) + ;;(format t "~%arg: ~s val: ~s" arg val) + (cond ((equal arg "-l") + (incf i) (load val)) + ((equal arg "-e") + (incf i) (eval (read-from-string val))) + ((equal arg "-quit") (quit)) + ((equal arg "-h") + (format t "~%~a" help)) + ((equal arg "-zb") + (incf i) (zebu-load-file val :verbose t)) + (t (if (probe-file arg) + (zebu-load-file arg :verbose t) + (progn + (warn "Unrecognized argument ~S~%~a" arg help) + (quit)))))) + (error (c) + (format t "~&Zebu-Parser failed: ~A~%" c) + (quit))))) + +;----------------------------------------------------------------------------; +; zebu-load-top +;-------------- +; interactive loader invocation +; +(defun zebu-load-top () + (format t "~&Enter the name of a Zebu .tab file to load: ") + (let ((ifile (read-line t))) + (zebu-load-file ifile))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-loader.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-loadgram.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-loadgram.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,778 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-loadgram.l +; Description: Load a grammar file (type: .zb) so that it can be compiled +; Author: Joachim H. Laubsch +; Created: 10-Oct-90 +; Modified: Thu Oct 2 16:31:15 1997 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 26-Jul-94 (Joachim H. Laubsch) +; Fixed Bug with "." as separator (ambiguous constituent names were made) +; 12-Mar-93 (Joachim H. Laubsch) +; Bind a Kleene* Variable +; 9-Mar-93 (Joachim H. Laubsch) +; allow a print-function specification in a domain definition rule +; 8-Feb-93 (Joachim H. Laubsch) +; allow defstruct forms for domain definition among the rules +; 31-Jul-92 (Joachim H. Laubsch) +; Introduced Kleene * and + +; 24-Apr-92 (Joachim H. Laubsch) +; Introduced a meta-grammar for reading a user grammar +; The meta-grammar is compiled using the null-grammar +; 25-Mar-92 (Joachim H. Laubsch) +; Warn about unused non-terminals +; 16-Jul-91 (Joachim H. Laubsch) +; to deal with multiple-grammars, first find in a grammar file: *GRAMMAR-OPTIONS* +; a keyworded arglist that can be passed to MAKE-GRAMMAR +; 20-Mar-91 (Joachim H. Laubsch) +; Introduced error checking during loading of grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. + +(IN-PACKAGE "ZEBU") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar *Kleene+-rules* () + "A list of rules that are generated as a consequence of the Kleene notation") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Read in a File Containing a Grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; RULES +;;; About the representations of grammars in files: +;;; non terminals are represented by lisp symbols, +;;; terminals by symbols (IDENTIFIER NUMBER STRING), or strings +;;; for example then BNF rule: +;;; A ::= B | C | "foo" | "c" | +;;; +;;; would be encoded -- using the NULL Grammar -- as: + +;;; (defrule A := B +;;; :build (f1 B) +;;; +;;; := C +;;; :build (f2 C) +;;; +;;; := "foo" +;;; ; ommitting the build clause has the +;;; := "c" ; effect of calling the identity function +;;; := () ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Format for a grammar file +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#|| +A grammar file has a filename of type "zb". + +The file consists of: + +1. A keyword agument-list for MAKE-GRAMMAR. + Example: + (:name "pc2" + :package "CL-USER" + :grammar "zebu-mg" + :identifier-continue-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + ) +2. If parsing with the NULL-Grammar + ( the default, if no :grammar keyword is given in 1.) + one or more defrule forms as above + If parsing with the META-Grammar + one or more rules using the syntax of the Meta-grammar + The start symbol of the grammar will be the lhs of the first + production encountered. + +The symbol AUGMENTED-START is reserved and will automatically appear in +a production deriving the start symbol. +The symbol THE-EMPTY-STRING is also reserved. + +Use load-grammar to internalize a grammar in the above syntax. + *productions* holds a list of all the productions. + *lambdas* holds a list of all of the associated lambdas (in reverse order) + *non-terminals* holds a list of all the non-terminals. +Each non-terminal symbol has a list of the productions it +appears in the left hand side of under its own-productions +property. +*g-symbol-alist* holds an alist whose cars are the string or symbol + which is read from the grammar, and whose cdrs hold corresponding + g-symbol structures; the order is in the reverse sense of *symbol-array*. +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Global variables +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *symbols*) ; a list of the grammar symbols +(defvar *symbol-array*) ; indexed by the symbol's index, of g-symbols +(defvar *productions*) +(defvar *production-count*) +(defvar *g-symbol-count*) +(defvar *g-symbol-alist*) +(defvar *start-symbol*) +(defvar *empty-string-g-symbol*) +(defvar *augmented-start-g-symbol*) +(defvar *the-end-g-symbol*) + +(defvar *grammar-options*) + +(declaim (special + *identifier-continue-chars* + *identifier-start-chars* + *null-grammar* + *compiler-grammar* + *domain-type-hierarchy* + *domain-types* + *domain-structs* + *lex-cats*)) + +;; new rule format +(defvar *ignore* '("DUMMY" "DUMMY1" "DUMMY2" "DUMMY3" "DUMMY4" + "DUMMY5" "DUMMY6" "DUMMY7" "DUMMY8")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro post-inc (x) + `(let ((old ,x)) + (setq ,x (1+ ,x)) + old)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Initialisation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun initialize-grammar () + (setq *symbols* '() + *productions* '() + *production-count* 0 + *g-symbol-count* 0 + *g-symbol-alist* '() + *start-symbol* '() + *zb-rules* '() + *lex-cats* '() + *domain-types* '() + *domain-structs* '() + *domain-type-hierarchy* '() + *empty-string-g-symbol* (g-symbol-intern 'the-empty-string) + *augmented-start-g-symbol* (g-symbol-intern 'augmented-start) + *the-end-g-symbol* (g-symbol-intern 'the-end-g-symbol)) + ) + +;----------------------------------------------------------------------------; +; g-symbol-intern +;---------------- +; This is sort of like interning. returns a g-symbol. +; if (equal (string x) (string y)) the g-symbols are eq + +(defun g-symbol-intern (string-or-symbol) + (check-type string-or-symbol (or string symbol) + "a string or symbol, in order to be a well-formed Zebu grammar rule.") + (let ((pair (assoc string-or-symbol *g-symbol-alist* + :test #'equal))) + (if pair + (cdr pair) + (let ((symbol (new-g-symbol + (string string-or-symbol) + (post-inc *g-symbol-count*)))) + (push (cons string-or-symbol symbol) *g-symbol-alist*) + (push symbol *symbols*) + symbol)))) + +;;; Do various things, fixing up global data structures and +;;; fields of grammar symbols. A bit sleazy: *start-symbol* being NIL +;;; is used to detect the first production. + +(defun process-production (lhs rhs &optional internal-use?) + (let ((lhs-symbol (g-symbol-intern lhs)) + ;; intern constituent as a G-SYMBOL + (rhs-symbols (mapcar #'g-symbol-intern rhs))) + (unless *start-symbol* + (setq *start-symbol* lhs-symbol) + (format t "~%Start symbols is: ~A~%" + (g-symbol-name *start-symbol*)) + (process-production 'AUGMENTED-START (list lhs) t)) + (let ((production + (make-production :lhs lhs-symbol + :rhs rhs-symbols + :production-index (post-inc *production-count*) + :production-length (length rhs-symbols)))) + (when (and (eq lhs-symbol *augmented-start-g-symbol*) + (not internal-use?)) + (error "AUGMENTED-START is a reserved grammar symbol")) + (push production *productions*) + (g-symbol-add-production lhs-symbol production) + (let ((rhs-symbol-set (make-oset :order-fn #'g-symbol-order-function))) + (dolist (gs rhs-symbols) + (oset-insert! gs rhs-symbol-set)) + (dolist (gs (oset-item-list rhs-symbol-set)) + (push production (g-symbol-rhs-productions gs))))))) + +;----------------------------------------------------------------------------; +; pre-process-rules +;------------------ +; Given a function to produce the next rule, process it +; and warn about: +; - redefinition of lhs symbol +; - repeated equal rhs +; - unused lhs symbols +; - undefined non-terminals +; - duplicate constituents + +(defun pre-process-rules (next-rule-fn do-semantics? &aux non-terminals) + (do ((zb-rule (funcall next-rule-fn) (funcall next-rule-fn))) + ((null zb-rule)) + (let ((lhs (zb-rule--name zb-rule))) + (when (assoc lhs *zb-rules*) + (warn "Non-terminal ~S is defined again" lhs) + ;; (break "Rule: ~S" zb-rule) + ) + (push (cons lhs zb-rule) *zb-rules*) + (do ((prods (zb-rule--productions zb-rule) (cdr prods))) + ((null prods)) + (let* ((production-rhs (car prods)) + (syntax (production-rhs--syntax production-rhs))) + (when (member syntax (rest prods) + :test #'equal :key #'production-rhs--syntax) + (warn "Multiply defined rhs of rule for ~S: ~S" lhs syntax)) + (when (member "" syntax :test #'equal) + (warn "Empty keyword ignored in rhs of ~s:~{ ~s~}" lhs syntax) + (setf syntax + (setf (production-rhs--syntax production-rhs) + (delete "" syntax :test #'equal)))) + (expand-Kleene-constituent production-rhs))) + (do ((prods (zb-rule--productions zb-rule) (cdr prods))) + ((null prods)) + (let* ((production-rhs (car prods)) + (syntax (production-rhs--syntax production-rhs)) + syntax1) ; the . notation is removed + ;; remove the . notation from the rhs + (do ((rhs-tail syntax (cdr rhs-tail))) ((null rhs-tail)) + (let ((constituent (car rhs-tail))) + (typecase constituent + (symbol + (when (and (production-rhs--semantics production-rhs) + (member constituent (cdr rhs-tail))) + (warn "Duplicate constituent in RHS of ~S~% ~S~% Use ." + lhs syntax)) + (let ((cname (constituent-name constituent))) + (push cname syntax1) + (pushnew cname non-terminals))) + (T (push constituent syntax1))))) + (when do-semantics? (process-semantics production-rhs)) + (process-production lhs (nreverse syntax1)))))) + (let* ((lhs-non-terminals (nreverse (mapcar #'car *zb-rules*))) + (lexical-categories (mapcar #'(lambda (c) + (symbol-name (car c))) + *lex-cats*)) + (rhs-non-terminals + (set-difference non-terminals + (union *open-categories* lexical-categories) + :test #'string-equal :key #'string)) + (undefined-non-terminals (set-difference rhs-non-terminals + lhs-non-terminals)) + (unused-non-terminals (set-difference (cdr lhs-non-terminals) + ;; the start symbol does not + ;; have to occur on any rhs + rhs-non-terminals)) + (unused-lex-cats + (set-difference lexical-categories non-terminals + :test #'string= :key #'string)) + (overused-lex-cats + (intersection lhs-non-terminals lexical-categories + :test #'string= :key #'string))) + (when undefined-non-terminals + (warn "The following non-terminals had no definition:~% ~{~a ~}" + undefined-non-terminals)) + (when unused-non-terminals + (warn "The following non-terminals where defined but not used:~% ~{~a ~}" + unused-non-terminals)) + (when unused-lex-cats + (warn "The following lexical categories where defined but not used:~% ~{~a ~}" + unused-lex-cats)) + (when overused-lex-cats + (warn "The following lexical categories where also defined as non-terminals:~% ~{~a ~}" + overused-lex-cats)))) + +;----------------------------------------------------------------------------; +; expand-Kleene-constituent +;-------------------------- +; handle Kleene * and +: adds to *Kleene+-rules* +;; * case will expand: +;; (defrule * +;; ::= () +;; ::= *-rest) +;; (defrule *-rest +;; ::= () +;; ::= *-rest) +;; in case of default seperator " ": +;; (defrule * +;; ::= () +;; ::= *) +;; + case will expand: +;; (defrule + +;; ::= :build (make-kb-sequence :first ) +;; ::= + +;; :build (make-kb-sequence :first :rest +)) +(defun expand-Kleene-constituent (production-rhs) + (flet ((new-kb-seq (pairs) + (let ((slots (mapcar + #'(lambda (pair) + (make-LABEL-VALUE-PAIR + :-LABEL (first pair) :-VALUE (second pair))) + pairs))) + (make-feat-term :-type 'kb-sequence + :-slots slots))) + (memo (item) (push item *Kleene+-rules*))) + (dolist (constituent (production-rhs--syntax production-rhs)) + (when (Kleene-p constituent) + (let* ((Kleene-const (Kleene--constituent constituent)) + (Kleene-Sep (Kleene--Separator constituent)) + (Kleene+ (encode-separator Kleene-const + (Kleene*-p constituent) + Kleene-Sep))) + (declare (symbol Kleene+)) + ;; replace the Kleene-expr by a new non-terminal: Kleene+ + (setf (production-rhs--syntax production-rhs) + (substitute Kleene+ constituent + (production-rhs--syntax production-rhs))) + (let ((semantics (production-rhs--semantics production-rhs))) + (when (and (feat-term-p semantics) + (not (default-separator? Kleene-Sep))) + (feat-term-substitute + Kleene+ (decode-kleene-name Kleene+) semantics))) + ;; (break "constituent: ~S" constituent) + (unless (find Kleene+ *Kleene+-rules* :key #'zb-rule--name) + ;; only if a rule of that name has not been defined yet! + (let ((KR-sem (new-kb-seq `((first ,Kleene-const) + (rest ,Kleene+))))) + (if (Kleene*-p constituent) ; * case + (if (default-separator? Kleene-Sep) + (memo (make-zb-rule + :-name Kleene+ + :-productions + `(,(make-Production-Rhs) + ,(make-Production-Rhs + :-syntax `(,Kleene-const ,Kleene+) + :-semantics KR-sem)))) + (let ((X*-rest (intern + (format nil "Rest-~a" + (symbol-name Kleene+))))) + (setq KR-sem + (new-kb-seq `((first ,Kleene-const) + (rest ,X*-rest)))) + (memo (make-zb-rule + :-name Kleene+ + :-productions + `(,(make-Production-Rhs) + ,(make-Production-Rhs + :-syntax `(,Kleene-const ,X*-rest) + :-semantics KR-sem)))) + (memo (make-zb-rule + :-name X*-rest + :-productions + `(,(make-Production-Rhs) + ,(make-Production-Rhs + :-syntax + `(,Kleene-Sep ,Kleene-const ,X*-rest) + :-semantics KR-sem)))))) + (progn + ;; (break "constituent: ~S" constituent) + (memo (make-zb-rule + :-name Kleene+ + :-productions + `(,(make-Production-Rhs + :-syntax (list Kleene-const) + :-semantics (new-kb-seq `((first ,Kleene-const)))) + ,(make-Production-Rhs + :-syntax `(,Kleene-const + ,@(unless (default-separator? Kleene-Sep) + (list Kleene-Sep)) + ,Kleene+) + :-semantics KR-sem))))))))))) + ;; (format t "~%*Kleene+-rules*: ~{~s ~}" (mapcar #'ZB-RULE--name *Kleene+-rules*)) + )) + +(defun default-separator? (Kleene-Sep) + (member Kleene-Sep '(" " "") :test #'string=)) + +(defun encode-separator (name k* Sep) + ;; k* = true iff Kleene operator is * + ;; k* = false iff Kleene operator is + + (intern (if (default-separator? Sep) + (format nil "~S~:[+~;*~]" name k*) + (format nil "~S~:[+~;*~]~A~D$" + name + k* + Sep + (length Sep))))) + +(defun decode-kleene-name (name) + (let* ((s (symbol-name name)) + (s-length (length s)) + (n (schar s (- s-length 2))) + (sep-length (- (char-int n) (char-int #\0)))) + (intern (subseq s 0 (- s-length sep-length 2))))) + +(defun constituent-name (constituent) + ;; constituent:symbol + ;; strip off . from constituent symbol, unless it ends in $ + (let* ((n (symbol-name constituent)) + (last-char-pos (1- (length n)))) + (if (char= (schar n last-char-pos) #\$) + constituent + (let ((p (position-if #'(lambda (c) (char= c #\.)) n + :from-end t))) + (if (and p + (let ((p+1 (1+ p))) + (and (= p+1 last-char-pos) + (digit-char-p (schar n p+1))))) + (intern (subseq n 0 p) (symbol-package constituent)) + constituent))))) + +(defun feat-term-substitute (new old ft) + (dolist (slot (feat-term--slots ft)) + (let ((val (label-value-pair--value slot))) + (if (eq val old) + (setf (label-value-pair--value slot) new) + (when (feat-term-p val) + (feat-term-substitute new old val)))))) + +(defun parse-defrule (rule &aux name) + (unless (and (consp rule) + (symbolp (car rule)) + (string= (string (car rule)) "DEFRULE") + (consp (cdr rule)) + (symbolp (setq name (cadr rule)))) + (error "Illegal rule ~S" rule)) + (let ((args (cddr rule)) rhs) + (flet ((parse-build (&key form type map) + (cond ((and (not form) type) + (if (symbolp type) + (setf form (generate-form type map)) + (error "Symbol expected as value of :type ~S in ~S" + type rhs)))) + (multiple-value-bind (ll dummies) + (make-lambda-list rhs) + (setq dummies + (nconc dummies + (mapcan #'(lambda (l) + (unless (member l dummies) + (unless (search-list l form) + (list l)))) + ll))) + ;; now generate the functions from the actions + `(lambda ,ll + ,@(when dummies `((declare (ignore .,dummies)))) + ,form) + ))) + (let ((R (make-zb-rule :-name name)) action rest) + (do ((args args rest)) + ((null args) + (setf (zb-rule--productions r) (nreverse (zb-rule--productions r))) + R) + (let ((key (car args)) + (val (cadr args))) + (setq rest (cddr args)) + (if (eq key ':=) + (progn + (setq rhs (if (listp val) val (list val))) + (if (and (consp rest) (eq (car rest) ':BUILD)) + ;; BUILD clause: construct fn and compile it + (let ((build-args (cadr rest))) + (setq action + (if (atom build-args) + (if (symbolp build-args) + build-args + (parse-build :FORM build-args)) + (if (keywordp (car build-args)) + (apply #'parse-build build-args) + (parse-build :FORM build-args)))) + (setq rest (cddr rest))) + ;; no :BUILD clause, use IDENTITY fn + (setq action + (if (= (length rhs) 1) 'identity 'identity*)))) + (error "Keyword expected in rule ~S at .. ~{~S ~}~% Probably no () around rule's rhs" + name args)) + (push (make-production-rhs :-syntax rhs + :-build-fn action) + (zb-rule--productions r)))))))) + +(defun cons-avm (Feat-Term) + (let ((type (Feat-Term--type Feat-Term))) + (cons + (intern (concatenate 'string "MAKE-" + (symbol-name type)) + (symbol-package type)) + (mapcan + #'(lambda (lvp) + (declare (type Label-value-pair lvp)) + (let ((slot (Label-value-pair--label lvp)) + (val (Label-value-pair--value lvp))) + (list (intern (string slot) *keyword-package*) + (if (Feat-Term-p val) + (cons-avm val) + val)))) + (Feat-Term--slots Feat-Term))))) + +(defun process-semantics (production-rhs) + (let ((Syntax (production-rhs--syntax production-rhs)) + (Feat-Term (production-rhs--semantics production-rhs))) + (flet ((msg () + (format nil "The Semantics ~S of the rule RHS:~% ~A~%" + Feat-Term + (with-output-to-string (s) + (print-production-rhs production-rhs s nil))))) + (flet ((cons-lambda (ft?) + (multiple-value-bind (ll dummies) + (make-lambda-list Syntax) + `(lambda ,ll + ,@(when dummies `((declare (ignore .,dummies)))) + ,(if ft? (cons-avm Feat-Term) Feat-Term))))) + (setf (production-rhs--build-fn production-rhs) + (typecase Feat-Term + (NULL (if (= 1 (length syntax)) + 'identity + 'identity*)) + ((or number string) + `(lambda (&rest args) (declare (ignore args)) + ,Feat-Term)) + (symbol + (if (member Feat-Term Syntax) + (cons-lambda nil) + (error "~A is a variable that does not occur in the RHS!" + (msg)))) + (Feat-Term (cons-lambda t)) + (T (error "~A should be a feature term, number, string or constituent!" (msg))))))))) + + +;----------------------------------------------------------------------------; +; generate-form +;-------------- +; +; +(defun generate-form (type map) + `(,(intern (concatenate 'string "MAKE-" (symbol-name type)) + (symbol-package type)) + ,@(mapcan + #'(lambda (pair) + (unless (consp pair) + (error "Element of :map must be a dotted pair in ~S" + map)) + (let ((constituent (car pair)) + (slot (cdr pair))) + (unless (symbolp constituent) + (error "Symbol expected in map ~S at ~S" + map constituent)) + (unless (keywordp slot) + (error "Keyword expected in map ~S at ~S" + map slot)) + (list slot constituent))) + map))) + +(defvar *dummy-count* 0) + +(defun next-dummy () + (let* ((root "DUMMY") + (dummy (intern (if (zerop *dummy-count*) + root + (format nil "DUMMY~S" *dummy-count*))))) + (incf *dummy-count*) + dummy)) + +(defun make-lambda-list (constituents) + (let ((*dummy-count* 0) dummies) + (values (mapcar #'(lambda (constituent) + (if (symbolp constituent) + constituent + (let ((d (next-dummy))) + (push d dummies) + d))) + constituents) + dummies))) + +;; search the list for atom and return T if atom occurs anywhere +;; this is overly cautious and should be replaced by a tree-walker +;; but it will only cause some warnings of the compiler. +(defun search-list (atom tree) + (if (atom tree) + (eq atom tree) + (when (consp tree) + (dolist (n tree) + (when (search-list atom n) (return t)))))) + + +#|| +(apply #'parse-build '( "(" Formula ")" ) '(:form (progn Formula))) +(apply #'parse-build '(Identifier) '(:type Propositional-variable + :map ((Identifier . :-name)))) +(apply #'parse-build '(Formula.1 "and" Formula.2) + '(:type Boolean-And + :map ((Formula.1 . :-rand1) + (Formula.2 . :-rand2)))) +||# + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Top level load function +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; LOAD-GRAMMAR loads a Zebu source grammar and prepares it for +;;; compilation +;;; Internalize a grammar in the lisp syntax described above. +;;; Set up data structures as described above. +;;; Every grammar interns the empty string as a grammar symbol +;;; Generate the hierarchy, if a :domain is specified +;;; and if *generate-domain* is true. + +(defun get-grammar-options-key (name) + (do ((options *grammar-options* (cddr options))) + ((null options) nil) + (when (eq (car options) name) (RETURN (cadr options))))) + +(defun load-grammar (filename &key (verbose T) + &aux (g-file (probe-file filename))) + (unless g-file + (error "grammar file not found: ~S" filename)) + (format t "~%Reading grammar from ~A~%" filename) + (initialize-grammar) + ;; read first form (possibly twice -- in the right package) + (let ((grammar-stream (open g-file :direction :input))) + (unwind-protect + (progn + (setq *grammar-options* + (catch 'read-grammar-options + (check-grammar-options + (read grammar-stream) g-file t))) + (unless *grammar-options* + (close grammar-stream) + (setq grammar-stream (open g-file :direction :input)) + (setq *grammar-options* + (catch 'read-grammar-options + (check-grammar-options + (read grammar-stream) g-file t)))) + (setq *lex-cats* (get-grammar-options-key ':lex-cats)) + (if (eq *compiler-grammar* *NULL-Grammar*) + (let ((eof (list nil))) + (pre-process-rules + #'(lambda () + (loop (let ((rule (read grammar-stream nil eof))) + (when verbose (print rule)) + (if (consp rule) + (if (eq rule eof) + (return nil) + (if (eq (car rule) 'defstruct) + (push rule *domain-structs*) + (return (parse-defrule rule)))) + (warn "In file ~a~% illegal rule ~s ignored!" + g-file rule))))) + nil)) + (let (*preserve-case* + *Kleene+-rules* + (ff (file-parser-aux + grammar-stream #'error t *compiler-grammar* + verbose))) + (pre-process-rules + #'(lambda () + (loop + (let ((f (or (pop ff) (pop *Kleene+-rules*)))) + (if (null f) + (return nil) + (if (zb-rule-p f) + (return f) + (push f *domain-types*)))))) + t)))) + (close grammar-stream))) + (format t "~%~S productions, ~S symbols~%" + *production-count* *g-symbol-count*) + (setq *symbol-array* (list->vector (reverse *symbols*))) + (unless *start-symbol* (error "No start symbol")) + g-file) + +;;;------------------------------------------------------------------------; +;; dump-domain-file +;;;------------------------------------------------------------------------; +;; generate code for domain, printers, and regular expressions +;; dump it onto the domain-file +;; it may be the case that none of the above are necessary, in which +;; case no domain-file is generated +;; the domain-file is specified as: +;; name: from grammar-option :DOMAIN-FILE +;; type: the first element of *load-source-pathname-types* +;; directory: same as grammar-file +;; if not directory in grammar-file from +;; *default-pathname-defaults* +;; if such a file exists already, a warning is given and the old file +;; is renamed. + +(defun dump-domain-file (grammar-file verbose) + (let* ((domain-file + (merge-pathnames + (or (get-grammar-options-key ':DOMAIN-FILE) + (make-pathname + :name (format nil "~A-domain" + (get-grammar-options-key ':NAME)))) + (merge-pathnames + (merge-pathnames (make-pathname + :type (first *load-source-pathname-types*)) + grammar-file) + *default-pathname-defaults*))) + (*print-array* t) ; bit-vectors of regex code + *print-level* *print-length* *print-circle* + written?) + #-MCL (when (probe-file domain-file) + (warn "Renaming existing domain file ~a" domain-file)) + (with-open-file (port domain-file + :if-does-not-exist :create + :if-exists #-MCL :rename #+MCL :supersede + :direction :output) + (format port ";;; This file was generated by Zebu (Version ~a)~%~%(IN-PACKAGE ~S)~%(REQUIRE \"zebu-package\")~%(USE-PACKAGE \"ZEBU\")~%" + zb:*zebu-version* (package-name *package*)) + + (when *generate-domain* + (format t "~%Generating domain source code onto file: ~a" + domain-file) + (setq written? (generate-domain-file domain-file port))) + + ;; Write actions onto domain file + (when verbose + (format t "~%Writing actions of rules to ~a" domain-file) + (terpri port)) + (dolist (r *zb-rules*) + (let ((non-terminal (car r))) + (when verbose (format t "~%Rule ~S" non-terminal)) + (dolist (production (zb-rule--productions (cdr r))) + (let ((fn (production-rhs--build-fn production))) + (when (consp fn) + (let ((fn-name (gentemp (symbol-name non-terminal)))) + (when verbose (format t " Action: ~S" fn-name)) + (setf (production-rhs--build-fn production) fn-name) + (pprint `(defun ,fn-name . ,(cdr fn)) port) + (terpri port) + (setq written? t))))))) + (terpri port) + ;; for lexical categories: compile the rx-token parsers! + (when *lex-cats* + (pprint '(eval-when (compile) + (unless (member "zebu-regex" *modules* :test #'equal) + (WARN "Load the Zebu Compiler!"))) + port) + (pprint '(declaim (special *REGEX-GROUPS* *REGEX-GROUPINGS*)) + port) + (dolist (lex-cat *lex-cats*) + (pprint (def-regex-parser (car lex-cat) (cadr lex-cat)) + port) + (terpri port)) + (setq written? t)) + (when written? + (nconc *grammar-options* (list ':DOMAIN-FILE + (namestring domain-file))) + domain-file)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-loadgram.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-lr0-sets.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-lr0-sets.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,197 @@ +; -*- mode: CL -*- ------------------------------------------------- ; +; File: zebu-lr0-sets.l +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 31-Oct-90 +; Modified: Fri Apr 23 10:00:40 1993 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. + + +;;; This defines the representation for sets of items, and +;;; computes the canonical lr(0) collection of sets of items. +;;; It currently leaves the closures lying around on the sets +;;; of items, they could be flushed just after they are used. +;;; It gets hold of the grammar via the symbol 'augmented start +;;; and the application of g-symbol-own-productions to symbols. +;;; The grammar should have been previously internalized +;;; using load-grammar. + +(in-package "ZEBU") + +(defvar *lr0-item-set-count*) +(defvar *lr0-item-sets*) +(defvar *lr0-start-state-index*) +(declaim (fixnum *lr0-start-state-index*)) + +;;; A type for sets of items. +;;; The kernel will be a o-set of items, the closure might be +;;; an o-set, or might be null if we are trying to save space. +;;; goto-map will be a oset of pairs whose cars are grammar symbols +;;; and whose cdrs are item-sets. + +(defstruct (item-set (:print-function + (lambda (item-set stream depth) + (declare (ignore depth)) + (item-set-print-kernel item-set nil stream)))) + index + kernel + (closure ()) + goto-map) + +(defun item-set-print-kernel (item-set closure-too? &optional (stream t)) + (oset-for-each + #'(lambda (item) + (item-print item stream) (terpri stream)) + (if closure-too? + (item-set-get-closure! item-set) + (item-set-kernel item-set)))) + +(declaim (inline goto-map-order-function item-set-order-function + new-item-set)) + +(defun goto-map-order-function (a b) + (g-symbol-order-function (car (the cons a)) (car (the cons b)))) + +(defun new-item-set (kernel) + (make-item-set :kernel kernel + :goto-map (make-oset + :order-fn #'goto-map-order-function))) + + +;;; Item sets can be identified by looking at their kernels, so: +(defun item-set-order-function (a b) + (declare (type item-set a b)) + ;; (oset-order-function (item-set-kernel a) (item-set-kernel b)) + ;; expand call for efficiency + (let* ((oset-a (item-set-kernel a)) + (oset-b (item-set-kernel b)) + (odf (oset-order-fn oset-a))) + (labels ((oset-order-aux (ilista ilistb) + (if (null ilista) + 'equal + (let ((item-order + (funcall odf + (car (the cons ilista)) + (car (the cons ilistb))))) + (if (eq 'equal item-order) + (oset-order-aux + (cdr (the cons ilista)) (cdr (the cons ilistb))) + item-order))))) + (if (eq odf (oset-order-fn oset-b)) + (let ((a-card (oset-cardinality oset-a)) + (b-card (oset-cardinality oset-b))) + (declare (fixnum a-card b-card)) + (if (< a-card b-card) + 'correct-order + (if (= a-card b-card) + ;; same cardinality, same type, so march down the lists... + (oset-order-aux (oset-item-list oset-a) + (oset-item-list oset-b)) + 'wrong-order))) + (error "incompatible types of sets: oset-order-function"))))) + +;;; Result is an oset of item-sets which comprise the canonical +;;; lr(0) sets of items. + +(defun make-lr0-collection () + (let* ((lr0-set (make-oset :order-fn #'item-set-order-function)) + (start-prod (car (g-symbol-own-productions + *augmented-start-g-symbol*))) + (initial-kernel + (make-oset + :item-list (list (new-item start-prod)) + :order-fn #'item-order-function + :cardinality 1))) + (let ((initial-state (new-item-set initial-kernel))) + (lr0-insert-item-set! initial-state lr0-set) + (setf *lr0-item-set-count* 0) + (dolist (is (oset-item-list lr0-set)) + (setf (item-set-index is) (post-inc *lr0-item-set-count*))) + (setf *lr0-start-state-index* (item-set-index initial-state)) + (format t "~S item sets~%" *lr0-item-set-count*) + (setf *lr0-item-sets* lr0-set) + '()))) + +;----------------------------------------------------------------------------; +; lr0-insert-item-set! +;--------------------- +; item-set should be of that type. +; Collection should be an o-set of item-sets. +; Returns a pointer to the item set in the collection. + +(defun lr0-insert-item-set! (item-set collection) + (multiple-value-bind (inserted? the-item) + (oset-insert-2! item-set collection) + (when inserted? ; item wasn't already there + (let ((item-set-goto-map (item-set-goto-map item-set))) + (princ ".") + (dolist (subset (oset-select-subsets + (item-set-get-closure! item-set) + #'symbol-after-dot)) + (declare (type oset subset)) + ;; (assert (typep subset 'oset)) + ;; subset is an oset of items with same after dot + (let ((subset-item-list (oset-item-list subset))) + (when subset-item-list + (let ((goto-set (make-oset :order-fn #'item-order-function))) + (dolist (item subset-item-list) + (let ((next (advance-dot item))) + (if next (oset-insert! next goto-set)))) + (unless (oset-empty? goto-set) + (oset-insert! + (cons (symbol-after-dot (car subset-item-list)) + (lr0-insert-item-set! (new-item-set goto-set) + collection)) + item-set-goto-map)))))))) + the-item)) + +;;; Returns the oset of items which is the closure of the item +;;; set, calculating it if need be from the kernel. +;;; Caches the closure in the closure slot. +(defun item-set-get-closure! (item-set) + (or (item-set-closure item-set) + (setf (item-set-closure item-set) (closure (item-set-kernel item-set))))) + + +;;; This isn't used in the current implementation: Sep 13, 1989. +#|| +(defun item-set-flush-closure (item-set) + (setf (item-set-closure item-set) '())) + +;; inline expanded in lr0-insert-item-set! +;;; Subset is an oset of items which all have the same after dot symbol. +;;; Result is an oset of items. +;;; Gives back an empty set if the dots are all the way to the right +;;; in the input set. + +(defun goto (subset) + (let ((result (make-oset :order-fn #'item-order-function))) + (dolist (item (oset-item-list subset) result) + (let ((next (advance-dot item))) + (if next (oset-insert! next result)))))) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test: +#|| +(load-grammar "ex1.zb") +(make-lr0-collection) +(print-collection nil) +(print-collection t) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-lr0-sets.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-mg-hierarchy.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-mg-hierarchy.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,176 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-mg-hierarchy.lisp +; Description: types and printers for the meta grammar +; Author: Joachim H. Laubsch +; Created: 13-May-92 +; Modified: Thu Dec 21 11:50:12 1995 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +(require "zebu-aux") +(provide "zebu-mg-hierarchy") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Top of hierarchy for ZEBU META-Grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(DEFSTRUCT (ZEBU-MG (:INCLUDE KB-DOMAIN) + (:CONSTRUCTOR NIL))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; KB-SEQUENCE +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *kb-sequence-separator* " " + "A string, separating the elements of a KB-sequence") + +(defstruct (KB-SEQUENCE (:include ZEBU-MG) + (:print-function KB-SEQUENCE-print)) + first + (rest nil :type (or NULL KB-SEQUENCE))) + +(defun KB-SEQUENCE-print (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (if (KB-SEQUENCE-p ITEM) + (let ((first (KB-SEQUENCE-first ITEM)) + (rest (KB-SEQUENCE-rest ITEM))) + (if (null rest) + (format STREAM "~a" first) + (if (kb-sequence-p rest) + (format STREAM "~a~:{~A~a~}" + first + (labels ((cons-kb-seq (seq) + (if (null seq) + nil + (cons (list *kb-sequence-separator* + (KB-SEQUENCE-first seq)) + (cons-kb-seq + (KB-SEQUENCE-rest seq)))))) + (cons-kb-seq rest))) + (format STREAM "~a~A~a" first *kb-sequence-separator* rest)))) + "")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FEAT-TERM +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(DEFSTRUCT (FEAT-TERM (:INCLUDE Zebu-mg) + #|| + (:print-function + (lambda (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "~@[type: ~S ~][~{~S~^ ~}]" + (FEAT-TERM--type ITEM) + (FEAT-TERM--slots ITEM)))) + ||# + ) + -TYPE + (-SLOTS nil)) + +(DEFSTRUCT (LABEL-VALUE-PAIR (:INCLUDE ZEBU-MG) + #|| + (:print-function + (lambda (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "(~S ~S)" + (Label-value-pair--label ITEM) + (Label-value-pair--value ITEM)))) + ||# + ) + -LABEL + (-VALUE nil)) + +#|| Not used yet +(DEFSTRUCT (GENERAL-VAR (:INCLUDE ZEBU-MG) + #|| + (:print-function + (lambda (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "%~S" + (General-Var--name ITEM)))) + ||# + ) + -NAME) + +(DEFSTRUCT (TAGGED-TERM (:INCLUDE ZEBU-MG) + #|| + (:print-function + (lambda (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "~S=~S" + (Tagged-Term--tag ITEM) + (Tagged-Term--term ITEM)))) + ||# + ) + -TERM + -TAG) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PRODUCTION-RHS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(DEFSTRUCT (PRODUCTION-RHS (:INCLUDE ZEBU-MG) + #|| + (:print-function print-production-rhs) + ||# + ) + (-SYNTAX nil) + (-SEMANTICS nil) + -BUILD-FN) + +(defun print-production-rhs (ITEM STREAM LEVEL) + (DECLARE (IGNORE LEVEL)) + (format STREAM + "~{~S ~}~@[ { ~S }~];" + (production-rhs--syntax ITEM) + (production-rhs--semantics ITEM))) + +(DEFSTRUCT (Kleene (:INCLUDE ZEBU-MG) ) + -constituent + -separator) + +(DEFSTRUCT (Kleene* (:INCLUDE Kleene) )) +(DEFSTRUCT (Kleene+ (:INCLUDE Kleene) )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Type definitions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct (domain-type (:include zebu-mg)) + -supertype -type -slots print-function) + +(defun cons-domain-type (name avm print-function) + ;; Return: [supertype type slots print-function] + (let ((type (if (feat-term-p avm) + (feat-term--type avm) + 'KB-Domain)) + (slots (if (feat-term-p avm) + (feat-term--slots avm) + avm))) + (make-domain-type + :-supertype type + :-type name + :-slots (mapcar #'(lambda (slot) + (let ((v (label-value-pair--value slot))) + (if (null v) + (label-value-pair--label slot) + (list (label-value-pair--label slot) v)))) + slots) + :print-function print-function))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-mg-hierarchy.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-mg.tab ============================================================================== --- (empty file) +++ vendor/zebu/zebu-mg.tab Wed Oct 17 09:04:46 2007 @@ -0,0 +1,146 @@ + +(:FILE "/home/rudi/lisp/zebu-3.5.5/zebu-mg.zb" :NAME "zebu-mg" :DOMAIN-FILE "zmg-dom" :PACKAGE "ZEBU" :GRAMMAR "null-grammar" :IDENTIFIER-START-CHARS "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" :IDENTIFIER-CONTINUE-CHARS "$-_.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" :DOMAIN-FILE "/home/rudi/lisp/zebu-3.5.5/zmg-dom.lisp") +#37(THE-EMPTY-STRING AUGMENTED-START THE-END-G-SYMBOL META-GRAMMAR DEF-TYPE ZB-RULE IDENTIFIER ":=" TYPED-CONJ PRINT-FUNCTION ";" CONJ "<<" "print-function:" ">>" ":" "[" LABEL-VALUE-PAIRS "]" FEAT-TERM NUMBER STRING "*" "+" LABEL-VALUE-PAIR "(" ")" NON-TERMINAL "-->" RHS RHS1 MORE-RHS CONSTITUENT-LIST "{" "}" CONSTITUENT "|" ) + + +#19(6 7 10 12 13 14 15 16 18 20 21 22 23 25 26 28 33 34 36 ) + +#34((1 . 1)(3 . 1)(3 . 1)(4 . 5)(4 . 5)(9 . 0)(9 . 4)(8 . 3)(11 . 3)(19 . 1)(19 . 1)(19 . 1)(19 . 2)(19 . 2)(19 . 1)(19 . 1)(24 . 4)(24 . 3)(17 . 0)(17 . 2)(5 . 4)(27 . 1)(29 . 0)(29 . 2)(30 . 1)(30 . 4)(32 . 2)(32 . 0)(35 . 1)(35 . 3)(35 . 3)(35 . 1)(31 . 0)(31 . 3)) + +#57( +((6 :S 54)) +((2 :A 0)) +((2 :R 1)) +((2 :R 2)) +((10 :R 5) (12 :S 10)) +((10 :S 6)) +((2 :R 3)) +((10 :R 5) (12 :S 10)) +((10 :S 9)) +((2 :R 4)) +((13 :S 11)) +((6 :S 12)) +((14 :S 13)) +((10 :R 6)) +((15 :S 15)) +((16 :S 17)) +((10 :R 7) (12 :R 7) (26 :R 7) (34 :R 7)) +((18 :R 18) (25 :S 51)) +((18 :S 19)) +((10 :R 8) (12 :R 8) (26 :R 8) (34 :R 8)) +((26 :R 10) (34 :R 10)) +((26 :R 11) (34 :R 11)) +((26 :R 12) (34 :R 12)) +((26 :R 13) (34 :R 13)) +((26 :R 14) (34 :R 14)) +((26 :R 15) (34 :R 15)) +((26 :S 27)) +((18 :R 16) (25 :R 16)) +((18 :R 17) (25 :R 17)) +((18 :R 18) (25 :S 51)) +((18 :R 19)) +((28 :S 32)) +((6 :S 55) (10 :R 22) (21 :S 46) (33 :R 27) (36 :R 27)) +((10 :S 34)) +((2 :R 20)) +((10 :R 32) (36 :S 47)) +((10 :R 23)) +((6 :S 56) (16 :S 17) (20 :S 20) (21 :S 21)) +((34 :S 39)) +((10 :R 25) (36 :R 25)) +((6 :S 55) (10 :R 27) (21 :S 46) (33 :R 27) (36 :R 27)) +((10 :R 26) (33 :R 26) (36 :R 26)) +((21 :S 43)) +((6 :R 29) (10 :R 29) (21 :R 29) (33 :R 29) (36 :R 29)) +((21 :S 45)) +((6 :R 30) (10 :R 30) (21 :R 30) (33 :R 30) (36 :R 30)) +((6 :R 31) (10 :R 31) (21 :R 31) (33 :R 31) (36 :R 31)) +((6 :S 55) (10 :R 27) (21 :S 46) (33 :R 27) (36 :R 27)) +((10 :R 32) (36 :S 47)) +((10 :R 33)) +((6 :S 14) (16 :S 17)) +((6 :S 52)) +((6 :S 56) (16 :S 17) (20 :S 20) (21 :S 21) (26 :S 28)) +((10 :R 24) (33 :S 37) (36 :R 24)) +((7 :S 50) (28 :R 21)) +((6 :R 28) (10 :R 28) (21 :R 28) (22 :S 42) (23 :S 44) (33 :R 28) (36 :R 28)) +((15 :S 15) (22 :S 22) (23 :S 23) (26 :R 9) (34 :R 9))) + +#57( +((3 . 1)(4 . 2)(5 . 3)(27 . 31)) +() +() +() +((9 . 5)) +() +() +((9 . 8)) +() +() +() +() +() +() +() +((11 . 16)) +() +((17 . 18)(24 . 29)) +() +() +() +() +() +() +() +() +() +() +() +((17 . 30)(24 . 29)) +() +() +((29 . 33)(30 . 35)(32 . 53)(35 . 40)) +() +() +((31 . 36)) +() +((8 . 24)(11 . 25)(19 . 38)) +() +() +((32 . 41)(35 . 40)) +() +() +() +() +() +() +((30 . 48)(32 . 53)(35 . 40)) +((31 . 49)) +() +((8 . 4)(11 . 7)) +() +((8 . 24)(11 . 25)(19 . 26)) +() +() +() +()) +0 + +2 + +#15((META-GRAMMAR . #S(ZB-RULE :-NAME META-GRAMMAR :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX (DEF-TYPE) :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(PRODUCTION-RHS :-SYNTAX (ZB-RULE) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) +(DEF-TYPE . #S(ZB-RULE :-NAME DEF-TYPE :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER ":=" TYPED-CONJ PRINT-FUNCTION ";") :-SEMANTICS NIL :-BUILD-FN DEF-TYPE16) #S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER ":=" CONJ PRINT-FUNCTION ";") :-SEMANTICS NIL :-BUILD-FN DEF-TYPE17)))) +(PRINT-FUNCTION . #S(ZB-RULE :-NAME PRINT-FUNCTION :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(PRODUCTION-RHS :-SYNTAX ("<<" "print-function:" IDENTIFIER ">>") :-SEMANTICS NIL :-BUILD-FN PRINT-FUNCTION15)))) +(TYPED-CONJ . #S(ZB-RULE :-NAME TYPED-CONJ :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER ":" CONJ) :-SEMANTICS NIL :-BUILD-FN TYPED-CONJ14)))) +(CONJ . #S(ZB-RULE :-NAME CONJ :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX ("[" LABEL-VALUE-PAIRS "]") :-SEMANTICS NIL :-BUILD-FN CONJ13)))) +(FEAT-TERM . #S(ZB-RULE :-NAME FEAT-TERM :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER) :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(PRODUCTION-RHS :-SYNTAX (NUMBER) :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(PRODUCTION-RHS :-SYNTAX (STRING) :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER "*") :-SEMANTICS NIL :-BUILD-FN FEAT-TERM10) #S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER "+") :-SEMANTICS NIL :-BUILD-FN FEAT-TERM11) #S(PRODUCTION-RHS :-SYNTAX (TYPED-CONJ) :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(PRODUCTION-RHS :-SYNTAX (CONJ) :-SEMANTICS NIL :-BUILD-FN FEAT-TERM12)))) +(LABEL-VALUE-PAIR . #S(ZB-RULE :-NAME LABEL-VALUE-PAIR :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX ("(" IDENTIFIER FEAT-TERM ")") :-SEMANTICS NIL :-BUILD-FN LABEL-VALUE-PAIR8) #S(PRODUCTION-RHS :-SYNTAX ("(" IDENTIFIER ")") :-SEMANTICS NIL :-BUILD-FN LABEL-VALUE-PAIR9)))) +(LABEL-VALUE-PAIRS . #S(ZB-RULE :-NAME LABEL-VALUE-PAIRS :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(PRODUCTION-RHS :-SYNTAX (LABEL-VALUE-PAIR LABEL-VALUE-PAIRS) :-SEMANTICS NIL :-BUILD-FN CONS)))) +(ZB-RULE . #S(ZB-RULE :-NAME ZB-RULE :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX (NON-TERMINAL "-->" RHS ";") :-SEMANTICS NIL :-BUILD-FN ZB-RULE7)))) +(NON-TERMINAL . #S(ZB-RULE :-NAME NON-TERMINAL :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) +(RHS . #S(ZB-RULE :-NAME RHS :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(PRODUCTION-RHS :-SYNTAX (RHS1 MORE-RHS) :-SEMANTICS NIL :-BUILD-FN CONS)))) +(RHS1 . #S(ZB-RULE :-NAME RHS1 :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX (CONSTITUENT-LIST) :-SEMANTICS NIL :-BUILD-FN RHS15) #S(PRODUCTION-RHS :-SYNTAX (CONSTITUENT-LIST "{" FEAT-TERM "}") :-SEMANTICS NIL :-BUILD-FN RHS16)))) +(CONSTITUENT-LIST . #S(ZB-RULE :-NAME CONSTITUENT-LIST :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX (CONSTITUENT CONSTITUENT-LIST) :-SEMANTICS NIL :-BUILD-FN CONS) #S(PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*)))) +(CONSTITUENT . #S(ZB-RULE :-NAME CONSTITUENT :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER) :-SEMANTICS NIL :-BUILD-FN IDENTITY) #S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER "*" STRING) :-SEMANTICS NIL :-BUILD-FN CONSTITUENT3) #S(PRODUCTION-RHS :-SYNTAX (IDENTIFIER "+" STRING) :-SEMANTICS NIL :-BUILD-FN CONSTITUENT4) #S(PRODUCTION-RHS :-SYNTAX (STRING) :-SEMANTICS NIL :-BUILD-FN IDENTITY)))) +(MORE-RHS . #S(ZB-RULE :-NAME MORE-RHS :-PRODUCTIONS (#S(PRODUCTION-RHS :-SYNTAX NIL :-SEMANTICS NIL :-BUILD-FN IDENTITY*) #S(PRODUCTION-RHS :-SYNTAX ("|" RHS1 MORE-RHS) :-SEMANTICS NIL :-BUILD-FN MORE-RHS1)))) +) \ No newline at end of file Added: vendor/zebu/zebu-mg.zb ============================================================================== --- (empty file) +++ vendor/zebu/zebu-mg.zb Wed Oct 17 09:04:46 2007 @@ -0,0 +1,155 @@ +; -*- mode: Lisp -*- --------------------------------------------------- ; +; File: zebu-mg.zb +; Description: Metagrammar for Zebu +; Author: Joachim H. Laubsch +; Created: 13-Apr-92 +; Modified: Thu Dec 21 16:26:28 1995 (Joachim H. Laubsch) +; Language: Lisp +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 10-Mar-93 (Joachim H. Laubsch) +; add domain definition +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(:name "zebu-mg" + :domain-file "zmg-dom" + :package "ZEBU" + :grammar "null-grammar" + :identifier-start-chars + "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + :identifier-continue-chars + "$-_.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" + ) + +(defrule Meta-Grammar + := Def-Type + := zb-rule) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Domain Definition +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defrule Def-Type + := ( Identifier ":=" Typed-Conj Print-function ";" ) + :build (cons-domain-type Identifier Typed-Conj Print-function) + + := ( Identifier ":=" Conj Print-function ";") + :build (cons-domain-type Identifier Conj Print-function) + ) + +(defrule Print-function + := () + + := ("<<" "print-function:" Identifier ">>") + :build (:form Identifier)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; AVM grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defrule Typed-Conj + := ( Identifier ":" Conj ) + :build (:type Feat-Term + :map ((Conj . :-slots) + (Identifier . :-type)))) + +(defrule Conj + := ( "[" Label-value-pairs "]" ) + :build (:form Label-value-pairs)) + +(defrule Feat-Term + := Identifier + := Number + := String + + := (Identifier "*") + :build (intern (concatenate 'string (string Identifier) "*")) + + := (Identifier "+") + :build (intern (concatenate 'string (string Identifier) "+")) + + := Typed-Conj + + := Conj + :build (:type Feat-Term + :map ((Conj . :-slots))) + ) + +(defrule Label-value-pair + := ( "(" Identifier Feat-Term ")" ) + :build (:type Label-value-pair + :map ((Identifier . :-label) + (Feat-Term . :-value))) + + := ( "(" Identifier ")" ) + :build (:type Label-value-pair + :map ((Identifier . :-label))) + ) + +(defrule Label-value-pairs + := () + + := ( Label-value-pair Label-value-pairs ) + :build cons + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Grammar Rules +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defrule zb-rule + := ( Non-terminal "-->" Rhs ";") + :build (:type zb-rule + :map ((Non-terminal . :-name) + (Rhs . :-productions)))) + +(defrule Non-terminal := Identifier) + +(defrule Rhs + := () + + := ( Rhs1 More-Rhs ) + :build cons + ) + +(defrule Rhs1 + := ( Constituent-list ) + :build (:type Production-Rhs + :map ((Constituent-list . :-syntax))) + + := ( Constituent-list "{" Feat-Term "}" ) + :build (:type Production-Rhs + :map ((Constituent-list . :-syntax) + (Feat-Term . :-semantics))) + ) + +(defrule Constituent-list + := ( Constituent Constituent-list ) + :build cons + + := () ) + +(defrule Constituent + := Identifier + := (Identifier "*" String) + :build (:type Kleene* :map ((Identifier . :-constituent) + (String . :-separator))) + := (Identifier "+" String) + :build (:type Kleene+ :map ((Identifier . :-constituent) + (String . :-separator))) + := String ) + +(defrule More-Rhs + := () + := ( "|" Rhs1 More-Rhs ) + :build (:form (cons Rhs1 More-Rhs))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-mg.zb +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-oset.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-oset.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,369 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-oset.lisp +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 14-Nov-90 +; Modified: Tue Aug 2 15:03:39 1994 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. + +(in-package "ZEBU") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Ordered Sets +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; A simple ordered set facility. Items kept in these sets must +;;; have an order function: these are supplied for integers and +;;; osets themselves. Items are kept in sorted lists, smallest +;;; first. Could be re-done with binary search trees. +;;; See integer-order-function for how order functions are supposed to +;;; work. + +;;; Constructor will default to make a set that orders integers. + +(defstruct (oset (:copier nil) + ) + (item-list '() :type list) + (order-fn #'integer-order-function) + (cardinality 0 :type fixnum)) + +(declaim (inline oset-empty?)) +(defun oset-empty? (oset) (null (oset-item-list oset))) + +;;; Example of how the order function is supposed to work. + +(declaim (inline integer-order-function)) +(defun integer-order-function (a b) + (declare (fixnum a b)) + (cond ((< a b) 'correct-order) + ((> a b) 'wrong-order) + (T 'equal))) + +;;; Destructively insert an item into a set +;;; Returns the item if it wasn't there already, else NIL. +(defun oset-insert! (item set) + ;; Returns NIL if nothing is inserted or T if item was inserted + ;; otherwise like oset-insert-2! + (declare (type oset set)) + (let ((ilist (oset-item-list set))) + (if (null ilist) + (progn (setf (oset-item-list set) (list item) + (oset-cardinality set) 1) + t) + (let ((odf (oset-order-fn set)) + order) + (cond ((eq 'correct-order + (setq order (funcall odf item (car (the cons ilist))))) + (setf (oset-item-list set) (cons item ilist)) + (incf (oset-cardinality set)) + t) + ((eq 'equal order) nil) ; item already there + (T ;; Ilist isn't null, and item goes somewhere after + ;; the car of ilist. + (do ((ilist ilist ilist-cdr) + (ilist-cdr (cdr ilist) (cdr ilist-cdr))) + ((null ilist-cdr) + (setf (cdr (the cons ilist)) (list item)) + (incf (oset-cardinality set)) + t) + (let ((ilist-cdr1 (car (the cons ilist-cdr)))) + (when (eq 'correct-order + (setq order (funcall odf item ilist-cdr1))) + (setf (cdr (the cons ilist)) (cons item ilist-cdr)) + (incf (oset-cardinality set)) + (return-from oset-insert! t)) + (when (eq 'equal order) ; already there + (return-from oset-insert! nil)))))))))) + +;;; Returns two values: (1) NIL if nothing is inserted ot T if item was +;;; inserted, and (2) a pointer to the item either found or inserted +;;; into the set (so is eq to a member of the set). + +(defun oset-insert-2! (item set) + (declare (type oset set)) + (let ((ilist (oset-item-list set))) + (if (null ilist) + (progn (setf (oset-item-list set) (list item) + (oset-cardinality set) 1) + (values t item)) + (let ((odf (oset-order-fn set)) + (ilist-hd (car (the cons ilist))) + order) + (cond ((eq 'correct-order + (setq order (funcall odf item ilist-hd))) + (setf (oset-item-list set) (cons item ilist)) + (incf (oset-cardinality set)) + (values t item)) + ((eq 'equal order) (values nil ilist-hd)) + ;; item already there + (T ;; Ilist isn't null, and item goes somewhere after + ;; the car of ilist. + (do ((ilist ilist ilist-cdr) (ilist-cdr (cdr ilist) (cdr ilist-cdr))) + ((null ilist-cdr) + (setf (cdr (the cons ilist)) (list item)) + (incf (oset-cardinality set)) + (values t item)) + (let ((ilist-cdr1 (car (the cons ilist-cdr)))) + (when (eq 'correct-order + (setq order (funcall odf item ilist-cdr1))) + (setf (cdr (the cons ilist)) (cons item ilist-cdr)) + (incf (oset-cardinality set)) + (return-from oset-insert-2! (values t item))) + (when (eq 'equal order) ; already there + (return-from oset-insert-2! (values nil ilist-cdr1))))))))))) + + +;;; Insert a list of items into an oset. returns the SET. +(declaim (inline oset-insert-list!)) +(defun oset-insert-list! (list oset) + (dolist (x list oset) (oset-insert! x oset))) + +;;; It's easy to define a generic order function on osets if they +;;; have the same order function +;;; making for easy osets of osets. + +(defun oset-order-function (oset-a oset-b &aux (odf (oset-order-fn oset-a))) + (declare (type oset oset-a oset-b)) + (labels ((oset-order-aux (ilista ilistb) + (if (null ilista) + 'equal + (let ((item-order (funcall odf (car ilista) (car ilistb)))) + (if (eq 'equal item-order) + (oset-order-aux (cdr ilista) (cdr ilistb)) + item-order))))) + (if (eq odf (oset-order-fn oset-b)) + (let ((a-card (oset-cardinality oset-a)) + (b-card (oset-cardinality oset-b))) + (declare (fixnum a-card b-card)) + (if (< a-card b-card) + 'correct-order + (if (= a-card b-card) + ;; same cardinality, same type, so march down the lists... + (oset-order-aux (oset-item-list oset-a) + (oset-item-list oset-b)) + 'wrong-order))) + (error "incompatible types of sets: oset-order-function")))) + +; (declaim (inline oset-comparable?)) +; (defun oset-comparable? (oseta osetb) +; (eq 'equal (oset-order-function oseta osetb))) + +;----------------------------------------------------------------------------; +; oset-select-subsets +;-------------------- +;;; Yields a list of disjoint subsets whose union is the set. For +;;; each subset the value of selection-fn applied to the members is +;;; the same in the sense of eqv. +;;; partition set according to selection-fn + +(defun oset-select-subsets (set selection-fn) + (let ((r-ilist (oset-item-list set)) + (alist '()) + (odf (oset-order-fn set))) + (dolist (item r-ilist) + (let* ((key (funcall selection-fn item)) + (found-association (assoc key alist :test #'eql))) + (if found-association + (setf (cdr found-association) + (cons item (cdr found-association))) + (push (cons key (list item)) alist)))) + (do ((alist-tl alist (cdr alist-tl))) + ((null alist-tl) alist) + (let ((items (cdar (the cons alist-tl)))) + (setf (car alist-tl) (make-oset :item-list (nreverse items) + :cardinality (length items) + :order-fn odf)))))) + +(declaim (inline oset-for-each oset-memq oset-copy oset-union oset-empty!)) +(defun oset-for-each (procedure set) + (declare (type oset set)) + (dolist (x (oset-item-list set)) (funcall procedure x))) + +(defun oset-memq (elt set) + (member elt (oset-item-list (the oset set)))) + +(defun oset-copy (oset) + (declare (type oset oset)) + (make-oset + :item-list (copy-list (oset-item-list oset)) + :order-fn (oset-order-fn oset) + :cardinality (oset-cardinality oset))) + +(defun oset-union (oset1 oset2) + (declare (type oset oset1 oset2)) + #|| + (assert (eql (oset-order-fn oset1) (oset-order-fn oset2)) + () + "Mismatched order functions in oset union.") + (if (> (oset-cardinality oset1) (oset-cardinality oset2)) + (oset-insert-list! (oset-item-list oset2) + (oset-copy oset1)) + (oset-insert-list! (oset-item-list oset1) + (oset-copy oset2))) + ||# + (oset-insert-list! (oset-item-list oset1) + (oset-copy oset2))) + +(defun oset-delete (item oset) + (declare (type oset oset)) + (let ((item-list (oset-item-list oset))) + (if (member item item-list) + (make-oset :item-list (delete item item-list) + :cardinality (1- (oset-cardinality oset)) + :order-fn (oset-order-fn oset)) + oset))) + +(defun oset-empty! (oset) + (declare (type oset oset)) + (setf (oset-cardinality oset) 0 + (oset-item-list oset) '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; LR(1) items +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; lr(1) items. +;;; These are going to be represented by structs: +;;; after-dot is an integer which indexes the symbol in the +;;; production which follows the dot +;;; that comes after the dot. +;;; +;;; look-aheads is an oset of grammar symbols. +;;; The item data structure +;;; essentially stands for the set of lr(1) items which are the same +;;; except for each having one lookahead symbol from the set look-aheads. +;;; +;;; look-ahead-dependers is an oset of items to whom +;;; lalr(1) lookaheads +;;; propagate from this item. + +(defstruct (item (:print-function item-print)) + (production nil) + (after-dot 0 :type fixnum) + (look-aheads (make-oset :order-fn #'g-symbol-order-function)) + (look-ahead-dependers + (make-oset :order-fn #'item-order-function))) + +;;; A handy predicate. +(declaim (inline dot-at-right-end?)) + +(defun dot-at-right-end? (item) + (declare (type item item)) + (= (the fixnum (production-length (item-production item))) + (the fixnum (item-after-dot item)))) + +;;; Get the symbol after the dot -- 'the-bogus-symbol if dot is flushright. +(defun symbol-after-dot (item) + (declare (type item item)) + (let ((pr-after (nthcdr (the fixnum (item-after-dot item)) + (the list (rhs (item-production item)))))) + (if pr-after + (car pr-after) + 'the-bogus-symbol))) + +;;; Make an item with the dot moved one to the right, or false if +;;; dot gets past the end. +;;; Since this is used during lr(0) set construction, it only +;;; deals with production and after-dot slots, the others +;;; are filled in as '() by default. +(defun advance-dot (item) + (declare (type item item)) + (let ((production (item-production item)) + (item-after-dot (item-after-dot item))) + (if (= (production-length production) + (the fixnum item-after-dot)) + nil + (make-item :production production + :after-dot (1+ item-after-dot))))) + +;;; Make an item which has the dot at the left end of the rhs. +(declaim (inline new-item)) +(defun new-item (production) + (make-item :production production)) + +;;; For osets of items: +;;; this is used during lr(0) sets of items construction. Only the +;;; production and after dot fields are tested, since these characterize +;;; lr(0) items. + +(defun item-order-function (ia ib) + (declare (type item ia ib)) + (let ((production-index-a (production-index (item-production ia))) + (production-index-b (production-index (item-production ib)))) + (declare (fixnum production-index-a production-index-b)) + (if (< production-index-a production-index-b) + 'correct-order + (if (= production-index-a production-index-b) + (let ((iad (item-after-dot ia)) (ibd (item-after-dot ib))) + (declare (fixnum iad ibd)) + (if (< iad ibd) + 'correct-order + (if (= iad ibd) + 'equal + 'wrong-order))) + 'wrong-order)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test: + +#|| + (integer-order-function 1 2) + (setq fred (make-oset)) + (oset-item-list fred) + (oset-insert! 3 fred) + (oset-insert-2! 4 fred) + (oset-insert-list! '(5 6 7 7) fred) + (oset-insert-list! '(10 11) fred) + (oset-insert! 1100 fred) + (setq ned (make-oset)) + (setq mary (make-oset :order-fn #'oset-order-function)) + (oset-insert! ned mary) + (oset-insert! ned mary) + (oset-insert! fred mary) + (oset-insert! fred mary) + (mapc #'oset-item-list (oset-item-list mary)) + (mapc #'oset-item-list (oset-select-subsets fred #'(lambda (x) (> x 5)))) + (mapc #'oset-item-list (oset-select-subsets fred #'evenp)) + (oset-for-each #'(lambda (x) (format t "~S " x)) fred) + (oset-memq 5 fred) + (oset-memq 99 fred) + (setq freddy (oset-copy fred)) + (oset-item-list freddy) + (setq al (car (oset-select-subsets fred #'evenp))) + (setq hal (cadr (oset-select-subsets fred #'evenp))) + (oset-item-list (oset-union al hal)) + (oset-item-list fred) + (oset-item-list (oset-delete 1100 fred)) + (oset-empty! freddy) + (oset-item-list freddy) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test: "zebu-item" +#|| + (defun red ((new-item (car *productions*))) + (item-print fred) + (defvar ned (advance-dot fred)) + (item-print ned) + (item-order-function ned ned) + (item-order-function ned fred) + (item-order-function fred ned) + (symbol-after-dot fred) + (dot-at-right-end? fred) + (dot-at-right-end? ned)) +||# + +||# +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-oset.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-package.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-package.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,214 @@ +; -*- mode: Lisp -*- --------------------------------------------------- ; +; File: zebu-defsystem-package.lisp +; Description: package definition (mk:defsystem version) +; Author: Rudi Schlatte, based on zebu-package.lisp by J.Laubsch +; Language: CL +; Package: CL-USER +; Status: Experimental (Do Not Distribute) +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Package and parameter definitions for use with mk:defsystem. +; Eliminates dependence on some symbols (*ZEBU-directory* et al.) +; being present in CL-USER. +; +; This file REPLACES zebu-package.lisp when using mk:defsystem for the +; load process. Rationale: zebu-package.lisp expects some symbols and +; packages to be present, and setting everything up including creating +; a fake package PSGRAPH was not something very clean to do. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "CL-USER") +(provide "zebu-package") + +#+LUCID ; while not up tp CLtL2 +(eval-when (compile load eval) + (defmacro LCL::DECLAIM (decl-spec) `(proclaim ',decl-spec))) + +;;; 2000-03-25 by rschlatte at ist.tu-graz.ac.at: +;;; This package is not used anywhere +;;#+LUCID +;;(defpackage "PSGRAPH" +;; (:use "LUCID-COMMON-LISP")) +;; +;;#-LUCID +;;(defpackage "PSGRAPH" +;; (:use "COMMON-LISP")) + + +(defpackage "ZEBU" + (:nicknames "ZB") + #+LUCID (:use "LISP" "LUCID-COMMON-LISP") + #+LUCID (:import-from "SYSTEM" "*KEYWORD-PACKAGE*") +;;; 2000-03-25 by rschlatte at ist.tu-graz.ac.at: +;;; Gives an error when loading compiled files +;; #+LUCID (:import-from "LCL" "DECLAIM") +;; (:import-from "PSGRAPH" PSGRAPH::PSGRAPH) + #+MCL (:use "COMMON-LISP" "CCL") + #+KCL (:use "LISP") + #+ALLEGRO (:use "COMMON-LISP" "EXCL") + #-(or lucid mcl kcl allegro) (:use "COMMON-LISP") + +;;; 2000-03-25 by rschlatte at ist.tu-graz.ac.at: +;;; Defined in this file / package instead, see below +;; (:import-from "CL-USER" CL-USER::*ZEBU-DIRECTORY* +;; CL-USER::*ZEBU-binary-directory*) + (:export "*COMMENT-BRACKETS*" "*COMMENT-START*" "*PRESERVE-CASE*" + "*CASE-SENSITIVE*" + "*DISALLOW-PACKAGES*" "*STRING-DELIMITER*" + "*SYMBOL-DELIMITER*" + "*IDENTIFIER-START-CHARS*" "*IDENTIFIER-CONTINUE-CHARS*" + "*ALLOW-CONFLICTS*" "*WARN-CONFLICTS*" + "*CURRENT-GRAMMAR*" "*GENERATE-DOMAIN*" + "*ZEBU-VERSION*" + "CATEGORIZE" "END-OF-TOKENS-CATEGORY" + "COMPILE-LALR1-GRAMMAR" "COMPILE-SLR-GRAMMAR" + "DEBUG-PARSER" + "DEFRULE" "FILE-PARSER" "FIND-GRAMMAR" "IDENTITY*" + "IDENTIFIERP" + "KB-DOMAIN" "KB-DOMAIN-P" "KB-TYPE-NAME-P" + "KB-SEQUENCE" "KB-SEQUENCE-P" "*KB-SEQUENCE-SEPARATOR*" + "MAKE-KB-SEQUENCE" "KB-SEQUENCE-FIRST" "KB-SEQUENCE-REST" + "KB-DEF-SLOT-TYPE" "KB-SET-VALUED-SLOT-P" + "KB-SLOT-TYPE" "KB-SLOTS" "KB-SUPERTYPE" "KB-SUBTYPES" + "KB-LEGAL-SLOT-P" + "KB-TREE-ATTRIBUTES" "DEFINE-TREE-ATTRIBUTES" "DEF-TREE-ATTRIBUTES" + "PREORDER-TRANSFORM" "POSTORDER-TRANSFORM" + "KIDS" "FOR-EACH-KID" "FOR-EACH-KID!" + "FOR-EACH-DESCENDANT" + "KB-COPY" "KB-EQUAL" "KB-COMPARE" + "LIST-PARSER" "LR-PARSE" "PRINT-ACTIONS" "READ-PARSER" + "COMPILE-FROM-COMMAND-LINE" + "EMPTY-SEQ" "SEQ-CONS" "EMPTY-SET" "SET-CONS" + "K-4-3" "K-2-1" "K-2-2" "K-3-2" "CONS-1-3" "CONS-2-3" + "NUMBER" "STRING" "IDENTIFIER" + "SHOW-KB-HIERARCHY" + "ZEBU" "ZEBU-COMPILER" "ZEBU-COMPILE-FILE" "ZEBU-LOAD-FILE" + "ZEBU-RR" "ZEBU-TOP" + ) +;;; 2000-03-25 by rschlatte at ist.tu-graz.ac.at: +;;; Defined in this file / package instead, see below +;; #-LUCID +;; (:import-from "CL-USER" +;; CL-USER::*LOAD-SOURCE-PATHNAME-TYPES* +;; CL-USER::*LOAD-BINARY-PATHNAME-TYPES*)) + ) + +(in-package "ZB") + +;;; 2000-03-25 by rschlatte at ist.tu-graz.ac.at: +;;; Moved definitions of *ZEBU-direcotory*, *ZEBU-binary-directory* +;;; over from ZEBU-init.lisp, got rid of importing symbols from +;;; CL-USER in (defpackage "ZEBU") + +; edit the following form for your Lisp, and the directory where you keep Zebu +(defparameter *ZEBU-directory* + (make-pathname + :directory ;; Might be loading zebu-package-fasl from the binary directory + (remove "binary" (pathname-directory *load-truename*) + :from-end t :test #'string-equal + :count 1 :end 1)) + "The location of the ZEBU source files.") + +;;---------------------------------------------------------------------------; +;; *ZEBU-binary-directory* +;;------------------------ +;; directory for compiled grammars and lisp files +;; +(defparameter *ZEBU-binary-directory* + (make-pathname :directory (append (pathname-directory *ZEBU-directory*) + (list "binary"))) + "The location of the compiled ZEBU files.") + + + +;;; 2000-03-25 by rschlatte at ist.tu-graz.ac.at: +;;; Extensions are defined multiple times in COMPILE-Zebu.lisp and +;;; ZEBU-init.lisp +;;; I was lazy and snarfed a list from mk:defsystem 3.x :-) +;;; TODO +;;; Do something clever with the environment package from CLOCC; +;;; such a list should really be maintained in one place only. + +;;; *filename-extensions* is a cons of the source and binary extensions. +(defvar *filename-extensions* + (car `(#+(and Symbolics Lispm) ("lisp" . "bin") + #+(and dec common vax (not ultrix)) ("LSP" . "FAS") + #+(and dec common vax ultrix) ("lsp" . "fas") + #+ACLPC ("lsp" . "fsl") + #+CLISP ("lsp" . "fas") + #+KCL ("lsp" . "o") + #+IBCL ("lsp" . "o") + #+Xerox ("lisp" . "dfasl") + ;; Lucid on Silicon Graphics + #+(and Lucid MIPS) ("lisp" . "mbin") + ;; the entry for (and lucid hp300) must precede + ;; that of (and lucid mc68000) for hp9000/300's running lucid, + ;; since *features* on hp9000/300's also include the :mc68000 + ;; feature. + #+(and lucid hp300) ("lisp" . "6bin") + #+(and Lucid MC68000) ("lisp" . "lbin") + #+(and Lucid Vax) ("lisp" . "vbin") + #+(and Lucid Prime) ("lisp" . "pbin") + #+(and Lucid SUNRise) ("lisp" . "sbin") + #+(and Lucid SPARC) ("lisp" . "sbin") + #+(and Lucid :IBM-RT-PC) ("lisp" . "bbin") + ;; PA is Precision Architecture, HP's 9000/800 RISC cpu + #+(and Lucid PA) ("lisp" . "hbin") + #+excl ("cl" . "fasl") + #+CMU ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) + "fasl")) +; #+(and :CMU (not (or :sgi :sparc))) ("lisp" . "fasl") +; #+(and :CMU :sgi) ("lisp" . "sgif") +; #+(and :CMU :sparc) ("lisp" . "sparcf") + #+PRIME ("lisp" . "pbin") + #+HP ("l" . "b") + #+TI ("lisp" . #.(string (si::local-binary-file-type))) + #+:gclisp ("LSP" . "F2S") + #+pyramid ("clisp" . "o") + #+:coral ("lisp" . "fasl") + ;; Harlequin LispWorks + #+:lispworks ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*) +; #+(and :sun4 :lispworks) ("lisp" . "wfasl") +; #+(and :mips :lispworks) ("lisp" . "mfasl") + #+:mcl ("lisp" . "fasl") + + ;; Otherwise, + ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp"))))) + "Filename extensions for Common Lisp. A cons of the form + (Source-Extension . Binary-Extension). If the system is + unknown (as in *features* not known), defaults to \"lisp\" and the + file type of compile-file-pathname.") + +(defparameter *load-source-pathname-types* + (list (car *filename-extensions*))) +(defparameter *load-binary-pathname-types* + (list (cdr *filename-extensions*))) + + +;;; 2000-03-25 by rschlatte at ist.tu-graz.ac.at: +;;; Snarfed from ZEBU-init.lisp +(defvar *zebu-version* + (let ((file (make-pathname + :name "Version" + :type nil + :directory (pathname-directory + *zebu-directory*)))) + (if (probe-file file) + (with-open-file (s file :direction :input) + (read-line s)) + "3.5.5"))) + +(declaim (special *COMMENT-BRACKETS* *COMMENT-START* *PRESERVE-CASE* + *CASE-SENSITIVE* *DISALLOW-PACKAGES* *STRING-DELIMITER* + *SYMBOL-DELIMITER* *IDENTIFIER-START-CHARS* + *IDENTIFIER-CONTINUE-CHARS* + *ALLOW-CONFLICTS* *WARN-CONFLICTS* + *CURRENT-GRAMMAR* *GENERATE-DOMAIN* + )) + +#-LUCID +(declaim (special *LOAD-SOURCE-PATHNAME-TYPES* + *LOAD-BINARY-PATHNAME-TYPES*)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-defsystem-package.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-printers.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-printers.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,178 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-printers.l +; Description: printing functions for grammar debugging +; Author: Joachim H. Laubsch +; Created: 4-Aug-92 +; Modified: Wed Sep 7 17:40:30 1994 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(IN-PACKAGE "ZEBU") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; printing the internals of a grammar +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun print-actions (grammar &optional (stream t)) + (let ((g (find-grammar (string grammar)))) + (if (null g) + (error "No Grammar named ~S loaded" grammar) + (let ((*package* (find-package (grammar-package g))) + (zb-rules (grammar-zb-rules g))) + (dotimes (i (length zb-rules)) + (let ((pair (svref zb-rules i))) + (format stream "~%~%Rule: ~S" (car pair)) + (dolist (prod (zb-rule--productions (cdr pair))) + (let ((action (production-rhs--build-fn prod))) + #+MCL (print action stream) + #-MCL (pprint action stream))))) + (values))))) + +(defun print-production (prod) + (format t "~A: ~A -> " + (production-index prod) (g-symbol-name (lhs prod))) + (dolist (x (rhs prod)) + (princ (g-symbol-name x)) (princ " "))) + +(defun print-productions () + (dolist (x (reverse *productions*)) + (print-production x) (terpri))) + +(defun print-symbols () + (dolist (sym (reverse *symbols*)) + (format t "~A: ~A~%" (g-symbol-index sym) (g-symbol-name sym))) + ) + +(defun print-own-productions (sym) + (dolist (x (g-symbol-own-productions sym)) + (print-production x) (terpri))) + +(defun print-rhs-productions (sym) + (dolist (x (g-symbol-rhs-productions sym)) + (print-production x) (terpri))) + +(defun cruise-symbols () + (dolist (sym (reverse *symbols*)) + (format t "~%~A: ~A~%" + (g-symbol-index sym) + (g-symbol-name sym)) + (when (g-symbol-own-productions sym) + (format t "Own productions:~%") + (print-own-productions sym)) + (when (g-symbol-rhs-productions sym) + (format t "RHS productions:~%") + (print-rhs-productions sym)) + (princ "----------------------------") + )) + +(defun cruise-symbols-2 () + (terpri) + (dotimes (i (length *symbol-array*)) + (let ((sym (svref *symbol-array* i))) + (format t "~S: ~S~%" + (g-symbol-index sym) + (g-symbol-name sym))))) + +(defun cruise-follow-sets () + (let (*print-circle*) + (dolist (gs *symbols*) + (when (g-symbol-non-terminal? gs) + (format t "~%~A: ~S~%--------------------" + gs + (oset-item-list (g-symbol-follow-set gs))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun print-collection (closures-too?) + (format t "~%Start state index: ~A~%" *lr0-start-state-index*) + (oset-for-each + #'(lambda (item-set) + (format t "------------------ ~A -------------------~%" + (item-set-index item-set)) + (item-set-print-kernel item-set closures-too?) + (let ((gotos (item-set-goto-map item-set))) + (when (oset-item-list gotos) + (princ "gotos: ") + (oset-for-each + #'(lambda (gmelt) + (format t "~A -> ~A " + (g-symbol-name (car gmelt)) + (item-set-index (cdr gmelt)))) + gotos) + (terpri))) + ) + *lr0-item-sets*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun item-print (item &optional (stream t) level) + ;; This only prints the lr(0) parts and the lookaheads. + (declare (ignore level)) + (let ((after-dot (item-after-dot item)) + (production (item-production item))) + (format stream "~A -> " (g-symbol-name (lhs production))) + (do ((ncdr (rhs production) (cdr ncdr)) + (i 0 (1+ i))) + ((null ncdr) + (when (= after-dot i) (princ ". ")) + (unless (oset-empty? (item-look-aheads item)) + (princ "{ " stream) + (oset-for-each + #'(lambda (gs) (format stream "~A " (g-symbol-name gs))) + (item-look-aheads item)) + (princ "}" stream))) + (format stream "~:[~;. ~]~A " + (= after-dot i) + (g-symbol-name (car ncdr)))))) + +(defun item-list-print (item-list) + (dolist (item item-list) + (terpri) + (item-print item))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun cruise-parse-tables () + (format t "Start-state is ~S" *lr0-start-state-index*) + (dotimes (i *lr0-item-set-count*) + (format t "~%~A~%actions: " i) + (oset-for-each + #'(lambda (action-elt) + (format t "~A : ~A ~A " + (get-print-name (car action-elt)) + (cadr action-elt) + (caddr action-elt))) + (svref (the vector *action-array*) i)) + (format t "~%gotos: ") + (oset-for-each + #'(lambda (goto-elt) + (format t "~A : ~A " + (get-print-name (car goto-elt)) + (cdr goto-elt)) + ) + (svref (the vector *goto-array*) i)) + (format t "~%--------------------------------------------------") + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test: +#|| + (load "zebu-loadgram") + (load-grammar "ex1.grm") + (print-symbols) + (cruise-symbols) + (cruise-symbols-2) + (print-productions) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-printers.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-regex.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-regex.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,530 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-regex.l +; Description: A Lisp based Regular Expression Compiler +; Author: Joachim H. Laubsch +; Created: 21-Sep-92 +; Modified: Mon Apr 18 13:38:26 1994 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; +; (c) Copyright 1992, Hewlett-Packard Company +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Hewlett-Packard Company +;;; makes no warranty about the software, its performance or its conformity +;;; to any specification. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +; 13-Jan-93 (Joachim H. Laubsch) +; Aletrnatives, to be indicated by \| need to be done! +; 7-Oct-92 (Joachim H. Laubsch) +; made . fail on Newline in String +; 28-Sep-92 (Joachim H. Laubsch) +; made ? work when it occured after a string (similar to the cases for +,*) +; 21-Sep-92 (Joachim H. Laubsch) +; made behavior conform more with Emacs Lisp's STRING-MATCH +; e.g. (string-match "\\(na\\)x\\1" "naxnana") matches now, +; but before (string-match "(na)x\\1" "naxnana") did. +; "\(" is the grouping construct, and since \ is the quoting character, +; it must be qoted as well, giving "\\(". +; Avoided string-copying by introducing pointers in the match group case. +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; -*- Mode:Common-Lisp; Package:ZEBU; Base:10 -*- +;;; +;;; This code was written by: +;;; +;;; Lawrence E. Freil +;;; National Science Center Foundation +;;; Augusta, Georgia 30909 +;;; +;;; If you modify this code, please comment your modifications +;;; clearly and inform the author of any improvements so they +;;; can be incorporated in future releases. +;;; +;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression +;;; parser. +;;; +;;; This regular expression parser operates by taking a +;;; regular expression and breaking it down into a list +;;; consisting of lisp expressions and flags. The list +;;; of lisp expressions is then turned into a +;;; lambda expression that can be later applied to a +;;; string argument for parsing. + + +(in-package "ZEBU") +(provide "zebu-regex") + +;;; +;;; Declare the global variables for storing the paren index list. +;;; +(declaim (special *regex-groups* *regex-groupings*)) + +;; In Gnu Emacs Lisp's regular expressions the braces: {,} are not special, +;; neither are the parens: (,), nor the alternatives char: | +;;(defvar *regex-special-chars* "?*+.()[]\\${}") +(defvar *regex-special-chars* "?*+.[]\\$") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; For debugging +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Declare some simple macros to make the code more readable. +;;; +(defvar *regex-debug* nil) ; Set to nil for no debugging code + +(defmacro info (message &rest args) + (if *regex-debug* + `(format *standard-output* ,message , at args))) + +(eval-when (compile) + (setq *regex-debug* nil)) + +;;; +;;; Declare a simple interface for testing. You probably wouldn't want +;;; to use this interface unless you were just calling this once. +;;; +#|| +(defun regex (expression string) + "Usage: (regex )" + ;; If the expression was an empty string then it always + ;; matches (so lets leave early) + (when (= ln-source 0) (return-from regex-compile '(t))) + (macrolet ((add-exp (list) + ;; Add an item to the end of expression + `(setf expression-ln (+ expression-ln (length ,list)) + expression (append expression ,list))) + (add-exp1 (item) + `(setf expression-ln (1+ expression-ln) + expression (nconc expression (list ,item))))) + + (info "Now entering regex-compile with ~S~%" source) + ;; + ;; This routine works in two parts. + ;; The first pass take the regular expression and produces a list of + ;; operators and lisp expressions for the entire regular expression. + ;; The second pass takes this list and produces the lambda expression. + (let ((expression ; holder for expressions + ;; + ;; Generate the very first expression to save the starting index + ;; so that group 0 will be the entire string matched always + ;; + (list '(setf (svref *regex-groups* 0) (list index nil)))) + (expression-ln 1) ; length of expression + (group 1) ; Current group index + (group-stack nil) ; Stack of current group endings + (result nil) ; holder for built expression. + ) + + ;; If the first character is a literal, then do a quick scan to see + ;; if it is even in the string. + ;; If not then we can issue a quick nil, + ;; otherwise we can start the search at the matching character to skip + ;; the checks of the non-matching characters anyway. + ;; + ;; If I really wanted to speed up this section of code it would be + ;; easy to recognize the case of a fairly long multi-character literal + ;; and generate a Boyer-Moore search for the entire literal. + ;; + ;; I generate the code to do a loop because on CMU Lisp this is about + ;; twice as fast a calling position. + ;; + + ;; + ;; Loop over each character in the regular expression building the + ;; expression list as we go. + ;; + (do ((eindex 0 (1+ eindex))) + ((= eindex ln-source)) + (let ((current (char source eindex))) + (info "Now processing character ~A index = ~A~%" current eindex) + (case current + (#\. + ;; + ;; Generate code for a single wild character + ;; + (add-exp1 '(if (>= index length) + (return-from compare nil) + (incf index))) + ) + (#\$ + ;; + ;; If this is the last character of the expression then + ;; anchor the end of the expression, otherwise let it slide + ;; as a standard character (even though it should be quoted). + ;; + (if (= eindex (1- ln-source)) + (add-exp1 '(if (/= index length) + (return-from compare nil))) + (add-exp1 '(if (and (< index length) + (eql (char string index) #\$)) + (incf index) + (return-from compare nil))))) + (#\* (add-exp1 'ASTERIX)) + + (#\+ (add-exp1 'PLUS)) + + (#\? (add-exp1 'QUESTION)) + + (#\[ + ;; + ;; Start of a range operation. + ;; Generate a bit-vector that has one bit per possible character + ;; and then on each character or range, set the possible bits. + ;; + ;; If the first character is carat then invert the set. + (let* ((invert (eql (char source (1+ eindex)) #\^)) + (bitstring (make-array + 256 + :element-type 'bit + :initial-element (if invert 1 0))) + (set-char (if invert 0 1))) + (if invert (incf eindex)) + (let (hi-char) + (do* ((x (1+ eindex) (1+ x)) + (char (char source x) + (if (= x ln-source) + (error "No closing \"]\" found in ~a" + source) + (char source x)))) + ((eql char #\]) (setf eindex x)) + (info "Building range with character ~A~%" (char source x)) + (if (let ((x+2 (+ x 2))) + (and (< x+2 ln-source) + (eql (char source (1+ x)) #\-) + (not (char= (setf hi-char (char source x+2)) + #\])))) + (progn + (if (char>= char hi-char) + (error "Invalid range \"~A-~A\". Ranges must be in acending order" + char hi-char)) + (do ((j (char-code char) (1+ j))) + ((> j (char-code hi-char)) + (incf x 2)) + (info "Setting bit for char ~A code ~A~%" (code-char j) j) + (setf (sbit bitstring j) set-char))) + (progn + ;; + ;; If the character is quoted then find out what + ;; it should have been + ;; + (when (char= char #\\) + (let (length) + (multiple-value-setq (char length) + (regex-quoted (subseq source (1+ x)) invert)) + (incf x length))) + (info "Setting bit for char ~C code ~A~%" + char (char-code char)) + (if (vectorp char) + (bit-ior bitstring char t) + (setf (sbit bitstring (char-code char)) + set-char)))))) + (add-exp1 `(let ((range ,bitstring)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil)))))) + (#\\ + ;; + ;; Intrepret the next character as a special, range, octal, group or + ;; just the character itself. + ;; + (multiple-value-bind (value length) + (regex-quoted (subseq source (1+ eindex)) nil) + (cond ((listp value) (add-exp value)) + ((characterp value) + (case value + (#\( + ;; + ;; Start a grouping. + ;; + (incf group) + (push group group-stack) + (add-exp1 `(setf (svref *regex-groups* ,(1- group)) + (list index nil))) + (add-exp1 group)) + (#\) + ;; + ;; End a grouping + ;; + (let ((group (pop group-stack))) + (add-exp1 `(setf (cadr (svref *regex-groups* ,(1- group))) + index)) + (add-exp1 (- group)))) + (t (add-exp1 `(if (and (< index length) + (eql (char string index) + ,value)) + (incf index) + (return-from compare nil)))))) + ((vectorp value) + (add-exp1 `(let ((range ,value)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil)))))) + (incf eindex length))) + (t + ;; + ;; We have a literal character. + ;; Scan to see how many we have and if it is more than one + ;; generate a string= verses as single eql. + ;; + (let* ((lit "") + (term (dotimes (litindex (- ln-source eindex) nil) + (let ((litchar (char source (+ eindex litindex)))) + (if (position litchar *regex-special-chars*) + (return litchar) + (progn + (info "Now adding ~A relative index ~A to lit~%" + litchar litindex) + (setf lit (concatenate 'string lit + (string litchar))))))))) + ;;(break "lit: ~S term: ~S" lit term) + (if (= (length lit) 1) + (progn + (add-exp1 `(if (and (< index length) + (eql (char string index) + ,current)) + (incf index) + (return-from compare nil)))) + ;; + ;; If we have a multi-character literal then we must + ;; check to see if the next character (if there is one) + ;; is an asterix or a plus. If so then we must not use this + ;; character in the big literal. + (progn + (when (member term '(#\* #\+ #\?)) + (setf lit (subseq lit 0 (1- (length lit))))) + (if (= (length lit) 1) + (add-exp1 `(if (and (< index length) + (eql (char string index) + ,(schar lit 0))) + (incf index) + (return-from compare nil))) + (progn + (add-exp1 `(let ((new-index (+ index ,(length lit)))) + (if (< length new-index) + (return-from compare nil)) + (if (string= string ,lit :start1 index + :end1 new-index) + (incf index ,(length lit)) + (return-from compare nil)))) + (incf eindex (1- (length lit)))))))))))) + ;; + ;; Plug end of list to return t. If we made it this far then + ;; We have matched! + (add-exp1 '(setf (cadr (svref *regex-groups* 0)) index)) + (add-exp1 '(return-from final-return t)) + ;; + ;; + ;; Now take the expression list and turn it into a lambda expression + ;; replacing the special flags with lisp code. + ;; For example: A BEGIN needs to be replaced by an expression that + ;; saves the current index, then evaluates everything till it gets to + ;; the END then save the new index if it didn't fail. + ;; On an ASTERIX I need to take the previous expression and wrap + ;; it in a do that will evaluate the expression till an error + ;; occurs and then another do that encompases the remainder of the + ;; regular expression and iterates decrementing the index by one + ;; of the matched expression sizes and then returns nil. After + ;; the last expression insert a form that returns t so that + ;; if the entire nested sub-expression succeeds then the loop + ;; is broken manually. + ;; + ;; + ;; Reversing the current expression makes building up the + ;; lambda list easier due to the nesting of expressions when + ;; an asterisk has been encountered. + (setf expression (reverse expression)) + (info "~&Regular Expression:~%(~{~s~% ~}) ;; ~d" + expression expression-ln) + + (do ((elt 0 (1+ elt))) + ((= elt expression-ln)) + (let ((piece (nth elt expression)) + (piece+1 (nth (1+ elt) expression))) + ;; + ;; Now check for PLUS, if so then ditto the expression and then let the + ;; ASTERIX below handle the rest. + ;; + ;; (princ ".") + (when (eql piece 'PLUS) + (cond ((listp piece+1) (push piece+1 result)) + ;; + ;; duplicate the entire group + ;; NOTE: This hasn't been implemented yet!! + (t (warn "~%GROUP repeat hasn't been implemented yet~%")))) + (cond ((listp piece) ; Just append the list + (push piece result)) + ((eql piece 'QUESTION) ; Wrap it in a block that won't fail + (cond ((listp piece+1) + (push `(progn (block compare ,piece+1) + t) + result) + (incf elt)) + ;; + ;; This is a QUESTION on an entire group which + ;; hasn't been implemented yet!!! + ;; + (t + (warn "~%Optional groups not implemented yet~%")))) + ((or (eql piece 'ASTERIX) ; Do the wild thing! + (eql piece 'PLUS)) + (when (listp piece+1) + ;; + ;; This is a single character wild card so + ;; do the simple form. + ;; + (setf result + `((let ((oindex index)) + (block compare + (do nil (nil) ,piece+1)) + (do ((start index (1- start))) + ((< start oindex) nil) + (let ((index start)) + (block compare + , at result)))))) + (incf elt)))))) ; Just ignore everything else. + + (info "~&Result:~s" result) + ;; + ;; Now wrap the result in a lambda list that can then be + ;; invoked or compiled, however the user wishes. + ;; + (setf result + `((setf *regex-groupings* ,group) + (block final-return + (block compare + (let ((index start) + (length end)) + , at result)))))))) + + +;;; +;;; Define a function that will take a quoted character and return +;;; what the real character should be plus how much of the source +;;; string was used. If the result is a set of characters, return an +;;; array of bits indicating which characters should be set. If the +;;; expression is one of the sub-group matches, return a +;;; list-expression that will provide the match. +;;; + +(defun regex-quoted (char-string &optional (invert nil)) + "Usage: (regex-quoted &optional invert) + Returns either the quoted character or a simple bit vector of bits set for + the matching values" + (let ((first (char char-string 0)) + (used-length 1) + result) + (setf result + (case first + (#\n #\NewLine) + (#\c #\Return) + (#\t #\Tab) + (#\d #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000) + (#\D #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111) + (#\w #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000) + (#\W #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111) + (#\b #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000) + (#\B #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111) + (#\s #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000) + (#\S #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111) + (t (if (and (char>= first #\0) (char<= first #\9)) + (if (and (> (length char-string) 2) + (and (char>= (char char-string 1) #\0) + (char<= (char char-string 1) #\9) + (char>= (char char-string 2) #\0) + (char<= (char char-string 2) #\9))) + ;; + ;; It is a single character specified in octal + ;; + (parse-integer char-string + :end (setf used-length 3) + :radix 8 :junk-allowed t) + + ;; + ;; We have a group number replacement. + ;; + (let ((group (- (char-code first) (char-code #\0)))) + `((let* ((range (svref *regex-groups* ,group)) + (start-old (car (the cons range))) + (end-old (cadr (the cons range))) + (ln-nstring (- end-old start-old)) + (new-index (+ index ln-nstring))) + (if (< length new-index) + (return-from compare nil)) + (if (string= string string + :start1 start-old + :end1 end-old + :start2 index + :end2 new-index) + (setq index new-index) + (return-from compare nil)))))) + first)))) + (if (and (vectorp result) invert) + (bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t)) + (values result used-length))) + +#|| +(defun match-beginning (n) + (first (SVREF *REGEX-GROUPS* n))) + +(defun match-end (n) + (second (SVREF *REGEX-GROUPS* n))) +||# + +(defun def-regex-parser (name pattern) + (when (and (eql (symbol-package name) (find-package "LISP")) + (fboundp name)) + (error "A lexical category should not name a Lisp function: ~s" + name)) + (let* ((body (regex-compile pattern))) + `(defun ,name (STRING &optional (START 0) (END (length STRING))) + ,@(when *regex-debug* + '((info "~%Looking at: ~S..." + (subseq string START (min (+ 10 START) END))))) + (when (progn .,body) + (second (SVREF *REGEX-GROUPS* 0)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-regex.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-rr.asd ============================================================================== --- (empty file) +++ vendor/zebu/zebu-rr.asd Wed Oct 17 09:04:46 2007 @@ -0,0 +1,14 @@ +;;; -*- Lisp -*- + +(in-package #:asdf) + +(defsystem #:zebu-rr + :version "3.5.5" + :depends-on ("zebu") + :components + ((:file "zebu-kb-domain") + (:file "zebu-tree-attributes" + :in-order-to ((compile-op (load-op "zebu-kb-domain")))) + (:file "zebra-debug" + :in-order-to ((compile-op (load-op "zebu-kb-domain" + "zebu-tree-attributes")))))) Added: vendor/zebu/zebu-rr.system ============================================================================== --- (empty file) +++ vendor/zebu/zebu-rr.system Wed Oct 17 09:04:46 2007 @@ -0,0 +1,21 @@ +;;; -*- Lisp -*- + +;;;(in-package "CL-USER") + +(mk:defsystem "zebu-rr" + :source-pathname "/users/students/rschlatt/lisp/zebu-3.5.5/" + :binary-pathname "/users/students/rschlatt/lisp/zebu-3.5.5/binary/" + ;;:package "ZEBU" + ;; Are the dependencies correct? + :depends-on ("zebu") + :components + ((:file "zebu-kb-domain") + (:file "zebu-tree-attributes" + :depends-on ("zebu-kb-domain")) + (:file "zebra-debug" + :depends-on ("zebu-kb-domain" "zebu-tree-attributes")))) + + + + + Added: vendor/zebu/zebu-slr.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-slr.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,52 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-slr.l +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 1-Nov-90 +; Modified: Fri Mar 8 14:46:41 1996 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. + +;;; +;;; Do all needed to build an slr table starting with a lisp syntax grammar. +(in-package "ZEBU") + +(defun slr-tables-from-grammar (file-name &rest args) + (apply #'load-grammar file-name args) + (calculate-empty-string-derivers) + (calculate-first-sets) + (calculate-follow-sets) + (make-lr0-collection) + (build-parse-tables nil) + file-name) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; test: + +#|| +(slr-tables-from-grammar "ex1.zb") +(format t "symbols: ~%") +(cruise-symbols-2) +(format t "productions: ~%") +(print-productions) +(format t "lr0 item sets: ~%") +(print-collection nil) +(format t "slr tables: ~%") +(cruise-parse-tables) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-slr.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-tables.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-tables.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,125 @@ +; -*- mode: CL -*- ------------------------------------------------- ; +; File: zebu-tables.l +; Description: Conversion to CL of the original Scheme program by (W M Wells) +; Author: Joachim H. Laubsch +; Created: 31-Oct-90 +; Modified: Mon Apr 11 14:11:29 1994 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Revisions: +; RCS $Log: $ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1989, by William M. Wells III +;;; All Rights Reserved +;;; Permission is granted for unrestricted non-commercial use. +(in-package "ZEBU") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; On the representation of parsing tables: +;;; +;;; Action function is an array, indexed by the state number, +;;; of functions of grammar symbols represented as osets of +;;; 3 element lists containing a g-symbol index, the character +;;; s, r, or a for shift reduce or accept, and an integer encoding the +;;; next state, or production index as appropriate. +;;; +;;; Goto for non-terminals will be represented by a parallel array +;;; of osets of pairs whose cars are g-symbol indices, and whose +;;; cdrs are state indices. + +(defvar *action-array*) +(defvar *goto-array*) +(declaim (type vector *action-array* *goto-array*)) + +;;; An oset order function for parse table entries. +(defun integer-function-order-function (a b) + (integer-order-function (car (the cons a)) (car (the cons b)))) + +;;; Build the description of the state machine which is the lr-parser. +;;; The *lr0-item-sets* correspond to the states of the parser machine. + +(defun build-parse-tables (doing-lalr1) + (setf *action-array* (make-sequence 'vector *lr0-item-set-count*)) + (setf *goto-array* (make-sequence 'vector *lr0-item-set-count*)) + (dotimes (i *lr0-item-set-count*) + (setf (svref (the vector *action-array*) i) + (make-oset :order-fn #'integer-function-order-function)) + (setf (svref (the vector *goto-array*) i) + (make-oset :order-fn #'integer-function-order-function))) + (oset-for-each + #'(lambda (item-set) + (oset-for-each + #'(lambda (goto-elt) + ;; Car of goto-elt is g-sym, cdr is item-set. + (if (g-symbol-non-terminal? (car goto-elt)) + (oset-insert! (cons (g-symbol-index (car goto-elt)) + (item-set-index (cdr goto-elt))) + (svref (the vector *goto-array*) + (item-set-index item-set))) + (parse-table-insert! (g-symbol-index (car goto-elt)) + :s + (item-set-index (cdr goto-elt)) + item-set))) + (item-set-goto-map item-set)) + (oset-for-each + #'(lambda (closure-item) + ;; Could these be kernel items? + (if (dot-at-right-end? closure-item) + (let* ((closure-item-production (item-production closure-item)) + (lhs-closure-item-production (lhs closure-item-production))) + (if (eq *augmented-start-g-symbol* lhs-closure-item-production) + (parse-table-insert! (g-symbol-index *the-end-g-symbol*) + :a 0 item-set) ; accept, bogus 0 + (oset-for-each + #'(lambda (gs) + (parse-table-insert! + (g-symbol-index gs) + :r + (production-index closure-item-production) + item-set)) + ;; Here is the only difference between slr and lalr1 + ;; (in the table construction phase). + (if doing-lalr1 + (item-look-aheads closure-item) + (g-symbol-follow-set lhs-closure-item-production))))))) + (item-set-get-closure! item-set)) + ) + *lr0-item-sets*)) + + +;;; An auxillary function for adding an entry to a parse table. +;;; A simple feature allows the system to be used with some +;;; ambiguous grammars: if the variable *allow-conflicts* it true, +;;; then when a conflict arises at table construction time, simply +;;; prefer the action which is already in the tables. +;;; This feature works for the "dangling else" problem. + +(defvar *allow-conflicts* t) +(declaim (special *warn-conflicts*)) + +(defun parse-table-insert! (g-sym-index action-key index item-set) + (let ((to-insert (list g-sym-index action-key index))) + (multiple-value-bind (inserted? the-item) + (oset-insert-2! to-insert + (svref *action-array* (item-set-index item-set))) + (unless inserted? + (when *warn-conflicts* + (warn "ACTION CONFLICT!!!-- state: ~S~%old entry: ~S new entry: ~S~%~ + Continuing to build tables despite conflicts.~%~ + Will prefer old entry: ~S" + (item-set-index item-set) the-item to-insert the-item)) + (unless *allow-conflicts* (error "ACTION CONFLICT")))))) + +(declaim (inline get-print-name)) +(defun get-print-name (index) + (g-symbol-name (svref (the vector *symbol-array*) index))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-tables.l +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu-tree-attributes.lisp ============================================================================== --- (empty file) +++ vendor/zebu/zebu-tree-attributes.lisp Wed Oct 17 09:04:46 2007 @@ -0,0 +1,836 @@ +; -*- mode: CL -*- ----------------------------------------------------- ; +; File: zebu-tree-attributes.lisp +; Description: Functions operating on abstract syntax trees +; Author: Joachim H. Laubsch +; Created: 26-Feb-93 +; Modified: Wed Oct 12 21:26:14 1994 (Joachim H. Laubsch) +; Language: CL +; Package: ZEBU +; Status: Experimental (Do Not Distribute) +; RCS $Header: $ +; +; (c) Copyright 1990, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "ZEBU") +(require "zebu-kb-domain") +(require "zebu-mg-hierarchy") +(provide "zebu-tree-attributes") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; tree attributes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Plist implementation + +(declaim (inline KB-TREE-ATTRIBUTES)) +(defun KB-tree-attributes (class-name) + (get (the symbol class-name) 'KB-TREE-ATTRIBUTES)) +;----------------------------------------------------------------------------; +; define-tree-attributes +;----------------------- +; for each class enter the tree attributes in the form: +; (( ...) . ( ...)) +; where is the name of the accessor for slot i +; is a compiled function to set slot i + +(defun define-tree-attributes (class slots) + (let (writers) + (dolist (slot slots) + (let ((def `(lambda (x y) + (declare (type ,class x)) + (setf (,slot x) y)))) + (push + (compile nil def) + writers))) + (setf (get (the symbol class) 'KB-TREE-ATTRIBUTES) + (cons slots (nreverse writers))) )) + +;; The reason for this macro is that then the compiler does +;; not need to be loaded when a file is loaded which contains +;; def-tree-attributes forms +#|| +(defmacro def-tree-attributes (class &rest slots) + (check-type class symbol) + (let (writers setters) + (dolist (slot slots) + (check-type slot symbol) + (let* ((setter (intern (format nil "SET-~a" slot))) + (def `(defun ,setter (x y) + (declare (type ,class x)) + (setf (,slot x) y)))) + (push def writers) + (push setter setters))) + `(progn + , at writers + (setf (get ',class 'KB-TREE-ATTRIBUTES) + (cons + ',slots + (mapcar #'(lambda (setter) (symbol-function setter)) + ',(nreverse setters))))))) + +;; avoid duplicate definitions +(defmacro def-tree-attributes (class &rest slots) + (check-type class symbol) + (let (writers setters) + (dolist (slot slots) + (check-type slot symbol) + (let ((setter (intern (format nil "SET-~a" slot)))) + (unless (fboundp setter) + (push `(defun ,setter (x y) + (declare (type ,class x)) + (setf (,slot x) y)) + writers)) + (push setter setters))) + `(progn + (eval-when (compile eval) , at writers) + (setf (get ',class 'KB-TREE-ATTRIBUTES) + (cons + ',slots + (mapcar #'(lambda (setter) + (symbol-function setter)) + ',(nreverse setters))))))) + +||# + +(defmacro def-tree-attributes (class &rest slots) + (check-type class symbol) + (flet ((wrong-slotdescr (d) + (error "Tree attribute ~s not a symbol~%or of the form ( :set)" + d))) + (let (writers setters set-valued-slots) + (dolist (slotdescr slots) + (let (slot setter) + (typecase slotdescr + (symbol (setf slot slotdescr)) + (cons (setf slot (first slotdescr)) + (push slotdescr set-valued-slots)) + (t (wrong-slotdescr slotdescr))) + (setf setter (intern (format nil "SET-~a" slot))) + (unless (fboundp setter) + (push `(defun ,setter (x y) + (declare (type ,class x)) + (setf (,slot x) y)) + writers)) + (push setter setters))) + `(progn + (eval-when (compile eval #+CLISP load) , at writers) + ,@(mapcar #'(lambda (set-valued-slot) + (let ((type (second set-valued-slot))) + (if (eq type :set) + `(zb::KB-def-slot-type + ',(first set-valued-slot) :set) + (wrong-slotdescr set-valued-slot)))) + set-valued-slots) + (setf (get ',class 'KB-TREE-ATTRIBUTES) + (cons + ',slots + (list . ,(mapcar #'(lambda (setter) `(function ,setter)) + (nreverse setters))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Hashtable implementation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#|| +(defvar *KB-TREE-ATTRIBUTES* (make-hash-table)) +(declaim (type HASH-TABLE *KB-TREE-ATTRIBUTES*)) + +(declaim (inline KB-TREE-ATTRIBUTES)) +(defun KB-TREE-ATTRIBUTES (class-name) + (gethash class-name *KB-TREE-ATTRIBUTES*)) + +;----------------------------------------------------------------------------; +; define-tree-attributes +;----------------------- +; for each class enter the tree attributes in the form: +; (( ...) . ( ...)) +; where is the name of the accessor for slot i +; is a compiled function to set slot i + +(declaim (inline KB-TREE-ATTRIBUTES)) +(defun define-tree-attributes (class slots) + (let (writers) + (dolist (slot slots) + (let ((def `(lambda (x y) + (declare (type ,class x)) + (setf (,slot x) y)))) + (push + (compile nil def) + writers))) + (setf (gethash class *KB-TREE-ATTRIBUTES*) + (cons slots (nreverse writers))) )) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Set/Sequence Valued Slots +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *KB-SLOT-types* (make-hash-table)) +(declaim (type HASH-TABLE *KB-SLOT-types*)) + +(declaim (inline KB-set-valued-slot-p)) +(defun KB-set-valued-slot-p (reader) + (eq (gethash reader *KB-SLOT-types*) ':set)) + +(defun KB-def-slot-type (reader type) + (setf (gethash reader *KB-SLOT-types*) type)) + +;----------------------------------------------------------------------------; +; kids +;----- +; collect all the kids of OBJECT which are in KB-Domain. +; if a kid is a SET or SEQUENCE of subnodes, include those which are +; in KB-Domain. + +(defun kids (object &aux R) + (declare (inline KB-TREE-ATTRIBUTES)) + (macrolet ((readers (x) `(the list (car (the cons ,x))))) + (let ((ta (KB-tree-attributes (type-of object)))) + (when ta + (dolist (reader (readers ta) R) + (declare (symbol reader)) + (let ((kids (funcall (the function (symbol-function reader)) object))) + (cond ((consp kids) + (dolist (k (the list kids)) + (when (KB-Domain-p k) (push k R)))) + ((KB-Domain-p kids) + (push kids R)))))))) + ) + +;-----------------------------------------------------------------------------; +; subexpressions +;--------------- +; +; All immediate subexpressions of a KB-Domain-element +; anything not of type KB-Domain-element does not have components + +(declaim (inline subexpressions)) +(defun subexpressions (KB-Domain-element) + (check-type KB-Domain-element KB-Domain) + (kids KB-Domain-element)) + +;----------------------------------------------------------------------------; +; for-each-kid +;------------- +; iterate over all kids of NODE which are in KB-Domain, calling FUN. +; NODE must be of type KB-Domain. +; Returns nil + +(defun for-each-kid (FUN NODE) + (declare (type function fun)) + (macrolet ((readers (x) `(the list (car (the cons ,x))))) + (if (KB-Domain-p NODE) ; (subtypep typ 'KB-Domain) + (let ((ta (KB-tree-attributes (type-of node)))) + (when ta + (dolist (reader (readers ta)) + (declare (symbol reader)) + (let ((subnode (funcall (the function (symbol-function reader)) NODE))) + (cond + ((CONSp subnode) ; value is a set or sequence + (dolist (kid (the list subnode)) + (when (KB-Domain-p kid) (funcall FUN kid)))) + ((KB-Domain-p subnode) (funcall fun subnode))))))) + (error "Can't iterate over non KB-Domain object: ~S" NODE)))) + +(defun for-each-kid! (FUN NODE) + ;; just like for-each-kid, but if FUN(kid) ~eq kid then replace kid + ;; by the value of FUN(kid) + ;; returns NODE + (declare (type function fun)) + (declare (inline KB-TREE-ATTRIBUTES)) + (if (KB-Domain-p NODE) ; (subtypep typ 'KB-Domain) + (macrolet ((readers (x) `(the list (car (the cons ,x)))) + (writers (x) `(the list (cdr (the cons ,x))))) + (let ((ta (KB-tree-attributes (type-of node)))) + (if (null ta) + NODE + ;; ta (( ...) ( ...)) + (do ((r (readers ta) (cdr r)) (w (writers ta) (cdr w))) + ((null r) NODE) + (let* ((reader (car (the cons r))) + (subnode (funcall (the function (symbol-function reader)) + NODE))) + (cond + ((CONSp subnode) ; value is a set or sequence + (do ((kids (the list subnode) (cdr kids))) + ((null kids)) + (let ((kid (car (the cons kids)))) + (if (KB-Domain-p kid) + (let ((newval (funcall FUN kid))) + (unless (eq kid newval) + (setf (car kids) newval))))))) + ((KB-Domain-p subnode) + (let ((vv (funcall fun subnode))) + (unless (eq vv subnode) + ;; (eval `(setf (,reader ,NODE) ',vv)) + (funcall (the compiled-function (car w)) NODE vv)))))))))) + (error "Can't iterate over non KB-Domain object: ~S" NODE))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; preorder-transform +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#|| +(defun preorder-transform (node funs) + (check-type node KB-Domain) + (check-type funs list) + (macrolet ((readers (x) `(the list (car (the cons ,x)))) + (writers (x) `(the list (cdr (the cons ,x)))) + (mung-node (n) `(preorder-transform-aux (transform-node ,n)))) + (labels ((preorder-transform-aux (n) + (let ((ta (KB-tree-attributes (type-of n)))) + (when (null ta) + (return-from preorder-transform-aux n)) + (do ((r (readers ta) (cdr r)) (w (writers ta) (cdr w))) + ((null r) n) + (let* ((reader (car (the cons r))) + (subnode (funcall (the function (symbol-function reader)) + n))) + (cond ((CONSp subnode) ; value is a set or sequence + (do ((kids (the list subnode) (cdr kids))) + ((null kids)) + (let ((kid (car (the cons kids)))) + (when (KB-Domain-p kid) + (let ((newval (mung-node kid))) + (unless (eq kid newval) + (setf (car (the cons kids)) newval))))))) + ((KB-Domain-p subnode) + (let ((subnode1 (mung-node subnode))) + (unless (eq subnode1 subnode) + (funcall (car (the cons w)) n subnode1))))))))) + (transform-node (n) + (let (fun-fired?) + (do ((funRest (the list funs)) + (oldn (KB-copy n) (KB-copy n))) + ((null funRest) n) + (let ((fun (car funRest))) + ;; run each function to acquiescence + ;; each function returns 2 values, + ;; (1) the new node + ;; (2) whether there was a change in this node + ;; that may make it necessary for this function to run + ;; again on the same node + ;; if a function had an effect --- fun-fired? = T --- + ;; we start all over with all functions (except the current) + (loop do (multiple-value-bind (v change?) + (funcall (the Function fun) n) + (if change? + (setq n v) + (if (eq n v) + (return n) + (setq n v))) + (format t "~%;; ~S~%;; ~S~%;; --> ~S" fun oldn v) + (setq fun-fired? t))) + (if fun-fired? + (setq funRest (remove fun funs) + fun-fired? nil) + (pop funRest))))))) + (mung-node node)))) +||# +(defun preorder-transform (node funs) + (declare (inline KB-TREE-ATTRIBUTES)) + (check-type node KB-Domain) (check-type funs list) + (macrolet ((readers (x) `(the list (car (the cons ,x)))) + (writers (x) `(the list (cdr (the cons ,x)))) + (mung-node (n) `(preorder-transform-aux (transform-node ,n)))) + (flet ((transform-node (n) + (let (fun-fired?) + (do ((funRest (the list funs))) + ((null funRest) n) + (let ((fun (car funRest))) + ;; run each function to acquiescence + ;; each function returns 2 values, + ;; (1) the new node + ;; (2) whether there was a change in this node + ;; that may make it necessary for this function to run + ;; again on the same node + ;; if a function had an effect --- fun-fired? = T --- + ;; we start all over with all functions (except the current) + (loop (multiple-value-bind (v change?) + (funcall (the Function fun) n) + (if change? + (setq n v) + (if (eq n v) + (return n) + (setq n v))) + ;; (format t "~%;; ~S~%;; ~S~%;; --> ~S" fun oldn v) + (setq fun-fired? t))) + (if fun-fired? + (setq funRest (remove fun funs) + fun-fired? nil) + (pop funRest))))))) + (labels ((preorder-transform-aux (n) + (let ((ta (KB-tree-attributes (type-of n)))) + (if (null ta) + n + (do ((r (readers ta) (cdr r)) + (w (writers ta) (cdr w))) + ((null r) n) + (let* ((reader (car (the cons r))) + (subnode (funcall + (the function + (symbol-function reader)) + n))) + (cond ((CONSp subnode) ; value is a set or sequence + (do ((kids (the list subnode) (cdr kids))) + ((null kids)) + (let ((kid (car (the cons kids)))) + (when (KB-Domain-p kid) + (let ((newval (mung-node kid))) + (unless (eq kid newval) + (setf (car (the cons kids)) newval))))))) + ((KB-Domain-p subnode) + (let ((subnode1 (mung-node subnode))) + (unless (eq subnode1 subnode) + (funcall (car (the cons w)) + n subnode1))))))))))) + (mung-node node))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; postorder-transform +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; just like preorder, but descend down first to the leaves, and then +;; transform from bottom-up +(defun postorder-transform (node funs &optional (exhaustive nil)) + (declare (inline KB-TREE-ATTRIBUTES)) + (check-type node KB-Domain) (check-type funs list) + (macrolet ((readers (x) `(the list (car (the cons ,x)))) + (writers (x) `(the list (cdr (the cons ,x)))) + ;; here is the difference to preorder: recurse first! + (mung-node (n) + `(transform-node (postorder-transform-aux ,n)))) + (flet ((transform-node (n) + (block transform-node + ;; (format t "~%transform-node: ~S" n) + (do ((funRest (the list funs)) rule-fired?) + ((null funRest) n) + (let ((fun (car funRest))) + ;; run each function to acquiescence + ;; each function returns 2 values, + ;; (1) the new node + ;; (2) whether there was a change in this node + ;; that may make it necessary for this function to run + ;; again on the same node + ;; if a function had an effect --- fun-fired? = T --- + ;; we start all over at the leaves + (loop (multiple-value-bind (v change?) + (funcall (the Function fun) n) + (if change? + (setq n v) + (if (eq n v) + (return nil) + (setq n v))) + (if exhaustive + (return-from transform-node + (values n t)) + (setq rule-fired? t)))) + (if rule-fired? + (setq funRest (remove fun funs) + rule-fired? nil) + (pop funRest))))))) + (labels ((postorder-transform-aux (n) + (let ((ta (KB-tree-attributes (type-of n)))) + (if (null ta) + n + ;; (format t "~%postorder-transform: ~S" n) + (do ((r (readers ta) (cdr r)) (w (writers ta) (cdr w))) + ((null r) n) + (let* ((reader (car (the cons r))) + (subnode (funcall (the function + (symbol-function reader)) + n))) + (cond ((CONSp subnode) ; value is a set or sequence + (do ((kids (the list subnode) (cdr kids))) + ((null kids)) + (let ((kid (car (the cons kids)))) + (when (KB-Domain-p kid) + (loop + (multiple-value-bind (newval rule-fired?) + (mung-node kid) + (if (eq kid newval) + (if rule-fired? + (if exhaustive + nil ; go on + (return nil)) + (return nil)) + (progn + (setf (car (the cons kids)) newval) + (setf kid newval) + (if exhaustive + nil ; go on + (return nil)))))))))) + ((KB-Domain-p subnode) + (loop + (multiple-value-bind (subnode1 rule-fired?) + (mung-node subnode) + (if (eq subnode1 subnode) + (if rule-fired? + (if exhaustive + nil ; go on + (return nil)) + (return nil)) + (progn + (funcall (car (the cons w)) n subnode1) + (setf subnode subnode1) + (if exhaustive + nil ; go on + (return nil)))))))))))))) + (loop (multiple-value-bind (new rule-fired?) + (mung-node node) + (if exhaustive + (if (or rule-fired? (not (eq new node))) + (setq node new) + (return new)) + (return new)))))))) + +#|| +(defun descendants (object) + (let ((R (list object))) + (dolist (kid (kids object) R) + (nconc R (descendants kid))))) +||# +;; more efficiently: + +;----------------------------------------------------------------------------; +; descendants +;------------ +; + +(defun descendants (object &aux R) + (declare (inline KB-TREE-ATTRIBUTES)) + (check-type object KB-Domain) + (macrolet ((readers (x) `(the list (car (the cons ,x))))) + (labels ((descendants-aux (object) + (let ((ta (KB-tree-attributes (type-of object)))) + (when ta + (dolist (reader (readers ta)) + (declare (symbol reader)) + (let ((kids (funcall (the function (symbol-function reader)) + object))) + (cond ((consp kids) + (dolist (k (the list kids)) + (push k R) + (descendants-aux k))) + ((KB-Domain-p kids) + (push kids R) + (descendants-aux kids))))))))) + (descendants-aux object) + (nreverse (cons object R))))) + +;----------------------------------------------------------------------------; +; for-each-descendant +;-------------------- +; like for-each-kid +; Returns nil + +(defun for-each-descendant (fn object) + (declare (type function fn)) + (check-type object KB-Domain) + (macrolet ((readers (x) `(the list (car (the cons ,x))))) + (labels ((descendants-aux (object) + (let ((ta (KB-tree-attributes (type-of object)))) + (when ta + (dolist (reader (readers ta)) + (declare (symbol reader)) + (let ((kids (funcall (the function (symbol-function reader)) + object))) + (cond ((consp kids) + (dolist (k (the list kids)) + (funcall fn k) + (descendants-aux k))) + ((KB-Domain-p kids) + (funcall fn kids) + (descendants-aux kids))))))))) + (funcall fn object) + (descendants-aux object)))) + +;----------------------------------------------------------------------------; +; KB-copy +;-------- +; A copy function that walks down all the tree-attributes and copies +; unless called with :recursive-p Nil + +#+LUCID +(defmacro %copy-structure (x) + `(SYSTEM:copy-structure ,x)) + +#-LUCID +(defun %copy-structure (term) + (let* ((ttype (type-of term)) + (copy-fn (find-symbol (concatenate + 'string "COPY-" (symbol-name ttype)) + (symbol-package ttype)))) + (if (fboundp copy-fn) + (funcall copy-fn term) + (error "No COPY function defined for ~s:~a" term ttype)))) + +(defun KB-copy (term &optional (recursive-p t)) + (declare (inline KB-TREE-ATTRIBUTES)) + (macrolet ((readers (x) `(the list (car (the cons ,x)))) + (writers (x) `(the list (cdr (the cons ,x))))) + (labels ((KB-copy-aux (term) + (declare (type KB-Domain term)) + (let ((new-term (%COPY-STRUCTURE term)) + (ta (KB-tree-attributes (type-of term)))) + (if (null ta) + new-term + (do ((r (readers ta) (cdr r)) (w (writers ta) (cdr w))) + ((null r) new-term) + (let* ((reader (car (the cons r))) + (writer (car (the cons w))) + (subnode (funcall (the function + (symbol-function + (the symbol reader))) + new-term))) + (cond ((CONSp subnode) ; value is a set or sequence + (let ((newsubnode + (copy-list (the list subnode)))) + (funcall (the compiled-function writer) + new-term newsubnode) + (do ((nrest newsubnode (cdr nrest))) + ((null nrest)) + (let ((kid (car (the cons nrest)))) + (when (KB-Domain-p kid) + (setf (car (the cons nrest)) + (KB-copy-aux kid))))))) + ((KB-Domain-p subnode) + (funcall (the compiled-function writer) + new-term + (KB-copy-aux subnode)))))))))) + (if recursive-p + (KB-copy-aux term) + (%COPY-STRUCTURE term))))) + +#|| +;; test +(setq $a (eval (READ-PARSER "walk(agt : John ) "))) +(setq $aa (KB-copy $a)) +;; +(car (KB-tree-attributes (type-of $a))) +;; (ATOMIC-WFF--PREDICATE ATOMIC-WFF--ROLE-ARGUMENT-PAIRS) +(eq (ATOMIC-WFF--PREDICATE $a) (ATOMIC-WFF--PREDICATE $aa)) ; NIL +(equal (ATOMIC-WFF--PREDICATE $a) (ATOMIC-WFF--PREDICATE $aa)) ; Nil +(kb-equal (ATOMIC-WFF--PREDICATE $a) (ATOMIC-WFF--PREDICATE $aa)) ; T +;; note: equalp does recursive descent on structures +(equalp (ATOMIC-WFF--PREDICATE $a) (ATOMIC-WFF--PREDICATE $aa)) ; T + +(setq $b (eval (READ-PARSER "and{walk(agent: John) talk(agent: John)}"))) +(type-of $b) +(car (KB-tree-attributes (type-of $b))) +(setq $bb (KB-copy $b)) + +||# + +;----------------------------------------------------------------------------; +; KB-equalp +;---------- +; compares 2 objects of the KB-domain for equality. (something like term-equal?) +; considers only tree-attributes as relevant +; This is easier to extend for set-valued slots: + +(defun KB-equal (a b) + (declare (inline KB-TREE-ATTRIBUTES)) + (check-type a KB-domain) + (check-type b KB-domain) + ;; ignores implementation of constants + (macrolet ((readers (x) `(the list (car (the cons ,x))))) + (labels + ((KB-equal-aux (a b) + (block KB-equal-aux + (let ((a-typ (type-of a)) (b-typ (type-of b))) + (unless (equal a-typ b-typ) (return-from KB-equal-aux 'Nil)) + (let ((ta (KB-tree-attributes a-typ))) + (or + (null ta) + (dolist (reader (readers ta) t) + (declare (symbol reader)) + (let* ((reader-fn (symbol-function reader)) + (a-subnode (funcall reader-fn a)) + (b-subnode (funcall reader-fn b))) + (unless (eq a-subnode b-subnode) + (unless (equal (type-of a-subnode) (type-of b-subnode)) + (return-from KB-equal-aux 'Nil)) + (cond + ((CONSp a-subnode) ; value is a set or sequence + (if (= (the fixnum (length (the list a-subnode))) + (the fixnum (length (the list b-subnode)))) + (if (KB-set-valued-slot-p reader) + ;; We have 2 sets to compare + ;; resort to this to avoid consing, see + ;; comment below: + (unless + (and (dolist (bb (the list b-subnode) t) + (unless (dolist (aa (the list a-subnode)) + (when (KB-equal-aux aa bb) + (return t))) + (return nil))) + (dolist (aa (the list a-subnode) t) + (unless (dolist (bb (the list b-subnode)) + (when (KB-equal-aux aa bb) + (return t))) + (return nil)))) + (return-from KB-equal-aux 'Nil)) + ;; We have two sequences to compare + ;; Their elements must be in KB-domain + (do ((arest a-subnode (cdr arest)) + (brest b-subnode (cdr brest))) + ((atom arest) (eq arest brest)) + (let ((aa (car (the cons arest))) + (bb (car (the cons brest)))) + (unless (KB-equal-aux aa bb) + (return-from KB-equal-aux 'Nil))))) + (return-from KB-equal-aux 'Nil))) + ((KB-domain-p a-subnode) + (unless (KB-equal-aux a-subnode b-subnode) + (return-from KB-equal-aux 'Nil))) + ((symbolp a-subnode) + (unless (string-equal (symbol-name a-subnode) + (symbol-name b-subnode)) + (return-from KB-equal-aux 'Nil))) + (T (unless (equal a-subnode b-subnode) + (return-from KB-equal-aux 'Nil))))))))))))) + (or (equal a b) + (KB-equal-aux a b))))) + +#|| +(KB-equal (read-nll "DESKTOP-OBJECT(NAME: 'Orders--STR')") + (read-nll "DESKTOP-OBJECT(NAME: Orders--STR)")) +(KB-equal (read-nll "WORK(agent:+{'ABRAMS','BROWNE'})") + (read-nll "WORK(agent:+{ABRAMS,BROWNE})")) +(compile 'KB-equalp) +||# +;----------------------------------------------------------------------------; +; KB-compare +;----------- +;; the following is useful for testing + +(defun KB-compare (a b &optional verbose + &aux (msg "~% KB-compare ~S:~S ~% = ~S:~S")) + (declare (inline KB-TREE-ATTRIBUTES)) + (check-type a KB-domain) + (check-type b KB-domain) + (macrolet ((readers (x) `(the list (car (the cons ,x))))) + (labels + ((KB-equal-aux (a b) + (block KB-equal-aux + (let ((a-typ (type-of a)) (b-typ (type-of b))) + (unless (equal a-typ b-typ) + (when verbose (format t msg a a-typ b b-typ)) + (return-from KB-equal-aux 'Nil)) + (if (typep a 'KB-domain) + (let ((ta (KB-tree-attributes a-typ))) + (or + (null ta) + (dolist (reader (readers ta) t) + (declare (symbol reader)) + (let* ((reader-fn (symbol-function reader)) + (a-subnode (funcall reader-fn a)) + (b-subnode (funcall reader-fn b))) + (when verbose + (format t msg + a-subnode (type-of a-subnode) + b-subnode (type-of b-subnode))) + (unless (eq a-subnode b-subnode) + (unless (equal (type-of a-subnode) (type-of b-subnode)) + (return-from KB-equal-aux 'Nil)) + (cond + ((CONSp a-subnode) ; value is a set or sequence + (if (= (the fixnum (length (the list a-subnode))) + (the fixnum (length (the list b-subnode)))) + (if (KB-set-valued-slot-p reader) + ;; We have 2 sets to compare + ;; resort to this to avoid consing, see + ;; comment below: + (unless + (and (dolist (bb (the list b-subnode) t) + (unless (dolist (aa (the list a-subnode)) + (when (KB-equal-aux aa bb) + (return t))) + (return nil))) + (dolist (aa (the list a-subnode) t) + (unless (dolist (bb (the list b-subnode)) + (when (KB-equal-aux aa bb) + (return t))) + (return nil)))) + (return-from KB-equal-aux 'Nil)) + ;; We have two sequences to compare + ;; Their elements must be in KB-domain + (do ((arest a-subnode (cdr arest)) + (brest b-subnode (cdr brest))) + ((atom arest) (eq arest brest)) + (let ((aa (car (the cons arest))) + (bb (car (the cons brest)))) + (or (equal aa bb) + (KB-equal-aux aa bb) + (return-from KB-equal-aux 'Nil))))) + (return-from KB-equal-aux 'Nil))) + ((KB-domain-p a-subnode) + (unless (KB-equal-aux a-subnode b-subnode) + (return-from KB-equal-aux 'Nil))) + ((symbolp a-subnode) + (unless (string= (symbol-name a-subnode) + (symbol-name b-subnode)) + (return-from KB-equal-aux 'Nil))) + (T (unless (equal a-subnode b-subnode) + (return-from KB-equal-aux 'Nil))))))))) + (equal a b)))))) + (or (eq a b) + (KB-equal-aux a b))))) + +#|| test +(KB-equal (make-Placeholder-Var :-Name 'u486) + (make-Placeholder-Var :-Name 'subject-nl-semantics)) +||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; tree-attributes for kb-sequence +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(def-tree-attributes kb-sequence + kb-sequence-first kb-sequence-rest) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Generate (define-tree-attributes ..) for zebu +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Das nachfolgende kannst Du zur Generierung der Tree-Attributes +; verwenden. Prepare-Tree-Attributes kann auch zur Laufzeit die +; Attribute eintragen; wenn Du die Definitionen ins Domainfile +; uebernimmst, muesste Zebu define-tree-attributes immer kennen +; (zebu-kernel?). + +;; diese hashtable ist fuer zebra wiederverwenbar (der gruene punkt) + +(defparameter *local-accessor-hashtable* (make-hash-table :test #'equal)) + +(defun labelnode2accessor (label topnode) + "Translates a label symbol and its topnode + into a structure accessor (-predicate atomic-wff -> at-wff--pred)" + (let* ((key (cons label topnode)) + (constr (gethash key *local-accessor-hashtable*))) + (if constr + constr + (setf (gethash key *local-accessor-hashtable*) + (intern (concatenate 'string + (symbol-name topnode) "-" + (symbol-name label))))))) + +(defun prepare-tree-attributes (type &optional (output-only nil) (stream T)) + "sets kb-tree-attributes of type and all of its subtypes" + (let ((slots (kb-slots type)) + (slot-funs nil)) + (dolist (item slots) + (if (symbolp item) + (push (labelnode2accessor item type) slot-funs) + ;; else + (push (labelnode2accessor (first item) type) slot-funs))) + (when slot-funs + (setq slot-funs (nreverse slot-funs)) + (if output-only + (format stream "~S~%~%" + `(define-tree-attributes ',type '(, at slot-funs))) + ;; else + (define-tree-attributes type slot-funs))) + (dolist (item (kb-subtypes type)) + (prepare-tree-attributes item output-only stream)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of zebu-tree-attributes.lisp +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Added: vendor/zebu/zebu.asd ============================================================================== --- (empty file) +++ vendor/zebu/zebu.asd Wed Oct 17 09:04:46 2007 @@ -0,0 +1,30 @@ +;;; -*- Lisp -*- + +(in-package #:asdf) + +(defsystem #:zebu + :version "3.5.5" + :components + ((:module "zebu-kernel" + ;; Functions needed in the ZEBU run-time and + ;; compile-time enironment + :pathname "" + :components + ((:file "zebu-package") + (:file "zebu-aux" + :in-order-to + ((compile-op (load-op "zebu-package")))) + (:file "zebu-mg-hierarchy" + :in-order-to + ((compile-op (load-op "zebu-aux")))))) + (:module "zebu-runtime" + ;; Run time system for LALR(1) parser + :pathname "" + :depends-on ("zebu-kernel") + :components + ((:file "zebu-loader") + (:file "zebu-driver" + :in-order-to ((compile-op (load-op "zebu-loader")))) + (:file "zebu-actions" + :in-order-to ((compile-op (load-op "zebu-loader")))))))) + Added: vendor/zebu/zebu.system ============================================================================== --- (empty file) +++ vendor/zebu/zebu.system Wed Oct 17 09:04:46 2007 @@ -0,0 +1,22 @@ +;;; -*- Lisp -*- + +(mk:defsystem "zebu" + :source-pathname "/users/students/rschlatt/lisp/zebu-3.5.5/" + :binary-pathname "/users/students/rschlatt/lisp/zebu-3.5.5/binary/" + ;;:package "ZEBU" + :components ((:module "zebu-kernel" + :source-pathname "" + :components ((:file "zebu-defsystem-package") + (:file "zebu-aux" + :depends-on ("zebu-defsystem-package")) + (:file "zebu-mg-hierarchy" + :depends-on ("zebu-defsystem-package")))) + (:module "zebu-runtime" + :source-pathname "" + :depends-on ("zebu-kernel") + :components ((:file "zebu-loader") + (:file "zebu-driver" + :depends-on ("zebu-loader")) + (:file "zebu-actions" + :depends-on ("zebu-loader")))))) + From ctian at common-lisp.net Wed Oct 17 13:07:50 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 09:07:50 -0400 (EDT) Subject: [cl-net-snmp-cvs] r75 - vendor/zebu Message-ID: <20071017130750.74BDC74384@common-lisp.net> Author: ctian Date: Wed Oct 17 09:07:49 2007 New Revision: 75 Modified: vendor/zebu/zebu-asdf-setup.lisp vendor/zebu/zebu-compile-mg.lisp vendor/zebu/zebu-compiler.asd vendor/zebu/zebu-driver.lisp vendor/zebu/zebu-generator.lisp vendor/zebu/zebu-loader.lisp vendor/zebu/zebu-loadgram.lisp vendor/zebu/zebu-mg.zb vendor/zebu/zebu-package.lisp vendor/zebu/zebu-regex.lisp vendor/zebu/zebu-tree-attributes.lisp Log: * 10_clc-debian.dpatch * 20_comment-start.dpatch * 30_ansi.dpatch Modified: vendor/zebu/zebu-asdf-setup.lisp ============================================================================== --- vendor/zebu/zebu-asdf-setup.lisp (original) +++ vendor/zebu/zebu-asdf-setup.lisp Wed Oct 17 09:07:49 2007 @@ -1,4 +1,3 @@ - (in-package :asdf) (defclass zebu-source-file (source-file) ()) @@ -9,8 +8,8 @@ (zebu:zebu-compile-file (component-pathname c))) (defmethod perform ((o load-op) (c zebu-source-file)) - (let* ((co (make-sub-operation o 'compile-op)) - (output-files (output-files co c))) + (let* ((co (make-instance 'compile-op)) + (output-files (output-files co c))) (setf (component-property c 'last-loaded) (file-write-date (car output-files))) (zb:zebu-load-file (car output-files)))) Modified: vendor/zebu/zebu-compile-mg.lisp ============================================================================== --- vendor/zebu/zebu-compile-mg.lisp (original) +++ vendor/zebu/zebu-compile-mg.lisp Wed Oct 17 09:07:49 2007 @@ -20,11 +20,25 @@ (eval-when (:compile-toplevel) (ignore-errors - (delete-file (merge-pathnames "zebu-mg.tab" *compile-file-truename*)) - (delete-file (merge-pathnames "zmg-dom.lisp" *compile-file-truename*))) + (delete-file (merge-pathnames "zebu-mg.tab" + #-common-lisp-controller + *compile-file-truename* + #+common-lisp-controller + (clc::source-root-path-to-fasl-path + *compile-file-truename*))) + (delete-file (merge-pathnames "zmg-dom.lisp" + #-common-lisp-controller + *compile-file-truename* + #+common-lisp-controller + (clc::source-root-path-to-fasl-path + *compile-file-truename*)))) (zebu-compile-file - (merge-pathnames "zebu-mg.zb" *compile-file-truename*))) - + (merge-pathnames "zebu-mg.zb" *compile-file-truename*) + #+common-lisp-controller :output-file + #+common-lisp-controller (merge-pathnames + "zebu-mg.tab" + (clc::source-root-path-to-fasl-path + *compile-file-truename*)))) (eval-when (:load-toplevel) (zebu-load-file Modified: vendor/zebu/zebu-compiler.asd ============================================================================== --- vendor/zebu/zebu-compiler.asd (original) +++ vendor/zebu/zebu-compiler.asd Wed Oct 17 09:07:49 2007 @@ -1,6 +1,6 @@ -;;; -*- Lisp -*- +;;;; -*- Mode: Lisp -*- -;;;(in-package "CL-USER") +(in-package :cl-user) (asdf:defsystem #:zebu-compiler ;; Compile time system for LALR(1) parser: Converts a grammar to a @@ -9,73 +9,38 @@ :components ((:file "zebu-regex") (:file "zebu-oset") - (:file "zebu-kb-domain") ; not explicitly in ZEBU-sys.lisp - (:file "zebu-g-symbol" - :in-order-to ((compile-op (load-op "zebu-oset")))) - (:file "zebu-loadgram" - :in-order-to ((compile-op (load-op "zebu-g-symbol") - (load-op "zebu-oset")))) - (:file "zebu-generator" - :in-order-to ((compile-op (load-op "zebu-loadgram") - (load-op "zebu-kb-domain")))) - (:file "zebu-lr0-sets" - :in-order-to ((compile-op (load-op "zebu-g-symbol") - (load-op "zebu-loadgram")))) - (:file "zebu-empty-st" - :in-order-to ((compile-op (load-op "zebu-loadgram")))) - (:file "zebu-first" - :in-order-to ((compile-op (load-op "zebu-loadgram") - (load-op "zebu-oset"))) - ;; :recompile-on "zebu-oset" - ) - (:file "zebu-follow" - :in-order-to ((compile-op (load-op "zebu-loadgram") - (load-op "zebu-first")))) - (:file "zebu-tables" - :in-order-to ((compile-op (load-op "zebu-g-symbol") - (load-op "zebu-loadgram") - (load-op "zebu-lr0-sets")))) - (:file "zebu-printers" - :in-order-to ((compile-op (load-op "zebu-loadgram") - (load-op "zebu-lr0-sets") - (load-op "zebu-tables")))) + (:file "zebu-kb-domain") ; not explicitly in ZEBU-sys.lisp + (:file "zebu-g-symbol" :depends-on ("zebu-oset")) + (:file "zebu-loadgram" :depends-on ("zebu-g-symbol" + "zebu-oset")) + (:file "zebu-generator" :depends-on ("zebu-loadgram" + "zebu-kb-domain")) + (:file "zebu-lr0-sets" :depends-on ("zebu-g-symbol" + "zebu-loadgram")) + (:file "zebu-empty-st" :depends-on ("zebu-loadgram")) + (:file "zebu-first" :depends-on ("zebu-loadgram" + "zebu-oset")) + (:file "zebu-follow" :depends-on ("zebu-loadgram" + "zebu-first")) + (:file "zebu-tables" :depends-on ("zebu-g-symbol" + "zebu-loadgram" + "zebu-lr0-sets")) + (:file "zebu-printers" :depends-on ("zebu-loadgram" + "zebu-lr0-sets" + "zebu-tables")) (:file "zebu-slr") - (:file "zebu-closure" - :in-order-to ((compile-op (load-op "zebu-oset") - (load-op "zebu-g-symbol") - (load-op "zebu-first")))) - (:file "zebu-lalr1" - :in-order-to ((compile-op (load-op "zebu-oset") - (load-op "zebu-lr0-sets") - (load-op "zebu-follow")))) - (:file "zebu-dump" - :in-order-to ((compile-op (load-op "zebu-loadgram") - (load-op "zebu-slr") - (load-op "zebu-lalr1")))) - (:file "zebu-compile" - :in-order-to ((compile-op (load-op "zebu-dump")))) - (:file "zebu-compile-mg" - :in-order-to ((compile-op (load-op "zebu-compile") - (load-op "zebu-dump") - (load-op "zebu-empty-st") - (load-op "zebu-closure") - (load-op "zebu-tables") - (load-op "zebu-generator")) - ((load-op (compile-op "zebu-compile-mg") - (load-op "zebu-compile") - (load-op "zebu-dump") - (load-op "zebu-empty-st") - (load-op "zebu-closure") - (load-op "zebu-tables") - (load-op "zebu-generator"))))) - (:file "zmg-dom" - :in-order-to ((compile-op (load-op "zebu-compile-mg")))) - (:file "zebu-kb-domain" - :in-order-to ((compile-op (load-op "zmg-dom")))) - ;;; Hook it into asdf - (:file "zebu-asdf-setup" - :in-order-to ((compile-op (load-op "zebu-kb-domain")))))) - - - - + (:file "zebu-closure" :depends-on ("zebu-oset" + "zebu-g-symbol" + "zebu-first")) + (:file "zebu-lalr1" :depends-on ("zebu-oset" + "zebu-lr0-sets" + "zebu-follow")) + (:file "zebu-dump" :depends-on ("zebu-loadgram" + "zebu-slr" + "zebu-lalr1")) + (:file "zebu-compile" :depends-on ("zebu-empty-st" + "zebu-closure" + "zebu-generator" + "zebu-dump")) + (:file "zebu-compile-mg" :depends-on ("zebu-compile")) + (:file "zebu-asdf-setup" :depends-on ("zebu-kb-domain")))) Modified: vendor/zebu/zebu-driver.lisp ============================================================================== --- vendor/zebu/zebu-driver.lisp (original) +++ vendor/zebu/zebu-driver.lisp Wed Oct 17 09:07:49 2007 @@ -125,7 +125,7 @@ (defvar *terminal-alist-SEQ*) (defvar *lexer-debug* nil) -(eval-when (compile) +(eval-when (:compile-toplevel) (setq *lexer-debug* nil)) #| @@ -980,7 +980,7 @@ ;; returned by read-parser (defvar *comment-brackets* '(("#|" . "|#")) ) -(defvar *comment-start* #\; ) +(defvar *comment-start* ";;") (defun file-parser (file &key (error-fn #'error) @@ -1003,32 +1003,53 @@ (subseq l (+ p (length end)))))) (if (string= l-rest "") (next-line stream) - l-rest)) - (skip-lines stream end))) - l))) - (next-line (stream) ; ignore comments + l-rest)) + (skip-lines stream end))) + l))) + (next-line (stream) ;; ignore comments (let ((l (read-line stream nil eof))) (when verbose (terpri) (princ l)) (if (stringp l) (let ((l-length (length (setq l (string-left-trim - '(#\Space #\Tab) l))))) - (if (zerop l-length) - (next-line stream) - (if (char= *comment-start* (schar l 0)) - (next-line stream) - ;; does this line start a comment - (dolist (comment *comment-brackets* l) - (let* ((start (car comment)) - (start-length (length start))) - (when (and - (>= l-length start-length) - (string= l start :end1 start-length)) - ;; a comment found - (return - (setq l (skip-lines - stream - (cdr comment)))))))))) - l)))) + '(#\Space #\Tab) l))))) + (if (zerop l-length) + ;; blank lines, pass ... + (next-line stream) + ;; search comment-start + (let ((pos (search *comment-start* l))) + (if pos ;; match a comment-start! + (if (zerop pos) + ;; at begin of line? pass ... + (next-line stream) + (progn + ;; return part from begin to comment-start + (setq l (subseq l 0 pos)) + ;; does this line start a comment + (dolist (comment *comment-brackets* l) + (let* ((start (car comment)) + (start-length (length start))) + (when (and + ;; binghe: we must recalc l's length + (>= (length l) start-length) + (string= l start :end1 + start-length)) + ;; a comment found + (return + (setq l (skip-lines + stream + (cdr comment))))))))) + (dolist (comment *comment-brackets* l) + (let* ((start (car comment)) + (start-length (length start))) + (when (and + (>= l-length start-length) + (string= l start :end1 start-length)) + ;; a comment found + (return + (setq l (skip-lines + stream + (cdr comment))))))))))) + l)))) (do ((line (next-line stream))) ((eq line eof) (nreverse R)) (multiple-value-bind (expr rest) @@ -1043,15 +1064,15 @@ (if (eq line eof) (if error-fn (funcall error-fn) - (error "Reached end of file ~S while parsing" - stream)) - line))) + (error "Reached end of file ~S while parsing" + stream)) + line))) ;; (when verbose (let ((*print-structure* t)) (print expr))) (push expr R) (when (eq line eof) (return (nreverse R))) (setq line (if rest (subseq line rest) - (next-line stream))))))) + (next-line stream))))))) ;----------------------------------------------------------------------------; ; debug-parser Modified: vendor/zebu/zebu-generator.lisp ============================================================================== --- vendor/zebu/zebu-generator.lisp (original) +++ vendor/zebu/zebu-generator.lisp Wed Oct 17 09:07:49 2007 @@ -421,7 +421,7 @@ ; return: (1) (( ) ..) ; (2) a lambda-list binding the %u .. variables used to accessors ; derived from the paths. -(defconstant *vars-to-use* '("%R" "%S" "%T" "%U" "%V" "%W" "%X" "%Y" "%Z")) +(defvar *vars-to-use* '("%R" "%S" "%T" "%U" "%V" "%W" "%X" "%Y" "%Z")) (defun gen-clauses (clauses KB-sequence-print-fn-AL &aux (vars-to-use (mapcar #'intern *vars-to-use*)) Modified: vendor/zebu/zebu-loader.lisp ============================================================================== --- vendor/zebu/zebu-loader.lisp (original) +++ vendor/zebu/zebu-loader.lisp Wed Oct 17 09:07:49 2007 @@ -240,11 +240,11 @@ x 'nil))) -(eval-when (compile) +(eval-when (:compile-toplevel) (setq *grammar-debug* nil)) #|| -(eval-when (eval) +(eval-when (:execute) (setq *grammar-debug* T)) ||# Modified: vendor/zebu/zebu-loadgram.lisp ============================================================================== --- vendor/zebu/zebu-loadgram.lisp (original) +++ vendor/zebu/zebu-loadgram.lisp Wed Oct 17 09:07:49 2007 @@ -716,15 +716,15 @@ (make-pathname :name (format nil "~A-domain" (get-grammar-options-key ':NAME)))) - (merge-pathnames (merge-pathnames (make-pathname :type (first *load-source-pathname-types*)) - grammar-file) - *default-pathname-defaults*))) + (clc::source-root-path-to-fasl-path + grammar-file)))) (*print-array* t) ; bit-vectors of regex code *print-level* *print-length* *print-circle* written?) - #-MCL (when (probe-file domain-file) + #-(or MCL sbcl) + (when (probe-file domain-file) (warn "Renaming existing domain file ~a" domain-file)) (with-open-file (port domain-file :if-does-not-exist :create @@ -757,7 +757,7 @@ (terpri port) ;; for lexical categories: compile the rx-token parsers! (when *lex-cats* - (pprint '(eval-when (compile) + (pprint '(eval-when (:compile-toplevel) (unless (member "zebu-regex" *modules* :test #'equal) (WARN "Load the Zebu Compiler!"))) port) Modified: vendor/zebu/zebu-mg.zb ============================================================================== --- vendor/zebu/zebu-mg.zb (original) +++ vendor/zebu/zebu-mg.zb Wed Oct 17 09:07:49 2007 @@ -1,20 +1,20 @@ -; -*- mode: Lisp -*- --------------------------------------------------- ; -; File: zebu-mg.zb -; Description: Metagrammar for Zebu -; Author: Joachim H. Laubsch -; Created: 13-Apr-92 -; Modified: Thu Dec 21 16:26:28 1995 (Joachim H. Laubsch) -; Language: Lisp -; Package: ZEBU -; Status: Experimental (Do Not Distribute) -; RCS $Header: $ -; -; (c) Copyright 1992, Hewlett-Packard Company -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; Revisions: -; RCS $Log: $ -; 10-Mar-93 (Joachim H. Laubsch) -; add domain definition +;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; File: zebu-mg.zb +;;; Description: Metagrammar for Zebu +;;; Author: Joachim H. Laubsch +;;; Created: 13-Apr-92 +;;; Modified: Thu Dec 21 16:26:28 1995 (Joachim H. Laubsch) +;;; Language: Lisp +;;; Package: ZEBU +;;; Status: Experimental (Do Not Distribute) +;;; RCS $Header: $ +;;; +;;; (c) Copyright 1992, Hewlett-Packard Company +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Revisions: +;;; RCS $Log: $ +;;; 10-Mar-93 (Joachim H. Laubsch) +;;; add domain definition ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (:name "zebu-mg" :domain-file "zmg-dom" Modified: vendor/zebu/zebu-package.lisp ============================================================================== --- vendor/zebu/zebu-package.lisp (original) +++ vendor/zebu/zebu-package.lisp Wed Oct 17 09:07:49 2007 @@ -21,7 +21,7 @@ (provide "zebu-package") #+LUCID ; while not up tp CLtL2 -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro LCL::DECLAIM (decl-spec) `(proclaim ',decl-spec))) ;;; 2000-03-25 by rschlatte at ist.tu-graz.ac.at: Modified: vendor/zebu/zebu-regex.lisp ============================================================================== --- vendor/zebu/zebu-regex.lisp (original) +++ vendor/zebu/zebu-regex.lisp Wed Oct 17 09:07:49 2007 @@ -86,7 +86,7 @@ (if *regex-debug* `(format *standard-output* ,message , at args))) -(eval-when (compile) +(eval-when (:compile-toplevel) (setq *regex-debug* nil)) ;;; Modified: vendor/zebu/zebu-tree-attributes.lisp ============================================================================== --- vendor/zebu/zebu-tree-attributes.lisp (original) +++ vendor/zebu/zebu-tree-attributes.lisp Wed Oct 17 09:07:49 2007 @@ -83,7 +83,7 @@ writers)) (push setter setters))) `(progn - (eval-when (compile eval) , at writers) + (eval-when (:compile-toplevel :execute) , at writers) (setf (get ',class 'KB-TREE-ATTRIBUTES) (cons ',slots @@ -114,7 +114,7 @@ writers)) (push setter setters))) `(progn - (eval-when (compile eval #+CLISP load) , at writers) + (eval-when (:compile-toplevel :execute #+CLISP :load-toplevel) , at writers) ,@(mapcar #'(lambda (set-valued-slot) (let ((type (second set-valued-slot))) (if (eq type :set) From ctian at common-lisp.net Wed Oct 17 16:08:21 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 12:08:21 -0400 (EDT) Subject: [cl-net-snmp-cvs] r76 - in trunk: . asn.1 mib smi snmp Message-ID: <20071017160821.7942574016@common-lisp.net> Author: ctian Date: Wed Oct 17 12:08:20 2007 New Revision: 76 Added: trunk/mib/print-oid.lisp Modified: trunk/asn.1/asn.1-domain.lisp trunk/asn.1/package.lisp trunk/mib/package.lisp trunk/mib/tree.lisp trunk/net-snmp.asd trunk/smi/oid.lisp trunk/smi/package.lisp trunk/snmp/package.lisp Log: custom oid display, short package names Modified: trunk/asn.1/asn.1-domain.lisp ============================================================================== --- trunk/asn.1/asn.1-domain.lisp (original) +++ trunk/asn.1/asn.1-domain.lisp Wed Oct 17 12:08:20 2007 @@ -1,6 +1,6 @@ ;;; This file was generated by Zebu (Version 3.5.5) -(IN-PACKAGE "COM.NETEASE.ASN.1") +(IN-PACKAGE "ASN.1") (REQUIRE "zebu-package") (USE-PACKAGE "ZEBU") Modified: trunk/asn.1/package.lisp ============================================================================== --- trunk/asn.1/package.lisp (original) +++ trunk/asn.1/package.lisp Wed Oct 17 12:08:20 2007 @@ -1,7 +1,6 @@ (in-package :snmp.system) -(defpackage com.netease.asn.1 - (:nicknames asn.1) +(defpackage asn.1 (:use :common-lisp #+lispworks :stream #+sbcl :sb-gray #+clisp :gray :zebu) Modified: trunk/mib/package.lisp ============================================================================== --- trunk/mib/package.lisp (original) +++ trunk/mib/package.lisp Wed Oct 17 12:08:20 2007 @@ -1,7 +1,6 @@ (in-package :snmp.system) -(defpackage :com.netease.mib - (:nicknames mib) +(defpackage mib (:use :common-lisp :asn.1 :smi :zebu) (:export *mib-tree* *mib-index* Added: trunk/mib/print-oid.lisp ============================================================================== --- (empty file) +++ trunk/mib/print-oid.lisp Wed Oct 17 12:08:20 2007 @@ -0,0 +1,21 @@ +(in-package :mib) + +(defmethod print-object ((obj object-id) stream) + (with-slots (rev-ids rev-names) obj + (print-unreadable-object (obj stream :type t) + (when *oid-print-id* + (let ((part-1 (reverse rev-ids))) + (format stream "~A~{.~A~}" (car part-1) (cdr part-1)))) + (when (and *oid-print-id* *oid-print-name*) + (format stream " (")) + (when *oid-print-name* + (let ((part-2 (if rev-names + (reverse rev-names) + (resolve (reverse rev-ids))))) + (when *oid-print-short* + (setf part-2 (nthcdr (- (oid-length obj) *oid-print-length*) part-2))) + (format stream "~A~{.~A~}" + (car part-2) + (cdr part-2)))) + (when (and *oid-print-id* *oid-print-name*) + (format stream ")"))))) Modified: trunk/mib/tree.lisp ============================================================================== --- trunk/mib/tree.lisp (original) +++ trunk/mib/tree.lisp Wed Oct 17 12:08:20 2007 @@ -85,19 +85,6 @@ (tree-id (gethash (first names) *mib-index*))))) (t nil)))) -(defmethod print-object ((obj object-id) stream) - (with-slots (rev-ids rev-names) obj - (print-unreadable-object (obj stream :type t) - (let ((part-1 (reverse rev-ids)) - (part-2 (if rev-names - (reverse rev-names) - (resolve (reverse rev-ids))))) - (format stream "~A~{.~A~} {~A~{.~A~}}" - (car part-1) - (cdr part-1) - (car part-2) - (cdr part-2)))))) - (defun parse-mib (file &key (verbose nil)) (let ((*comment-start* "--") (*comment-brackets* '(("/*" . "*/"))) Modified: trunk/net-snmp.asd ============================================================================== --- trunk/net-snmp.asd (original) +++ trunk/net-snmp.asd Wed Oct 17 12:08:20 2007 @@ -2,8 +2,7 @@ (in-package :cl-user) -(defpackage com.netease.snmp.system - (:nicknames snmp.system) +(defpackage snmp.system (:use :common-lisp :asdf) (:export #+lispworks make-fli-templates)) @@ -11,7 +10,7 @@ (defsystem net-snmp :description "Simple Network Manangement Protocol" - :version "1.1" + :version "1.2" :author "Chun Tian (binghe) " :depends-on (:cl-fad ; for directory and file :cl-ppcre ; for oid resolve @@ -46,6 +45,7 @@ :components ((:file "package") (:file "tree" :depends-on ("package")) (:file "build" :depends-on ("tree")) + (:file "print-oid" :depends-on ("tree")) #+lispworks (:file "browser" :depends-on ("tree"))) :depends-on (smi)) Modified: trunk/smi/oid.lisp ============================================================================== --- trunk/smi/oid.lisp (original) +++ trunk/smi/oid.lisp Wed Oct 17 12:08:20 2007 @@ -4,6 +4,11 @@ (in-package :smi) +(defvar *oid-print-name* t) +(defvar *oid-print-id* nil) +(defvar *oid-print-short* t) +(defvar *oid-print-length* 2) + (defclass object-id () ((rev-ids :initform nil :type list :reader oid-revid :initarg :id) (rev-names :initform nil :type list :reader oid-name :initarg :name) Modified: trunk/smi/package.lisp ============================================================================== --- trunk/smi/package.lisp (original) +++ trunk/smi/package.lisp Wed Oct 17 12:08:20 2007 @@ -1,13 +1,15 @@ (in-package :snmp.system) -(defpackage com.netease.smi - (:nicknames smi) +(defpackage smi (:use :common-lisp :asn.1 #-(and lispworks win32) :net.sockets) (:export ;; general value-of general-type plain-value ;; object-id object-id oid make-object-id rev-ids rev-names + oid-length oid-revid oid-name oid-< + *oid-print-name* *oid-print-id* *oid-print-short* + *oid-print-length* ;; pdu get-request-pdu get-next-request-pdu @@ -43,4 +45,4 @@ (defmethod plain-value ((object general-type)) (value-of object)) -(defparameter *version* 2) +(defparameter *version* 3) Modified: trunk/snmp/package.lisp ============================================================================== --- trunk/snmp/package.lisp (original) +++ trunk/snmp/package.lisp Wed Oct 17 12:08:20 2007 @@ -1,8 +1,8 @@ (in-package :snmp.system) -(defpackage :com.netease.snmp - (:nicknames snmp) - (:use :common-lisp :smi :asn.1 :mib #-win32 :net.sockets #-win32 :io.streams) +(defpackage snmp + (:use :common-lisp :smi :asn.1 :mib + #-win32 :net.sockets #-win32 :io.streams) (:export v1-session v2c-session v3-session make-session *default-version* *default-community* *default-port* snmp-get snmp-walk)) From ctian at common-lisp.net Wed Oct 17 16:11:56 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 12:11:56 -0400 (EDT) Subject: [cl-net-snmp-cvs] r77 - trunk Message-ID: <20071017161156.DBA3C68222@common-lisp.net> Author: ctian Date: Wed Oct 17 12:11:56 2007 New Revision: 77 Modified: trunk/Makefile trunk/README Log: clean more files; fill README Modified: trunk/Makefile ============================================================================== --- trunk/Makefile (original) +++ trunk/Makefile Wed Oct 17 12:11:56 2007 @@ -1,4 +1,7 @@ clean: find . -name "*~" -exec rm {} \; find . -name "*.64ufasl" -exec rm {} \; + find . -name "*.old" -exec rm {} \; +build: + lispworks -build deliver.lisp Modified: trunk/README ============================================================================== --- trunk/README (original) +++ trunk/README Wed Oct 17 12:11:56 2007 @@ -1 +1,48 @@ -^_^ +CL-USER 2 > (snmp:snmp-walk "localhost" "system") +((# + "Linux 2950.lab.163.org 2.6.18-4-xen-vserver-amd64 #1 SMP Fri May 4 03:26:45 UTC 2007 x86_64") + (# + #) + (# + #) + (# + "Root (configure /etc/snmp/snmpd.local.conf)") + (# "2950.lab.163.org") + (# + "Unknown (configure /etc/snmp/snmpd.local.conf)") + (# #) + (# #) + (# #) + (# #) + (# #) + (# + #) + (# + #) + (# + #) + (# + #) + (# "The MIB module for SNMPv2 entities") + (# + "The MIB module for managing TCP implementations") + (# + "The MIB module for managing IP and ICMP implementations") + (# + "The MIB module for managing UDP implementations") + (# + "View-based Access Control Model for SNMP.") + (# + "The SNMP Management Architecture MIB.") + (# + "The MIB for Message Processing and Dispatching.") + (# + "The management information definitions for the SNMP User-based Security Model.") + (# #) + (# #) + (# #) + (# #) + (# #) + (# #) + (# #) + (# #)) From ctian at common-lisp.net Wed Oct 17 16:15:00 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 12:15:00 -0400 (EDT) Subject: [cl-net-snmp-cvs] r78 - tags/1.2 Message-ID: <20071017161500.6BB0F281E5@common-lisp.net> Author: ctian Date: Wed Oct 17 12:15:00 2007 New Revision: 78 Added: tags/1.2/ - copied from r77, trunk/ Log: Release 1.2 From ctian at common-lisp.net Wed Oct 17 16:27:54 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 17 Oct 2007 12:27:54 -0400 (EDT) Subject: [cl-net-snmp-cvs] r79 - dists www Message-ID: <20071017162754.E94211E0A2@common-lisp.net> Author: ctian Date: Wed Oct 17 12:27:39 2007 New Revision: 79 Added: dists/ dists/cl-net-snmp_1.2.tar.gz (contents, props changed) Modified: www/index.shtml Log: Add dists file for 1.2 Added: dists/cl-net-snmp_1.2.tar.gz ============================================================================== Binary file. No diff available. Modified: www/index.shtml ============================================================================== --- www/index.shtml (original) +++ www/index.shtml Wed Oct 17 12:27:39 2007 @@ -1,15 +1,12 @@ - - - cl-net-snmp - - - - - -

+cl-net-snmp + + + + + + +

@@ -17,7 +14,7 @@

About

Cl-NET-SNMP is a pure lisp SNMP implementation now. -
+
This package is still in early development stage, lots of work for me to do, but I'll continue coding, because I use it for managing my servers. (I'm a Unix System Administrator of @@ -39,37 +36,36 @@

Release

- Fri Sep 28 12:00:00 CST 2007: version 1.0, - - get the source.
-
-
- Sun Apr 8 20:11:52 CST 2007: version 0.10, - - get the source.
+ Thu Oct 18 00:19:45 CST 2007: version 1.2, + + get the source.

Source Code

Click - + here to view the source code on common-lisp.net's Web-SVN interface, and use - follow command to check out the code:
-
- + follow command to check out the code:
+
- -
+
A modify version of ZEBU LALR(1) parser can be found at - here. + here, or use + follow command to check out the code:
+
+ +

Document

- I define two classes: 'snmp-session and 'oid, and a 'snmp-get-msg method to do the - work, see README file in source code. + Sample usage: (snmpV1, public) +
CL-USER 2 > (snmp:snmp-walk "localhost" "system")
((#<SMI:OBJECT-ID sysDescr.0>
"Linux 2950.lab.163.org 2.6.18-4-xen-vserver-amd64 #1 SMP Fri May 4 03:26:45 UTC 2007 x86_64")
(#<SMI:OBJECT-ID sysObjectID.0> #<SMI:OBJECT-ID netSnmpAgentOIDs.linux>)
(#<SMI:OBJECT-ID sysUpTime.sysUpTimeInstance> #<SMI:TIMETICKS (169041005) 469:33:30.05>)
(#<SMI:OBJECT-ID sysContact.0> "Chun Tian (binghe) <binghe.lisp at gmail.com>")
(#<SMI:OBJECT-ID sysName.0> "2950.lab.163.org")
(#<SMI:OBJECT-ID sysLocation.0> "Hangzhou, China")
(#<SMI:OBJECT-ID sysORLastChange.0> #<SMI:TIMETICKS (1) 0:00:00.01>)
(#<SMI:OBJECT-ID sysORID.1> #<SMI:OBJECT-ID snmpModules.snmpMIB>)
(#<SMI:OBJECT-ID sysORID.2> #<SMI:OBJECT-ID mib-2.tcpMIB>)
(#<SMI:OBJECT-ID sysORID.3> #<SMI:OBJECT-ID mib-2.ip>)
(#<SMI:OBJECT-ID sysORID.4> #<SMI:OBJECT-ID mib-2.udpMIB>)
(#<SMI:OBJECT-ID sysORID.5> #<SMI:OBJECT-ID vacmMIBGroups.vacmBasicGroup>)
(#<SMI:OBJECT-ID sysORID.6> #<SMI:OBJECT-ID snmpFrameworkMIBCompliances.snmpFrameworkMIBCompliance>)
(#<SMI:OBJECT-ID sysORID.7> #<SMI:OBJECT-ID snmpMPDMIBCompliances.snmpMPDCompliance>)
(#<SMI:OBJECT-ID sysORID.8> #<SMI:OBJECT-ID usmMIBCompliances.usmMIBCompliance>)
(#<SMI:OBJECT-ID sysORDescr.1> "The MIB module for SNMPv2 entities")
(#<SMI:OBJECT-ID sysORDescr.2> "The MIB module for managing TCP implementations")
(#<SMI:OBJECT-ID sysORDescr.3> "The MIB module for managing IP and ICMP implementations")
(#<SMI:OBJECT-ID sysORDescr.4> "The MIB module for managing UDP implementations")
(#<SMI:OBJECT-ID sysORDescr.5> "View-based Access Control Model for SNMP.")
(#<SMI:OBJECT-ID sysORDescr.6> "The SNMP Management Architecture MIB.")
(#<SMI:OBJECT-ID sysORDescr.7> "The MIB for Message Processing and Dispatching.")
(#<SMI:OBJECT-ID sysORDescr.8>
 "The management information definitions for the SNMP User-based Security Model.")
(#<SMI:OBJECT-ID sysORUpTime.1> #<SMI:TIMETICKS (0) 0:00:00.00>)
(#<SMI:OBJECT-ID sysORUpTime.2> #<SMI:TIMETICKS (0) 0:00:00.00>)
(#<SMI:OBJECT-ID sysORUpTime.3> #<SMI:TIMETICKS (0) 0:00:00.00>)
(#<SMI:OBJECT-ID sysORUpTime.4> #<SMI:TIMETICKS (0) 0:00:00.00>)
(#<SMI:OBJECT-ID sysORUpTime.5> #<SMI:TIMETICKS (0) 0:00:00.00>)
(#<SMI:OBJECT-ID sysORUpTime.6> #<SMI:TIMETICKS (1) 0:00:00.01>)
(#<SMI:OBJECT-ID sysORUpTime.7> #<SMI:TIMETICKS (1) 0:00:00.01>)
(#<SMI:OBJECT-ID sysORUpTime.8> #<SMI:TIMETICKS (1) 0:00:00.01>))

Relate Lisp Projects

@@ -102,13 +98,12 @@

Maintainer

Chun Tian (binghe) <ctian at common-lisp dot - net>, Lisp Programmer, Unix Administrator.
+ net>, Lisp Programmer, Unix Administrator.
Welcome to his chinese BLOG - on NetEase blog system.^_^
+ on NetEase blog system.^_^
- - + \ No newline at end of file From ctian at common-lisp.net Thu Oct 18 11:11:30 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Thu, 18 Oct 2007 07:11:30 -0400 (EDT) Subject: [cl-net-snmp-cvs] r80 - in trunk: . smi Message-ID: <20071018111130.6D15D5313C@common-lisp.net> Author: ctian Date: Thu Oct 18 07:11:29 2007 New Revision: 80 Modified: trunk/net-snmp.asd trunk/smi/ipaddress.lisp Log: Add ipaddress support and fix for win32 load Modified: trunk/net-snmp.asd ============================================================================== --- trunk/net-snmp.asd (original) +++ trunk/net-snmp.asd Thu Oct 18 07:11:29 2007 @@ -30,7 +30,7 @@ (:file "integer" :depends-on ("package")) (:file "string" :depends-on ("package")) (:file "sequence" :depends-on ("package")) - (:file "ipaddress" :depends-on ("package")) + #-win32 (:file "ipaddress" :depends-on ("package")) (:file "oid" :depends-on ("package")) (:file "timeticks" :depends-on ("package")) (:file "pdu" :depends-on ("package")) @@ -50,6 +50,7 @@ (:file "browser" :depends-on ("tree"))) :depends-on (smi)) ;; SNMP + #-win32 (:module snmp :components ((:file "package") (:file "constants" :depends-on ("package")) Modified: trunk/smi/ipaddress.lisp ============================================================================== --- trunk/smi/ipaddress.lisp (original) +++ trunk/smi/ipaddress.lisp Thu Oct 18 07:11:29 2007 @@ -1,3 +1,26 @@ (in-package :smi) -;;; We use net.sockets:sockaddr class as ipaddr type. +;; IP Address Type, use IOLIB's ipv4addr class + +(defmethod plain-value ((address ipv4addr)) + (vector-to-dotted (name address))) + +(defmethod ber-encode ((value ipv4addr)) + (declare (ignore value)) + (nconc (ber-encode-type 1 0 0) + (ber-encode-length 4) + (coerce (name value) 'list))) + +(defmethod ber-decode-value ((stream stream) (type (eql :ipaddress)) length) + (declare (type stream stream) + (type fixnum length) + (ignore type)) + (assert (= 4 length)) + (let ((part-1 (read-byte stream)) + (part-2 (read-byte stream)) + (part-3 (read-byte stream)) + (part-4 (read-byte stream))) + (make-instance 'ipv4addr :name (vector part-1 part-2 part-3 part-4)))) + +(eval-when (:load-toplevel :execute) + (install-asn.1-type :ipaddress 1 0 0)) From ctian at common-lisp.net Thu Oct 18 11:46:15 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Thu, 18 Oct 2007 07:46:15 -0400 (EDT) Subject: [cl-net-snmp-cvs] r81 - trunk Message-ID: <20071018114615.517AE55356@common-lisp.net> Author: ctian Date: Thu Oct 18 07:46:15 2007 New Revision: 81 Modified: trunk/net-snmp.asd Log: Add CFFI to depends Modified: trunk/net-snmp.asd ============================================================================== --- trunk/net-snmp.asd (original) +++ trunk/net-snmp.asd Thu Oct 18 07:46:15 2007 @@ -17,6 +17,7 @@ :ironclad ; for v3 support :net-telent-date ; for time convert #-win32 :iolib ; for networking + #+win32 :cffi ; for portable FFI :zebu) ; for mib parse :components (;; ASN.1 (:module asn.1 From ctian at common-lisp.net Thu Oct 18 11:52:35 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Thu, 18 Oct 2007 07:52:35 -0400 (EDT) Subject: [cl-net-snmp-cvs] r82 - trunk/mib Message-ID: <20071018115235.B7C9B55529@common-lisp.net> Author: ctian Date: Thu Oct 18 07:52:35 2007 New Revision: 82 Modified: trunk/mib/print-oid.lisp Log: Fix OID print-object Modified: trunk/mib/print-oid.lisp ============================================================================== --- trunk/mib/print-oid.lisp (original) +++ trunk/mib/print-oid.lisp Thu Oct 18 07:52:35 2007 @@ -13,7 +13,8 @@ (reverse rev-names) (resolve (reverse rev-ids))))) (when *oid-print-short* - (setf part-2 (nthcdr (- (oid-length obj) *oid-print-length*) part-2))) + (setf part-2 (nthcdr (let ((d (- (oid-length obj) *oid-print-length*))) + (if (plusp d) d 0)) part-2))) (format stream "~A~{.~A~}" (car part-2) (cdr part-2)))) From ctian at common-lisp.net Sat Oct 20 06:57:17 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 02:57:17 -0400 (EDT) Subject: [cl-net-snmp-cvs] r84 - vendor/cl-http/lw Message-ID: <20071020065717.EDD761B032@common-lisp.net> Author: ctian Date: Sat Oct 20 02:57:16 2007 New Revision: 84 Modified: vendor/cl-http/lw/pre-cl-http.lisp Log: (require "comm") for LispWorks 5 Modified: vendor/cl-http/lw/pre-cl-http.lisp ============================================================================== --- vendor/cl-http/lw/pre-cl-http.lisp (original) +++ vendor/cl-http/lw/pre-cl-http.lisp Sat Oct 20 02:57:16 2007 @@ -31,7 +31,7 @@ #+LispWorks3.2 (do-demand-pre-loads :comms) -#+LispWorks4 +#+(or LispWorks4 LispWorks5) (require "comm") #+(and compile-reverse LispWorks3.2) From ctian at common-lisp.net Sat Oct 20 06:58:24 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 02:58:24 -0400 (EDT) Subject: [cl-net-snmp-cvs] r85 - vendor/cl-http/lw/server Message-ID: <20071020065824.454D21E0A4@common-lisp.net> Author: ctian Date: Sat Oct 20 02:58:24 2007 New Revision: 85 Modified: vendor/cl-http/lw/server/sysdcl.lisp Log: Load necessary file for LispWorks 5 Modified: vendor/cl-http/lw/server/sysdcl.lisp ============================================================================== --- vendor/cl-http/lw/server/sysdcl.lisp (original) +++ vendor/cl-http/lw/server/sysdcl.lisp Sat Oct 20 02:58:24 2007 @@ -36,17 +36,17 @@ "PACKAGE" ; HTTP Packages #+LispWorks "HTTP:lw;server;package" ; LispWorks specific package changes - #+LispWorks4 + #+(or LispWorks4 LispWorks5) "http:smtp;package" "PRELIMINARY" ; Showable procedures "VARIABLES" ; Variables and constants #+Genera lispm ; Load Lisp Machine specific code #+LispWorks3.2 "HTTP:lw;server;tcp-stream" ; LispWorks 3.2.2 specific - #+LispWorks4 + #+(or LispWorks4 LispWorks5) "HTTP:lw;server;tcp-stream-4" ; LispWorks 4 specific #-Genera "HTTP:mcl;server;www-utils" ; Some portable utils are there - #+(or LispWorks4.0 LispWorks4.1 LispWorks4.2 LispWorks4.3) + #+(or LispWorks4.0 LispWorks4.1 LispWorks4.2 LispWorks4.3 LispWorks5) "HTTP:lw;server;time-and-author" ; LispWorks 4 specific file properties #+(or UNIX Harlequin-PC-Lisp) "HTTP:lw;server;unix" ; add-ons for UNIX-like ports From ctian at common-lisp.net Sat Oct 20 07:01:42 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 03:01:42 -0400 (EDT) Subject: [cl-net-snmp-cvs] r86 - vendor/cl-http/server Message-ID: <20071020070142.C453832043@common-lisp.net> Author: ctian Date: Sat Oct 20 03:01:42 2007 New Revision: 86 Modified: vendor/cl-http/server/scripts.lisp Log: match LispWorks 5's API Modified: vendor/cl-http/server/scripts.lisp ============================================================================== --- vendor/cl-http/server/scripts.lisp (original) +++ vendor/cl-http/server/scripts.lisp Sat Oct 20 03:01:42 2007 @@ -342,7 +342,7 @@ :script :script script args))) -(defmethod documentation ((script script) #-(or CMU LispWorks4) &optional doc-type) +(defmethod documentation ((script script) #-(or CMU LispWorks4 LispWorks5) &optional doc-type) (declare (ignore doc-type)) (http:get-value script :documentation)) From ctian at common-lisp.net Sat Oct 20 07:02:43 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 03:02:43 -0400 (EDT) Subject: [cl-net-snmp-cvs] r87 - vendor/cl-http/server Message-ID: <20071020070243.5ECA332056@common-lisp.net> Author: ctian Date: Sat Oct 20 03:02:43 2007 New Revision: 87 Modified: vendor/cl-http/server/variables.lisp Log: Add definition for LispWorks 5 Modified: vendor/cl-http/server/variables.lisp ============================================================================== --- vendor/cl-http/server/variables.lisp (original) +++ vendor/cl-http/server/variables.lisp Sat Oct 20 03:02:43 2007 @@ -349,7 +349,7 @@ #+(or Genera ACLPC) 'character #+MCL (symbol-value 'ccl:*default-character-type*) #+LispWorks3.2 'base-character - #+(or Allegro Lucid CMU LispWorks4) 'base-char + #+(or Allegro Lucid CMU LispWorks4 LispWorks5) 'base-char #-(or Genera Allegro ACLPC MCL LispWorks Lucid CMU) 'base-character) (define-constant +standard-text-copy-mode+ From ctian at common-lisp.net Sat Oct 20 07:27:49 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 03:27:49 -0400 (EDT) Subject: [cl-net-snmp-cvs] r88 - vendor/cl-http/server Message-ID: <20071020072749.6F5DC5805E@common-lisp.net> Author: ctian Date: Sat Oct 20 03:27:49 2007 New Revision: 88 Modified: vendor/cl-http/server/variables.lisp Log: Try to use lw:*default-character-element-type* Modified: vendor/cl-http/server/variables.lisp ============================================================================== --- vendor/cl-http/server/variables.lisp (original) +++ vendor/cl-http/server/variables.lisp Sat Oct 20 03:27:49 2007 @@ -349,7 +349,8 @@ #+(or Genera ACLPC) 'character #+MCL (symbol-value 'ccl:*default-character-type*) #+LispWorks3.2 'base-character - #+(or Allegro Lucid CMU LispWorks4 LispWorks5) 'base-char + #+(or Allegro Lucid CMU LispWorks4) 'base-char + #+LispWorks5 (symbol-value 'lw:*default-character-element-type*) #-(or Genera Allegro ACLPC MCL LispWorks Lucid CMU) 'base-character) (define-constant +standard-text-copy-mode+ From ctian at common-lisp.net Sat Oct 20 07:40:42 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 03:40:42 -0400 (EDT) Subject: [cl-net-snmp-cvs] r89 - vendor/cl-http/server Message-ID: <20071020074042.43D7532045@common-lisp.net> Author: ctian Date: Sat Oct 20 03:40:41 2007 New Revision: 89 Modified: vendor/cl-http/server/url.lisp Log: match LispWorks 5 API Modified: vendor/cl-http/server/url.lisp ============================================================================== --- vendor/cl-http/server/url.lisp (original) +++ vendor/cl-http/server/url.lisp Sat Oct 20 03:40:41 2007 @@ -2873,7 +2873,7 @@ (defsetf description %set-description) -(defmethod documentation ((url documentation-mixin) #-(or CMU LispWorks4) &optional doc-type) +(defmethod documentation ((url documentation-mixin) #-(or CMU LispWorks4 LispWorks5) &optional doc-type) (declare (ignore doc-type)) (with-slots (plist) url (getf plist :description))) From ctian at common-lisp.net Sat Oct 20 08:33:07 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 04:33:07 -0400 (EDT) Subject: [cl-net-snmp-cvs] r90 - in vendor/cl-http: client clim/ui lw lw/server mcl/server server Message-ID: <20071020083307.02217330D4@common-lisp.net> Author: ctian Date: Sat Oct 20 04:33:06 2007 New Revision: 90 Modified: vendor/cl-http/client/connection.lisp vendor/cl-http/clim/ui/http-ui.lisp vendor/cl-http/lw/server/time-and-author.lisp vendor/cl-http/lw/start.lisp vendor/cl-http/mcl/server/www-utils.lisp vendor/cl-http/server/data-cache.lisp vendor/cl-http/server/headers.lisp vendor/cl-http/server/server.lisp vendor/cl-http/server/url.lisp Log: Fix for LispWorks 5 64-bit Modified: vendor/cl-http/client/connection.lisp ============================================================================== --- vendor/cl-http/client/connection.lisp (original) +++ vendor/cl-http/client/connection.lisp Sat Oct 20 04:33:06 2007 @@ -447,7 +447,7 @@ (cond ((zerop (connection-free-since connection)) (let* ((time (get-universal-time)) (close (+ time (the integer (or (connection-timeout connection) *client-persistent-connection-timeout*))))) - (declare (bignum time)) + (declare (#-lispworks-64bit bignum #+lispworks-64bit fixnum time)) ;; reset instance variables (setf (connection-free-since connection) time (connection-close-time connection) close)) Modified: vendor/cl-http/clim/ui/http-ui.lisp ============================================================================== --- vendor/cl-http/clim/ui/http-ui.lisp (original) +++ vendor/cl-http/clim/ui/http-ui.lisp Sat Oct 20 04:33:06 2007 @@ -119,8 +119,8 @@ (defun http-ui () "Top level function for starting the HTTP-UI user interface" (or (clim:find-application-frame 'http-ui :create nil) - (let ((width #+Genera clim:+fill+ #-Genera 750) - (height #+Genera clim:+fill+ #-Genera 650)) + (let ((width #+Genera clim:+fill+ #-(or lispworks Genera 750) #+lispworks 1600) + (height #+Genera clim:+fill+ #-(or lispworks Genera 650) #+lispworks 1000)) (clim:run-frame-top-level (clim:make-application-frame 'http-ui :width width :height height))))) @@ -296,8 +296,8 @@ :default proxy-caching-p))) (if proxy-enabled-p (when (not proxy-is-enabled-p) - (http:enable-proxy-service)) - (http:disable-proxy-service)) + (funcall (symbol-function (find-symbol "ENABLE-PROXY-SERVICE" :package :http)))) + (funcall (symbol-function (find-symbol "DISABLE-PROXY-SERVICE" :package :http)))) (setf http::*debug-proxy* debug-proxy http::*proxy-caching-p* proxy-caching-p)))) Modified: vendor/cl-http/lw/server/time-and-author.lisp ============================================================================== --- vendor/cl-http/lw/server/time-and-author.lisp (original) +++ vendor/cl-http/lw/server/time-and-author.lisp Sat Oct 20 04:33:06 2007 @@ -30,7 +30,7 @@ #+unix (defconstant *time-til-70* 2208988800) -#+unix +#+(and unix (not lispworks-64bit)) (defun set-file-dates (file &key creation modification access) (declare (ignore creation)) ; makes no sense on UNIX (let* ((pathname (truename file)) @@ -49,6 +49,12 @@ (unless (zerop (c-utime filename buffer)) (report-unix-error 'set-file-dates (lw:errno-value) pathname))))) +#+(and unix lispworks-64bit) +(defun set-file-dates (file &key creation modification access) + (declare (ignore creation)) ; makes no sense on UNIX + ;; binghe: do nothing until c exception is fixed + t) + #+unix (defun report-unix-error (function errno pathname) (error "Failed to ~A file ~A: ~A(~A)." Modified: vendor/cl-http/lw/start.lisp ============================================================================== --- vendor/cl-http/lw/start.lisp (original) +++ vendor/cl-http/lw/start.lisp Sat Oct 20 04:33:06 2007 @@ -11,6 +11,9 @@ (in-package "CL-USER") +#+lispworks-64bit +(require "clim") + ;;; lispm major.minor LispWorks major.minor (setq *cl-http-server-version* '(70 190 1 9 2)) Modified: vendor/cl-http/mcl/server/www-utils.lisp ============================================================================== --- vendor/cl-http/mcl/server/www-utils.lisp (original) +++ vendor/cl-http/mcl/server/www-utils.lisp Sat Oct 20 04:33:06 2007 @@ -158,7 +158,7 @@ (define next-3am-universal-time (&optional (offset 0) (reference-time (get-universal-time))) "Returns the universal time for the next 3am in the local timezone relative to REFERENCE-TIME. OFFSET is a positive or negative number of seconds relative to 3am." - (declare (fixnum offset) (bignum reference-time)) + (declare (fixnum offset) (#-lispworks-64bit bignum #+lispworks-64bit fixnum reference-time)) (multiple-value-bind (seconds minutes hours date month year day-of-the-week) (decode-universal-time reference-time) (declare (fixnum seconds minutes hours) @@ -169,7 +169,8 @@ #.(* 60. 60. 24.) ;plus 24 hours 0) offset ;offset - (the bignum (encode-universal-time 0 0 3. date month year (time-zone)))))) + (the #-lispworks-64bit bignum + #+lispworks-64bit fixnum (encode-universal-time 0 0 3. date month year (time-zone)))))) ;;;-------------------------------------------------------------------- ;;; Modified: vendor/cl-http/server/data-cache.lisp ============================================================================== --- vendor/cl-http/server/data-cache.lisp (original) +++ vendor/cl-http/server/data-cache.lisp Sat Oct 20 04:33:06 2007 @@ -1062,7 +1062,8 @@ (next-revalidation (recache-data-universe-as-necessary data-universe cache-time)) (finish-time (get-universal-time)) (wait-seconds (- next-revalidation finish-time))) - (declare (bignum start-time finish-time next-revalidation)) + (declare (#-lispworks-64bit bignum #+lispworks-64bit fixnum + start-time finish-time next-revalidation)) #+ignore(notify-log-window "Waiting ~\\time-interval\\ seconds before Revalidating ~A" wait-seconds (data-universe-name data-universe)) (setq elapsed-time (- finish-time start-time)) Modified: vendor/cl-http/server/headers.lisp ============================================================================== --- vendor/cl-http/server/headers.lisp (original) +++ vendor/cl-http/server/headers.lisp Sat Oct 20 04:33:06 2007 @@ -4044,7 +4044,8 @@ (integer cache-time) (cons (apply #'min cache-time))))) (declare (fixnum margin) - (bignum last-modification cache-time cache-universal-time)) + (#-lispworks-64bit bignum #+lispworks-64bit fixnum + last-modification cache-time cache-universal-time)) (< (- last-modification margin) (+ cache-universal-time margin))))) (declaim (inline if-modified-since-p)) Modified: vendor/cl-http/server/server.lisp ============================================================================== --- vendor/cl-http/server/server.lisp (original) +++ vendor/cl-http/server/server.lisp Sat Oct 20 04:33:06 2007 @@ -4260,7 +4260,12 @@ (unless (and directory-string (eql cached-last-modification current-modification) (or (not (numberp use-cache)) - (< (- (the bignum (server-request-time *server*)) (the bignum cache-time)) + ;; LispWorks 5 Point (bignum -> fixnum) + (< (- (the #-lispworks-64bit bignum + #+lispworks-64bit fixnum + (server-request-time *server*)) + (the #-lispworks-64bit bignum + #+lispworks-64bit fixnum cache-time)) use-cache))) #+ignore(fast-format *standard-output* "~&[~I] Caching Directory: ~A" (http::write-standard-time (get-universal-time) stream) ,url) Modified: vendor/cl-http/server/url.lisp ============================================================================== --- vendor/cl-http/server/url.lisp (original) +++ vendor/cl-http/server/url.lisp Sat Oct 20 04:33:06 2007 @@ -4013,7 +4013,8 @@ (with-slots (expiration-function) expiration-mixin (setf expiration-function #'(lambda (url) (declare (ignore url)) - (the bignum (+ *one-year-interval* (get-universal-time))))))) + (the #-lispworks-64bit bignum + #+lispworks-64bit fixnum (+ *one-year-interval* (get-universal-time))))))) (defmethod set-expiration-function ((expiration-mixin expiration-mixin) (type (eql :time)) &rest arguments) (with-slots (expiration-function) expiration-mixin @@ -4029,7 +4030,8 @@ (check-type argument integer) (setf expiration-function #'(lambda (url) (declare (ignore url)) - (the bignum (+ (get-universal-time) argument))))))) + (the #-lispworks-64bit bignum + #+lispworks-64bit fixnum (+ (get-universal-time) argument))))))) (defmethod set-expiration-function ((expiration-mixin expiration-mixin) (type (eql :function)) &rest arguments ) (with-slots (expiration-function) expiration-mixin @@ -4068,7 +4070,8 @@ (check-type argument integer) (setf max-age-function #'(lambda (url) (declare (ignore url)) - (- (the bignum (get-universal-time)) + (- (the #-lispworks-64bit bignum + #+lispworks-64bit fixnum (get-universal-time)) (the integer argument))))))) (defmethod set-max-age-function ((expiration-mixin expiration-mixin) (type (eql :interval)) &rest arguments) @@ -4081,7 +4084,8 @@ (declare (ignore arguments)) (with-slots (max-age-function) expiration-mixin (setf max-age-function #'(lambda (url) - (- (the bignum (get-universal-time)) + (- (the #-lispworks-64bit bignum + #+lispworks-64bit fixnum (get-universal-time)) (the integer (expiration-universal-time url))))))) From ctian at common-lisp.net Sat Oct 20 09:57:57 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 05:57:57 -0400 (EDT) Subject: [cl-net-snmp-cvs] r91 - in vendor/cl-http: lw/server proxy/examples server smtp Message-ID: <20071020095757.79C47481C2@common-lisp.net> Author: ctian Date: Sat Oct 20 05:57:56 2007 New Revision: 91 Modified: vendor/cl-http/lw/server/sysdcl.lisp vendor/cl-http/proxy/examples/configuration.lisp vendor/cl-http/server/variables.lisp vendor/cl-http/smtp/smtp.lisp Log: More fix for LW5 Modified: vendor/cl-http/lw/server/sysdcl.lisp ============================================================================== --- vendor/cl-http/lw/server/sysdcl.lisp (original) +++ vendor/cl-http/lw/server/sysdcl.lisp Sat Oct 20 05:57:56 2007 @@ -46,7 +46,7 @@ #+(or LispWorks4 LispWorks5) "HTTP:lw;server;tcp-stream-4" ; LispWorks 4 specific #-Genera "HTTP:mcl;server;www-utils" ; Some portable utils are there - #+(or LispWorks4.0 LispWorks4.1 LispWorks4.2 LispWorks4.3 LispWorks5) + #+(or LispWorks4.0 LispWorks4.1 LispWorks4.2 LispWorks4.3 LispWorks4.4 LispWorks5) "HTTP:lw;server;time-and-author" ; LispWorks 4 specific file properties #+(or UNIX Harlequin-PC-Lisp) "HTTP:lw;server;unix" ; add-ons for UNIX-like ports @@ -86,8 +86,8 @@ "PREFERENCES" ; Configuration Preference Facility "WEB-CONFIGURATION" ; Server Configuration via the Web #+LispWorks "HTTP:lw;server;tcp-interface" - #+LispWorks4 "http:smtp;smtp" ; Simple SMTP mailer - #+LispWorks4 "http:smtp;mail" ; Interfaces for sending email + #+(and LispWorks4 LispWorks5) "http:smtp;smtp" ; Simple SMTP mailer + #+(and LispWorks4 LispWorks5) "http:smtp;mail" ; Interfaces for sending email )) #-Genera Modified: vendor/cl-http/proxy/examples/configuration.lisp ============================================================================== --- vendor/cl-http/proxy/examples/configuration.lisp (original) +++ vendor/cl-http/proxy/examples/configuration.lisp Sat Oct 20 05:57:56 2007 @@ -54,7 +54,7 @@ ;; The maximum size in bytes that a proxy cache is allows to consume in ;; storage. Use this parameter to control garbage collection. -(setq *proxy-cache-maximum-size* 20000000) ;20 megabytes for a small proxy +(setq *proxy-cache-maximum-size* 2000000000) ;20 Gigabytes for a common proxy ;; The minimum expiration time in seconds for an object to be cached. This ;; bounds resource expiration times. @@ -86,6 +86,23 @@ ;; Define default subnet security for proxy service to avoid a breach of your ;; site's IP security (define-proxy-subnets - #|"128.52.0.0"|# ; MIT AI Lab + "172.16.0.0" + "172.17.0.0" + "172.18.0.0" + "172.19.0.0" + "172.20.0.0" + "172.21.0.0" + "172.22.0.0" + "172.23.0.0" + "172.24.0.0" + "172.25.0.0" + "172.26.0.0" + "172.27.0.0" + "172.28.0.0" + "172.29.0.0" + "172.30.0.0" + "172.31.0.0" + "192.168.0.0" + "127.0.0.0" #.(local-host-ip-address) ;restrict proxy service to local host as default ) Modified: vendor/cl-http/server/variables.lisp ============================================================================== --- vendor/cl-http/server/variables.lisp (original) +++ vendor/cl-http/server/variables.lisp Sat Oct 20 05:57:56 2007 @@ -350,7 +350,7 @@ #+MCL (symbol-value 'ccl:*default-character-type*) #+LispWorks3.2 'base-character #+(or Allegro Lucid CMU LispWorks4) 'base-char - #+LispWorks5 (symbol-value 'lw:*default-character-element-type*) + #+LispWorks5 'base-char #-(or Genera Allegro ACLPC MCL LispWorks Lucid CMU) 'base-character) (define-constant +standard-text-copy-mode+ Modified: vendor/cl-http/smtp/smtp.lisp ============================================================================== --- vendor/cl-http/smtp/smtp.lisp (original) +++ vendor/cl-http/smtp/smtp.lisp Sat Oct 20 05:57:56 2007 @@ -98,7 +98,7 @@ `(let ((,stream (scl:make-instance 'message-body-stream :output-stream ,output-stream))) . ,body)) -#-(or Genera LispWorks4) +#-(or Genera LispWorks4 LispWorks5) (defmacro with-message-body-encoding ((stream output-stream) &body body) `(let ((,stream ,output-stream)) . ,body)) From ctian at common-lisp.net Sat Oct 20 10:06:25 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 06:06:25 -0400 (EDT) Subject: [cl-net-snmp-cvs] r92 - vendor/cl-http/lw/server Message-ID: <20071020100625.2195F250F5@common-lisp.net> Author: ctian Date: Sat Oct 20 06:06:24 2007 New Revision: 92 Modified: vendor/cl-http/lw/server/sysdcl.lisp Log: trivial bugfix for smtp Modified: vendor/cl-http/lw/server/sysdcl.lisp ============================================================================== --- vendor/cl-http/lw/server/sysdcl.lisp (original) +++ vendor/cl-http/lw/server/sysdcl.lisp Sat Oct 20 06:06:24 2007 @@ -86,8 +86,8 @@ "PREFERENCES" ; Configuration Preference Facility "WEB-CONFIGURATION" ; Server Configuration via the Web #+LispWorks "HTTP:lw;server;tcp-interface" - #+(and LispWorks4 LispWorks5) "http:smtp;smtp" ; Simple SMTP mailer - #+(and LispWorks4 LispWorks5) "http:smtp;mail" ; Interfaces for sending email + #+(or LispWorks4 LispWorks5) "http:smtp;smtp" ; Simple SMTP mailer + #+(or LispWorks4 LispWorks5) "http:smtp;mail" ; Interfaces for sending email )) #-Genera @@ -246,4 +246,4 @@ "more-preferences" "presentation-types" "window-log" - "http-ui")) \ No newline at end of file + "http-ui")) From ctian at common-lisp.net Sat Oct 20 11:00:28 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 07:00:28 -0400 (EDT) Subject: [cl-net-snmp-cvs] r93 - vendor/cl-http/lw/server Message-ID: <20071020110028.8F2B1330DB@common-lisp.net> Author: ctian Date: Sat Oct 20 07:00:27 2007 New Revision: 93 Modified: vendor/cl-http/lw/server/tcp-interface.lisp Log: Fix more LW 5 bugs Modified: vendor/cl-http/lw/server/tcp-interface.lisp ============================================================================== --- vendor/cl-http/lw/server/tcp-interface.lisp (original) +++ vendor/cl-http/lw/server/tcp-interface.lisp Sat Oct 20 07:00:27 2007 @@ -375,7 +375,7 @@ (disable-http-service)) ;; force shutdown of all servers and free resources on exit from lisp. -#+LispWorks4 +#+(or LispWorks4 LispWorks5) (eval-when (:load-toplevel) (lw:define-action "When quitting image" "Shutdown CL-HTTP" #'shutdown-http-service) ) From ctian at common-lisp.net Sat Oct 20 14:40:52 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 20 Oct 2007 10:40:52 -0400 (EDT) Subject: [cl-net-snmp-cvs] r94 - vendor/cl-http/lw/server Message-ID: <20071020144052.845835313F@common-lisp.net> Author: ctian Date: Sat Oct 20 10:40:48 2007 New Revision: 94 Modified: vendor/cl-http/lw/server/unix.lisp Log: More fix Modified: vendor/cl-http/lw/server/unix.lisp ============================================================================== --- vendor/cl-http/lw/server/unix.lisp (original) +++ vendor/cl-http/lw/server/unix.lisp Sat Oct 20 10:40:48 2007 @@ -470,18 +470,18 @@ "Returns non-null if PATHNAME?denotes a directory." #+lispworks3.2 (lw:directoryp pathname) - #+lispworks4 + #+(or lispworks4 lispworks5) ;; (lw:file-directory-p pathname) ;this one touches the file system -- JCMa 10/9/2003 (system:directory-pathname-p pathname)) ;;; When it's unclear what shell is used by CL, check the shell argument SHELL ;;; -- OBC -#-LispWorks4 +#-(or LispWorks4 LispWorks5) (defun system (arg) (sys::call-system arg)) ;;; OBC added -#-LispWorks4 +#-(or LispWorks4 LispWorks5) (defun unix-sh-test (cond path &aux (strpath (cond ((stringp path) path) ((pathnamep path) (namestring path))))) @@ -609,21 +609,21 @@ (define create-directories-recursively (pathname) "Recursively create directories according to the directories present in PATHNAME." - #-LispWorks4 + #-(or LispWorks4 LispWorks5) (create-directory-recursively1 pathname) - #+LispWorks4 + #+(or LispWorks4 LispWorks5) (ensure-directories-exist pathname)) ;;; For implementations where pathname-directory does ;;; not return NIL when there is no directory in the pathname. ;;; -- OBC -#-LispWorks4 +#-(or LispWorks4 LispWorks5) (defun pathname-dirs (pathname) (let ((dirs (pathname-directory pathname))) (and (consp dirs) dirs))) ;;; -- OBC -#-LispWorks4 +#-(or LispWorks4 LispWorks5) (defun create-a-directory (path &optional (error-p t)) (let ((str (namestring path))) ;;(directorystring path) (case (system (format nil "mkdir ~S" str)) @@ -636,12 +636,12 @@ ;;; Return path if you can write in it or over it. ;;; -- OBC -#-LispWorks4 +#-(or LispWorks4 LispWorks5) (defun file-permit-p (path &optional (permission "w")) (and (unix-sh-test (concatenate 'string "-" permission) path) path)) ;;; -- OBC -#-LispWorks4 +#-(or LispWorks4 LispWorks5) (defun create-directory-recursively1 (path &optional (error-p t)) (ctypecase path (string (setq path (translate-logical-pathname (pathname path)))) From ctian at common-lisp.net Mon Oct 29 16:08:06 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Mon, 29 Oct 2007 11:08:06 -0500 (EST) Subject: [cl-net-snmp-cvs] r95 - vendor/cl-http Message-ID: <20071029160806.DD3293C00F@common-lisp.net> Author: ctian Date: Mon Oct 29 11:08:06 2007 New Revision: 95 Removed: vendor/cl-http/ Log: remote cl-http From ctian at common-lisp.net Wed Oct 31 13:51:02 2007 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 31 Oct 2007 08:51:02 -0500 (EST) Subject: [cl-net-snmp-cvs] r96 - books/onlisp trunk Message-ID: <20071031135102.2E6CF5C000@common-lisp.net> Author: ctian Date: Wed Oct 31 08:51:02 2007 New Revision: 96 Modified: books/onlisp/0-preface.tex books/onlisp/4-utility_functions.tex trunk/README Log: commit changes Modified: books/onlisp/0-preface.tex ============================================================================== --- books/onlisp/0-preface.tex (original) +++ books/onlisp/0-preface.tex Wed Oct 31 08:51:02 2007 @@ -59,7 +59,7 @@ ????????????????: ???? \textsl{??} ???????. ???????????? Lisp ???---??????????????????????????. ?????????---?? Lisp ????--- ????????????????????. \textsl{On Lisp} ?????????? Lisp ?????. -????, ??????, ?????, ?????, ?????---???? Lisp ??????????. +????, ??????, ?????, ?????, ?????---???? Lisp ??????????. ??, ?????, ????????????????????????????. ??????????????????. ?????????????????????????, ???????????????. Modified: books/onlisp/4-utility_functions.tex ============================================================================== --- books/onlisp/4-utility_functions.tex (original) +++ books/onlisp/4-utility_functions.tex Wed Oct 31 08:51:02 2007 @@ -1,6 +1,9 @@ \chapter{????} \label{chap:utility_functions} +Common Lisp ?????????: ??????????, ???????????? +(special form). ?????????? Lisp ???. ???? ``??'' ????% +??????. ??????, ???????????, ???????????. %%% Local Variables: Modified: trunk/README ============================================================================== --- trunk/README (original) +++ trunk/README Wed Oct 31 08:51:02 2007 @@ -1,3 +1,5 @@ +CL-USER 1 > (clc:clc-require :net-snmp) + CL-USER 2 > (snmp:snmp-walk "localhost" "system") ((# "Linux 2950.lab.163.org 2.6.18-4-xen-vserver-amd64 #1 SMP Fri May 4 03:26:45 UTC 2007 x86_64")