45 lines
1.9 KiB
Forth
45 lines
1.9 KiB
Forth
\ Copyright 2025 Bradley D. Nelson
|
|
\
|
|
\ Licensed under the Apache License, Version 2.0 (the "License");
|
|
\ you may not use this file except in compliance with the License.
|
|
\ You may obtain a copy of the License at
|
|
\
|
|
\ http://www.apache.org/licenses/LICENSE-2.0
|
|
\
|
|
\ Unless required by applicable law or agreed to in writing, software
|
|
\ distributed under the License is distributed on an "AS IS" BASIS,
|
|
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
\ See the License for the specific language governing permissions and
|
|
\ limitations under the License.
|
|
|
|
vocabulary flyclasses flyclasses definitions
|
|
|
|
0 value classes
|
|
1 value methods
|
|
0 value dispatch
|
|
0 value implementing
|
|
|
|
: flyclass create classes , 1 +to classes does> @ ;
|
|
: method& ( m cls -- a ) classes mod methods * + cells dispatch + ;
|
|
: accrued ( -- a ) 0 implementing method& ;
|
|
: method create methods , 1 +to methods does> @ over method& @ execute ;
|
|
: implementation ( cls -- ) to implementing ;
|
|
: >min ( a -- n ) cell+ @ ; : >max ( a -- a ) @ ;
|
|
: >below ( a -- a ) 2 cells + @ ; : >above ( a -- a) 3 cells + @ ;
|
|
: field ( min max -- "name" )
|
|
create 2dup , , accrued @ , swap - 1+ accrued @ * dup , accrued !
|
|
does> >r r@ >above mod r@ >below / r> >min + ;
|
|
: doput ( n o -- o "name" ) >r dup r@ >below mod swap r@ >above / r@ >above * +
|
|
swap r@ >max min r@ >min - r> >below * + ;
|
|
: put ( n o -- o "name" ) ' >body postpone literal postpone doput ; immediate
|
|
: extension ( cls -- ) 0 swap method& accrued methods cells cmove ;
|
|
: initiate here to dispatch
|
|
classes 1- for classes , methods 1- 1- for ['] abort , next next ;
|
|
: do:: ( o cls m -- ) swap method& @ execute ;
|
|
: :: ( o cls "name" -- ) ' >body @ postpone literal postpone do:: ; immediate
|
|
: m: ' >body @ :noname ;
|
|
: ;m postpone ; swap implementing method& ! ; immediate
|
|
|
|
forth definitions
|
|
|