Permalink
Browse files

new files again

  • Loading branch information...
1 parent 318a0d2 commit be894e88d83246638c8bbf02a23067879d73069b Michiel van Oosten committed Mar 31, 2012
Showing with 396 additions and 80 deletions.
  1. +70 −0 #ast-builder.lisp#
  2. +57 −0 #packages.lisp#
  3. +227 −0 #treewalker2.lisp#
  4. +1 −1 language-definition-reader2.lisp
  5. +41 −79 treewalker2.lisp
View
@@ -0,0 +1,70 @@
+(in-package :ast-builder)
+(setf (readtable-case *readtable*) :invert)
+
+(defstruct ast
+ ast sign keyword number string)
+
+(defun build-ast (jack-filename language-definition-filename)
+ (walk-tree jack-filename language-definition-filename)
+ )
+
+(defun convert-to-sexp ()
+ (read-from-string (with-output-to-string (*standard-output*)
+ (print-tokens) )))
+
+
+(defun print-tokens ()
+ (dolist (i (cdr *matched-tokens*))
+ (let ((elt (car i))
+ (type (cadr i))
+ (space (caddr i)))
+ (format t "~a ~a ~a~%" elt type (type-of elt)))))
+
+(defun print-tokens1 ()
+ (dolist (i (cdr *matched-tokens*))
+ (let ((elt (car i))
+ (type (cadr i))
+ (space (caddr i)))
+ (if (not (symbolp elt)) (setf space " ") )
+ (if (symbolp elt) (setf elt (symbol-name elt))
+ (if (equal type "sign") (setf elt "")
+ (if (not ( equal type "ast"))
+ (setf elt (format nil "-~a-" elt)))))
+
+ (format t "~a~a" space elt))))
+
+
+(defun print-stack ()
+ )
+(defun print-stack2 ()
+ (let ((indent 1)
+ (index 0)
+ (stack (reverse stack)))
+ (dotimes (i (length stack))
+ (format t "~VT~a: " indent index )
+ (cond ((equal (car (elt stack i)) '@)
+ (incf indent)
+ ;(pop (elt stack i))
+ ))
+ (incf index)
+ (labels ((p (production)
+ (cond
+ ((null production) nil)
+ (t (format t " ~a~a " (car production) (cadr production))
+ (p (cddr production))))))
+ (p (elt stack i))
+ (format t "~%")))))
+(defun print-stack-top ())
+(defun print-stack-top1 ()
+ (labels ((p (production)
+ (cond
+ ((null production) nil)
+ (t (format t " ~a~a " (car production) (cadr production))
+ (p (cddr production))))))
+ (p (car stack))
+ (format t "~%")))
+
+
+
+(build-ast "c:/home/mysrc/lisp/eocs/11/Pong/Main.jack"
+ "c:/home/mysrc/lisp/eocs/jack-compiler/jack-def-test.txt")
View
@@ -0,0 +1,57 @@
+(in-package :common-lisp)
+(defpackage :com.gigamonkeys.pathnames
+ (:use :common-lisp)
+ (:nicknames :pathnames)
+ (:export
+ :list-directory
+ :file-exists-p
+ :directory-pathname-p
+ :file-pathname-p
+ :pathname-as-directory
+ :pathname-as-file
+ :walk-directory
+ :directory-p
+ :file-p))
+(defpackage :com.michieljoris.eocs.language-definition
+ (:nicknames :language-definition)
+ (:use :cl)
+ (:export :load-language-definition-file :get-toplevel-construct-definition
+ :get-construct-definition :get-construct-definition-readable))
+(defpackage :com.michieljoris.eocs.tokenizer
+ (:nicknames :tokenizer)
+ (:use :cl)
+ (:export :load-tokens
+ :get-token
+ :set-mark
+ :go-back-to-last-set-mark
+ :discard-last-set-mark
+ :alpha_
+ :sign
+ :string
+ :number))
+(defpackage :com.michieljoris.eocs.tree-walker
+ (:use :cl :tokenizer :language-definition)
+ (:nicknames :tree-walker)
+ (:export :walk-tree))
+(defpackage :com.michieljoris.eocs.ast-builder
+ (:use :cl :tree-walker)
+ (:nicknames :ast-builder)
+ (:export :build-ast))
+(defpackage :com.michieljoris.eocs.jack-compiler
+ (:use :cl)
+ (:nicknames :jack-compiler)
+ (:export :compile-jack))
+(defpackage :com.michieljoris.hack-assembler
+ (:use :cl :pathnames :pregexp)
+ (:nicknames :hack-assembler)
+ (:export :compile-asm))
+(defpackage :com.michieljoris.eocs.vm-compiler
+ (:use :cl)
+ (:nicknames :vm-compiler)
+ (:export :compile-vm))
+(defpackage :com.michieljoris.eocs
+ (:use :cl pathnames :jack-compiler :vm-compiler :hack-assembler)
+ (:nicknames :eocs)
+ (:export)
+)
+
View
@@ -0,0 +1,227 @@
+;Exhaustive depth first recursive search EBNF programmable LL parser
+;producing AST in sexpr form
+(in-package :tree-walker)
+(setf (readtable-case *readtable*) :invert)
+(defparameter stack nil)
+(defparameter *matched-tokens* (list nil))
+(defparameter *current-token* *matched-tokens*)
+(defparameter *mark-stack* (list nil))
+(defparameter newline (string (coerce '(#\Newline) 'string)))
+
+(defun walk-tree (jack-filename language-definition-filename)
+ (load-tokens jack-filename)
+ (load-language-definition-file language-definition-filename)
+ (init-terminal-generator)
+ (format t "Starting processing -------------------------------~%")
+ (format t "~a~%" (compare-and-iterate (get-terminal t) (get-token)))
+ ;; (print-tokens)
+ *matched-tokens*
+ ;; (print-stack2)
+ )
+
+(defun compare-and-iterate (terminal token)
+ ;; (format t "comparing: terminal [~a] and token [~a]~%" terminal (car token))
+ (cond
+ ((and terminal (not token)) "ERROR: Unexpected EOF")
+ ((and (not terminal) token) "ERROR: EOF expected")
+ ((not (or token terminal)) "Success!!")
+ (t (compare-and-iterate
+ (get-terminal (match terminal token)) (get-token)))))
+
+(defun get-terminal (last-match)
+ (if (null stack)
+ (format t "Stack is emptky. No valid parse found...")
+ (cond
+ (last-match
+ (cond ((listp last-match)
+ (record-match last-match)))
+ (cond
+ ((null (car stack))
+ (format t "Top of stack is empty. Found a valid parse~%")
+ (pop stack)
+ ;to find other parses, do a get-terminal here..
+ nil)
+ (t
+ (expand-node)
+ (let ((terminal (pop (car stack))))
+ (pop (car stack))
+ (cond
+ ((is-ast-marker terminal)
+ (record-match (list terminal "ast" ""))
+ ;; ((equal terminal 'close)
+ ;; (record-match (list "close" "ast" ""))
+ (get-terminal t))
+ (t terminal))))))
+ (t
+ ;; (format t "Discarding path: ~%" ))
+ (pop stack)
+ (cut-branches)
+ (go-back-to-last-set-marks)
+ (get-terminal t)))))
+
+(defun is-ast-marker (sym)
+ (and (symbolp sym) ( equal #\$ (elt (symbol-name sym) 0))))
+
+(defun cut-branches ()
+ (cond ((equal '@ (caar stack)) ;this is a node,
+ (pop stack) ;discarded all paths, so discarding node
+ (discard-last-set-marks)
+ (cut-branches)))
+
+ )
+
+(defun match (terminal token)
+ ;; (format t "matching [~a] with [~a]~%" terminal (car token))
+ (if (stringp terminal) (progn
+ ;; (format t "string compare result: ~a~%"
+ ;; (equal terminal (car token)))
+ (if (equal terminal (car token))
+ token))
+
+ ;; (if (symbolp terminal)
+
+ (let ((sym-name (symbol-name terminal)))
+ (cond
+ ((string-equal sym-name "stringConstant")
+ (stringConstant token))
+ ((string-equal sym-name "identifier")
+ (identifier token))
+ ((string-equal sym-name "integerConstant")
+ ;; (record-match token)
+ (integerConstant token))
+ (t (error "Don't know this terminal: ~a~%" terminal))))))
+;; (handler-case (funcall terminal token)
+;; (undefined-function
+;; () (format t "Error: undefined construct ~a~%" terminal)))))
+
+
+(defun init-terminal-generator ()
+ (setf stack nil)
+ (setf *matched-tokens* (list nil))
+ (setf *current-token* *matched-tokens*)
+ (setf *mark-stack* (list nil))
+ (set-marks)
+ (push (cons '@ (get-toplevel-construct-definition)) stack)
+ (push (cdar stack) stack)
+ )
+
+(defun factor-out-regex (elt q)
+ (let ((sn (symbol-name q)))
+ (cond
+ ((equal sn "?")
+ ;; (record-match (list "open-list" "ast" ""))
+ (list '$open-list '! (list '/ elt '! nil '!) '! '$close-list '!) )
+ ;; (list (list '/ elt '! nil '!) '! ) )
+ ((equal sn "*")
+ ;; (record-match (list "open" "ast" ""))
+ (list '$open-list '! ( list '/ (list elt '! elt '*) '! nil '!) '!
+ '$close-list '!) )
+ ;; (list ( list '/ (list elt '! elt '*) '! nil '!) '! ) )
+ ((equal sn "+") (list elt '! elt '*))
+ (t (list elt '!)))))
+
+(defun unpack-top-node ()
+ (let* ((top (pop stack))
+ (node (factor-out-regex (pop top) (pop top))))
+ (push (concatenate 'list node top) stack)))
+
+(defun expand-node ()
+ (unpack-top-node)
+ ;; (format t ">>>foctored out the regex ? and + and * of the first elt:~%")
+ ;; (print-stack-top)
+ (let ((node (caar stack)))
+ (cond
+ ((listp node)
+ (cond
+ ((equal (car node) '/)
+ (let ((top (car stack)))
+ (push (set-marks) (car stack))
+ (push '@ (car stack)) ;mark it as a node
+ ;(cond ((car stack) (push nil stack) (set-marks)))
+ (grow-branches (cdr node) (cddr top))
+ ;; (format t ">>>Grew branches:~%")
+ ;; (print-stack)
+ (expand-node)))
+ (t
+ (let ((prod (pop stack)))
+ (push (concatenate 'list (car prod) (cddr prod)) stack)
+ ;; (format t ">>>Unwrapped list [~a]:~%" (car prod))
+ ;; (print-stack-top)
+ (expand-node))
+ )))
+ ((not (stringp (caar stack)))
+ (let ((def (get-construct-definition (caar stack))))
+ (if def
+ (let ((prod (pop stack)))
+ ;; (record-match (list "open-production" "ast" ""))
+ ;; (record-match (list (car prod) "def" ""))
+ ;; (format t "~a" (dollarfy-symbol (car prod)))
+ (push (concatenate 'list
+ (list (prefix-symbol "$open-" (car prod)) '!)
+ def
+ (list (prefix-symbol "$close-" (car prod)) '!)
+ (cddr prod)) stack)
+ ;; (format t ">>>Expanded prodname [~a]:~%" (car prod))
+ ;; (print-stack-top)
+ (expand-node))))))))
+
+(defun prefix-symbol (str sym)
+ (intern (concatenate 'string str (symbol-name sym))))
+
+(defun grow-branches (branches rest-of-branch)
+ (cond
+ ((null branches) nil)
+ (t (let ((elt (pop branches))
+ (q (pop branches)))
+ (if elt
+ (if (and (listp elt) (equal q '!) (not (equal '/ (car elt))))
+ (push (concatenate 'list elt rest-of-branch) stack)
+ (push (cons elt (cons q rest-of-branch)) stack))
+ (push rest-of-branch stack))
+ (grow-branches branches rest-of-branch)))))
+
+
+(defun start ()
+ (init-terminal-generator)
+ ;; (print-stack)
+ )
+
+
+(defun set-marks ()
+ (push *current-token* *mark-stack*)
+ (set-mark)
+ )
+
+(defun go-back-to-last-set-marks ()
+ (go-back-to-last-set-mark)
+ (setf *current-token* (car *mark-stack*))
+ )
+
+(defun discard-last-set-marks ()
+ (discard-last-set-mark)
+ (let ((discarded-mark (car ( pop *mark-stack*))))
+ (declare (ignore discarded-mark))
+ ))
+
+
+(defun identifier (token)
+ ;; (format t "Comparing [~a] with [~a]~%" (cdr token) "alpha_")
+ ;; (if (equal (cdr token) "alpha_")
+ ;; (format t "Validated by custom function..~%")
+ ;; (format t "Not validated by custom function!!!~%")
+ ;; )
+ ;; (print (type-of token))
+ ;; (print (type-of "alpha_"))
+ ;; (format t "type of token is :~a~%" (cadr token))
+ (if (equal (cadr token) "alpha_") token))
+
+(defun integerConstant (token)
+ (if (equal (cadr token) "number") token))
+
+(defun stringConstant (token)
+ (if (equal (cadr token) "string") token))
+
+(defun record-match (match)
+ (let ((m (list match)))
+ (setf (cdr *current-token*) m)
+ (setf *current-token* m)))
@@ -117,7 +117,7 @@
(defun get-construct-definition (element)
(incf *counter*)
- (if (> *counter* 3000) (error "to many def requests. Must be a loop!!!"))
+ (if (> *counter* 8000) (error "to many def requests. Must be a loop!!!"))
(getf production-list element))
(defun get-construct-definition-readable (element)
(getf dlist element))
Oops, something went wrong.

0 comments on commit be894e8

Please sign in to comment.