compile/compiler-context.lisp

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