[gforth] / gforth / prims2cl.fs  

gforth: gforth/prims2cl.fs

1 : jwilke 1.1 \ prims2cl.fs Primitives to c-library code
2 :    
3 : anton 1.3 \ Copyright (C) 1998,1999 Free Software Foundation, Inc.
4 : jwilke 1.1
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 : anton 1.4 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20 : jwilke 1.1
21 :     \ Author: Jens Wilke
22 :     \ Revision Log
23 :     \ 09oct97jaw V1.0 Initial Version
24 :    
25 :     include ./prims2x.fs
26 :    
27 :     Create InputFile 130 chars allot
28 :    
29 :     : c-code
30 : anton 1.5 InputFile count ['] output-c-func ['] abort process-file
31 : jwilke 1.1 ;
32 :    
33 :     : c-names
34 : anton 1.5 InputFile count ['] output-funclabel ['] abort process-file
35 : jwilke 1.1 ;
36 :    
37 :     : forth-names
38 : anton 1.5 InputFile count ['] output-forthname dup process-file
39 : jwilke 1.1 ;
40 :    
41 :     : .\
42 :     0 word count pad place pad count postpone sliteral postpone type postpone cr ; immediate
43 :    
44 :     : c-header
45 :     .\ #include "engine/forth.h"
46 :     .\ extern char *cstr(Char *from, UCell size, int clear);
47 :     .\ extern char *tilde_cstr(Char *from, UCell size, int clear);
48 :     .\
49 :     .\ #undef TOS
50 :     .\ #define TOS sp[0]
51 :     .\ #undef IF_TOS
52 :     .\ #define IF_TOS(x)
53 :     .\ #undef NEXT_P2
54 : jwilke 1.2 .\ #define NEXT_P2
55 : jwilke 1.1 .\ #undef NEXT_P1
56 :     .\ #define NEXT_P1
57 :     .\ #undef NEXT_P0
58 :     .\ #define NEXT_P0
59 :     .\ #undef NAME
60 :     .\ #define NAME(x)
61 :     .\ #undef DEF_CA
62 :     .\ #define DEF_CA
63 :     .\ #undef I_
64 :     .\ #define I_ I_
65 :     .\
66 :     .\ #define NAME_LEN 32
67 :     .\ #define NULL 0
68 :     .\
69 :     ;
70 :    
71 :     : catalog
72 :     .\ void *catalog(int p)
73 :     .\ {
74 :     .\ static void *ADDR_TABLE[]={
75 :     c-names
76 :     .\ };
77 :     .\ static char NAME_TABLE[][NAME_LEN]={
78 :     forth-names
79 :     .\ };
80 :     ." int funcs=" function-number @ s>d <# #S #> type ." ;" cr
81 :     .\
82 :     .\ static struct { void *func;
83 :     .\ char len;
84 :     .\ char name[NAME_LEN];
85 :     .\ }f;
86 :     .\
87 :     .\ switch (p)
88 :     .\ { case -2: /*
89 :     .\ We return the table known words
90 :     .\ don't use this!!!
91 :     .\ */
92 :     .\ return (NAME_TABLE[0]);
93 :     .\
94 :     .\ case -1: /*
95 :     .\ Return number of words in this module
96 :     .\ */
97 :     .\ return ((void *) funcs);
98 :     .\ }
99 :     .\ /*
100 :     .\ Check for valid function number
101 :     .\ */
102 :     .\ if (p<0 || p>=funcs) return (0);
103 :     .\ /*
104 :     .\ Find matching forth word and return its address
105 :     .\ */
106 :     .\ strcpy(f.name,NAME_TABLE[p]);
107 :     .\ f.len=strlen(f.name);
108 :     .\ f.func=ADDR_TABLE[p];
109 :     .\ return (&f);
110 :     .\ }
111 :     ;
112 :    
113 :     : main
114 :     c-header
115 :     c-code
116 :     catalog
117 :     ;
118 :    
119 :     : file
120 :     bl word count InputFile place ;
121 :    
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help