home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / p / plbin.zip / pl / src / pl-wic.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  27KB  |  1,093 lines
  1. /*  pl-wic.c,v 1.5 1993/02/23 13:16:50 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: load and save intermediate code files
  8. */
  9.  
  10. #include "pl-incl.h"
  11.  
  12. forwards char *    getString P((FILE *));
  13. forwards long    getNum P((FILE *));
  14. forwards real    getReal P((FILE *));
  15. forwards bool    loadWicFd P((char *, FILE *, bool, bool));
  16. forwards bool    loadPredicate P((FILE *));
  17. forwards bool    loadExport P((FILE *));
  18. forwards bool    loadImport P((FILE *));
  19. forwards void    putString P((char *, FILE *));
  20. forwards void    putAtom P((Atom, FILE *));
  21. forwards void    putNum P((long, FILE *));
  22. forwards void    putReal P((real, FILE *));
  23. forwards void    saveWicClause P((Clause, FILE *));
  24. forwards void    closeProcedureWic P((void));
  25. forwards void    checkSource P((Atom));
  26. forwards bool    openWic P((char *));
  27. forwards bool    closeWic P((void));
  28. forwards bool    addClauseWic P((Word, Atom));
  29. forwards bool    addDirectiveWic P((word));
  30. forwards bool    startModuleWic P((Atom, SourceFile));
  31. forwards bool    exportWic P((Atom, int));
  32. forwards bool    importWic P((Atom, Atom, int));
  33. forwards word    directiveClause P((word, char *));
  34. forwards bool    compileFile P((char *));
  35. forwards bool    putStates P((FILE *));
  36.  
  37. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  38. SWI-Prolog can compile Prolog source files into intermediate code files, 
  39. which can be loaded very  fast.   They  can  be  saved  as  stand  alone
  40. executables using Unix #! magic number.
  41.  
  42. A wic file consists of the magic code and a version check code.  This is
  43. followed by the command line option defaults.  Then an  optional  series
  44. of  `include'  statements follow.  Finally the predicates and directives
  45. are  described.   Predicates  are  described  close  to   the   internal
  46. representation.  Directives are described as Prolog source.
  47.  
  48. The default options and include statements are written incrementally  in
  49. each  wic  file.   In  the  normal  boot  cycle  first  the boot file is
  50. determined.  Then the option structure is filled with the default option
  51. found in this boot file.  Next the command line arguments are scanned to
  52. obtain all options.  Then stacks, built  in's,  etc.   are  initialised.
  53. The  the  boot  file is read again, but now only scanning for directives
  54. and predicates.
  55.  
  56. IF YOU CHANGE ANYTHING TO THIS FILE, SO THAT OLD WIC-FILES CAN NO LONGER
  57. BE READ, PLEASE DO NOT FORGET TO INCREMENT THE VERSION NUMBER!
  58.  
  59. Below is an informal description of the format of a `wic' file:
  60.  
  61. <wic-file>    ::=    #!<path>
  62.             <magic code>
  63.             <version number>
  64.             <localSize>            % a <word>
  65.             <globalSize>            % a <word>
  66.             <trailSize>            % a <word>
  67.             <argumentSize>            % a <word>
  68.             <lockSize>            % a <word>
  69.             <goal>                % a <string>
  70.             <topLevel>            % a <string>
  71.             <initFile>            % a <string>
  72.             {<statement>}
  73. <magic code>    ::=    <string>            % normally #!<path>
  74. <version number>::=    <word>
  75. <statement>    ::=    'W' <string>            % include wic file
  76.               | 'P' <num> <string>
  77.                 {<clause>} <pattern>    % predicate
  78.               | 'D' <string>            % directive
  79.               | 'F' <string> <system> <time>    % source file
  80.               | 'M' <string> <string>        % start module in file
  81.               | 'E' <num> <string>        % export predicate
  82.               | 'I' <string> <num> <string>    % import predicate
  83. <clause>    ::=    'C' <n var> <n slots> <n clause> <externals> <codes>    % clause
  84.               | 'X'                 % end of list
  85. <externals>    ::=    <num> {<external>}
  86. <external>    ::=    'a' <string>            % atom
  87.             'f' <num> <string>        % functor
  88.             'p' <num> <string>        % predicate
  89.             'e' <string> <num> <string>    % extern predicate
  90.             'n' <word>            % number
  91.             'r' <word>            % real (float)
  92.             's' <string>            % string
  93. <system>    ::=    's'                % system source file
  94.               | 'u'                % user source file
  95. <time>        ::=    <word>                % time file was loaded
  96. <pattern>    ::=    <word>                % indexing pattern
  97. <codes>        ::=    <num> {<code>}
  98. <string>    ::=    {<non-zero byte>} <0>
  99. <word>        ::=    <4 byte entity>
  100.  
  101. Numbers are stored in  a  packed  format  to  reduce  the  size  of  the
  102. intermediate  code  file  as  99%  of  them  is  normally  small, but in
  103. principle not limited (virtual  machine  codes,  arities,  table  sizes,
  104. etc).   The  upper  two  bits  of  the  first byte contain the number of
  105. additional bytes.  the bytes represent the number `most-significant part
  106. first'.  See the functions putNum() and getNum()  for  details.   Before
  107. you  don't  agree  to  this  schema,  you  should  remember it makes the
  108. intermediate code files about 30% smaller  and  avoids  the  differences
  109. between  16  and  32  bits  machines (arities on 16 bits machines are 16
  110. bits) as well as machines with different byte order.
  111. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  112.  
  113. #define VERSION 10            /* save version number */
  114.  
  115. static char saveMagic[] = "SWI-Prolog (c) 1990 Jan Wielemaker\n";
  116. static char *wicFile;            /* name of output file */
  117. static FILE *wicFd;            /* file descriptor of wic file */
  118. static Procedure currentProc;        /* current procedure */
  119. static SourceFile currentSource;    /* current source file */
  120.  
  121. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  122. On tos, loading takes long; give the user  something  to  look  at.   On
  123. workstations, it normally is so fast it is hardy noticable.
  124. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  125.  
  126. #if tos
  127. forwards void    notifyLoad P((char *file));
  128. forwards void    notifyLoaded P((void));
  129. forwards void    notifyPredicate P((char *name, int arity));
  130.  
  131. static void
  132. notifyLoad(file)
  133. char *file;
  134. { printf("Loading %s ", file);
  135.   fflush(stdout);
  136. }
  137.  
  138. static void
  139. notifyLoaded()
  140. { printf("\r\033K");
  141. }
  142.  
  143. static void
  144. notifyPredicate(name, arity)
  145. char *name;
  146. int arity;
  147. { static char cur[] = "|/-\\";
  148.   static int  n = 0;
  149.  
  150.   printf("%c\b", cur[n++ & 0x3]);
  151. }
  152. #endif
  153.  
  154. #if unix || EMX
  155. #define notifyLoad(file)
  156. #define notifyLoaded()
  157. #define notifyPredicate(name, arity)
  158. #endif
  159.  
  160. static char *
  161. getString(fd)
  162. FILE *fd;
  163. { static char *tmp;
  164.   static char *tmpend;
  165.   static int  tmpsize = 512;
  166.   char *s;
  167.  
  168.   if ( tmp == NULL )
  169.   { tmp    = malloc(tmpsize);
  170.     tmpend = &tmp[tmpsize-1];
  171.   }
  172.  
  173.   for( s = tmp; (*s = Getc(fd)) != EOS; s++ )
  174.   { if ( s == tmpend )
  175.     { tmp = realloc(tmp, tmpsize+512);
  176.       s = &tmp[tmpsize-1];
  177.       tmpsize += 512;
  178.       tmpend = &tmp[tmpsize-1];
  179.     }
  180.     if ( *s == EOF )
  181.       fatalError("Unexpected EOF on intermediate code file at offset %d",
  182.          ftell(fd));
  183.   }
  184.  
  185.   return tmp;
  186. }
  187.  
  188. static long
  189. getNum(fd)
  190. FILE *fd;
  191. { long first = Getc(fd);
  192.   int bytes, shift, b;
  193.  
  194.   if ( (bytes = (int) ((first >> 6) & 0x3)) == 0 )
  195.     return (first << 26) >> 26;        /* 99% of them: speed up a bit */
  196.  
  197.   first &= 0x3f;
  198.   for( b = 0; b < bytes; b++ )
  199.   { first <<= 8;
  200.     first |= Getc(fd) & 0xff;
  201.   }
  202.  
  203.   shift = (3-bytes)*8 + 2;
  204.  
  205.   return (first << shift) >> shift;
  206. }
  207.  
  208. static real
  209. getReal(fd)
  210. FILE *fd;
  211. { real f;
  212.   char *s = (char *)&f;
  213.   int n;
  214.  
  215.   for(n=0; n<sizeof(f); n++)
  216.     *s++ = Getc(fd);
  217.  
  218.   return f;
  219. }
  220.  
  221. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  222. Load a complete `wic' file.  `toplevel' tells  us  whether  we  are  the
  223. toplevel  file  opened,  and thus should include other `wic' files or we
  224. should ignore the include statements.  `load_options' tells us  to  only
  225. load the options of the toplevel file.
  226.  
  227. All wic files loaded are appended in the  right  order  to  a  chain  of
  228. `states'.  They are written to a new toplevel wic file by openWic().
  229. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  230.  
  231. bool
  232. loadWicFile(file, toplevel, load_options)
  233. char *file;
  234. bool toplevel, load_options;
  235. { FILE *fd;
  236.   bool rval = TRUE;
  237.  
  238.   if ((fd = Fopen(file, STREAM_OPEN_BIN_READ)) == (FILE *) NULL)
  239.   { fatalError("Can't open %s: %s", file, OsError());
  240.     rval = FALSE;
  241.     goto out;
  242.   }
  243.  
  244.   notifyLoad(file);
  245.  
  246.   if (loadWicFd(file, fd, toplevel, load_options) == FALSE)
  247.   { rval = FALSE;
  248.     goto out;
  249.   }
  250.   if (toplevel == TRUE && load_options == FALSE)
  251.   { if (appendState(file) == FALSE)
  252.     { rval = FALSE;
  253.       goto out;
  254.     }
  255.   }
  256.  
  257. out:
  258.   if (fd != (FILE *) NULL)
  259.     fclose(fd);
  260.  
  261.   notifyLoaded();
  262.  
  263.   return rval;
  264. }
  265.  
  266.  
  267. static bool
  268. loadWicFd(file, fd, toplevel, load_options)
  269. char *file;
  270. FILE *fd;
  271. bool toplevel, load_options;
  272. { char *s;
  273.   Char c;
  274.   int n;
  275.  
  276. #if OS2
  277.   for(n=0; n<5; n++)                    /* skip first five lines */
  278. #else
  279.   for(n=0; n<2; n++)            /* skip first two lines */
  280. #endif
  281.   { while( (c=(Char)Getc(fd)) != '\n' && c != EOF ) ;
  282.     if ( c == EOF )
  283.       return fatalError("%s is not a SWI-Prolog intermediate code file", file);
  284.   }
  285.  
  286.   s = getString(fd);
  287.   if (!streq(s, saveMagic) )
  288.     return fatalError("%s is not a SWI-Prolog intermediate code file", file);
  289.  
  290.   if (getNum(fd) != VERSION)
  291.   { fatalError("Intermediate code file %s has incompatible save version",
  292.            file);
  293.     fail;
  294.   }
  295.  
  296.   if (load_options && toplevel)
  297.   { options.localSize    = getNum(fd);
  298.     options.globalSize   = getNum(fd);
  299.     options.trailSize    = getNum(fd);
  300.     options.argumentSize = getNum(fd);
  301.     options.lockSize     = getNum(fd);
  302.     DEBUG(2, printf("local=%ld, global=%ld, trail=%ld, argument=%ld\n",
  303.         options.localSize, options.globalSize,
  304.         options.trailSize, options.argumentSize));
  305.     options.goal         = store_string(getString(fd) );
  306.     options.topLevel     = store_string(getString(fd) );
  307.     options.initFile     = store_string(getString(fd) );
  308.  
  309.     succeed;
  310.   } else
  311.   { int n;
  312.     for(n=0; n<5; n++)   getNum(fd);
  313.     for(n=0; n<3; n++)   getString(fd);
  314.   }
  315.  
  316.   for(;;)
  317.   { switch(c=Getc(fd) )
  318.     { case EOF:
  319.     succeed;
  320.       case 'W':
  321.     { char *name;
  322.  
  323.       name = store_string(getString(fd) );
  324.       if (toplevel == TRUE)
  325.       { appendState(name);
  326.         loadWicFile(name, FALSE, FALSE);
  327.       }
  328.       continue;
  329.     }
  330.       case 'P':
  331.     { loadPredicate(fd);
  332.       continue;
  333.     }
  334.       case 'D':
  335.     { word directive;
  336.       word rval;
  337.  
  338.       s = getString(fd);
  339.       seeString(s);
  340.       setVar(directive);
  341.       rval = pl_read(&directive);
  342.       seenString();
  343.       if (rval == TRUE)
  344.       { environment_frame = (LocalFrame) NULL;
  345.         if (callGoal(MODULE_user, directive, FALSE) == FALSE)
  346.         { printf("[WARNING: directive failed: ");
  347.           pl_write(&directive);
  348.           printf("]\n");
  349.         }
  350.       }
  351.  
  352.       continue;
  353.     }      
  354.       case 'F':
  355.     { currentSource = lookupSourceFile(lookupAtom(getString(fd) ));
  356.       currentSource->system = (Getc(fd) == 's' ? TRUE : FALSE);
  357.       currentSource->time = Getw(fd);
  358.       continue;
  359.     }
  360.       case 'M':
  361.     { char *file;
  362.  
  363.       modules.source = lookupModule(lookupAtom(getString(fd)));
  364.       file = getString(fd);
  365.       if (!streq(file, "-") )
  366.         modules.source->file = lookupSourceFile(lookupAtom(file));
  367.       continue;
  368.     }
  369.       case 'E':
  370.     { loadExport(fd);
  371.       continue;
  372.     }
  373.       case 'I':
  374.     { loadImport(fd);
  375.       continue;
  376.     }
  377.       default:
  378.     sysError("Illegal statement in wic file: %d", c);
  379.     }
  380.   }
  381. }
  382.  
  383. static bool
  384. loadPredicate(fd)
  385. FILE *fd;
  386. { int arity;
  387.   int n;
  388.   char *name;
  389.   Procedure proc;
  390.   Definition def;
  391.   Clause clause;
  392.   Word xp;
  393.   Code bp;
  394.  
  395.   arity = (int) getNum(fd);
  396.   if ((name = getString(fd)) == (char *) NULL)
  397.     sysError("bad string in wic file");
  398.   notifyPredicate(name, arity);
  399.   proc = lookupProcedure(lookupFunctorDef(lookupAtom(name), arity), 
  400.               modules.source);
  401.   def = proc->definition;
  402.   def->source = currentSource;
  403.   if ( SYSTEM_MODE &&
  404.        false(def, DYNAMIC) &&
  405.        false(def, MULTIFILE) )
  406.   { set(def, SYSTEM);
  407.     set(def, HIDE_CHILDS);
  408.   }
  409.  
  410.   for(;;)
  411.   { switch(Getc(fd) )
  412.     { case 'X':
  413.       { ulong pattern = Getw(fd);
  414.  
  415.     if ( def->indexPattern != pattern )
  416.     { def->indexPattern = pattern;
  417.       def->indexCardinality = cardinalityPattern(def->indexPattern);
  418.       if ( pattern != 0x1 )
  419. #if O_AUTOINDEX
  420.         clear(def, AUTOINDEX);
  421. #endif /* O_AUTOINDEX */
  422.       reindexProcedure(proc);
  423.     }
  424.  
  425.     succeed;
  426.       }
  427.       case 'C':
  428.     clause = (Clause) allocHeap(sizeof(struct clause));
  429.     clause->next = (Clause) NULL;
  430.     clause->references = 0;
  431.     clearFlags(clause);
  432.     clause->variables = getNum(fd);
  433.     clause->slots = getNum(fd);
  434.     clause->subclauses = getNum(fd);
  435.     clause->procedure = proc;
  436.  
  437.     clause->XR_size = getNum(fd);
  438.     statistics.externals += clause->XR_size;
  439.     if ( clause->XR_size > 0 )
  440.     { clause->externals = (Word) allocHeap(clause->XR_size * sizeof(word));
  441.       xp = clause->externals;
  442.       for(n=0; n<clause->XR_size; n++, xp++)
  443.       { char c;
  444.  
  445.         switch( c=Getc(fd) )
  446.         { case 'a':
  447.         *xp = (word)lookupAtom(getString(fd) );
  448.         continue;
  449. #if O_STRING
  450.           case 's':
  451.         *xp = heapString(getString(fd));
  452.         continue;
  453. #endif /* O_STRING */
  454.           case 'f':
  455.         arity = (int) getNum(fd);
  456.         name = getString(fd);
  457.         *xp = (word)lookupFunctorDef(lookupAtom(name), arity);
  458.         continue;
  459.           case 'p':
  460.         arity = (int) getNum(fd);
  461.         name = getString(fd);
  462.         *xp = (word)lookupProcedure(lookupFunctorDef(lookupAtom(name), arity), 
  463.                         modules.source);
  464.         continue;
  465.           case 'e':
  466.         { Module module = lookupModule(lookupAtom(getString(fd) ));
  467.  
  468.           arity = (int) getNum(fd);
  469.           name = getString(fd);
  470.           *xp = (word)lookupProcedure(lookupFunctorDef(lookupAtom(name), arity), 
  471.                           module);
  472.           continue;
  473.         }
  474.           case 'n':
  475.         *xp = Getw(fd);
  476.         continue;
  477.           case 'r':
  478.         *xp = heapReal(getReal(fd));
  479.         continue;
  480.           default:
  481.         sysError("%s (char. index 0%lo): illegal XR entry: %c",
  482.                     procedureName(proc), ftell(fd), c);
  483.         }
  484.       }
  485.     } else          
  486.       clause->externals = NULL;
  487.     clause->code_size = getNum(fd);
  488.     statistics.codes += clause->code_size;
  489.     clause->codes = (Code) allocHeap(clause->code_size * sizeof(code));
  490.     bp = clause->codes;
  491. #if O_VMCODE_IS_ADDRESS
  492.     while( bp < &clause->codes[clause->code_size] )
  493.     { code op = getNum(fd);
  494.       int n;
  495.       
  496.       *bp++ = encode(op);
  497.       for(n = codeTable[op].arguments; n > 0; n--)
  498.         *bp++ = getNum(fd);
  499.     }
  500. #else
  501.     for(n=0; n<clause->code_size; n++)
  502.       *bp++ = getNum(fd);
  503. #endif
  504.  
  505.     assertProcedure(proc, clause, 'z');
  506.     reindexClause(clause);
  507.     }
  508.   }
  509. }
  510.  
  511. static bool
  512. loadExport(fd)
  513. FILE *fd;
  514. { int arity =  (int) getNum(fd);
  515.   char *name = getString(fd);
  516.   FunctorDef functor = lookupFunctorDef(lookupAtom(name), arity);
  517.   Procedure proc = lookupProcedure(functor, modules.source);
  518.  
  519.   addHTable(modules.source->public, functor, proc);
  520.  
  521.   succeed;
  522. }
  523.   
  524. static bool
  525. loadImport(fd)
  526. FILE *fd;
  527. { Module source = lookupModule(lookupAtom(getString(fd) ));
  528.   int arity = (int) getNum(fd);
  529.   char *name = getString(fd);
  530.   FunctorDef functor = lookupFunctorDef(lookupAtom(name), arity);
  531.   Procedure proc = lookupProcedure(functor, source);
  532.   Procedure old;
  533.  
  534.   DEBUG(2, printf("loadImport(): %s/%d into %s\n", name, arity, stringAtom(modules.source->name)));
  535.  
  536.   if ((old = isCurrentProcedure(functor, modules.source)) != (Procedure) NULL)
  537.   { if ( old->definition == proc->definition )
  538.       succeed;            /* already done this! */
  539.  
  540.     if (!isDefinedProcedure(old) )
  541.     { old->definition = proc->definition;
  542.       succeed;
  543.     }
  544.  
  545.     return warning("Failed to import %s into %s", 
  546.            procedureName(proc), 
  547.            stringAtom(modules.source->name) );
  548.   }
  549.   addHTable(modules.source->procedures, functor, proc);
  550.  
  551.   succeed;
  552. }
  553.  
  554. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  555. The code below handles the creation of `wic' files.  It offers a  number
  556. of  predicates  which  enables  us  to write the compilation toplevel in
  557. Prolog.
  558.  
  559. Note that we keep track of the `current procedure' to keep  all  clauses
  560. of a predicate together.
  561. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  562.  
  563. static void
  564. putString(s, fd)
  565. register char *s;
  566. FILE *fd;
  567. { while(*s)
  568.   { Putc(*s, fd);
  569.     s++;
  570.   }
  571.  
  572.   Putc(EOS, fd);
  573. }
  574.  
  575. static void
  576. putAtom(a, fd)
  577. Atom a;
  578. FILE *fd;
  579. { putString(a->name, fd);
  580. }
  581.  
  582. static void
  583. putNum(n, fd)
  584. long n;
  585. FILE *fd;
  586. { long m = n > 0 ? n : n - 1;
  587.  
  588.   if ( m < (1L << 5) )
  589.   { Putc((char) (n & 0x3f), fd);
  590.     return;
  591.   }
  592.   if ( m < (1L << 13) )
  593.   { Putc((char) (((n >> 8) & 0x3f) | (1 << 6)), fd);
  594.     Putc((char) (n & 0xff), fd);
  595.     return;
  596.   }
  597.   if ( m < (1L << 21) )
  598.   { Putc((char) (((n >> 16) & 0x3f) | (2 << 6)), fd);
  599.     Putc((char) ((n >> 8) & 0xff), fd);
  600.     Putc((char) (n & 0xff), fd);
  601.     return;
  602.   }
  603.   if ( m < (1L << 29) )
  604.   { Putc((char) (((n >> 24) & 0x3f) | (3 << 6)), fd);
  605.     Putc((char) ((n >> 16) & 0xff), fd);
  606.     Putc((char) ((n >> 8) & 0xff), fd);
  607.     Putc((char) (n & 0xff), fd);
  608.     return;
  609.   }
  610.   sysError("Argument to putNum() out of range: %ld", n);
  611. }
  612.  
  613. static void
  614. putReal(f, fd)
  615. real f;
  616. FILE *fd;
  617. { char *s = (char *)&f;
  618.   int n;
  619.  
  620.   for(n=0; n < sizeof(f); n++)
  621.     Putc(*s++, fd);
  622. }
  623.  
  624.  
  625. static void
  626. saveWicClause(clause, fd)
  627. Clause clause;
  628. FILE *fd;
  629. { Word xp;
  630.   word xr;
  631.   Code bp;
  632.   int n;
  633.  
  634.   Putc('C', fd);
  635.   putNum(clause->variables, fd);
  636.   putNum(clause->slots, fd);
  637.   putNum(clause->subclauses, fd);
  638.  
  639.   putNum(clause->XR_size, fd);
  640.   xp = clause->externals;
  641.   for(n=0; n<clause->XR_size; n++, xp++)
  642.   { xr = *xp;
  643.     if (isAtom(xr) )
  644.     { Putc('a', fd);
  645.       putAtom((Atom)xr, fd);
  646.     } else if (isInteger(xr) )
  647.     { Putc('n', fd);
  648.       Putw(xr, fd);
  649.     } else if (isReal(xr) )
  650.     { Putc('r', fd);
  651.       putReal(valReal(xr), fd);
  652. #if O_STRING
  653.     } else if ( isString(xr) )
  654.     { Putc('s', fd);
  655.       putString(valString(xr), fd);
  656. #endif /* O_STRING */
  657.     } else if (((FunctorDef)xr)->type == FUNCTOR_TYPE)
  658.     { Putc('f', fd);
  659.       putNum(((FunctorDef)xr)->arity, fd);
  660.       putAtom(((FunctorDef)xr)->name, fd);
  661.     } else
  662.     { if (((Procedure)xr)->definition->module != modules.source)
  663.       { Putc('e', fd);
  664.     putAtom(((Procedure)xr)->definition->module->name, fd);
  665.       } else
  666.       { Putc('p', fd);
  667.       }
  668.       putNum(((Procedure)xr)->functor->arity, fd);
  669.       putAtom(((Procedure)xr)->functor->name, fd);
  670.     }
  671.   }
  672.  
  673.   putNum(clause->code_size, fd);
  674.   bp = clause->codes;
  675. #if O_VMCODE_IS_ADDRESS
  676.   while( bp < &clause->codes[clause->code_size] )
  677.   { code op = decode(*bp++);
  678.     int n;
  679.  
  680.     putNum(op, fd);
  681.     for(n = codeTable[op].arguments; n > 0; n--)
  682.       putNum(*bp++, fd);
  683.   }
  684. #else
  685.   for(n=0; n<clause->code_size; n++, bp++)
  686.     putNum(*bp, fd);
  687. #endif
  688. }
  689.  
  690.  
  691.         /********************************
  692.         *         COMPILATION           *
  693.         *********************************/
  694.  
  695. static void
  696. closeProcedureWic()
  697. { if (currentProc != (Procedure) NULL)
  698.   { Putc('X', wicFd);
  699.     Putw(currentProc->definition->indexPattern, wicFd);
  700.     currentProc = (Procedure) NULL;
  701.   }
  702. }
  703.  
  704. static void
  705. checkSource(file)
  706. Atom file;
  707. { SourceFile sf = lookupSourceFile(file);
  708.  
  709.   if (sf != currentSource)
  710.   { currentSource = sf;
  711.     Putc('F', wicFd);
  712.     putAtom(file, wicFd);
  713.     Putc(sf->system ? 's' : 'u', wicFd);
  714.     Putw(sf->time, wicFd);
  715.   }
  716. }
  717.  
  718. static bool
  719. openWic(file)
  720. char *file;
  721. { char *exec;
  722.  
  723.   wicFile = file;
  724.  
  725.   DEBUG(1, printf("Open compiler output file %s\n", file));
  726.   if ( (wicFd = Fopen(file, STREAM_OPEN_BIN_WRITE)) == (FILE *)NULL )
  727.     return warning("Can't open %s: %s", file, OsError());
  728.   DEBUG(1, printf("Searching for executable\n"));
  729.   if ( loaderstatus.restored_state )
  730.   { exec = stringAtom(loaderstatus.restored_state);
  731.   } else
  732.   { TRY( getSymbols() );
  733.     exec = stringAtom(loaderstatus.orgsymbolfile);
  734.   }
  735.   DEBUG(1, printf("Executable = %s\n", exec));
  736.   if ( !(exec = OsPath(AbsoluteFile(PrologPath(exec)))) )
  737.     fail;
  738.   DEBUG(1, printf("Expanded executable = %s\n", exec));
  739. /*fprintf(wicFd, "#!%s -x\n", exec);*/
  740. #if OS2
  741.   fprintf(wicFd, "/* Compiled SWI-Prolog Program */\r\n'@ECHO OFF'\r\nparse source . . name\r\n\"%s -x \" name arg(1)\r\nexit\r\n", exec);
  742. #else
  743.   fprintf(wicFd, "#!/bin/sh\nexec %s -x $0 $*\n", exec);
  744. #endif /* OS2 */
  745.   DEBUG(2, printf("Magic  ...\n"));
  746.   putString( saveMagic,            wicFd);
  747.   DEBUG(2, printf("Numeric options ...\n"));
  748.   putNum(    VERSION,              wicFd);
  749.   putNum(    options.localSize,    wicFd);
  750.   putNum(    options.globalSize,   wicFd);
  751.   putNum(    options.trailSize,    wicFd);
  752.   putNum(    options.argumentSize, wicFd);
  753.   putNum(    options.lockSize,     wicFd);
  754.   DEBUG(2, printf("String options ...\n"));
  755.   putString(options.goal,          wicFd);
  756.   putString(options.topLevel,      wicFd);
  757.   putString(options.initFile,        wicFd);
  758.  
  759.   DEBUG(2, printf("States ...\n"));
  760.   putStates(wicFd);
  761.   currentProc = (Procedure) NULL;
  762.   currentSource = (SourceFile) NULL;
  763.  
  764.   DEBUG(2, printf("Header complete ...\n"));
  765.   succeed;
  766. }  
  767.  
  768. static bool
  769. closeWic()
  770. { if (wicFd == (FILE *) NULL)
  771.     fail;
  772.   closeProcedureWic();
  773.   fclose(wicFd);
  774.   return MarkExecutable(wicFile);
  775. }
  776.  
  777. static bool
  778. addClauseWic(term, file)
  779. Word term;
  780. Atom file;
  781. { Clause clause;
  782.  
  783.   if ((clause = assert_term(term, 'z', file)) != (Clause)NULL)
  784.   { if (clause->procedure != currentProc)
  785.     { closeProcedureWic();
  786.       checkSource(file);
  787.       currentProc = clause->procedure;
  788.       Putc('P', wicFd);
  789.       putNum(currentProc->functor->arity, wicFd);
  790.       putAtom(currentProc->functor->name, wicFd);
  791.     }
  792.     saveWicClause(clause, wicFd);
  793.     succeed;
  794.   }
  795.  
  796.   fail;
  797. }
  798.  
  799. static bool
  800. addDirectiveWic(term)
  801. word term;
  802. { char *s = (char *)lTop;
  803. #if !O_DYNAMIC_STACKS
  804.   long n = (char *)lMax - (char *)lTop;
  805.  
  806.   tellString(s, n-2);
  807. #else
  808.   tellString(s, 1000000);
  809. #endif
  810.   TRY(pl_writeq(&term) );
  811.   toldString();
  812.   strcat(s, ". ");
  813.  
  814.   closeProcedureWic();
  815.   Putc('D', wicFd);
  816.   putString(s, wicFd);
  817.  
  818.   succeed;
  819. }  
  820.  
  821. static bool
  822. startModuleWic(name, file)
  823. Atom name;
  824. SourceFile file;
  825. { closeProcedureWic();
  826.  
  827.   Putc('M', wicFd);
  828.   putAtom(name, wicFd);
  829.   if (file != (SourceFile) NULL)
  830.     putAtom(file->name, wicFd);
  831.   else
  832.     putString("-", wicFd);
  833.  
  834.   succeed;
  835. }
  836.  
  837. static bool
  838. exportWic(name, arity)
  839. Atom name;
  840. int arity;
  841. { closeProcedureWic();
  842.  
  843.   Putc('E', wicFd);
  844.   putNum(arity, wicFd);
  845.   putAtom(name, wicFd);
  846.  
  847.   succeed;
  848. }
  849.  
  850. static bool
  851. importWic(module, name, arity)
  852. Atom module, name;
  853. int arity;
  854. { closeProcedureWic();
  855.  
  856.   Putc('I', wicFd);
  857.   putAtom(module, wicFd);
  858.   putNum(arity, wicFd);
  859.   putAtom(name, wicFd);
  860.  
  861.   succeed;
  862. }
  863.  
  864.         /********************************
  865.         *        PROLOG SUPPORT         *
  866.         *********************************/
  867.  
  868. word
  869. pl_open_wic(name)
  870. Word name;
  871. { if (!isAtom(*name) )
  872.     fail;
  873.  
  874.   return openWic(stringAtom(*name));
  875. }
  876.  
  877. word
  878. pl_close_wic()
  879. { return closeWic();
  880. }
  881.  
  882. word
  883. pl_add_clause_wic(term, file)
  884. Word term, file;
  885. { if (isVar(*term) || !isAtom(*file) )
  886.     return warning("$add_clause_wic/2: instantiation fault");
  887.  
  888.   return addClauseWic(term, (Atom)*file);
  889. }
  890.  
  891. word
  892. pl_add_directive_wic(term)
  893. Word term;
  894. { if (isVar(*term) )
  895.     return warning("$add_directive_wic/1: directive is a variable");
  896.  
  897.   return addDirectiveWic(*term);
  898. }
  899.  
  900. word
  901. pl_start_module_wic(term, file)
  902. Word term, file;
  903. { if (!isAtom(*term) || (!isAtom(*file) && !isInteger(*file)))
  904.     return warning("$start_module_wic/1: instantiation fault");
  905.  
  906.   return startModuleWic((Atom)*term,
  907.             isInteger(*file) ? (SourceFile) NULL
  908.                      : lookupSourceFile((Atom)*file));
  909. }
  910.  
  911. word
  912. pl_export_wic(name, arity)
  913. Word name, arity;
  914. { if (!isAtom(*name) || !isInteger(*arity) )
  915.     return warning("$export_wic/2: instantiation fault");
  916.  
  917.   return exportWic((Atom)*name, (int)valNum(*arity));
  918. }
  919.  
  920. word
  921. pl_import_wic(module, name, arity)
  922. Word module, name, arity;
  923. { if (!isAtom(*module) || !isAtom(*name) || !isInteger(*arity) )
  924.     return warning("$import_wic/3: instantiation fault");
  925.  
  926.   return importWic((Atom)*module, (Atom)*name, (int) valNum(*arity));
  927. }
  928.  
  929.  
  930.         /********************************
  931.         *     BOOTSTRAP COMPILATION     *
  932.         *********************************/
  933.  
  934. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  935. The code below offers a restricted compilation  toplevel  used  for  the
  936. bootstrap  compilation  (-b  option).  It handles most things the Prolog
  937. defined compiler handles as well, except:
  938.  
  939.   - Be carefull to define  a  predicate  first  before  using  it  as  a
  940.     directive
  941.   - It does not offer `consult', `ensure_loaded' or the  list  notation.
  942.     (there is no way to include other files).
  943. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  944.  
  945. /*  Check if a clause is of the for ":- directive". If not return NULL, 
  946.     otherwise return the argument.
  947.  
  948.  ** Wed Jun  8 16:12:39 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  949.  
  950. static word
  951. directiveClause(clause, functor)
  952. word clause;
  953. char *functor;
  954. { if (!isTerm(clause) )
  955.     return (word) NULL;
  956.   if (functorTerm(clause)->arity == 1 &&
  957.        streq(functorTerm(clause)->name->name, functor) )
  958.   { word d;
  959.  
  960.     d = argTerm(clause, 0);
  961.     if (isVar(d) )
  962.       return (word) NULL;
  963.  
  964.     if ( !isTerm(d) || functorTerm(d) != FUNCTOR_module2 )
  965.     { word directive;
  966.       
  967.       directive = globalFunctor(FUNCTOR_module2);
  968.       argTerm(directive, 0) = (word) modules.source->name;
  969.       argTerm(directive, 1) = d;
  970.  
  971.       return directive;
  972.     }
  973.  
  974.     return d;
  975.   } else
  976.     return (word) NULL;
  977. }
  978.  
  979. /*  Compile an entire file into intermediate code.
  980.  
  981.  ** Thu Apr 28 13:44:43 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  982.  
  983. static bool
  984. compileFile(file)
  985. char *file;
  986. { word term;
  987.   char *path;
  988.   word f;
  989.   word directive;
  990.  
  991.   DEBUG(1, printf("Boot compilation of %s\n", file));
  992.   if ((path = AbsoluteFile(file)) == (char *) NULL)
  993.     fail;
  994.   DEBUG(2, printf("Expanded to %s\n", path));
  995.  
  996.   f = (word) lookupAtom(path);
  997.   DEBUG(2, printf("Opening\n"));
  998.   if (pl_see(&f) == FALSE)
  999.     fail;
  1000.   DEBUG(2, printf("pl_start_consult()\n"));
  1001.   pl_start_consult(&f);
  1002.   
  1003.   for(;;)
  1004.   { setVar(term);
  1005.     DEBUG(2, printf("pl_read_clause() -> "));
  1006.     if (pl_read_clause(&term) == FALSE)
  1007.       continue;
  1008.     DEBUG(2, pl_write(&term); pl_nl());
  1009.     if (term == (word) ATOM_end_of_file)
  1010.       break;
  1011.     if ((directive = directiveClause(term, ":-")) != (word) NULL)
  1012.     { environment_frame = (LocalFrame) NULL;
  1013.       DEBUG(1, Putf(":- "); pl_write(&directive); Putf(".\n") );
  1014.       callGoal(MODULE_user, directive, FALSE);
  1015.       addDirectiveWic(directive);
  1016.     } else if ((directive = directiveClause(term, "$:-")) != (word) NULL)
  1017.     { environment_frame = (LocalFrame) NULL;
  1018.       DEBUG(1, Putf("$:- "); pl_write(&directive); Putf(".\n") );
  1019.       callGoal(MODULE_user, directive, FALSE);
  1020.     } else
  1021.       addClauseWic(&term, (Atom)f);
  1022.   }
  1023.   pl_seen();
  1024.  
  1025.   succeed;
  1026. }
  1027.  
  1028. bool
  1029. compileFileList(out, argc, argv)
  1030. char *out;
  1031. int argc;
  1032. char **argv;
  1033. { newOp("$:-", OP_FX, 1200);
  1034.   TRY(openWic(out) );
  1035.   
  1036.   for(;argc > 0; argc--, argv++)
  1037.   { if (streq(argv[0], "-c") )
  1038.       break;
  1039.     compileFile(argv[0]);
  1040.   }
  1041.  
  1042.   return closeWic();
  1043. }
  1044.  
  1045.  
  1046.         /********************************
  1047.         *         STATE LISTS           *
  1048.         *********************************/
  1049.  
  1050. /*  Add a new state to the chain of states this Prolog session is build
  1051.     from. The file name is made absolute to avoid directory problems
  1052.     with incremental loading.
  1053. */
  1054.  
  1055. bool
  1056. appendState(name)
  1057. char *name;
  1058. { State state, st;
  1059.   char *absolute;
  1060.  
  1061.   if ((absolute = AbsoluteFile(name)) == (char *) NULL)
  1062.     return warning("invalid file specification: %s", name);
  1063.  
  1064.   state = (State) allocHeap(sizeof(struct state) );
  1065.   state->next = (State) NULL;
  1066.   state->name = store_string(absolute);
  1067.  
  1068.   if (stateList == (State) NULL)
  1069.   { stateList = state;
  1070.     succeed;
  1071.   }
  1072.   for(st = stateList; st->next; st = st->next) ;
  1073.   st->next = state;
  1074.  
  1075.   succeed;
  1076. }
  1077.  
  1078. /*  Add 'W' statements to the WIC file for each file in the state list.
  1079. */
  1080.  
  1081. static bool
  1082. putStates(fd)
  1083. FILE *fd;
  1084. { State st;
  1085.  
  1086.   for(st = stateList; st; st = st->next)
  1087.   { Putc('W', fd);
  1088.     putString(st->name, fd);
  1089.   }
  1090.  
  1091.   succeed;
  1092. }
  1093.