Annotation of gforth/intcomp.fs, revision 1.2

1.1       anton       1: \ defining words for words with non-default and non-immediate compilation semantics
                      2: 
                      3: \ Copyright (C) 1996 Free Software Foundation, Inc.
                      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
                      9: \ as published by the Free Software Foundation; either version 2
                     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
                     18: \ along with this program; if not, write to the Free Software
                     19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                     20: 
                     21: \ used like
                     22: \ : <name> create-interpret/compile ...
                     23: \     interpretation> ... <interpretation
                     24: \     compilation> ... <compilation ;
                     25: 
                     26: 
                     27: noname create
                     28: does> abort" interpreting word without interpretation semantics" ;
                     29: lastxt >does-code
                     30: does> abort" compiling word without compilation semantics" ;
                     31: lastxt >does-code
                     32: constant no-compilation-does-code
                     33: constant no-interpretation-does-code
                     34: 
                     35: : create-interpret/compile ( -- )
                     36:     0 0 interpret/compile:
1.2     ! anton      37:     here lastxt interpret/compile-comp !
        !            38:     no-compilation-does-code here does-code!
        !            39:     [ 0 >body ] literal allot
1.1       anton      40:     here lastxt interpret/compile-int !
                     41:     no-interpretation-does-code here does-code!
1.2     ! anton      42:     [ 0 >body ] literal allot ; \ restrict?
1.1       anton      43: 
                     44: : fix-does-code ( addr ret-addr -- )
                     45:     lastxt [ interpret/compile-struct drop ] literal + >r
                     46:     lastxt interpret/compile?
1.2     ! anton      47:     lastxt interpret/compile-int @ r@ >body = and
        !            48:     lastxt interpret/compile-comp @ r> = and
1.1       anton      49:     0= abort" not created with create-interpret/compile"
1.2     ! anton      50:     [ /does-handler cell+ cell+ ] literal + \ to does-code
1.1       anton      51:     swap @ does-code! ;
                     52: 
                     53: : (interpretation>) ( -- )
                     54:     lastxt interpret/compile-int r@ fix-does-code ;
                     55: 
                     56: : interpretation> ( -- orig colon-sys )
                     57:     POSTPONE (interpretation>) POSTPONE ahead
1.2     ! anton      58:     dodoes, defstart dead-code off 0 set-locals-size-list ; immediate restrict
1.1       anton      59: 
                     60: : <interpretation ( orig colon-sys -- )
                     61:     ?struc POSTPONE exit
                     62:     POSTPONE then ; immediate restrict
                     63: 
                     64: : (compilation>) ( -- )
                     65:     lastxt interpret/compile-comp r@ fix-does-code ;
                     66: 
                     67: : compilation> ( -- orig colon-sys )
                     68:     POSTPONE (compilation>) POSTPONE ahead
1.2     ! anton      69:     dodoes, defstart dead-code off 0 set-locals-size-list POSTPONE >body ; immediate restrict
1.1       anton      70: 
                     71: comp' <interpretation drop Alias <compilation immediate restrict
                     72: 
                     73: \ example
                     74: \ : constant ( n "name" -- )
                     75: \     create-interpret/compile
                     76: \     ,
                     77: \ interpretation>
                     78: \     @
                     79: \ <interpretation
                     80: \ compilation>
                     81: \     @ postpone literal
                     82: \ <compilation ;
                     83: 
                     84: \ 5 constant five
                     85: 
                     86: \ cr
                     87: \ five . cr
                     88: \ : fuenf five ;
                     89: \ see fuenf cr

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>