Browse files

[cl-backend] methods with 0 arguments

  • Loading branch information...
1 parent 9a4634a commit 619094e9feb2e3f1dbfab07bbe7e9b299c6c5dcb @pmurias pmurias committed Jan 27, 2011
Showing with 47 additions and 4 deletions.
  1. +47 −4 cl-backend/backend.lisp
@@ -20,31 +20,60 @@
(defun class-symbol (i) (intern (concatenate 'string "CLASS-" (write-to-string i))))
; P6 Classes
+(defun trace (value) (format t "~w~%" value) value)
(defun make-scalar (value) (let ((scalar (make-instance 'p6-Scalar)))
(setf (slot-value scalar 'value) value)
+(defclass p6-Object () ())
+(defgeneric |new| (invocant))
+(defmethod |new| (invocant) (make-instance (class-of invocant)))
+;(defmethod |bar| (invocant arg) (format t "in bar: ~w" arg))
(defclass p6-Scalar () (value))
(defgeneric |FETCH| (value))
(defmethod |FETCH| ((container p6-Scalar)) (slot-value container 'value))
+(defmethod |STORE| ((container p6-Scalar) value) (setf (slot-value container 'value)value))
(defmethod |FETCH| (thing) thing)
-(defmethod |STORE| ((container p6-Scalar) value) (setf (slot-value container 'value)value))
(defmacro nam-sub (i lexicals body)
`(defun ,(sub-symbol i) () (let ,(lexicals-to-let lexicals) ,body)))
-(defmacro nam-class (name attributes methods) `(defclass ,(class-symbol name) () ()))
+(defun xref-to-subsymbol (xref) (sub-symbol (cadr xref)))
+(defun compile-method (method)
+ (fare-matcher:match method
+ ((and (list name normal dunno xref) (when (equal normal "normal")))
+ `(defmethod ,(intern name) (invocant) (,(xref-to-subsymbol xref))))))
+(defmacro nam-class (name attributes methods)
+ (trace methods)
+ (trace
+ `(progn
+ (defclass ,(class-symbol name) (p6-Object) ())
+ ,@(mapcar #'compile-method methods)
+ )))
+(defun stash-to-lisp-expression (path) `(make-instance (class-symbol (first (last ',path)))))
; converts one lexical to a variable declaration for a let
(defun lexical-to-let (lexical)
(fare-matcher:match lexical
((and (list var sub dunno-1 id dunno-2) (when (equal sub "sub"))) (list (intern var) `(symbol-function ',(sub-symbol id))))
((and (list var simple dunno) (when (equal simple "simple"))) (list (intern var) (make-scalar "")))
- ((and (list* var stash path) (when (equal stash "stash"))) (list (intern var) `(quote ,path)))))
+ ((and (list* var stash path) (when (equal stash "stash")))
+ (list (intern var) (stash-to-lisp-expression path)))))
; converts a list of lexicals
(defun lexicals-to-let (lexicals) (mapcar #'lexical-to-let lexicals))
@@ -63,14 +92,27 @@
(defun nam-box (type thing) thing)
(defun nam-fetch (thing) (FETCH thing))
+(defmacro nam-letvar (var) (intern var))
(defmacro nam-scopedlex (var &rest rvalue)
(if (consp rvalue)
`(setf ,(intern var) ,@rvalue)
(intern var)))
+(defun to-let-vars (vars)
+ (if (consp vars)
+ (cons (list (intern (car vars)) (cadr vars)) (to-let-vars (cddr vars)))
+ '()))
+(defmacro nam-letn (&body vars-and-body)
+ `(let ,(to-let-vars (butlast vars-and-body)) ,(first (last vars-and-body))))
; ???
(defun nam-subcall (dunno-what-that-is thing &rest args) (apply thing args))
+(defmacro nam-methodcall (method-name dunno invocant &rest args)
+ `(,(intern (cadr method-name)) ,@args))
(defmacro nam-corelex (var) `(nam-scopedlex ,var))
@@ -118,6 +160,7 @@
(defun p6-say (&rest things) (mapcar #'print-thing things) (format t "~%"))
(defun p6-concat (&rest things) (apply 'concatenate 'string (mapcar #'FETCH things)))
(defun wrap-for-eval (compiled-unit)
`(let ((|&infix:<~>| #'p6-concat)
(|&say| #'p6-say)
@@ -127,7 +170,7 @@
(let ((compiled-unit (compile-unit (json:decode-json (open (first *args*))))))
- (format t "~a~%~%~%" compiled-unit)
+ (format t "~w~%~%~%" compiled-unit)
(let ((wrapped (wrap-for-eval compiled-unit)))
; (format t "~a~%" wrapped)
(eval wrapped)

0 comments on commit 619094e

Please sign in to comment.