Return to primtest.fs CVS log

Up to [gforth] / gforth / test

Annotation of gforth/test/primtest.fs, revision 1.2

1.1       anton       1: \ test for Gforth primitives
                      2: 
                      3: \ Copyright (C) 2003 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., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
                     20: 
                     21: Create mach-file here over 1+ allot place
                     22: 
                     23: 0 [IF]
                     24: \ debugging: produce a relocation and a symbol table
                     25: s" rel-table" r/w create-file throw
                     26: Constant fd-relocation-table
                     27: 
                     28: \ debuggging: produce a symbol table
                     29: s" sym-table" r/w create-file throw
                     30: Constant fd-symbol-table
                     31: [THEN]
                     32: 
                     33: 
                     34: bl word vocabulary find nip 0= [IF]
                     35:     \ if search order stuff is missing assume we are compiling on a gforth
                     36:     \ system and include it.
                     37:     \ We want the files taken from our current gforth installation
                     38:     \ so we don't include relatively to this file
                     39:     require startup.fs
                     40: [THEN]
                     41: 
                     42: \ include etags.fs
                     43: 
                     44: include ./../cross.fs              \ cross-compiler
                     45: 
                     46: decimal
                     47: 
                     48: has? kernel-start has? kernel-size makekernel
                     49: \ create image-header
                     50: has? header [IF]
                     51: here 1802 over 
                     52:     A,                  \ base address
                     53:     0 ,                 \ checksum
                     54:     0 ,                 \ image size (without tags)
                     55: has? kernel-size
                     56:     ,                   \ dict size
                     57:     has? stack-size ,   \ data stack size
                     58:     has? fstack-size ,  \ FP stack size
                     59:     has? rstack-size ,  \ return stack size
                     60:     has? lstack-size ,  \ locals stack size
                     61:     0 A,                \ code entry point
                     62:     0 A,                \ throw entry point
                     63:     has? stack-size ,   \ unused (possibly tib stack size)
                     64:     0 ,                 \ unused
                     65:     0 ,                 \ data stack base
                     66:     0 ,                 \ fp stack base
                     67:     0 ,                 \ return stack base
                     68:     0 ,                 \ locals stack base
                     69: [THEN]
                     70: 
                     71: doc-off
                     72: has? prims [IF]
                     73:     include ./../kernel/aliases.fs             \ primitive aliases
                     74: [ELSE]
                     75:     prims-include
                     76:     undef-words
                     77:     include prim.fs
                     78:     all-words  
                     79: [THEN]
                     80: doc-on
                     81: 
                     82: has? header [IF]
                     83: 1802 <> [IF] .s cr .( header start address expected!) cr uffz [THEN]
                     84: AConstant image-header
                     85: : forthstart image-header @ ;
                     86: [THEN]
                     87: 
                     88: \ 0 AConstant forthstart
                     89: 
                     90: : emit ( c -- )
                     91:     stdout emit-file drop ;
                     92: 
                     93: : cr ( -- )
                     94:     10 emit ;
                     95: 
                     96: : type ( addr u -- )
                     97:     stdout write-file drop ;
                     98: 
1.2     ! anton      99: char j constant char-j
        !           100: 
        !           101: variable var-k
        !           102: char k var-k !
        !           103: defer my-emit
        !           104: ' emit is my-emit
        !           105: cell% 2* 0 0 field >body
        !           106: 
        !           107: variable s0
        !           108: : depth s0 @ sp@ cell+ - ;
        !           109: 
        !           110: \  : myconst ( n -- )
        !           111: \      create ,
        !           112: \    does> ( -- n )
        !           113: \      @ ;
        !           114: \  char m myconst char-m
        !           115: 
        !           116: : unloop-test ( -- )
        !           117:     0 >r 0 >r unloop ;
        !           118: 
1.1       anton     119: : boot ( -- )
1.2     ! anton     120:     sp@ s0 !
1.1       anton     121:     [char] a stdout emit-file drop
                    122:     [char] b emit
                    123:     s" cde" type
                    124:     ." fgh"
1.2     ! anton     125:     [char] i ['] emit execute
        !           126:     ['] char-j execute emit
        !           127:     ['] var-k execute @ emit
        !           128:     \ !!douser
        !           129:     [char] l ['] my-emit execute
        !           130:     [char] l ['] my-emit ['] >body execute perform
        !           131:     \ !!dodoes ['] char-m execute emit
        !           132:     noop
        !           133:     [char] m ['] my-emit ['] execute dup execute
        !           134:     [char] m ['] 1+ execute emit
        !           135:     [char] o ['] my-emit >body perform
        !           136:     unloop-test ." p"
        !           137:     [char] q my-emit
        !           138:     \ !!does-exec
        !           139:     \ !! branch-lp+!#
        !           140:     ahead ." wrong" then ." r"
        !           141:     0 if ." wrong" else ." s" then
        !           142:     1 if ." t" else ." wrong" then
        !           143:     \ !! ?dup-?branch ?dup-0=-?branch
        !           144:     \ 0 ?dup-if ." wrong" drop else ." u" then
        !           145:     \ [char] v ?dup-if emit else ." wrong" then
1.1       anton     146:     cr
1.2     ! anton     147:     depth (bye) ;
1.1       anton     148: 
                    149: \ Setup                                                13feb93py
                    150: 
                    151: has? header [IF]
                    152:     \ set image size
                    153:     here image-header 2 cells + !         
                    154:     \ set image entry point
                    155:     ' boot >body  image-header 8 cells + A!         
                    156: [ELSE]
                    157:     >boot
                    158: [THEN]
                    159: 
                    160: \ include ./../kernel/pass.fs                    \ pass pointers from cross to target
                    161: 
                    162: .unresolved                          \ how did we do?
                    163: