flo

#!/local/bin/kalypso
;
; Copyright © 2019 Keith Packard <keithp@keithp.com>
;
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful, but
; WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
; General Public License for more details.
;
; You should have received a copy of the GNU General Public License along
; with this program; if not, write to the Free Software Foundation, Inc.,
; 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
;
;
; flo
;
; factor left common expressions out of a grammar
;

;
; remove the first element from each of a list
; of productions (unless the production is nil)
;

(defun clip-firsts (productions)
  (cond (productions
	 (cond ((car productions)
	       	(cons (caar productions) (clip-firsts (cdr productions)))
		)
	       (t (clip-firsts (cdr productions)))
	       )
	 )
	(t nil)
	)
  )

;
; return the first duplicated element from a list of elements
;

(defun has-common (firsts)
  (cond ((nil? firsts) nil)
	((member? (car firsts) (cdr firsts)) (car firsts))
	(t (has-common (cdr firsts)))
	)
  )

;
; return a list of productions which have the given
; element as their first member
;
(defun with-first (productions first)
  (cond ((nil? productions) nil)
	((= (caar productions) first)
	 (cons (car productions) (with-first (cdr productions) first))
	 )
	(t (with-first (cdr productions) first))
	)
  )

;
; return a list of productions which *don't* have the given
; element as their first member
;
(defun without-first (productions first)
  (cond ((nil? productions) nil)
	((not (= (caar productions) first))
	 (cons (car productions) (without-first (cdr productions) first))
	 )
	(t (without-first (cdr productions) first))
	)
  )


;
; strip the first 'count' elements off a list of productions
;

(defun remove-firsts (productions count)
  (cond ((nil? productions) nil)
	(t (cons (nthcdr count (car productions))
		 (remove-firsts (cdr productions)
				count
				)
		 )
	   )
	)
  )

;
; return 't if each production in the list has the same first
; element
;
(defun all-common-first (productions)
  (cond ((and productions (cdr productions))
	 (cond ((or (and (nil? (car productions))
			 (nil? (cadr productions))
			 )
		    (and (car productions)
			 (cadr productions)
		    	 (= (caar productions) (caadr productions))
			 )
		    )
		(all-common-first (cdr productions))
		)
	       (t nil)
	       )
	 )
	(t)
	)
  )

;
; return the maximal list of common first sub-lists
; from a set of productions
;
(defun max-common (productions)
  (cond ((all-common-first productions)
	 (cons (caar productions)
	       (max-common (remove-firsts productions 1))
	       )
	 )
	(t
	 nil)
	)
  )

;
; factor out common left sub-lists from the list
; of productions associated with a particular non-terminal
;
(defun eliminate-common (non-terminal dictionary)
  (let ((productions (eval non-terminal))
  	(firsts)
	(common)
	(common-list)
	(removed)
	(new)
	(new-name)
	)
    (setq firsts (clip-firsts productions))
    (setq common (has-common firsts))
    (cond (common
	   (setq removed (with-first productions common))
	   (setq common-list (max-common removed))
	   (setq new-name (get-name non-terminal))
	   (setq new t)
	   ;
	   ; generate a name for the new non-terminal
	   ;  keep appending "p" until it's new
	   ;
	   (while new
		  (setq new-name (strcat new-name "p"))
		  (setq new (dictionary-lookup dictionary new-name))
		  )
	   (setq new (symbol new-name dictionary))
	   (set new (remove-firsts removed (length common-list)))
	   (set non-terminal (cons (conc common-list (list new))
				    (without-first productions common))
		 )
	   (cons new (conc (eliminate-common new dictionary)
	  		   (eliminate-common non-terminal dictionary)
			   )	
		 )
	   )
	  (t nil)
	  )
    )
  )
	   
;
; remove common left sub-expressions from each non-terminal
; in the grammar
;
(defun factor-left (non-terminals)
  (let ((l) (new))
    (setq l non-terminals)
    (while l
	   (setq new (eliminate-common (car l) flo-dictionary))
	   (cond (new
	   	  (setq non-terminals (conc non-terminals new))
		  )
		 )
	   (setq l (cdr l))
	   )
    non-terminals
    )
  )

(defun to-non-terminal-list (grammar)
  (if grammar
      (let ((name (caar grammar)))
	(set name (cdar grammar))
	(cons name (to-non-terminal-list (cdr grammar)))
	)
   else
      nil
      )
  )

(defun from-non-terminal-list (non-terminals)
  (cond (non-terminals
	 (cons (cons (car non-terminals) (eval (car non-terminals)))
	       (from-non-terminal-list (cdr non-terminals))
	       )
	 )
	(nil)
	)
  )

(defun print-productions (productions)
  (cond (productions
	 (patom "\t")
	 (cond ((car productions)
 	 	(print (car productions))
		)
	       (t (patom "()"))
	       )
	 (terpr)
	 (print-productions (cdr productions))
	 )
	)
  )

(defun print-one-set (set)
  (patom " (")
  (print (car set)) (terpr)
  (print-productions (cdr set))
  (patom "\t)\n")
  )

(defun print-grammars (grammar)
  (cond (grammar
	 (print-one-set (car grammar))
	 (print-grammars (cdr grammar))
	 )
	)
  )

(defun print-grammar (grammar)
  (patom "(\n")
  (print-grammars grammar)
  (patom " )\n")
  )

(defun flo-file (fd)
  (setq flo-dictionary (new-dictionary))
  (setq grammar (fread-dictionary fd flo-dictionary))
  (setq non-terminals (to-non-terminal-list grammar))
  (setq result (from-non-terminal-list (factor-left non-terminals)))
  (print-grammar result)
  )

(setq file-in stdin)

(setq argv (cdr argv))

(if argv
    (setq file-in (fopen (car argv) 'r))
    (if (nil? file-in)
	(error (strcat "flo: can't open " (sprint (car argv))))
	)
    )

(flo-file file-in)