core/compiler/units/units-tests.factor

   1 USING: compiler definitions compiler.units tools.test arrays sequences words kernel
   2 accessors namespaces fry eval quotations math ;
   3 IN: compiler.units.tests
   4
   5 [ [ [ ] define-temp ] with-compilation-unit ] must-infer
   6 [ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
   7
   8 ! Non-optimizing compiler bugs
   9 [ 1 1 ] [
  10     "A" <uninterned-word> [ [ [ 1 ] dip ] 2array 1array t t modify-code-heap ] keep
  11     1 swap execute
  12 ] unit-test
  13
  14 [ "A" "B" ] [
  15     disable-optimizer
  16
  17     gensym "a" set
  18     gensym "b" set
  19     [
  20         "a" get [ "A" ] define
  21         "b" get "a" get '[ _ execute ] define
  22     ] with-compilation-unit
  23     "b" get execute
  24     [
  25         "a" get [ "B" ] define
  26     ] with-compilation-unit
  27     "b" get execute
  28
  29     enable-optimizer
  30 ] unit-test
  31
  32 ! Check that we notify observers
  33 SINGLETON: observer
  34
  35 observer add-definition-observer
  36
  37 SYMBOL: counter
  38
  39 0 counter set-global
  40
  41 M: observer definitions-changed 2drop global [ counter inc ] bind ;
  42
  43 [ gensym [ ] (( -- )) define-declared ] with-compilation-unit
  44
  45 [ 1 ] [ counter get-global ] unit-test
  46
  47 observer remove-definition-observer
  48
  49 ! Notify observers with nested compilation units
  50 observer add-definition-observer
  51
  52 0 counter set-global
  53
  54 DEFER: nesting-test
  55
  56 [ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test
  57
  58 observer remove-definition-observer
  59
  60 ! Make sure that non-optimized calls to a generic word which
  61 ! hasn't been compiled yet work properly
  62 GENERIC: uncompiled-generic-test ( a -- b )
  63
  64 M: integer uncompiled-generic-test 1 + ;
  65
  66 << [ uncompiled-generic-test ] [ jit-compile ] [ suffix! ] bi >>
  67 "q" set
  68
  69 [ 4 ] [ 3 "q" get call ] unit-test
  70
  71 [ ] [ [ \ uncompiled-generic-test forget ] with-compilation-unit ] unit-test