Adding ICE40 FPGA synthesizer

pico-ice/ice40/flyclasses.fs

@@ -0,0 +1,44 @@
+\ 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
+