compile/compiler-context.lisp

   1 (in-package :avm2-compiler)
   2
   3 (defclass symbol-table ()
   4   ((functions :initform (make-hash-table) :accessor functions)
   5    ;; functions are really methods at the bytecode level, haven't
   6    ;; figured out how to make separate functions yet
   7    (variables :initform (make-hash-table) :accessor variables)
   8    (properties :initform (make-hash-table) :accessor properties)
   9    ;; not sure if constants work the same as properties yet, so
  10    ;; keeping separate for now
  11    ;; (static-properties might be a better name, if they are separate?)
  12    (constants :initform (make-hash-table) :accessor constants)
  13    (class-methods :initform (make-hash-table) :accessor class-methods)
  14    (static-methods :initform (make-hash-table) :accessor class-static-methods)
  15    (classes :initform (make-hash-table) :accessor classes)
  16    (inherited :initform nil :initarg :inherit :accessor inherited-symbol-tables)
  17    (setf-functions :initform (make-hash-table) :initarg :setf :accessor setf-functions)
  18    (macro-functions :initform (make-hash-table) :accessor macro-functions)
  19    (cmacro-functions :initform (make-hash-table) :accessor cmacro-functions)))
  20
  21 (defparameter *player-symbol-table* (make-instance 'symbol-table))
  22
  23 (defparameter *cl-symbol-table* (make-instance 'symbol-table :inherit (list *player-symbol-table*)))
  24
  25 (defparameter *symbol-table*
  26   (make-instance 'symbol-table :inherit (list *cl-symbol-table*)))
  27
  28 (defmacro define-swf-find-foo (name hash-accessors)
  29   `(defun ,name (symbol &optional (s *symbol-table*))
  30      (or (car (gethash symbol (,hash-accessors s)))
  31          (loop for i in (inherited-symbol-tables s)
  32             when (,name symbol i)
  33             return it))))
  34 (define-swf-find-foo find-swf-method class-methods)
  35 (define-swf-find-foo find-swf-static-method class-static-methods)
  36 (define-swf-find-foo find-swf-property properties)
  37 (define-swf-find-foo find-swf-constant constants)
  38 (define-swf-find-foo find-swf-function functions)
  39 (define-swf-find-foo find-swf-setf-function setf-functions)
  40 (define-swf-find-foo find-swf-macro-function macro-functions)
  41 (define-swf-find-foo find-swf-cmacro-function cmacro-functions)
  42 ;;(inherited-symbol-tables *symbol-table*)
  43 ;;(find-swf-static-method '%flash:random )
  44
  45 (defmacro define-swf-add-foo (name hash-accessor)
  46   `(defun ,name (symbol value &optional (s *symbol-table*))
  47      (setf (gethash symbol (,hash-accessor s))
  48            (list value))))
  49
  50 #+nil(define-swf-add-foo add-swf-property properties)
  51 (define-swf-add-foo add-swf-macro-function macro-functions)
  52 (define-swf-add-foo add-swf-cmacro-functions cmacro-functions)
  53 (defun add-swf-property (symbol swf-name &optional (s *symbol-table*))
  54   (pushnew swf-name
  55            (gethash symbol (properties s) (list))
  56            :test 'string=))
  57
  58
  59 (defmethod swf-name ((object (eql nil)))
  60   nil)
  61
  62 (defclass symbol-class-data ()
  63   ((name :initarg :name :accessor name)
  64    (ns :initarg :ns :accessor ns)
  65    (swf-name :initarg :swf-name :accessor swf-name)
  66    (extends :initform nil :initarg :extends :accessor extends)
  67    (implements :initform nil :initarg :implements :accessor implements)
  68    (properties :initform nil :initarg :properties :accessor properties)
  69    (constructor :initform nil :initarg :constructor :accessor constructor)))
  70
  71 (defun add-swf-class (name swf-name &key ns extends implements properties constructor)
  72   (setf (gethash name (classes *symbol-table*))
  73         (make-instance 'symbol-class-data :name name
  74                        :swf-name swf-name
  75                        :ns ns
  76                        :extends extends
  77                        :implements implements
  78                        :properties properties
  79                        :constructor constructor)))
  80
  81 (defun find-swf-class (symbol &optional (s *symbol-table*))
  82   (let ((c (or (gethash symbol (classes s))
  83                (loop for i in (inherited-symbol-tables s)
  84                   when (find-swf-class symbol i)
  85                   return it))))
  86     (unless c (format t "couldn't find class ~s~%" symbol) #+nil(break))
  87     c))
  88
  89 ;;; handler for normal form evaluation, evaluate ARGS, and call
  90 ;;; function/member/whatever identified by OPERATOR
  91 (defmethod scompile-cons (operator args)
  92   (let ((tmp))
  93     (cond
  94       #+nil((and (consp operator) (setf tmp (find-swf-setf-function (first operator) *symbol-table*)))
  95             ;;; not sure how to name setf-functions, probably keep a list of
  96             ;;; unnamed lambdas, and compile in references to those?
  97             ;;; or maybe add a top-level namespace for them?
  98             )
  99       ((consp operator) (error "cons in operator position not supported yet"))
 100
 101       ;; if OPERATOR is a known method, call with %call-property
 102       ;;  (prop obj args...) === obj.prop(args)
 103       ((setf tmp (find-swf-method operator *symbol-table*))
 104        (scompile `(%call-property ,(first args) ,tmp ,@(rest args))))
 105
 106       ;; if OPERATOR is a known static method, call with %call-lex-prop
 107       ;;  (prop obj args...) === obj.prop(args)
 108       ((setf tmp (find-swf-static-method operator *symbol-table*))
 109        (scompile `(%call-lex-prop ,(car tmp) ,(second tmp) ,@args)))
 110
 111       ;; if OPERATOR is a known property (member var), call %get-property
 112       ;;  (:prop obj)
 113       ((setf tmp (find-swf-property operator *symbol-table*))
 114        (scompile `(%get-property ,(first args) ,tmp)))
 115
 116       ;; normal function call, find-prop-strict + call-property
 117       ((setf tmp (find-swf-function operator *symbol-table*))
 118        (scompile `(%call-property-without-object ,(car tmp) ,@args)))
 119
 120       ;; default = normal call?
 121       ;; fixme: might be nicer if we could detect unknown functions
 122       (t
 123        (scompile `(%call-property-without-object ,operator ,@args))
 124        #+nil(error " unknown function call? ~s ~s ~% " operator args)))))
 125
 126
 127 #+nil(let ((*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table* *player-symbol-table*))))
 128   (find-swf-static-method 'flash:floor *symbol-table*))