src/c/xlstruct.c

   1 /* xlstruct.c - the defstruct facility */
   2 /* Copyright (c) 1989, by David Michael Betz.                            */
   3 /* You may give out copies of this software; for conditions see the file */
   4 /* COPYING included with this distribution.                              */
   5
   6 #include "xlisp.h"
   7
   8 /* forward declarations */
   9 LOCAL VOID addslot P5H(LVAL, LVAL, int, LVAL *, LVAL *);
  10 LOCAL VOID updateslot P3H(LVAL, LVAL, LVAL);
  11
  12 /* local variables */
  13 static char prefix[STRMAX+1];
  14 static char makestr[] = "MAKE-%s";
  15
  16 /* xmkstruct - the '%make-struct' function */
  17 LVAL xmkstruct(V)
  18 {
  19     LVAL type,val;
  20     int i;
  21
  22     /* get the structure type */
  23     type = xlgasymbol();
  24
  25     /* make the structure */
  26     val = newstruct(type,xlargc);
  27
  28     /* store each argument */
  29     for (i = 1; moreargs(); ++i)
  30         setelement(val,i,nextarg());
  31     xllastarg();
  32
  33     /* return the structure */
  34     return (val);
  35 }
  36
  37 /* xcpystruct - the '%copy-struct' function */
  38 LVAL xcpystruct(V)
  39 {
  40     LVAL str,val;
  41     int size,i;
  42     str = xlgastruct();
  43     xllastarg();
  44     size = getsize(str);
  45     val = newstruct(getelement(str,0),size-1);
  46     for (i = 1; i < size; ++i)
  47         setelement(val,i,getelement(str,i));
  48     return (val);
  49 }
  50
  51 /* xstrref - the '%struct-ref' function */
  52 LVAL xstrref(V)
  53 {
  54     LVAL str,val;
  55     int i;
  56     str = xlgastruct();
  57     val = xlgafixnum(); i = (int)getfixnum(val);
  58     xllastarg();
  59     if (i >= getsize(str)) /* wrong structure TAA MOD fix*/
  60         xlerror("bad structure reference",str);
  61     return (getelement(str,i));
  62 }
  63
  64 /* xstrset - the '%struct-set' function */
  65 LVAL xstrset(V)
  66 {
  67     LVAL str,val;
  68     int i;
  69     str = xlgastruct();
  70     val = xlgafixnum(); i = (int)getfixnum(val);
  71     val = xlgetarg();
  72     xllastarg();
  73     if (i >= getsize(str)) /* wrong structure TAA MOD fix*/
  74         xlerror("bad structure reference",str);
  75     setelement(str,i,val);
  76     return (val);
  77 }
  78
  79 /* xstrtypep - the '%struct-type-p' function */
  80 LVAL xstrtypep(V)
  81 {
  82   LVAL type,val;
  83   type = xlgasymbol();
  84   val = xlgetarg();
  85   xllastarg();
  86   if (structp(val)) {
  87     for (val = getelement(val,0);
  88          ! null(val);
  89          val = xlgetprop(val,s_strinclude))
  90       if (val == type) return(s_true);
  91     return(NIL);
  92   }
  93   else return(NIL);
  94 }
  95
  96 /* xdefstruct - the 'defstruct' special form */
  97 LVAL xdefstruct(V)
  98 {
  99   LVAL structname,slotname,defexpr,sym,tmp,args,body;
 100   LVAL options,oargs,slots,constrsym,predsym;
 101   char *pname = NULL;
 102   int slotn, has_include;
 103
 104   /* protect some pointers */
 105   xlstkcheck(6);
 106   xlsave(structname);
 107   xlsave(slotname);
 108   xlsave(defexpr);
 109   xlsave(args);
 110   xlsave(body);
 111   xlsave(tmp);
 112
 113   /* initialize */
 114   args = body = NIL;
 115   slotn = 0;
 116   has_include = FALSE;
 117   constrsym = NULL;
 118   predsym = NULL;
 119
 120   /* get the structure name */
 121   tmp = xlgetarg();
 122   if (symbolp(tmp)) {
 123     structname = tmp;
 124     pname = getstring(getpname(structname));
 125     sprintf(prefix, "%s-", pname);
 126   }
 127
 128   /* get the structure name and options */
 129   else if (consp(tmp) && symbolp(car(tmp))) {
 130     structname = car(tmp);
 131     pname = getstring(getpname(structname));
 132     sprintf(prefix, "%s-", pname);
 133
 134     /* handle the list of options */
 135     for (options = cdr(tmp); consp(options); options = cdr(options)) {
 136
 137       /* get the next argument */
 138       tmp = car(options);
 139
 140       /* handle options that don't take arguments */
 141       if (symbolp(tmp)) {
 142         xlerror("unknown option",tmp);
 143       }
 144
 145       /* handle options that take arguments */
 146       else if (consp(tmp) && symbolp(car(tmp))) {
 147         oargs = cdr(tmp);
 148
 149         /* check for the :CONC-NAME keyword */
 150         if (car(tmp) == k_concname) {
 151
 152           /* get the name of the structure to include */
 153           if (!consp(oargs) || !symbolp(car(oargs)))
 154             xlerror("expecting a symbol",oargs);
 155
 156           /* save the prefix */
 157           if (null(car(oargs)))
 158             STRCPY(prefix, "");
 159           else
 160             STRCPY(prefix,getstring(getpname(car(oargs))));
 161         }
 162
 163         /* check for the :INCLUDE keyword */
 164         else if (car(tmp) == k_include) {
 165           LVAL parent;
 166
 167           if (has_include)
 168             xlfail("only one :INCLUDE option allowed");
 169           else
 170             has_include = TRUE;
 171
 172           /* get the name of the structure to include */
 173           if (!consp(oargs) || !symbolp(car(oargs)))
 174             xlerror("expecting a structure name",oargs);
 175           parent = tmp = car(oargs);
 176           oargs = cdr(oargs);
 177
 178           /* add each slot from the included structure */
 179           slots = xlgetprop(tmp,s_sslots);
 180           for (; consp(slots); slots = cdr(slots)) {
 181             if (consp(car(slots)) && consp(cdr(car(slots)))) {
 182
 183               /* get the next slot description */
 184               tmp = car(slots);
 185
 186               /* create the slot access functions */
 187               addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
 188             }
 189           }
 190
 191           /* handle slot initialization overrides */
 192           for (; consp(oargs); oargs = cdr(oargs)) {
 193             tmp = car(oargs);
 194             if (symbolp(tmp)) {
 195               slotname = tmp;
 196               defexpr = NIL;
 197             }
 198             else if (consp(tmp) && symbolp(car(tmp))) {
 199               slotname = car(tmp);
 200               defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
 201             }
 202             else
 203               xlerror("bad slot description",tmp);
 204             updateslot(args,slotname,defexpr);
 205           }
 206           xlputprop(structname,parent,s_strinclude);
 207         }
 208         /* check for :PRINT-FUNCTION option (Ken Whedbee) */
 209         else if (car(tmp) == k_prntfunc) {
 210           if (!consp(oargs) || !symbolp(car(oargs)))
 211             xlerror("expecting a print function name",oargs);
 212           xlputprop(structname,car(oargs),s_prntfunc);
 213         }
 214         else if (car(tmp) == k_construct) {
 215           if (!consp(oargs) || !symbolp(car(oargs)))
 216             xlerror("expecting a constructor function name",oargs);
 217           if (consp(cdr(oargs)))
 218             xlfail("BOA constructors not supported");
 219           constrsym = car(oargs);
 220           if (! symbolp(constrsym)) xlbadtype(constrsym);
 221           xlputprop(structname,constrsym, s_strconstruct);
 222         }
 223         else if (car(tmp) == k_predicate) {
 224           if (!consp(oargs) || !symbolp(car(oargs)))
 225             xlerror("expecting a predicate function name",oargs);
 226           predsym = car(oargs);
 227           if (! symbolp(predsym)) xlbadtype(predsym);
 228         }
 229         else
 230           xlerror("unknown option",tmp);
 231       }
 232       else
 233         xlerror("bad option syntax",tmp);
 234     }
 235   }
 236
 237   /**** need to add documentation string */
 238   /* flush documentation string */
 239   if (moreargs() && stringp(*xlargv)) (void)(nextarg());
 240
 241   /* get each of the structure members */
 242   while (moreargs()) {
 243
 244     /* get the slot name and default value expression */
 245     tmp = xlgetarg();
 246     if (symbolp(tmp)) {
 247       slotname = tmp;
 248       defexpr = NIL;
 249     }
 250     else if (consp(tmp) && symbolp(car(tmp))) {
 251       slotname = car(tmp);
 252       defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
 253     }
 254     else
 255       xlerror("bad slot description",tmp);
 256
 257     /* create a closure for non-trivial default expressions */
 258     if (defexpr != NIL) {
 259       tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
 260       setbody(tmp,cons(defexpr,NIL));
 261       tmp = cons(tmp,NIL);
 262       defexpr = tmp;
 263     }
 264
 265     /* create the slot access functions */
 266     addslot(slotname,defexpr,++slotn,&args,&body);
 267   }
 268
 269   /* store the slotnames and default expressions */
 270   xlputprop(structname,args,s_sslots);
 271
 272   /* enter the MAKE-xxx symbol */
 273   if (constrsym == NULL) {
 274     sprintf(buf, makestr, pname);
 275 #ifdef PACKAGES
 276     constrsym = xlintern(buf, getvalue(s_package));
 277 #else
 278     constrsym = xlenter(buf);
 279 #endif /* PACKAGES */
 280     xlputprop(structname,constrsym, s_strconstruct);
 281   }
 282
 283   /* make the MAKE-xxx function */
 284   if (! null(constrsym)) {
 285     args = cons(lk_key,args);
 286     tmp = cons(structname,NIL);
 287     tmp = cons(s_quote,tmp);
 288     body = cons(tmp,body);
 289     body = cons(s_mkstruct,body);
 290     body = cons(body,NIL);
 291     setfunction(constrsym,
 292                 xlclose(constrsym,s_lambda,args,body,xlenv,xlfenv));
 293   }
 294
 295   /* enter the xxx-P symbol */
 296   if (predsym == NULL) {
 297     sprintf(buf,"%s-P", pname);
 298 #ifdef PACKAGES
 299     predsym = xlintern(buf, getvalue(s_package));
 300 #else
 301     predsym = xlenter(buf);
 302 #endif /* PACKAGES */
 303   }
 304
 305   /* make the xxx-P function */
 306   if (! null(predsym)) {
 307     args = cons(s_x,NIL);
 308     body = cons(s_x,NIL);
 309     tmp = cons(structname,NIL);
 310     tmp = cons(s_quote,tmp);
 311     body = cons(tmp,body);
 312     body = cons(s_strtypep,body);
 313     body = cons(body,NIL);
 314     setfunction(predsym,
 315                 xlclose(predsym,s_lambda,args,body,NIL,NIL));
 316   }
 317
 318   /* enter the COPY-xxx symbol */
 319   sprintf(buf,"COPY-%s", pname);
 320 #ifdef PACKAGES
 321   sym = xlintern(buf, getvalue(s_package));
 322 #else
 323   sym = xlenter(buf);
 324 #endif /* PACKAGES */
 325
 326   /* make the COPY-xxx function */
 327   args = cons(s_x,NIL);
 328   body = cons(s_x,NIL);
 329   body = cons(s_cpystruct,body);
 330   body = cons(body,NIL);
 331   setfunction(sym,
 332               xlclose(sym,s_lambda,args,body,NIL,NIL));
 333
 334   /* restore the stack */
 335   xlpopn(6);
 336
 337   /* return the structure name */
 338   return (structname);
 339 }
 340
 341 /* xlrdstruct - convert a list to a structure (used by the reader) */
 342 /* Modified by TAA to quote arguments and accept leading colons on keys */
 343 LVAL xlrdstruct P1C(LVAL, list)
 344 {
 345     LVAL structname,slotname,expr,last,val;
 346
 347     /* protect the new structure */
 348     xlsave1(expr);
 349
 350     /* get the structure name */
 351     if (!consp(list) || !symbolp(car(list)))
 352         xlerror("bad structure initialization list",list);
 353     structname = car(list);
 354     list = cdr(list);
 355
 356     /* initialize the constructor function call expression */
 357     expr = consa(xlgetprop(structname, s_strconstruct));
 358     last = expr;
 359
 360     /* turn the rest of the initialization list into keyword arguments */
 361     while (consp(list) && consp(cdr(list))) {
 362
 363         /* get the slot keyword name */
 364         slotname = car(list);
 365         if (!symbolp(slotname))
 366             xlerror("expecting a slot name",slotname);
 367
 368         /* add the slot keyword */
 369 #ifdef PACKAGES
 370         rplacd(last,consa(xlintern(getstring(getpname(slotname)), xlkeypack)));
 371 #else
 372         if (*(getstring(getpname(slotname))) != ':') { /* add colon */
 373             sprintf(buf,":%s",getstring(getpname(slotname)));
 374             rplacd(last,cons(xlenter(buf),NIL));
 375         }
 376         else {
 377             rplacd(last,cons(slotname,NIL));
 378         }
 379 #endif /* PACKAGES */
 380         last = cdr(last);
 381         list = cdr(list);
 382
 383         /* add the value expression  -- QUOTED (TAA MOD) */
 384         rplacd(last,cons(NIL,NIL));
 385         last = cdr(last);
 386         rplaca(last, (slotname = cons(s_quote,NIL)));
 387         rplacd(slotname, cons(car(list), NIL));
 388         list = cdr(list);
 389     }
 390
 391     /* make sure all of the initializers were used */
 392     if (consp(list))
 393         xlerror("bad structure initialization list",list);
 394
 395     /* invoke the creation function */
 396     val = xleval(expr);
 397
 398     /* restore the stack */
 399     xlpop();
 400
 401     /* return the new structure */
 402     return (val);
 403 }
 404
 405 /* xlprstruct - print a structure (used by printer) */
 406 VOID xlprstruct P4C(LVAL, fptr, LVAL, vptr, FIXTYPE, plevel, int, flag)
 407 {
 408     LVAL next;
 409     int i,n;
 410     FRAMEP newfp;
 411
 412     {
 413       LVAL type = getelement(vptr,0);
 414       next = xlgetprop(type, s_prntfunc);
 415       while (null(next) && ! null(type)) {
 416         type = xlgetprop(type,s_strinclude);
 417         next = xlgetprop(type, s_prntfunc);
 418       }
 419     }
 420     if (!null(next)) { /* Ken Whedbee addition */
 421         newfp = xlsp;
 422         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
 423         pusharg(symbolp(next) ? xlgetfunction(next) : next);
 424         pusharg(cvfixnum((FIXTYPE) 3));
 425         pusharg(vptr);
 426         pusharg(fptr);
 427         pusharg(cvfixnum(plevel));
 428         xlfp = newfp;
 429         xlapply(3);
 430     }
 431     else {
 432         xlputstr(fptr,"#S(");   /* TAA MOD */
 433         xlprint(fptr,getelement(vptr,0),flag);
 434         next = xlgetprop(getelement(vptr,0), s_sslots);
 435         for (i = 1, n = getsize(vptr) - 1; i <= n && consp(next); ++i) {
 436             if (consp(car(next))) { /* should always succeed */
 437                 xlputc(fptr,' ');   /* Alternate, could print " :" */
 438                 xlprint(fptr,car(car(next)),flag);
 439                 xlputc(fptr,' ');
 440                 xlprint(fptr,getelement(vptr,i),flag);
 441             }
 442             next = cdr(next);
 443         }
 444         xlputc(fptr,')');
 445     }
 446 }
 447
 448 /* addslot - make the slot access functions */
 449 LOCAL VOID addslot P5C(LVAL, slotname, LVAL, defexpr, int, slotn, LVAL *, pargs, LVAL *, pbody)
 450 {
 451     LVAL sym,args,body,tmp;
 452
 453     /* protect some pointers */
 454     xlstkcheck(4);
 455     xlsave(sym);
 456     xlsave(args);
 457     xlsave(body);
 458     xlsave(tmp);
 459
 460     /* construct the update function name */
 461     sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
 462 #ifdef PACKAGES
 463     sym = xlintern(buf, getvalue(s_package));
 464 #else
 465     sym = xlenter(buf);
 466 #endif /* PACKAGES */
 467
 468     /* make the access function */
 469     args = cons(s_s,NIL);
 470     body = cons(cvfixnum((FIXTYPE)slotn),NIL);
 471     body = cons(s_s,body);
 472     body = cons(s_strref,body);
 473     body = cons(body,NIL);
 474     setfunction(sym,
 475                 xlclose(sym,s_lambda,args,body,NIL,NIL));
 476
 477     /* make the update function */
 478     args = cons(s_x,NIL);
 479     args = cons(s_s,args);
 480     body = cons(s_x,NIL);
 481     body = cons(cvfixnum((FIXTYPE)slotn),body);
 482     body = cons(s_s,body);
 483     body = cons(s_strset,body);
 484     body = cons(body,NIL);
 485     xlputprop(sym,
 486               xlclose(NIL,s_lambda,args,body,NIL,NIL),
 487               s_setf);
 488
 489     /* add the slotname to the make-xxx keyword list */
 490     tmp = cons(defexpr,NIL);
 491     tmp = cons(slotname,tmp);
 492     tmp = cons(tmp,NIL);
 493     if ((args = *pargs) == NIL)
 494         *pargs = tmp;
 495     else {
 496         while (consp(cdr(args)))
 497             args = cdr(args);
 498         rplacd(args,tmp);
 499     }
 500
 501     /* add the slotname to the %make-xxx argument list */
 502     tmp = cons(slotname,NIL);
 503     if ((body = *pbody) == NIL)
 504         *pbody = tmp;
 505     else {
 506         while (consp(cdr(body)))
 507             body = cdr(body);
 508         rplacd(body,tmp);
 509     }
 510
 511     /* restore the stack */
 512     xlpopn(4);
 513 }
 514
 515 /* updateslot - update a slot definition */
 516 LOCAL VOID updateslot P3C(LVAL, args, LVAL, slotname, LVAL, defexpr)
 517 {
 518     LVAL tmp;
 519     for (; consp(args); args = cdr(args))
 520         if (slotname == car(car(args))) {
 521             if (defexpr != NIL) {
 522                 xlsave1(tmp);
 523                 tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
 524                 setbody(tmp,cons(defexpr,NIL));
 525                 tmp = cons(tmp,NIL);
 526                 defexpr = tmp;
 527                 xlpop();
 528             }
 529             rplaca(cdr(car(args)),defexpr);
 530             break;
 531         }
 532     if (args == NIL)
 533         xlerror("unknown slot name",slotname);
 534 }