50 #define TYPE(bp) (bp-Domains-Number_imports-Current_start)
51 #define NEWGEN_IMPL "#+akcl lisp:vector #-akcl (lisp:vector lisp:t)"
65 #define OR_VALUE_INDEX 3
75 static char buffer[ 1024 ] ;
84 sprintf(
buffer,
"`(:external ,(lisp:+ %s %d) %s)",
85 start,
TYPE( bp ),
":external-undefined" ) ;
86 else sprintf(
buffer,
":undefined", bp->
name ) ;
90 sprintf(
buffer,
":list-undefined" ) ;
95 sprintf(
buffer,
"(lisp:make-array '(" ) ;
97 for( ilp = dp->
ar.
dimensions ; ilp != NULL ; ilp = ilp->cdr ) {
101 strcat(
buffer,
") :initial-element '--no-value--)" ) ;
105 sprintf(
buffer,
"(set:set-make)" ) ;
139 printf(
" (lisp:caddr (lisp:svref and %d)))\n",
offset ) ;
141 printf(
"(lisp:defsetf %s-%s (and) (new-and)\n",
143 printf(
" `(lisp:setf (lisp:caddr (lisp:svref ,and %d)) ",
offset ) ;
144 printf(
",new-and))\n" ) ;
158 printf(
"(lisp:setf (lisp:aref newgen::*gen-tabulated-alloc*" ) ;
159 printf(
" (lisp:+ %s %d)) %d)\n",
161 printf(
"(lisp:defvar %s::%s-domain (lisp:+ %s %d))\n",
165 printf(
"(lisp:setf (lisp:aref newgen::*gen-tabulated-index* " ) ;
177 printf(
"(lisp:defvar old-make-%s)\n", bp->
name ) ;
178 printf(
"(lisp:setf old-make-%s (lisp:symbol-function 'make-%s))\n",
180 printf(
"(lisp:fmakunbound 'make-%s)\n", bp->
name) ;
181 printf(
"(lisp:setf (lisp:symbol-function 'make-%s)\n", bp->
name ) ;
182 printf(
" #'(lisp:lambda (lisp:&rest args)\n", bp->
name ) ;
183 printf(
" (lisp:let ((node (lisp:apply old-make-%s args)))\n", bp->
name ) ;
184 printf(
" (newgen::enter-tabulated-def\n" ) ;
185 printf(
" (lisp:aref newgen::*gen-tabulated-index* %s-domain)\n",
190 printf(
" :allow-ref-p lisp:nil)\n" ) ;
200 printf(
" (-type- `(:newgen ,(lisp:+ %s %d)))\n",
start,
TYPE( bp ) ) ;
203 printf(
" (-tabular- (newgen::find-free-tabulated %d))\n",
222 for( ; dlp != NULL ; dlp=dlp->cdr ) {
223 union domain *dp = dlp->domain ;
229 for( size=2, dlp=dom->
co.
components; dlp != NULL ; dlp=dlp->cdr, size++ ) {
245 struct domainlist *dlp ;
246 char *or_impl = (
IS_TABULATED( bp )) ?
"tabular-or" :
"or" ;
249 printf(
"(lisp:defun make-%s ", name ) ;
250 printf(
"(tag lisp:&optional (val :unit))\n" );
251 printf(
" (lisp:let ((node (newgen::make-%s)))\n", or_impl) ;
252 printf(
" (lisp:setf (newgen::%s-type node) `(:newgen ,(lisp:+ %s %d)))\n",
256 printf(
" (lisp:setf (newgen::%s-tabular node) ", or_impl ) ;
257 printf(
"(newgen::find-free-tabulated (lisp:+ %s %d)))\n",
260 printf(
" (lisp:setf (newgen::%s-tag node) tag)\n", or_impl ) ;
261 printf(
" (lisp:setf (newgen::%s-val node) val)\n", or_impl ) ;
263 printf(
"(lisp:defmacro %s-tag(node) `(newgen::%s-tag ,node))\n",
267 union domain *dp = dlp->domain ;
269 printf(
"(lisp:defconstant is-%s-%s %d)\n",
271 printf(
"(lisp:setf newgen::*tag-names* " ) ;
272 printf(
"(lisp:acons %d 'is-%s-%s newgen::*tag-names*))\n",
275 printf(
"`(lisp:= (%s-tag ,or) is-%s-%s))\n",
278 if( dp->
ba.
type == BASIS &&
283 printf(
"(lisp:defmacro %s-%s (or) `(newgen::%s-val ,or))\n",
344 printf(
"(lisp:defmacro write-%s (fd obj) `(gen-write ,fd ,obj))\n",
346 printf(
"(lisp:defmacro read-%s (lisp:&optional (fd *standard-input*))\n",
348 printf(
" `(gen-read ,fd))\n");
354 else fatal(
"gen_domain: Unknown constructed %s\n",
i2a( dp->
co.
op )) ;
381 int domain_count = 0 ;
385 sprintf(
start,
"newgen::*gen-%s-start*", file ) ;
388 if( bp->
name == NULL ||
int gen_external_member(dp, offset)
GEN_EXTERNAL_MEMBER generates the manipulation functions for a possible external member (either and o...
#define OR_VALUE_INDEX
Unused in Lisp.
static char start[1024]
The name of the variable from which to start counting domain numbers.
void gen_external(bp)
GEN_EXTERNAL generates the type code for external type BP.
struct gen_binding * Tabulated_bp
void gen_list(bp)
GEN_LIST defines the manipulation functions for a list type BP.
static void gen_prelude(bp)
GEN_PRELUDE generates prelude declarations for potentially tabulated domain BP.
void gen_or(bp)
GEN_OR generates the manipulation function for an OR_OP type BP.
static generate_type_member(bp)
GEN_TYPE generates the type member for potentially tabulated BP domain.
void gen_and(bp)
GEN_AND generates the manipulation functions for an AND type BP.
static void gen_postlude(bp)
GEN_POSTLUDE generates tabulation table updates.
void gen_array(bp)
GEN_ARRAY defines the manipulation functions for an array type BP.
void gencode(file)
GENCODE generates the code necessary to manipulate every non-inlinable type in the Domains table.
char * init_member(dp)
INIT_MEMBER returns the initialization code for a value in the domain DP.
void gen_set(bp)
GEN_SET defines the manipulation functions for a set type BP.
int Read_spec_mode
extern int Current_first ;
void gen_domain(bp)
GEN_DOMAIN generates the manipulation functions for a type BP.
static char * package
The package name in which functions will be defined.
struct gen_binding Domains[MAX_DOMAIN]
in build.c
char * i2a(int)
I2A (Integer TO Ascii) yields a string for a given Integer.
#define IS_INLINABLE(bp)
Different kinds of BINDING structure pointers.
#define HASH_OFFSET
For tabulated objects, the offset HASH_OFFSET of the hashed subdomain.
#define MAX_DOMAIN
MAX_DOMAIN is the maximum number of entries in the DOMAINS table.
#define UNIT_TYPE_NAME
The UNIT_TYPE_NAME is the used to type expressions which only perform side-effects.
struct inlinable * inlined
A DOMAIN union describes the structure of a user type.
struct gen_binding * element
struct domainlist * components
struct intlist * dimensions
struct gen_binding * constructand