Skip to content
Browse files

[cl-backend] refactor the way subs are compiled

  • Loading branch information...
1 parent a7f0672 commit a7cd0754ce8959696dfa89c44079e3ec3406523f @pmurias pmurias committed
Showing with 57 additions and 38 deletions.
  1. +57 −38 cl-backend/backend.lisp
View
95 cl-backend/backend.lisp
@@ -2,6 +2,10 @@
(user-homedir-pathname)))
(ql:quickload "cl-json")
(ql:quickload "fare-matcher")
+
+
+; Logging - not sure we need it
+
(ql:quickload "cl-log")
(use-package "COM.RAVENBROOK.COMMON-LISP-LOG")
@@ -10,21 +14,24 @@
(log-message :info "cl-backend started")
-(defun nam-op-log (name result) (log-message :info (format nil "~a => ~w" name (strip-ann result))) result)
+(defun nam-op-log (name result) "Log what an nam op gets transformed into" (log-message :info (format nil "~a => ~w" name (strip-ann result))) result)
+; Macros
+
+(defmacro nam-op (name params &body body) `(defmacro ,(concat-symbol 'nam- name) ,params (nam-op-log ',name (progn ,@body))))
+
(defun strip-ann (thing)
(if (consp thing)
(if (eq (first thing) 'nam-ann)
- (strip-ann (cadddr thing))
+ (strip-ann (fourth thing))
(mapcar #'strip-ann thing)
)
thing))
(defun concat-symbol (a b) (intern (concatenate 'string (string a) (string b))))
-(defmacro nam-op (name params &body body) `(defmacro ,(concat-symbol 'nam- name) ,params (nam-op-log ',name (progn ,@body))))
(defun to-symbol-first (thing)
@@ -64,8 +71,30 @@
-(nam-op sub (i lexicals body)
- `(defun ,(sub-symbol i) () (let ,(lexicals-to-let lexicals) ,body)))
+(defmacro define-nam-sub
+ (i ; The Xref Id
+ name ; Sub's name for backtraces
+ outer_xref ; OUTER:: sub, may be in a setting unit
+ flags ; See doc/nam.pod
+ children ; Supports tree traversals
+ param_role_hack ; See doc/nam.pod
+ augment_hack ; See doc/nam.pod
+ hint_hack ; See doc/nam.pod
+ is_phaser ; See doc/nam.pod
+ body_of ; Only valid in immediate block of class {} et al
+ in_class ; Innermost enclosing body_of
+ cur_pkg ; OUR:: as a list of names
+ class ; &?BLOCK.WHAT; "Sub" or "Regex"
+ ltm ; Only for regexes; stores declarative prefix
+ exports ; List of global names
+ signature ; May be null in exotic cases
+ lexicals ; Come in multiple forms
+ nam ; See description of opcodes earlier
+ )
+
+ `(defun ,(sub-symbol i) () (let ,(lexicals-to-let lexicals) ,@nam)))
+
+
(defun xref-to-subsymbol (xref) (sub-symbol (cadr xref)))
@@ -75,7 +104,7 @@
`(defmethod ,(intern name) (invocant) (,(xref-to-subsymbol xref))))))
-(nam-op class (name attributes methods)
+(defun define-nam-class (name attributes methods)
`(progn
(defclass ,(class-symbol name) (p6-Object) ())
,@(mapcar #'compile-method methods)
@@ -137,39 +166,27 @@
(nam-op newboundvar (dunno1 dunno2 thing) thing)
+(defun compile-sub-or-packagoid (i def)
+ (let* ((type (first def))
+ (args (if (equal type "sub") (append (butlast (rest def)) (list (to-symbol-first (last def)))) (rest def))))
+
+ `(
+ ,(intern (string-upcase (concatenate 'string "define-nam-" type)))
+ ,i
+ ,@args
+ )))
+
-(defun compile-sub (i sub)
- (fare-matcher:match sub
- ((and (list
- sub ; "sub" literal
- name
- outer ; raw xref
- flags
- dunno-what-that-is ; [ map { $_->xref->[1] } @{ $self->zyg } ]
- parametric-role-hack
- augment-hack
- hint-hack
- is-phaser
- body-of
- in-class
- cur-pkg
- class
- ltm
- exports
- signature-params
- lexicals
- nam
- ) (when (equal sub "sub"))) (list 'nam-sub i lexicals (to-symbol-first nam)))
- ((and (list
- class ; "class" literal
- name
- exports
- attributes
- methods
- superclasses
- linearized_mro
- ) (when (equal class "class"))) (list 'nam-class name attributes methods))))
+;; ((and (list
+;; class ; "class" literal
+;; name
+;; exports
+;; attributes
+;; methods
+;; superclasses
+;; linearized_mro
+;; ) (when (equal class "class"))) (list 'define-nam-class name attributes methods))))
@@ -186,7 +203,7 @@
xref ; Resolves refs from other units
tdeps ; Holds dependency data for recompilation
stash_root ; Trie holding classes and global variables
- ) (loop for sub in xref for i upfrom 0 collect (compile-sub i sub)))))
+ ) (loop for thing in xref for i upfrom 0 collect (compile-sub-or-packagoid i thing)))))
(defun print-thing (thing) (format t "~A" (FETCH thing)))
(defun p6-say (&rest things) (mapcar #'print-thing things) (format t "~%"))
@@ -202,6 +219,8 @@
(let ((compiled-unit (compile-unit (json:decode-json (open (first *args*))))))
+ ;(format t "~w~%~%~%" (json:decode-json (open (first *args*))))
+ ;(format t "~w~%~%~%" compiled-unit)
(format t "~w~%~%~%" (strip-ann compiled-unit))
(let ((wrapped (wrap-for-eval compiled-unit)))
(eval wrapped)

0 comments on commit a7cd075

Please sign in to comment.
Something went wrong with that request. Please try again.