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 add-swf-property (symbol swf-name &optional (s *symbol-table*))
  49   (pushnew swf-name
  50            (gethash symbol (properties s) (list))
  51            :test 'string=))
  52
  53 (defun find-swf-function (symbol &optional (s *symbol-table*))
  54   (or (car (gethash symbol (functions s)))
  55       (loop for i in (inherited-symbol-tables s)
  56          when (find-swf-function symbol i)
  57          return it)))
  58
  59
  60 (defun find-swf-class (symbol &optional (s *symbol-table*))
  61   (or (gethash symbol (classes s))
  62       (loop for i in (inherited-symbol-tables s)
  63          when (find-swf-class symbol i)
  64          return it)))
  65
  66 ;;; handler for normal form evaluation, evaluate ARGS, and call
  67 ;;; function/member/whatever identified by OPERATOR
  68 (defmethod scompile-cons (operator args)
  69   (let ((tmp))
  70     (cond
  71
  72       ;; if OPERATOR is a known method, call with %call-property
  73       ;;  (prop obj args...) === obj.prop(args)
  74       ((setf tmp (find-swf-method operator *symbol-table*))
  75        (scompile `(%call-property ,(first args) ,tmp ,@(rest args))))
  76
  77       ;; if OPERATOR is a known static method, call with %call-lex-prop
  78       ;;  (prop obj args...) === obj.prop(args)
  79       ((setf tmp (find-swf-static-method operator *symbol-table*))
  80        (scompile `(%call-lex-prop ,(car tmp) ,(second tmp) ,@args)))
  81
  82       ;; if OPERATOR is a known property (member var), call %get-property
  83       ;;  (:prop obj)
  84       ((setf tmp (find-swf-property operator *symbol-table*))
  85        (scompile `(%get-property ,(first args) ,tmp)))
  86
  87       ;; normal function call, find-prop-strict + call-property
  88       ((setf tmp (find-swf-function operator *symbol-table*))
  89        (scompile `(%call-property-without-object ,(car tmp) ,@args)))
  90
  91       ;; default = normal call?
  92       ;; fixme: might be nicer if we could detect unknown functions
  93       (t
  94        (scompile `(%call-property-without-object ,operator ,@args))
  95        #+nil(error " unknown function call? ~s ~s ~% " operator args)))))
  96
  97