extra/mortar/mortar.factor

   1
   2 USING: kernel io parser words namespaces quotations arrays assocs sequences
   3        splitting grouping math shuffle ;
   4
   5 IN: mortar
   6
   7 ! class { name slots methods class-methods }
   8
   9 : class-name ( class -- name ) dup symbol? [ get ] when first ;
  10
  11 : class-slots ( class -- slots ) dup symbol? [ get ] when second ;
  12
  13 : class-methods ( class -- methods ) dup symbol? [ get ] when third ;
  14
  15 : class-class-methods ( class -- methods ) dup symbol? [ get ] when fourth ;
  16
  17 : class? ( thing -- ? )
  18 dup array?
  19 [ dup length 4 = [ first symbol? ] [ drop f ] if ]
  20 [ drop f ]
  21 if ;
  22
  23 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  24
  25 : add-method ( class name quot -- )
  26 rot get class-methods peek swapd set-at ;
  27
  28 : add-class-method ( class name quot -- )
  29 rot get class-class-methods peek swapd set-at ;
  30
  31 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  32
  33 ! object { class values }
  34
  35 : object-class ( object -- class ) first ;
  36
  37 : object-values ( object -- values ) second ;
  38
  39 : object? ( thing -- ? )
  40 dup array?
  41 [ dup length 2 = [ first class? ] [ drop f ] if ]
  42 [ drop f ]
  43 if ;
  44
  45 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  46
  47 : is? ( object class -- ? ) swap object-class class-name = ;
  48
  49 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  50
  51 USE: inference.transforms
  52
  53 ! : narray ( n -- array ) [ drop ] map reverse ;
  54
  55 : [narray] ( n -- quot ) [ [ drop ] map reverse ] curry ;
  56
  57 : narray ( n -- array ) [narray] call ;
  58
  59 \ narray [ [narray] ] 1 define-transform
  60
  61 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  62
  63 : new ( class -- object )
  64 get dup >r class-slots length narray r> swap 2array ;
  65
  66 : new-empty ( class -- object )
  67 get dup >r class-slots length f <array> r> swap 2array ;
  68
  69 ! : new* ( class -- object ) new-empty <- init ;
  70
  71 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  72
  73 : slot-value ( object slot -- value )
  74 over object-class class-slots index swap object-values nth ;
  75
  76 : set-slot-value ( object slot value -- object )
  77 swap pick object-class class-slots index pick object-values set-nth ;
  78
  79 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  80
  81 ! : send-message ( object message -- )
  82 ! over object-class class-methods assoc-stack call ;
  83
  84 : send-message ( object message -- )
  85 2dup swap object-class class-methods assoc-stack dup
  86 [ nip call ]
  87 ! [ drop nip "message not understood: " write print flush ]
  88 [ drop "message not understood: " write print drop ]
  89 if ;
  90
  91 : <- scan parsed \ send-message parsed ; parsing
  92
  93 ! : send-message* ( message n -- )
  94 ! 1+ npick object-class class-methods assoc-stack call ;
  95
  96 : send-message* ( message n -- )
  97 1+ npick dupd object-class class-methods assoc-stack dup
  98 [ nip call ]
  99 [ drop "message not understood: " write print flush ]
 100 if ;
 101
 102 : <--   scan parsed 2 parsed \ send-message* parsed ; parsing
 103
 104 : <---  scan parsed 3 parsed \ send-message* parsed ; parsing
 105
 106 : <---- scan parsed 4 parsed \ send-message* parsed ; parsing
 107
 108 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 109
 110 : send-message-to-class ( class message -- )
 111 over class-class-methods assoc-stack call ;
 112
 113 : <<- scan parsed \ send-message-to-class parsed ; parsing
 114
 115 : send-message-to-class* ( message n -- )
 116 1+ npick class-class-methods assoc-stack call ;
 117
 118 : <<-- scan parsed 2 parsed \ send-message-to-class* parsed ; parsing
 119
 120 : <<--- scan parsed 3 parsed \ send-message-to-class* parsed ; parsing
 121
 122 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 123
 124 : send-message-next ( object message -- )
 125 over object-class class-methods but-last assoc-stack call ;
 126
 127 : <-~ scan parsed \ send-message-next parsed ; parsing
 128
 129 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 130
 131 ! : new* ( class -- object ) <<- create ;
 132
 133 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 134
 135 IN: slot-accessors
 136
 137 IN: mortar
 138
 139 ! : generate-slot-getter ( name -- )
 140 ! "$" over append "slot-accessors" create swap [ slot-value ] curry
 141 ! define-compound ;
 142
 143 : generate-slot-getter ( name -- )
 144 "$" over append "slot-accessors" create swap [ slot-value ] curry define ;
 145
 146 ! : generate-slot-setter ( name -- )
 147 ! ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
 148 ! define-compound ;
 149
 150 : generate-slot-setter ( name -- )
 151 ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
 152 define ;
 153
 154 : generate-slot-accessors ( name -- )
 155 dup
 156 generate-slot-getter
 157 generate-slot-setter ;
 158
 159 : accessors ( seq -- seq ) dup peek [ generate-slot-accessors ] each ; parsing
 160
 161 ! : slots:
 162 ! ";" parse-tokens dup [ generate-slot-accessors ] each parsed ; parsing
 163
 164 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 165
 166 ! : <symbol> ( string -- symbol ) in get create dup define-symbol ;
 167
 168 : empty-method-table ( -- array ) H{ } clone 1array ;
 169
 170 ! : define-simple-class ( name parent slots -- )
 171 ! >r >r <symbol>
 172 ! r> dup class-slots r> append
 173 ! swap dup class-methods empty-method-table append
 174 ! swap class-class-methods empty-method-table append
 175 ! 4array dup first set-global ;
 176
 177 : define-simple-class ( name parent slots -- )
 178 >r dup class-slots r> append
 179 swap dup class-methods empty-method-table append
 180 swap class-class-methods empty-method-table append
 181 4array dup first set-global ;
 182
 183 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 184
 185 : define-independent-class ( name slots -- )
 186 empty-method-table empty-method-table 4array dup first set-global ;
 187
 188 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 189
 190 : add-methods ( class seq -- ) 2 group [ first2 add-method ] with each ;
 191
 192 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 193
 194 : !( ")" parse-tokens drop ; parsing