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
  20 (defparameter *player-symbol-table* (make-instance 'symbol-table))
  21
  22 (defparameter *cl-symbol-table* (make-instance 'symbol-table :inherit (list *player-symbol-table*)))
  23
  24 (defparameter *symbol-table*
  25   (make-instance 'symbol-table :inherit (list *cl-symbol-table*)))
  26
  27 ;; fixme: combine these?
  28 (defun find-swf-method (symbol &optional (s *symbol-table*))
  29   (or (car (gethash symbol (class-methods s)))
  30       (loop for i in (inherited-symbol-tables s)
  31          when (find-swf-method symbol i)
  32          return it)))
  33
  34 (defun find-swf-static-method (symbol &optional (s *symbol-table*))
  35   (or (car (gethash symbol (class-static-methods s)))
  36       (loop for i in (inherited-symbol-tables s)
  37          when (find-swf-static-method symbol i)
  38          return it)))
  39 ;;(inherited-symbol-tables *symbol-table*)
  40 ;;(find-swf-static-method 'flash::math.random )
  41
  42 (defun find-swf-property (symbol &optional (s *symbol-table*))
  43   (or (car (gethash symbol (properties s)))
  44       (loop for i in (inherited-symbol-tables s)
  45          when (find-swf-property symbol i)
  46          return it)))
  47
  48 (defun find-swf-constant (symbol &optional (s *symbol-table*))
  49   (or (car (gethash symbol (constants s)))
  50       (loop for i in (inherited-symbol-tables s)
  51          when (find-swf-constant symbol i)
  52          return it)))
  53
  54 (defun add-swf-property (symbol swf-name &optional (s *symbol-table*))
  55   (pushnew swf-name
  56            (gethash symbol (properties s) (list))
  57            :test 'string=))
  58
  59 (defun find-swf-function (symbol &optional (s *symbol-table*))
  60   (or (car (gethash symbol (functions s)))
  61       (loop for i in (inherited-symbol-tables s)
  62          when (find-swf-function symbol i)
  63          return it)))
  64
  65 (defclass symbol-class-data ()
  66   ((name :initarg :name :accessor name)
  67    (ns :initarg :ns :accessor ns)
  68    (swf-name :initarg :swf-name :accessor swf-name)
  69    (extends :initform nil :initarg :extends :accessor extends)
  70    (implements :initform nil :initarg :implements :accessor implements)
  71    (properties :initform nil :initarg :properties :accessor properties)
  72    (constructor :initform nil :initarg :constructor :accessor constructor)))
  73
  74 (defun add-swf-class (name swf-name &key ns extends implements properties constructor)
  75   (setf (gethash name (classes *symbol-table*))
  76         (make-instance 'symbol-class-data :name name
  77                        :swf-name swf-name
  78                        :ns ns
  79                        :extends extends
  80                        :implements implements
  81                        :properties properties
  82                        :constructor constructor)))
  83
  84 (defun find-swf-class (symbol &optional (s *symbol-table*))
  85   (let ((c (or (gethash symbol (classes s))
  86                (loop for i in (inherited-symbol-tables s)
  87                   when (find-swf-class symbol i)
  88                   return it))))
  89     (unless c (format t "couldn't find class ~s~%" symbol) #+nil(break))
  90     c))
  91
  92 ;;; handler for normal form evaluation, evaluate ARGS, and call
  93 ;;; function/member/whatever identified by OPERATOR
  94 (defmethod scompile-cons (operator args)
  95   (let ((tmp))
  96     (cond
  97
  98       ;; if OPERATOR is a known method, call with %call-property
  99       ;;  (prop obj args...) === obj.prop(args)
 100       ((setf tmp (find-swf-method operator *symbol-table*))
 101        (scompile `(%call-property ,(first args) ,tmp ,@(rest args))))
 102
 103       ;; if OPERATOR is a known static method, call with %call-lex-prop
 104       ;;  (prop obj args...) === obj.prop(args)
 105       ((setf tmp (find-swf-static-method operator *symbol-table*))
 106        (scompile `(%call-lex-prop ,(car tmp) ,(second tmp) ,@args)))
 107
 108       ;; if OPERATOR is a known property (member var), call %get-property
 109       ;;  (:prop obj)
 110       ((setf tmp (find-swf-property operator *symbol-table*))
 111        (scompile `(%get-property ,(first args) ,tmp)))
 112
 113       ;; normal function call, find-prop-strict + call-property
 114       ((setf tmp (find-swf-function operator *symbol-table*))
 115        (scompile `(%call-property-without-object ,(car tmp) ,@args)))
 116
 117       ;; default = normal call?
 118       ;; fixme: might be nicer if we could detect unknown functions
 119       (t
 120        (scompile `(%call-property-without-object ,operator ,@args))
 121        #+nil(error " unknown function call? ~s ~s ~% " operator args)))))
 122
 123
 124 #+nil(let ((*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table* *player-symbol-table*))))
 125   (find-swf-static-method 'flash:floor *symbol-table*))