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
  42     2drop [ counter inc ] with-global ;
  43
  44 [ gensym [ ] ( -- ) define-declared ] with-compilation-unit
  45
  46 { 1 } [ counter get-global ] unit-test
  47
  48 observer remove-definition-observer
  49
  50 ! Notify observers with nested compilation units
  51 observer add-definition-observer
  52
  53 0 counter set-global
  54
  55 DEFER: nesting-test
  56
  57 { } [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test
  58
  59 observer remove-definition-observer
  60
  61 ! Make sure that non-optimized calls to a generic word which
  62 ! hasn't been compiled yet work properly
  63 GENERIC: uncompiled-generic-test ( a -- b )
  64
  65 M: integer uncompiled-generic-test 1 + ;
  66
  67 << [ uncompiled-generic-test ] [ jit-compile ] [ suffix! ] bi >>
  68 "q" set
  69
  70 { 4 } [ 3 "q" get call ] unit-test
  71
  72 { } [ [ \ uncompiled-generic-test forget ] with-compilation-unit ] unit-test