[lisp-snmp] [patch] CL-YACC support in ASN.1 (was Re: SF.net SVN: cl-net-snmp:[737] asn.1/trunk)

[Chun T. (binghe) <bin...@gm...>]

Hi, John

I've merged your patch in a quite different way:

1) Define a variable *asn.1-syntax* to hold all LALR syntax rules.
2) Convert your CL-YACC changes into loadable patch and put them in  
#p"ASN1:vendor;"
3) On LispWorks, still use PARSERGEN
4) On non-LispWorks, use your DEFPARSER-TO-YACC to convert *asn.1- 
syntax* into CL-YACC format.

5) The "eval-compile-asn.1" funtion haven't merged.

I think it's beautiful way to made this big changes and only generate  
minimum diff to original code, but ... it seems that something goes  
wrong, either in CL-YACC patch side, or in DEFPARSER-TO-YACC. Can you  
find it?

Regards,

--binghe

On 2009-2-7, at 00:04, bi...@us... wrote:

> Revision: 737
>          http://cl-net-snmp.svn.sourceforge.net/cl-net-snmp/?rev=737&view=rev
> Author:   binghe
> Date:     2009-02-06 16:04:09 +0000 (Fri, 06 Feb 2009)
>
> Log Message:
> -----------
> [asn.1] merge YACC patch from John Fremlin (MSI)
>
> Modified Paths:
> --------------
>    asn.1/trunk/asn.1-dev.asd
>    asn.1/trunk/compiler/compiler.lisp
>    asn.1/trunk/compiler/parser.lisp
>    asn.1/trunk/compiler/syntax.lisp
>
> Added Paths:
> -----------
>    asn.1/trunk/vendor/yacc.lisp
>
> Modified: asn.1/trunk/asn.1-dev.asd
> ===================================================================
> --- asn.1/trunk/asn.1-dev.asd	2009-02-06 16:00:46 UTC (rev 736)
> +++ asn.1/trunk/asn.1-dev.asd	2009-02-06 16:04:09 UTC (rev 737)
> @@ -10,7 +10,6 @@
> #+lispworks
> (require "parsergen")
>
> -#+lispworks
> (defsystem asn.1-dev
>   :description "ASN.1 Compiler"
>   :version "5.0-dev"
> @@ -18,6 +17,7 @@
>   :author "Chun Tian (binghe) <bin...@gm...>"
>   :depends-on (:asn.1 #-lispworks :yacc)
>   :components ((:module "compiler"
> +                :depends-on ("vendor")
> 		:components ((:file "reader")
> 			     (:file "syntax")
> 			     (:file "parser"
> @@ -27,4 +27,6 @@
>                              (:file "compiler"
>                               :depends-on ("sort" "parser" "compile- 
> type"))
>                              (:file "interpreter"
> -                              :depends-on ("compiler"))))))
> +                              :depends-on ("compiler"))))
> +               (:module "vendor"
> +                :components (#-lispworks (:file "yacc")))))
>
> Modified: asn.1/trunk/compiler/compiler.lisp
> ===================================================================
> --- asn.1/trunk/compiler/compiler.lisp	2009-02-06 16:00:46 UTC (rev  
> 736)
> +++ asn.1/trunk/compiler/compiler.lisp	2009-02-06 16:04:09 UTC (rev  
> 737)
> @@ -3,7 +3,7 @@
>
> (in-package :asn.1)
>
> -(defvar *mib-name-map-table* (make-hash-table :test #'string=))
> +(defvar *mib-name-map-table* (make-hash-table :test #'equal))
>
> ;;; Empty and old MIB module
> (defvar *mib-name-map* nil)
>
> Modified: asn.1/trunk/compiler/parser.lisp
> ===================================================================
> --- asn.1/trunk/compiler/parser.lisp	2009-02-06 16:00:46 UTC (rev 736)
> +++ asn.1/trunk/compiler/parser.lisp	2009-02-06 16:04:09 UTC (rev 737)
> @@ -3,13 +3,28 @@
>
> (in-package :asn.1)
>
> +#+lispworks
> +(macrolet ((define-parser (name syntax)
> +             `(parsergen:defparser ,name ,@syntax)))
> +  (define-parser asn.1-parser #.*asn.1-syntax*))
> +
> +#-lispworks
> +(macrolet ((define-parser (name reserved-words start-symbol syntax)
> +             `(yacc:define-parser ,name
> +                (:terminals ,reserved-words)
> +                (:start-symbol ,start-symbol)
> +                ,@syntax)))
> +  (define-parser *asn.1-parser*
> +                 #.(list* :id :number :string *reserved-words*)
> +                 %module-definition
> +                 #.(defparser-to-yacc *asn.1-syntax*)))
> +
> (defun asn.1-lexer (stream)
>   (let ((*readtable* *asn.1-readtable*)
>         (*package* (find-package :asn.1)))
>     (let ((token (read stream nil nil nil)))
> -      (if token
> -        (values (detect-token token) token)
> -        (values nil nil)))))
> +      (when token
> +        (values (detect-token token) token)))))
>
> (defgeneric detect-token (token))
>
> @@ -33,7 +48,10 @@
>     (parse s)))
>
> (defmethod parse ((source stream))
> -  (asn.1-parser #'(lambda () (asn.1-lexer source))))
> +  (funcall #+lispworks #'asn.1-parser
> +           #-lispworks #'yacc:parse-with-lexer
> +           #'(lambda () (asn.1-lexer source))
> +           #-lispworks *asn.1-parser*))
>
> (defmethod parse ((source t))
>   (error "Unknown Parser Source"))
>
> Modified: asn.1/trunk/compiler/syntax.lisp
> ===================================================================
> --- asn.1/trunk/compiler/syntax.lisp	2009-02-06 16:00:46 UTC (rev 736)
> +++ asn.1/trunk/compiler/syntax.lisp	2009-02-06 16:04:09 UTC (rev 737)
> @@ -44,9 +44,9 @@
> (eval-when (:load-toplevel :execute)
>   (fill-reserved-words))
>
> -(parsergen:defparser asn.1-parser
> +(defparameter *asn.1-syntax* '(
>   ((%root %module-definition) $1)
> -  ((root assignment) $1)
> +  ;; ((root assignment) $1)
>   ((%module-definition :id
>                        DEFINITIONS
>                        %tag-default
> @@ -244,3 +244,61 @@
>   ((%general IDENTIFIER) $1)
>   ((%general INTEGER) $1)
>   ((%general |IA5String|) $1))
> +) ;; defvar *asn.1-syntax*
> +
> +;;; binghe: flatten is from alexandria project
> +(defun flatten (tree)
> +  "Traverses the tree in order, collecting non-null leaves into a  
> list."
> +  (let (list)
> +    (labels ((traverse (subtree)
> +               (when subtree
> +                 (if (consp subtree)
> +                     (progn
> +                       (traverse (car subtree))
> +                       (traverse (cdr subtree)))
> +                     (push subtree list)))))
> +      (traverse tree))
> +    (nreverse list)))
> +
> +;;; binghe: following funtions is contributed by John Fremlin from  
> MSI <jf...@ms...>
> +
> +(defun defparser-production-to-yacc (grammar-symbols forms)
> +  (cond ((not (and forms (or (not (listp forms)) (some 'identity  
> forms))))
> +	 nil)
> +	(t
> +	 (labels ((make-var (i)
> +		    (intern (format nil "$~D" i)))
> +		  (vars ()
> +		    (loop for i from 1
> +                          for x in grammar-symbols collect (make- 
> var i)))
> +		  (used-vars ()
> +                    (remove-duplicates
> +                     (loop for sym in (flatten forms)
> +                           when (and (symbolp sym) (eql #\$ (elt  
> (symbol-name sym) 0))
> +                                     (ignore-errors (parse-integer  
> (symbol-name sym) :start 1)))
> +                           collect (make-var (parse-integer (symbol- 
> name sym) :start 1)))
> +                     :test 'eql)))
> +	   (let ((unused-vars (set-difference (vars) (used-vars))))
> +	     (list `#'(lambda(,@(vars))
> +                        ,@(when unused-vars  (list `(declare  
> (ignore ,@unused-vars))))
> +                        ,forms)))))))
> +
> +(defun defparser-to-yacc (rules)
> +  (let (grouped-rules)
> +    (loop for rule in rules do
> +	  (destructuring-bind ((non-terminal &rest grammar-symbols)  
> &optional forms)
> +	      rule
> +	    (assert non-terminal)
> +            #+ignore
> +            (push (append grammar-symbols (defparser-production-to- 
> yacc grammar-symbols forms))
> +		  (sys:cdr-assoc non-terminal grouped-rules))
> +            ;;; binghe: I don't know if this rewrite is correct ...
> +            (let ((temp (assoc non-terminal grouped-rules))
> +                  (item (append grammar-symbols
> +                                (defparser-production-to-yacc  
> grammar-symbols forms))))
> +              (if (null temp)
> +                  (setf grouped-rules (acons non-terminal item  
> grouped-rules))
> +                (rplacd temp
> +                        (push item (cdr temp)))))))
> +    (loop for (name . alternatives) in (nreverse grouped-rules)
> +	  collect `(,name ,@(reverse alternatives)))))
>
> Added: asn.1/trunk/vendor/yacc.lisp
> ===================================================================
> --- asn.1/trunk/vendor/yacc.lisp	                        (rev 0)
> +++ asn.1/trunk/vendor/yacc.lisp	2009-02-06 16:04:09 UTC (rev 737)
> @@ -0,0 +1,75 @@
> +;;;; -*- Mode: Lisp -*-
> +;;;; $Id$
> +
> +;;;; Patch to CL-YACC, made by John Fremlin from MSI  
> <jf...@ms...>, waiting for merge
> +
> +(in-package :yacc)
> +
> +(define-condition conflict-warning (yacc-compile-warning simple- 
> warning)
> +  ((kind :initarg :kind :reader conflict-warning-kind)
> +   (state :initarg :state :reader conflict-warning-state)
> +   (terminal :initarg :terminal :reader conflict-warning-terminal)
> +   (chosen-action :initarg :chosen-action :reader conflict-warning- 
> chosen-action :initform nil))
> +  (:report (lambda (w stream)
> +             (format stream "~A conflict on terminal ~S in state  
> ~A, ~_~?, ~@[taking action ~A~]"
> +                     (case (conflict-warning-kind w)
> +                       (:shift-reduce "Shift/Reduce")
> +                       (:reduce-reduce "Reduce/Reduce")
> +                       (t (conflict-warning-kind w)))
> +                     (conflict-warning-terminal w)
> +                     (conflict-warning-state w)
> +                     (simple-condition-format-control w)
> +                     (simple-condition-format-arguments w)
> +		     (conflict-warning-chosen-action w)))))
> +
> +(defun handle-conflict (a1 a2 grammar action-productions id s
> +                        &optional muffle-conflicts)
> +  "Decide what to do with a conflict between A1 and A2 in state ID  
> on symbol S.
> +Returns three actions: the chosen action, the number of new sr and  
> rr."
> +  (declare (type action a1 a2) (type grammar grammar)
> +           (type index id) (symbol s))
> +  (when (action-equal-p a1 a2)
> +    (return-from handle-conflict (values a1 0 0)))
> +  (when (and (shift-action-p a2) (reduce-action-p a1))
> +    (psetq a1 a2 a2 a1))
> +  (let ((p1 (cdr (assoc a1 action-productions)))
> +        (p2 (cdr (assoc a2 action-productions))))
> +    ;; operator precedence and associativity
> +    (when (and (shift-action-p a1) (reduce-action-p a2))
> +      (let* ((op1 (find-single-terminal (production-derives p1)  
> grammar))
> +             (op2 (find-single-terminal (production-derives p2)  
> grammar))
> +             (op1-tail (find-precedence op1 (grammar-precedence  
> grammar)))
> +             (op2-tail (find-precedence op2 (grammar-precedence  
> grammar))))
> +        (when (and (eq s op1) op1-tail op2-tail)
> +          (cond
> +            ((eq op1-tail op2-tail)
> +             (return-from handle-conflict
> +               (ecase (caar op1-tail)
> +                 ((:left) (values a2 0 0))
> +                 ((:right) (values a1 0 0))
> +                 ((:nonassoc) (values nil 0 0)))))
> +            (t
> +             (return-from handle-conflict
> +               (if (tailp op2-tail (cdr op1-tail))
> +                   (values a1 0 0)
> +                   (values a2 0 0))))))))
> +    ;; default: prefer first defined production
> +    (let ((kind (typecase a1
> +                  (shift-action :shift-reduce)
> +                  (t :reduce-reduce)))
> +	  (chosen-action
> +	   (if (production< p1 p2)
> +	       a1
> +             a2)))
> +      (unless muffle-conflicts
> +	(warn (make-condition
> +               'conflict-warning
> +               :kind kind
> +               :state id :terminal s
> +               :format-control "~S and ~S~@[ ~_~A~]~@[ ~_~A~]"
> +               :format-arguments (list a1 a2 p1 p2)
> +               :chosen-action chosen-action)))
> +      (values chosen-action
> +	      (if (eq kind :shift-reduce) 1 0)
> +	      (if (eq kind :reduce-reduce) 1 0)))))
> +
>
>
> Property changes on: asn.1/trunk/vendor/yacc.lisp
> ___________________________________________________________________
> Added: svn:keywords
>   + Id
>
>
> This was sent by the SourceForge.net collaborative development  
> platform, the world's largest Open Source development site.

--
Chun Tian (binghe)
NetEase.com, Inc.
P. R. China