1 % $Id: mp.w 1299 2008-05-28 14:09:04Z taco $
2 % MetaPost, by John Hobby. Public domain.
4 % Much of this program was copied with permission from MF.web Version 1.9
5 % It interprets a language very similar to D.E. Knuth's METAFONT, but with
6 % changes designed to make it more suitable for PostScript output.
8 % TeX is a trademark of the American Mathematical Society.
9 % METAFONT is a trademark of Addison-Wesley Publishing Company.
10 % PostScript is a trademark of Adobe Systems Incorporated.
12 % Here is TeX material that gets inserted after \input webmac
13 \def\hang{\hangindent 3em\noindent\ignorespaces}
14 \def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
16 \def\psqrt#1{\sqrt{\mathstrut#1}}
18 \def\pct!{{\char`\%}} % percent sign in ordinary text
19 \font\tenlogo=logo10 % font used for the METAFONT logo
21 \def\MF{{\tenlogo META}\-{\tenlogo FONT}}
22 \def\MP{{\tenlogo META}\-{\tenlogo POST}}
23 \def\[#1]{\ignorespaces} % left over from pascal web
24 \def\<#1>{$\langle#1\rangle$}
25 \def\section{\mathhexbox278}
26 \let\swap=\leftrightarrow
27 \def\round{\mathop{\rm round}\nolimits}
28 \mathchardef\vb="026A % synonym for `\|'
30 \def\(#1){} % this is used to make section names sort themselves better
31 \def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
38 This is \MP, a graphics-language processor based on D. E. Knuth's \MF.
40 The main purpose of the following program is to explain the algorithms of \MP\
41 as clearly as possible. However, the program has been written so that it
42 can be tuned to run efficiently in a wide variety of operating environments
43 by making comparatively few changes. Such flexibility is possible because
44 the documentation that follows is written in the \.{WEB} language, which is
45 at a higher level than C.
47 A large piece of software like \MP\ has inherent complexity that cannot
48 be reduced below a certain level of difficulty, although each individual
49 part is fairly simple by itself. The \.{WEB} language is intended to make
50 the algorithms as readable as possible, by reflecting the way the
51 individual program pieces fit together and by providing the
52 cross-references that connect different parts. Detailed comments about
53 what is going on, and about why things were done in certain ways, have
54 been liberally sprinkled throughout the program. These comments explain
55 features of the implementation, but they rarely attempt to explain the
56 \MP\ language itself, since the reader is supposed to be familiar with
57 {\sl The {\logos METAFONT\/}book} as well as the manual
59 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
60 {\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
61 AT\AM T Bell Laboratories.
63 @ The present implementation is a preliminary version, but the possibilities
64 for new features are limited by the desire to remain as nearly compatible
65 with \MF\ as possible.
67 On the other hand, the \.{WEB} description can be extended without changing
68 the core of the program, and it has been designed so that such
69 extensions are not extremely difficult to make.
70 The |banner| string defined here should be changed whenever \MP\
71 undergoes any modifications, so that it will be clear which version of
72 \MP\ might be the guilty party when a problem arises.
74 @^system dependencies@>
76 @d banner "This is MetaPost, Version 1.004" /* printed when \MP\ starts */
77 @d metapost_version "1.004"
78 @d mplib_version "0.45"
79 @d version_string " (Cweb version 0.45)"
84 @ The external library header for \MP\ is |mplib.h|. It contains a
85 few typedefs and the header defintions for the externally used
88 The most important of the typedefs is the definition of the structure
89 |MP_options|, that acts as a small, configurable front-end to the fairly
90 large |MP_instance| structure.
93 typedef struct MP_instance * MP;
95 typedef struct MP_options {
98 @<Exported function headers@>
100 @ The internal header file is much longer: it not only lists the complete
101 |MP_instance|, but also a lot of functions that have to be available to
102 the \ps\ backend, that is defined in a separate \.{WEB} file.
104 The variables from |MP_options| are included inside the |MP_instance|
109 typedef struct psout_data_struct * psout_data;
111 typedef signed int integer;
113 @<Types in the outer block@>
114 @<Constants in the outer block@>
115 # ifndef LIBAVL_ALLOCATOR
116 # define LIBAVL_ALLOCATOR
117 struct libavl_allocator {
118 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
119 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
122 typedef struct MP_instance {
126 @<Internal library declarations@>
135 #include <unistd.h> /* for access() */
136 #include <time.h> /* for struct tm \& co */
138 #include "mpmp.h" /* internal header */
139 #include "mppsout.h" /* internal header */
142 @<Basic printing procedures@>
143 @<Error handling procedures@>
145 @ Here are the functions that set up the \MP\ instance.
148 @<Declare |mp_reallocate| functions@>
149 struct MP_options *mp_options (void);
150 MP mp_new (struct MP_options *opt);
153 struct MP_options *mp_options (void) {
154 struct MP_options *opt;
155 opt = malloc(sizeof(MP_options));
157 memset (opt,0,sizeof(MP_options));
162 @ The |__attribute__| pragma is gcc-only.
164 @<Internal library ... @>=
165 #if !defined(__GNUC__) || (__GNUC__ < 2)
166 # define __attribute__(x)
167 #endif /* !defined(__GNUC__) || (__GNUC__ < 2) */
170 MP __attribute__ ((noinline))
171 mp_new (struct MP_options *opt) {
173 mp = malloc(1*sizeof(MP_instance));
176 @<Set |ini_version|@>;
177 @<Setup the non-local jump buffer in |mp_new|@>;
178 @<Allocate or initialize variables@>
179 if (opt->main_memory>mp->mem_max)
180 mp_reallocate_memory(mp,opt->main_memory);
181 mp_reallocate_paths(mp,1000);
182 mp_reallocate_fonts(mp,8);
187 void mp_free (MP mp) {
188 int k; /* loop variable */
189 @<Dealloc variables@>
194 void __attribute__((noinline))
195 mp_do_initialize ( MP mp) {
196 @<Local variables for initialization@>
197 @<Set initial values of key variables@>
199 int mp_initialize (MP mp) { /* this procedure gets things started properly */
200 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
201 @<Install and test the non-local jump buffer@>;
202 t_open_out; /* open the terminal for output */
203 @<Check the ``constant'' values...@>;
206 mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
207 "---case %i",(int)mp->bad);
208 do_fprintf(mp->err_out,(char *)ss);
212 mp_do_initialize(mp); /* erase preloaded mem */
213 if (mp->ini_version) {
214 @<Run inimpost commands@>;
216 @<Initialize the output routines@>;
217 @<Get the first line of input and prepare to start@>;
219 mp_init_map_file(mp, mp->troff_mode);
220 mp->history=mp_spotless; /* ready to go! */
221 if (mp->troff_mode) {
222 mp->internal[mp_gtroffmode]=unity;
223 mp->internal[mp_prologues]=unity;
225 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
226 mp->cur_sym=mp->start_sym; mp_back_input(mp);
232 @<Exported function headers@>=
233 extern struct MP_options *mp_options (void);
234 extern MP mp_new (struct MP_options *opt) ;
235 extern void mp_free (MP mp);
236 extern int mp_initialize (MP mp);
238 @ The overall \MP\ program begins with the heading just shown, after which
239 comes a bunch of procedure declarations and function declarations.
240 Finally we will get to the main program, which begins with the
241 comment `|start_here|'. If you want to skip down to the
242 main program now, you can look up `|start_here|' in the index.
243 But the author suggests that the best way to understand this program
244 is to follow pretty much the order of \MP's components as they appear in the
245 \.{WEB} description you are now reading, since the present ordering is
246 intended to combine the advantages of the ``bottom up'' and ``top down''
247 approaches to the problem of understanding a somewhat complicated system.
249 @ Some of the code below is intended to be used only when diagnosing the
250 strange behavior that sometimes occurs when \MP\ is being installed or
251 when system wizards are fooling around with \MP\ without quite knowing
252 what they are doing. Such code will not normally be compiled; it is
253 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
255 @ This program has two important variations: (1) There is a long and slow
256 version called \.{INIMP}, which does the extra calculations needed to
258 initialize \MP's internal tables; and (2)~there is a shorter and faster
259 production version, which cuts the initialization to a bare minimum.
261 Which is which is decided at runtime.
263 @ The following parameters can be changed at compile time to extend or
264 reduce \MP's capacity. They may have different values in \.{INIMP} and
265 in production versions of \MP.
267 @^system dependencies@>
270 #define file_name_size 255 /* file names shouldn't be longer than this */
271 #define bistack_size 1500 /* size of stack for bisection algorithms;
272 should probably be left at this value */
274 @ Like the preceding parameters, the following quantities can be changed
275 at compile time to extend or reduce \MP's capacity. But if they are changed,
276 it is necessary to rerun the initialization program \.{INIMP}
278 to generate new tables for the production \MP\ program.
279 One can't simply make helter-skelter changes to the following constants,
280 since certain rather complex initialization
281 numbers are computed from them.
284 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
285 int pool_size; /* maximum number of characters in strings, including all
286 error messages and help texts, and the names of all identifiers */
287 int mem_max; /* greatest index in \MP's internal |mem| array;
288 must be strictly less than |max_halfword|;
289 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
290 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
291 must not be greater than |mem_max| */
293 @ @<Option variables@>=
294 int error_line; /* width of context lines on terminal error messages */
295 int half_error_line; /* width of first lines of contexts in terminal
296 error messages; should be between 30 and |error_line-15| */
297 int max_print_line; /* width of longest text lines output; should be at least 60 */
298 int hash_size; /* maximum number of symbolic tokens,
299 must be less than |max_halfword-3*param_size| */
300 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
301 int param_size; /* maximum number of simultaneous macro parameters */
302 int max_in_open; /* maximum number of input files and error insertions that
303 can be going on simultaneously */
304 int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
305 void *userdata; /* this allows the calling application to setup local */
308 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
313 set_value(mp->error_line,opt->error_line,79);
314 set_value(mp->half_error_line,opt->half_error_line,50);
315 set_value(mp->max_print_line,opt->max_print_line,100);
316 mp->main_memory=5000;
319 set_value(mp->hash_size,opt->hash_size,9500);
320 set_value(mp->hash_prime,opt->hash_prime,7919);
321 set_value(mp->param_size,opt->param_size,150);
322 set_value(mp->max_in_open,opt->max_in_open,10);
323 mp->userdata=opt->userdata;
325 @ In case somebody has inadvertently made bad settings of the ``constants,''
326 \MP\ checks them using a global variable called |bad|.
328 This is the first of many sections of \MP\ where global variables are
332 integer bad; /* is some ``constant'' wrong? */
334 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
335 or something similar. (We can't do that until |max_halfword| has been defined.)
337 @<Check the ``constant'' values for consistency@>=
339 if ( (mp->half_error_line<30)||(mp->half_error_line>mp->error_line-15) ) mp->bad=1;
340 if ( mp->max_print_line<60 ) mp->bad=2;
341 if ( mp->mem_top<=1100 ) mp->bad=4;
342 if (mp->hash_prime>mp->hash_size ) mp->bad=5;
344 @ Some |goto| labels are used by the following definitions. The label
345 `|restart|' is occasionally used at the very beginning of a procedure; and
346 the label `|reswitch|' is occasionally used just prior to a |case|
347 statement in which some cases change the conditions and we wish to branch
348 to the newly applicable case. Loops that are set up with the |loop|
349 construction defined below are commonly exited by going to `|done|' or to
350 `|found|' or to `|not_found|', and they are sometimes repeated by going to
351 `|continue|'. If two or more parts of a subroutine start differently but
352 end up the same, the shared code may be gathered together at
355 @ Here are some macros for common programming idioms.
357 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
358 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
359 @d negate(A) (A)=-(A) /* change the sign of a variable */
360 @d double(A) (A)=(A)+(A)
363 @d do_nothing /* empty statement */
364 @d Return goto exit /* terminate a procedure call */
365 @f return nil /* \.{WEB} will henceforth say |return| instead of \\{return} */
367 @* \[2] The character set.
368 In order to make \MP\ readily portable to a wide variety of
369 computers, all of its input text is converted to an internal eight-bit
370 code that includes standard ASCII, the ``American Standard Code for
371 Information Interchange.'' This conversion is done immediately when each
372 character is read in. Conversely, characters are converted from ASCII to
373 the user's external representation just before they are output to a
377 Such an internal code is relevant to users of \MP\ only with respect to
378 the \&{char} and \&{ASCII} operations, and the comparison of strings.
380 @ Characters of text that have been converted to \MP's internal form
381 are said to be of type |ASCII_code|, which is a subrange of the integers.
384 typedef unsigned char ASCII_code; /* eight-bit numbers */
386 @ The present specification of \MP\ has been written under the assumption
387 that the character set contains at least the letters and symbols associated
388 with ASCII codes 040 through 0176; all of these characters are now
389 available on most computer terminals.
391 We shall use the name |text_char| to stand for the data type of the characters
392 that are converted to and from |ASCII_code| when they are input and output.
393 We shall also assume that |text_char| consists of the elements
394 |chr(first_text_char)| through |chr(last_text_char)|, inclusive.
395 The following definitions should be adjusted if necessary.
396 @^system dependencies@>
398 @d first_text_char 0 /* ordinal number of the smallest element of |text_char| */
399 @d last_text_char 255 /* ordinal number of the largest element of |text_char| */
402 typedef unsigned char text_char; /* the data type of characters in text files */
404 @ @<Local variables for init...@>=
407 @ The \MP\ processor converts between ASCII code and
408 the user's external character set by means of arrays |xord| and |xchr|
409 that are analogous to Pascal's |ord| and |chr| functions.
411 @d xchr(A) mp->xchr[(A)]
412 @d xord(A) mp->xord[(A)]
415 ASCII_code xord[256]; /* specifies conversion of input characters */
416 text_char xchr[256]; /* specifies conversion of output characters */
418 @ The core system assumes all 8-bit is acceptable. If it is not,
419 a change file has to alter the below section.
420 @^system dependencies@>
422 Additionally, people with extended character sets can
423 assign codes arbitrarily, giving an |xchr| equivalent to whatever
424 characters the users of \MP\ are allowed to have in their input files.
425 Appropriate changes to \MP's |char_class| table should then be made.
426 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
427 codes, called the |char_class|.) Such changes make portability of programs
428 more difficult, so they should be introduced cautiously if at all.
429 @^character set dependencies@>
430 @^system dependencies@>
433 for (i=0;i<=0377;i++) { xchr(i)=i; }
435 @ The following system-independent code makes the |xord| array contain a
436 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
437 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
438 |j| or more; hence, standard ASCII code numbers will be used instead of
439 codes below 040 in case there is a coincidence.
442 for (i=first_text_char;i<=last_text_char;i++) {
445 for (i=0200;i<=0377;i++) { xord(xchr(i))=i;}
446 for (i=0;i<=0176;i++) { xord(xchr(i))=i;}
448 @* \[3] Input and output.
449 The bane of portability is the fact that different operating systems treat
450 input and output quite differently, perhaps because computer scientists
451 have not given sufficient attention to this problem. People have felt somehow
452 that input and output are not part of ``real'' programming. Well, it is true
453 that some kinds of programming are more fun than others. With existing
454 input/output conventions being so diverse and so messy, the only sources of
455 joy in such parts of the code are the rare occasions when one can find a
456 way to make the program a little less bad than it might have been. We have
457 two choices, either to attack I/O now and get it over with, or to postpone
458 I/O until near the end. Neither prospect is very attractive, so let's
461 The basic operations we need to do are (1)~inputting and outputting of
462 text, to or from a file or the user's terminal; (2)~inputting and
463 outputting of eight-bit bytes, to or from a file; (3)~instructing the
464 operating system to initiate (``open'') or to terminate (``close'') input or
465 output from a specified file; (4)~testing whether the end of an input
466 file has been reached; (5)~display of bits on the user's screen.
467 The bit-display operation will be discussed in a later section; we shall
468 deal here only with more traditional kinds of I/O.
470 @ Finding files happens in a slightly roundabout fashion: the \MP\
471 instance object contains a field that holds a function pointer that finds a
472 file, and returns its name, or NULL. For this, it receives three
473 parameters: the non-qualified name |fname|, the intended |fopen|
474 operation type |fmode|, and the type of the file |ftype|.
476 The file types that are passed on in |ftype| can be used to
477 differentiate file searches if a library like kpathsea is used,
478 the fopen mode is passed along for the same reason.
481 typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
483 @ @<Exported types@>=
485 mp_filetype_terminal = 0, /* the terminal */
486 mp_filetype_error, /* the terminal */
487 mp_filetype_program , /* \MP\ language input */
488 mp_filetype_log, /* the log file */
489 mp_filetype_postscript, /* the postscript output */
490 mp_filetype_memfile, /* memory dumps */
491 mp_filetype_metrics, /* TeX font metric files */
492 mp_filetype_fontmap, /* PostScript font mapping files */
493 mp_filetype_font, /* PostScript type1 font programs */
494 mp_filetype_encoding, /* PostScript font encoding files */
495 mp_filetype_text /* first text file for readfrom and writeto primitives */
497 typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
498 typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
499 typedef char *(*mp_file_reader)(MP, void *, size_t *);
500 typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
501 typedef void (*mp_file_closer)(MP, void *);
502 typedef int (*mp_file_eoftest)(MP, void *);
503 typedef void (*mp_file_flush)(MP, void *);
504 typedef void (*mp_file_writer)(MP, void *, const char *);
505 typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
508 @ @<Option variables@>=
509 mp_file_finder find_file;
510 mp_file_opener open_file;
511 mp_file_reader read_ascii_file;
512 mp_binfile_reader read_binary_file;
513 mp_file_closer close_file;
514 mp_file_eoftest eof_file;
515 mp_file_flush flush_file;
516 mp_file_writer write_ascii_file;
517 mp_binfile_writer write_binary_file;
519 @ The default function for finding files is |mp_find_file|. It is
520 pretty stupid: it will only find files in the current directory.
522 This function may disappear altogether, it is currently only
523 used for the default font map file.
526 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
528 if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
529 return strdup(fname);
534 @ This has to be done very early on, so it is best to put it in with
535 the |mp_new| allocations
537 @d set_callback_option(A) do { mp->A = mp_##A;
538 if (opt->A!=NULL) mp->A = opt->A;
541 @<Allocate or initialize ...@>=
542 set_callback_option(find_file);
543 set_callback_option(open_file);
544 set_callback_option(read_ascii_file);
545 set_callback_option(read_binary_file);
546 set_callback_option(close_file);
547 set_callback_option(eof_file);
548 set_callback_option(flush_file);
549 set_callback_option(write_ascii_file);
550 set_callback_option(write_binary_file);
552 @ Because |mp_find_file| is used so early, it has to be in the helpers
556 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
557 void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
558 char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
559 void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
560 void mp_close_file (MP mp, void *f) ;
561 int mp_eof_file (MP mp, void *f) ;
562 void mp_flush_file (MP mp, void *f) ;
563 void mp_write_ascii_file (MP mp, void *f, const char *s) ;
564 void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
566 @ The function to open files can now be very short.
569 void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
572 realmode[0] = *fmode;
576 if (ftype==mp_filetype_terminal) {
577 return (fmode[0] == 'r' ? stdin : stdout);
578 } else if (ftype==mp_filetype_error) {
580 } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
581 return (void *)fopen(fname, realmode);
587 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
590 char name_of_file[file_name_size+1]; /* the name of a system file */
591 int name_length;/* this many characters are actually
592 relevant in |name_of_file| (the rest are blank) */
594 @ @<Option variables@>=
595 int print_found_names; /* configuration parameter */
597 @ If this parameter is true, the terminal and log will report the found
598 file names for input files instead of the requested ones.
599 It is off by default because it creates an extra filename lookup.
601 @<Allocate or initialize ...@>=
602 mp->print_found_names = (opt->print_found_names>0 ? true : false);
604 @ \MP's file-opening procedures return |false| if no file identified by
605 |name_of_file| could be opened.
607 The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
608 It is not used for opening a mem file for read, because that file name
612 if (mp->print_found_names) {
613 char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
615 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
616 strncpy(mp->name_of_file,s,file_name_size);
622 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
625 return (*f ? true : false)
628 boolean mp_a_open_in (MP mp, void **f, int ftype) {
629 /* open a text file for input */
633 boolean mp_w_open_in (MP mp, void **f) {
634 /* open a word file for input */
635 *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
636 return (*f ? true : false);
639 boolean mp_a_open_out (MP mp, void **f, int ftype) {
640 /* open a text file for output */
644 boolean mp_b_open_out (MP mp, void **f, int ftype) {
645 /* open a binary file for output */
649 boolean mp_w_open_out (MP mp, void **f) {
650 /* open a word file for output */
651 int ftype = mp_filetype_memfile;
656 char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
658 size_t len = 0, lim = 128;
660 FILE *f = (FILE *)ff;
662 (void) mp; /* for -Wunused */
670 if (s==NULL) return NULL;
671 while (c!=EOF && c!='\n' && c!='\r') {
673 s =realloc(s, (lim+(lim>>2)));
674 if (s==NULL) return NULL;
682 if (c!=EOF && c!='\n')
692 void mp_write_ascii_file (MP mp, void *f, const char *s) {
702 void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
707 len = fread(*data,1,*size,(FILE *)f);
713 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
717 fwrite(s,size,1,(FILE *)f);
723 void mp_close_file (MP mp, void *f) {
732 int mp_eof_file (MP mp, void *f) {
736 return feof((FILE *)f);
745 void mp_flush_file (MP mp, void *f) {
753 @ Input from text files is read one line at a time, using a routine called
754 |input_ln|. This function is defined in terms of global variables called
755 |buffer|, |first|, and |last| that will be described in detail later; for
756 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
757 values, and that |first| and |last| are indices into this array
758 representing the beginning and ending of a line of text.
761 size_t buf_size; /* maximum number of characters simultaneously present in
762 current lines of open files */
763 ASCII_code *buffer; /* lines of characters being read */
764 size_t first; /* the first unused position in |buffer| */
765 size_t last; /* end of the line just input to |buffer| */
766 size_t max_buf_stack; /* largest index used in |buffer| */
768 @ @<Allocate or initialize ...@>=
770 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
772 @ @<Dealloc variables@>=
776 void mp_reallocate_buffer(MP mp, size_t l) {
778 if (l>max_halfword) {
779 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
781 buffer = xmalloc((l+1),sizeof(ASCII_code));
782 memcpy(buffer,mp->buffer,(mp->buf_size+1));
784 mp->buffer = buffer ;
788 @ The |input_ln| function brings the next line of input from the specified
789 field into available positions of the buffer array and returns the value
790 |true|, unless the file has already been entirely read, in which case it
791 returns |false| and sets |last:=first|. In general, the |ASCII_code|
792 numbers that represent the next line of the file are input into
793 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
794 global variable |last| is set equal to |first| plus the length of the
795 line. Trailing blanks are removed from the line; thus, either |last=first|
796 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
799 The variable |max_buf_stack|, which is used to keep track of how large
800 the |buf_size| parameter must be to accommodate the present job, is
801 also kept up to date by |input_ln|.
804 boolean mp_input_ln (MP mp, void *f ) {
805 /* inputs the next line or returns |false| */
808 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
809 s = (mp->read_ascii_file)(mp,f, &size);
813 mp->last = mp->first+size;
814 if ( mp->last>=mp->max_buf_stack ) {
815 mp->max_buf_stack=mp->last+1;
816 while ( mp->max_buf_stack>=mp->buf_size ) {
817 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
820 memcpy((mp->buffer+mp->first),s,size);
821 /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
827 @ The user's terminal acts essentially like other files of text, except
828 that it is used both for input and for output. When the terminal is
829 considered an input file, the file variable is called |term_in|, and when it
830 is considered an output file the file variable is |term_out|.
831 @^system dependencies@>
834 void * term_in; /* the terminal as an input file */
835 void * term_out; /* the terminal as an output file */
836 void * err_out; /* the terminal as an output file */
838 @ Here is how to open the terminal files. In the default configuration,
839 nothing happens except that the command line (if there is one) is copied
840 to the input buffer. The variable |command_line| will be filled by the
841 |main| procedure. The copying can not be done earlier in the program
842 logic because in the |INI| version, the |buffer| is also used for primitive
845 @^system dependencies@>
847 @d t_open_out do {/* open the terminal for text output */
848 mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
849 mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
851 @d t_open_in do { /* open the terminal for text input */
852 mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
853 if (mp->command_line!=NULL) {
854 mp->last = strlen(mp->command_line);
855 strncpy((char *)mp->buffer,mp->command_line,mp->last);
856 xfree(mp->command_line);
862 @d t_close_out do { /* close the terminal */
863 /* (mp->close_file)(mp,mp->term_out); */
864 /* (mp->close_file)(mp,mp->err_out); */
867 @d t_close_in do { /* close the terminal */
868 /* (mp->close_file)(mp,mp->term_in); */
871 @<Option variables@>=
874 @ @<Allocate or initialize ...@>=
875 mp->command_line = xstrdup(opt->command_line);
877 @ Sometimes it is necessary to synchronize the input/output mixture that
878 happens on the user's terminal, and three system-dependent
879 procedures are used for this
880 purpose. The first of these, |update_terminal|, is called when we want
881 to make sure that everything we have output to the terminal so far has
882 actually left the computer's internal buffers and been sent.
883 The second, |clear_terminal|, is called when we wish to cancel any
884 input that the user may have typed ahead (since we are about to
885 issue an unexpected error message). The third, |wake_up_terminal|,
886 is supposed to revive the terminal if the user has disabled it by
887 some instruction to the operating system. The following macros show how
888 these operations can be specified:
889 @^system dependencies@>
891 @d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
892 @d clear_terminal do_nothing /* clear the terminal input buffer */
893 @d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
894 /* cancel the user's cancellation of output */
896 @ We need a special routine to read the first line of \MP\ input from
897 the user's terminal. This line is different because it is read before we
898 have opened the transcript file; there is sort of a ``chicken and
899 egg'' problem here. If the user types `\.{input cmr10}' on the first
900 line, or if some macro invoked by that line does such an \.{input},
901 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
902 commands are performed during the first line of terminal input, the transcript
903 file will acquire its default name `\.{mpout.log}'. (The transcript file
904 will not contain error messages generated by the first line before the
905 first \.{input} command.)
907 The first line is even more special. It's nice to let the user start
908 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
909 such a case, \MP\ will operate as if the first line of input were
910 `\.{cmr10}', i.e., the first line will consist of the remainder of the
911 command line, after the part that invoked \MP.
913 @ Different systems have different ways to get started. But regardless of
914 what conventions are adopted, the routine that initializes the terminal
915 should satisfy the following specifications:
917 \yskip\textindent{1)}It should open file |term_in| for input from the
918 terminal. (The file |term_out| will already be open for output to the
921 \textindent{2)}If the user has given a command line, this line should be
922 considered the first line of terminal input. Otherwise the
923 user should be prompted with `\.{**}', and the first line of input
924 should be whatever is typed in response.
926 \textindent{3)}The first line of input, which might or might not be a
927 command line, should appear in locations |first| to |last-1| of the
930 \textindent{4)}The global variable |loc| should be set so that the
931 character to be read next by \MP\ is in |buffer[loc]|. This
932 character should not be blank, and we should have |loc<last|.
934 \yskip\noindent(It may be necessary to prompt the user several times
935 before a non-blank line comes in. The prompt is `\.{**}' instead of the
936 later `\.*' because the meaning is slightly different: `\.{input}' need
937 not be typed immediately after~`\.{**}'.)
939 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
941 @ The following program does the required initialization
942 without retrieving a possible command line.
943 It should be clear how to modify this routine to deal with command lines,
944 if the system permits them.
945 @^system dependencies@>
948 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
955 if (!mp->noninteractive) {
956 wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
959 if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
960 do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
961 @.End of file on the terminal@>
965 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
967 if ( loc<(int)mp->last ) {
968 return true; /* return unless the line was all blank */
970 if (!mp->noninteractive) {
971 do_fprintf(mp->term_out,"Please type the name of your input file.\n");
977 boolean mp_init_terminal (MP mp) ;
980 @* \[4] String handling.
981 Symbolic token names and diagnostic messages are variable-length strings
982 of eight-bit characters. Many strings \MP\ uses are simply literals
983 in the compiled source, like the error messages and the names of the
984 internal parameters. Other strings are used or defined from the \MP\ input
985 language, and these have to be interned.
987 \MP\ uses strings more extensively than \MF\ does, but the necessary
988 operations can still be handled with a fairly simple data structure.
989 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
990 of the strings, and the array |str_start| contains indices of the starting
991 points of each string. Strings are referred to by integer numbers, so that
992 string number |s| comprises the characters |str_pool[j]| for
993 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
994 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
995 location. The first string number not currently in use is |str_ptr|
996 and |next_str[str_ptr]| begins a list of free string numbers. String
997 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
998 string currently being constructed.
1000 String numbers 0 to 255 are reserved for strings that correspond to single
1001 ASCII characters. This is in accordance with the conventions of \.{WEB},
1003 which converts single-character strings into the ASCII code number of the
1004 single character involved, while it converts other strings into integers
1005 and builds a string pool file. Thus, when the string constant \.{"."} appears
1006 in the program below, \.{WEB} converts it into the integer 46, which is the
1007 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
1008 into some integer greater than~255. String number 46 will presumably be the
1009 single character `\..'\thinspace; but some ASCII codes have no standard visible
1010 representation, and \MP\ may need to be able to print an arbitrary
1011 ASCII character, so the first 256 strings are used to specify exactly what
1012 should be printed for each of the 256 possibilities.
1015 typedef int pool_pointer; /* for variables that point into |str_pool| */
1016 typedef int str_number; /* for variables that point into |str_start| */
1019 ASCII_code *str_pool; /* the characters */
1020 pool_pointer *str_start; /* the starting pointers */
1021 str_number *next_str; /* for linking strings in order */
1022 pool_pointer pool_ptr; /* first unused position in |str_pool| */
1023 str_number str_ptr; /* number of the current string being created */
1024 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
1025 str_number init_str_use; /* the initial number of strings in use */
1026 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
1027 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
1029 @ @<Allocate or initialize ...@>=
1030 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
1031 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
1032 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
1034 @ @<Dealloc variables@>=
1035 xfree(mp->str_pool);
1036 xfree(mp->str_start);
1037 xfree(mp->next_str);
1039 @ Most printing is done from |char *|s, but sometimes not. Here are
1040 functions that convert an internal string into a |char *| for use
1041 by the printing routines, and vice versa.
1043 @d str(A) mp_str(mp,A)
1044 @d rts(A) mp_rts(mp,A)
1047 int mp_xstrcmp (const char *a, const char *b);
1048 char * mp_str (MP mp, str_number s);
1051 str_number mp_rts (MP mp, const char *s);
1052 str_number mp_make_string (MP mp);
1054 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1055 very good: it does not handle nesting over more than one level.
1058 int mp_xstrcmp (const char *a, const char *b) {
1059 if (a==NULL && b==NULL)
1069 char * mp_str (MP mp, str_number ss) {
1072 if (ss==mp->str_ptr) {
1076 s = xmalloc(len+1,sizeof(char));
1077 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1082 str_number mp_rts (MP mp, const char *s) {
1083 int r; /* the new string */
1084 int old; /* a possible string in progress */
1088 } else if (strlen(s)==1) {
1092 str_room((integer)strlen(s));
1093 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1094 old = mp_make_string(mp);
1099 r = mp_make_string(mp);
1101 str_room(length(old));
1102 while (i<length(old)) {
1103 append_char((mp->str_start[old]+i));
1105 mp_flush_string(mp,old);
1111 @ Except for |strs_used_up|, the following string statistics are only
1112 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1116 integer strs_used_up; /* strings in use or unused but not reclaimed */
1117 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1118 integer strs_in_use; /* total number of strings actually in use */
1119 integer max_pl_used; /* maximum |pool_in_use| so far */
1120 integer max_strs_used; /* maximum |strs_in_use| so far */
1122 @ Several of the elementary string operations are performed using \.{WEB}
1123 macros instead of functions, because many of the
1124 operations are done quite frequently and we want to avoid the
1125 overhead of procedure calls. For example, here is
1126 a simple macro that computes the length of a string.
1129 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string
1131 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1133 @ The length of the current string is called |cur_length|. If we decide that
1134 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1135 |cur_length| becomes zero.
1137 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1138 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1140 @ Strings are created by appending character codes to |str_pool|.
1141 The |append_char| macro, defined here, does not check to see if the
1142 value of |pool_ptr| has gotten too high; this test is supposed to be
1143 made before |append_char| is used.
1145 To test if there is room to append |l| more characters to |str_pool|,
1146 we shall write |str_room(l)|, which tries to make sure there is enough room
1147 by compacting the string pool if necessary. If this does not work,
1148 |do_compaction| aborts \MP\ and gives an apologetic error message.
1150 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1151 { mp->str_pool[mp->pool_ptr]=(A); incr(mp->pool_ptr);
1153 @d str_room(A) /* make sure that the pool hasn't overflowed */
1154 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1155 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1156 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1159 @ The following routine is similar to |str_room(1)| but it uses the
1160 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1161 string space is exhausted.
1163 @<Declare the procedure called |unit_str_room|@>=
1164 void mp_unit_str_room (MP mp);
1167 void mp_unit_str_room (MP mp) {
1168 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1169 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1172 @ \MP's string expressions are implemented in a brute-force way: Every
1173 new string or substring that is needed is simply copied into the string pool.
1174 Space is eventually reclaimed by a procedure called |do_compaction| with
1175 the aid of a simple system system of reference counts.
1176 @^reference counts@>
1178 The number of references to string number |s| will be |str_ref[s]|. The
1179 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1180 positive number of references; such strings will never be recycled. If
1181 a string is ever referred to more than 126 times, simultaneously, we
1182 put it in this category. Hence a single byte suffices to store each |str_ref|.
1184 @d max_str_ref 127 /* ``infinite'' number of references */
1185 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]);
1191 @ @<Allocate or initialize ...@>=
1192 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1194 @ @<Dealloc variables@>=
1197 @ Here's what we do when a string reference disappears:
1199 @d delete_str_ref(A) {
1200 if ( mp->str_ref[(A)]<max_str_ref ) {
1201 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1202 else mp_flush_string(mp, (A));
1206 @<Declare the procedure called |flush_string|@>=
1207 void mp_flush_string (MP mp,str_number s) ;
1210 @ We can't flush the first set of static strings at all, so there
1211 is no point in trying
1214 void mp_flush_string (MP mp,str_number s) {
1216 mp->pool_in_use=mp->pool_in_use-length(s);
1217 decr(mp->strs_in_use);
1218 if ( mp->next_str[s]!=mp->str_ptr ) {
1222 decr(mp->strs_used_up);
1224 mp->pool_ptr=mp->str_start[mp->str_ptr];
1228 @ C literals cannot be simply added, they need to be set so they can't
1231 @d intern(A) mp_intern(mp,(A))
1234 str_number mp_intern (MP mp, const char *s) {
1237 mp->str_ref[r] = max_str_ref;
1242 str_number mp_intern (MP mp, const char *s);
1245 @ Once a sequence of characters has been appended to |str_pool|, it
1246 officially becomes a string when the function |make_string| is called.
1247 This function returns the identification number of the new string as its
1250 When getting the next unused string number from the linked list, we pretend
1252 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1253 are linked sequentially even though the |next_str| entries have not been
1254 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1255 |do_compaction| is responsible for making sure of this.
1258 @<Declare the procedure called |do_compaction|@>
1259 @<Declare the procedure called |unit_str_room|@>
1260 str_number mp_make_string (MP mp);
1263 str_number mp_make_string (MP mp) { /* current string enters the pool */
1264 str_number s; /* the new string */
1267 mp->str_ptr=mp->next_str[s];
1268 if ( mp->str_ptr>mp->max_str_ptr ) {
1269 if ( mp->str_ptr==mp->max_strings ) {
1271 mp_do_compaction(mp, 0);
1275 if ( mp->strs_used_up!=mp->max_str_ptr ) mp_confusion(mp, "s");
1276 @:this can't happen s}{\quad \.s@>
1278 mp->max_str_ptr=mp->str_ptr;
1279 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1283 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1284 incr(mp->strs_used_up);
1285 incr(mp->strs_in_use);
1286 mp->pool_in_use=mp->pool_in_use+length(s);
1287 if ( mp->pool_in_use>mp->max_pl_used )
1288 mp->max_pl_used=mp->pool_in_use;
1289 if ( mp->strs_in_use>mp->max_strs_used )
1290 mp->max_strs_used=mp->strs_in_use;
1294 @ The most interesting string operation is string pool compaction. The idea
1295 is to recover unused space in the |str_pool| array by recopying the strings
1296 to close the gaps created when some strings become unused. All string
1297 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1298 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1299 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1300 with |needed=mp->pool_size| supresses all overflow tests.
1302 The compaction process starts with |last_fixed_str| because all lower numbered
1303 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1306 str_number last_fixed_str; /* last permanently allocated string */
1307 str_number fixed_str_use; /* number of permanently allocated strings */
1309 @ @<Declare the procedure called |do_compaction|@>=
1310 void mp_do_compaction (MP mp, pool_pointer needed) ;
1313 void mp_do_compaction (MP mp, pool_pointer needed) {
1314 str_number str_use; /* a count of strings in use */
1315 str_number r,s,t; /* strings being manipulated */
1316 pool_pointer p,q; /* destination and source for copying string characters */
1317 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1318 r=mp->last_fixed_str;
1321 while ( s!=mp->str_ptr ) {
1322 while ( mp->str_ref[s]==0 ) {
1323 @<Advance |s| and add the old |s| to the list of free string numbers;
1324 then |break| if |s=str_ptr|@>;
1326 r=s; s=mp->next_str[s];
1328 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1329 after the end of the string@>;
1332 @<Move the current string back so that it starts at |p|@>;
1333 if ( needed<mp->pool_size ) {
1334 @<Make sure that there is room for another string with |needed| characters@>;
1336 @<Account for the compaction and make sure the statistics agree with the
1338 mp->strs_used_up=str_use;
1341 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1342 t=mp->next_str[mp->last_fixed_str];
1343 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1344 incr(mp->fixed_str_use);
1345 mp->last_fixed_str=t;
1348 str_use=mp->fixed_str_use
1350 @ Because of the way |flush_string| has been written, it should never be
1351 necessary to |break| here. The extra line of code seems worthwhile to
1352 preserve the generality of |do_compaction|.
1354 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1359 mp->next_str[t]=mp->next_str[mp->str_ptr];
1360 mp->next_str[mp->str_ptr]=t;
1361 if ( s==mp->str_ptr ) goto DONE;
1364 @ The string currently starts at |str_start[r]| and ends just before
1365 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1366 to locate the next string.
1368 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1371 while ( q<mp->str_start[s] ) {
1372 mp->str_pool[p]=mp->str_pool[q];
1376 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1377 we do this, anything between them should be moved.
1379 @ @<Move the current string back so that it starts at |p|@>=
1380 q=mp->str_start[mp->str_ptr];
1381 mp->str_start[mp->str_ptr]=p;
1382 while ( q<mp->pool_ptr ) {
1383 mp->str_pool[p]=mp->str_pool[q];
1388 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1390 @<Make sure that there is room for another string with |needed| char...@>=
1391 if ( str_use>=mp->max_strings-1 )
1392 mp_reallocate_strings (mp,str_use);
1393 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1394 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1395 mp->max_pool_ptr=mp->pool_ptr+needed;
1399 void mp_reallocate_strings (MP mp, str_number str_use) ;
1400 void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1403 void mp_reallocate_strings (MP mp, str_number str_use) {
1404 while ( str_use>=mp->max_strings-1 ) {
1405 int l = mp->max_strings + (mp->max_strings>>2);
1406 XREALLOC (mp->str_ref, l, int);
1407 XREALLOC (mp->str_start, l, pool_pointer);
1408 XREALLOC (mp->next_str, l, str_number);
1409 mp->max_strings = l;
1412 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1413 while ( needed>mp->pool_size ) {
1414 int l = mp->pool_size + (mp->pool_size>>2);
1415 XREALLOC (mp->str_pool, l, ASCII_code);
1420 @ @<Account for the compaction and make sure the statistics agree with...@>=
1421 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1422 mp_confusion(mp, "string");
1423 @:this can't happen string}{\quad string@>
1424 incr(mp->pact_count);
1425 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1426 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1428 s=mp->str_ptr; t=str_use;
1429 while ( s<=mp->max_str_ptr ){
1430 if ( t>mp->max_str_ptr ) mp_confusion(mp, "\"");
1431 incr(t); s=mp->next_str[s];
1433 if ( t<=mp->max_str_ptr ) mp_confusion(mp, "\"");
1436 @ A few more global variables are needed to keep track of statistics when
1437 |stat| $\ldots$ |tats| blocks are not commented out.
1440 integer pact_count; /* number of string pool compactions so far */
1441 integer pact_chars; /* total number of characters moved during compactions */
1442 integer pact_strs; /* total number of strings moved during compactions */
1444 @ @<Initialize compaction statistics@>=
1449 @ The following subroutine compares string |s| with another string of the
1450 same length that appears in |buffer| starting at position |k|;
1451 the result is |true| if and only if the strings are equal.
1454 boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1455 /* test equality of strings */
1456 pool_pointer j; /* running index */
1458 while ( j<str_stop(s) ) {
1459 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1465 @ Here is a similar routine, but it compares two strings in the string pool,
1466 and it does not assume that they have the same length. If the first string
1467 is lexicographically greater than, less than, or equal to the second,
1468 the result is respectively positive, negative, or zero.
1471 integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1472 /* test equality of strings */
1473 pool_pointer j,k; /* running indices */
1474 integer ls,lt; /* lengths */
1475 integer l; /* length remaining to test */
1476 ls=length(s); lt=length(t);
1477 if ( ls<=lt ) l=ls; else l=lt;
1478 j=mp->str_start[s]; k=mp->str_start[t];
1480 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1481 return (mp->str_pool[j]-mp->str_pool[k]);
1488 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1489 and |str_ptr| are computed by the \.{INIMP} program, based in part
1490 on the information that \.{WEB} has output while processing \MP.
1495 void mp_get_strings_started (MP mp) {
1496 /* initializes the string pool,
1497 but returns |false| if something goes wrong */
1498 int k; /* small indices or counters */
1499 str_number g; /* a new string */
1500 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1503 mp->pool_in_use=0; mp->strs_in_use=0;
1504 mp->max_pl_used=0; mp->max_strs_used=0;
1505 @<Initialize compaction statistics@>;
1507 @<Make the first 256 strings@>;
1508 g=mp_make_string(mp); /* string 256 == "" */
1509 mp->str_ref[g]=max_str_ref;
1510 mp->last_fixed_str=mp->str_ptr-1;
1511 mp->fixed_str_use=mp->str_ptr;
1516 void mp_get_strings_started (MP mp);
1518 @ The first 256 strings will consist of a single character only.
1520 @<Make the first 256...@>=
1521 for (k=0;k<=255;k++) {
1523 g=mp_make_string(mp);
1524 mp->str_ref[g]=max_str_ref;
1527 @ The first 128 strings will contain 95 standard ASCII characters, and the
1528 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1529 unless a system-dependent change is made here. Installations that have
1530 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1531 would like string 032 to be printed as the single character 032 instead
1532 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1533 even people with an extended character set will want to represent string
1534 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1535 to produce visible strings instead of tabs or line-feeds or carriage-returns
1536 or bell-rings or characters that are treated anomalously in text files.
1538 Unprintable characters of codes 128--255 are, similarly, rendered
1539 \.{\^\^80}--\.{\^\^ff}.
1541 The boolean expression defined here should be |true| unless \MP\ internal
1542 code number~|k| corresponds to a non-troublesome visible symbol in the
1543 local character set.
1544 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1545 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1547 @^character set dependencies@>
1548 @^system dependencies@>
1550 @<Character |k| cannot be printed@>=
1553 @* \[5] On-line and off-line printing.
1554 Messages that are sent to a user's terminal and to the transcript-log file
1555 are produced by several `|print|' procedures. These procedures will
1556 direct their output to a variety of places, based on the setting of
1557 the global variable |selector|, which has the following possible
1561 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1564 \hang |log_only|, prints only on the transcript file.
1566 \hang |term_only|, prints only on the terminal.
1568 \hang |no_print|, doesn't print at all. This is used only in rare cases
1569 before the transcript file is open.
1571 \hang |pseudo|, puts output into a cyclic buffer that is used
1572 by the |show_context| routine; when we get to that routine we shall discuss
1573 the reasoning behind this curious mode.
1575 \hang |new_string|, appends the output to the current string in the
1578 \hang |>=write_file| prints on one of the files used for the \&{write}
1579 @:write_}{\&{write} primitive@>
1583 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1584 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1585 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1586 relations are not used when |selector| could be |pseudo|, or |new_string|.
1587 We need not check for unprintable characters when |selector<pseudo|.
1589 Three additional global variables, |tally|, |term_offset| and |file_offset|
1590 record the number of characters that have been printed
1591 since they were most recently cleared to zero. We use |tally| to record
1592 the length of (possibly very long) stretches of printing; |term_offset|,
1593 and |file_offset|, on the other hand, keep track of how many
1594 characters have appeared so far on the current line that has been output
1595 to the terminal, the transcript file, or the \ps\ output file, respectively.
1597 @d new_string 0 /* printing is deflected to the string pool */
1598 @d pseudo 2 /* special |selector| setting for |show_context| */
1599 @d no_print 3 /* |selector| setting that makes data disappear */
1600 @d term_only 4 /* printing is destined for the terminal only */
1601 @d log_only 5 /* printing is destined for the transcript file only */
1602 @d term_and_log 6 /* normal |selector| setting */
1603 @d write_file 7 /* first write file selector */
1606 void * log_file; /* transcript of \MP\ session */
1607 void * ps_file; /* the generic font output goes here */
1608 unsigned int selector; /* where to print a message */
1609 unsigned char dig[23]; /* digits in a number being output */
1610 integer tally; /* the number of characters recently printed */
1611 unsigned int term_offset;
1612 /* the number of characters on the current terminal line */
1613 unsigned int file_offset;
1614 /* the number of characters on the current file line */
1615 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1616 integer trick_count; /* threshold for pseudoprinting, explained later */
1617 integer first_count; /* another variable for pseudoprinting */
1619 @ @<Allocate or initialize ...@>=
1620 memset(mp->dig,0,23);
1621 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1623 @ @<Dealloc variables@>=
1624 xfree(mp->trick_buf);
1626 @ @<Initialize the output routines@>=
1627 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
1629 @ Macro abbreviations for output to the terminal and to the log file are
1630 defined here for convenience. Some systems need special conventions
1631 for terminal output, and it is possible to adhere to those conventions
1632 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1633 @^system dependencies@>
1635 @d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
1636 @d wterm(A) do_fprintf(mp->term_out,(A))
1637 @d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->term_out,(char *)ss); }
1638 @d wterm_cr do_fprintf(mp->term_out,"\n")
1639 @d wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
1640 @d wlog(A) do_fprintf(mp->log_file,(A))
1641 @d wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->log_file,(char *)ss); }
1642 @d wlog_cr do_fprintf(mp->log_file, "\n")
1643 @d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
1646 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1647 use an array |wr_file| that will be declared later.
1649 @d mp_print_text(A) mp_print_str(mp,text((A)))
1652 void mp_print_ln (MP mp);
1653 void mp_print_visible_char (MP mp, ASCII_code s);
1654 void mp_print_char (MP mp, ASCII_code k);
1655 void mp_print (MP mp, const char *s);
1656 void mp_print_str (MP mp, str_number s);
1657 void mp_print_nl (MP mp, const char *s);
1658 void mp_print_two (MP mp,scaled x, scaled y) ;
1659 void mp_print_scaled (MP mp,scaled s);
1661 @ @<Basic print...@>=
1662 void mp_print_ln (MP mp) { /* prints an end-of-line */
1663 switch (mp->selector) {
1666 mp->term_offset=0; mp->file_offset=0;
1669 wlog_cr; mp->file_offset=0;
1672 wterm_cr; mp->term_offset=0;
1679 do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1681 } /* note that |tally| is not affected */
1683 @ The |print_visible_char| procedure sends one character to the desired
1684 destination, using the |xchr| array to map it into an external character
1685 compatible with |input_ln|. (It assumes that it is always called with
1686 a visible ASCII character.) All printing comes through |print_ln| or
1687 |print_char|, which ultimately calls |print_visible_char|, hence these
1688 routines are the ones that limit lines to at most |max_print_line| characters.
1689 But we must make an exception for the \ps\ output file since it is not safe
1690 to cut up lines arbitrarily in \ps.
1692 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1693 |do_compaction| and |do_compaction| can call the error routines. Actually,
1694 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1696 @<Basic printing...@>=
1697 void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1698 switch (mp->selector) {
1700 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1701 incr(mp->term_offset); incr(mp->file_offset);
1702 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1703 wterm_cr; mp->term_offset=0;
1705 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1706 wlog_cr; mp->file_offset=0;
1710 wlog_chr(xchr(s)); incr(mp->file_offset);
1711 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1714 wterm_chr(xchr(s)); incr(mp->term_offset);
1715 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1720 if ( mp->tally<mp->trick_count )
1721 mp->trick_buf[mp->tally % mp->error_line]=s;
1724 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1725 mp_unit_str_room(mp);
1726 if ( mp->pool_ptr>=mp->pool_size )
1727 goto DONE; /* drop characters if string space is full */
1732 { char ss[2]; ss[0] = xchr(s); ss[1]=0;
1733 do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
1740 @ The |print_char| procedure sends one character to the desired destination.
1741 File names and string expressions might contain |ASCII_code| values that
1742 can't be printed using |print_visible_char|. These characters will be
1743 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1744 (This procedure assumes that it is safe to bypass all checks for unprintable
1745 characters when |selector| is in the range |0..max_write_files-1|.
1746 The user might want to write unprintable characters.
1748 @d print_lc_hex(A) do { l=(A);
1749 mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
1752 @<Basic printing...@>=
1753 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1754 int l; /* small index or counter */
1755 if ( mp->selector<pseudo || mp->selector>=write_file) {
1756 mp_print_visible_char(mp, k);
1757 } else if ( @<Character |k| cannot be printed@> ) {
1760 mp_print_visible_char(mp, k+0100);
1761 } else if ( k<0200 ) {
1762 mp_print_visible_char(mp, k-0100);
1764 print_lc_hex(k / 16);
1765 print_lc_hex(k % 16);
1768 mp_print_visible_char(mp, k);
1772 @ An entire string is output by calling |print|. Note that if we are outputting
1773 the single standard ASCII character \.c, we could call |print("c")|, since
1774 |"c"=99| is the number of a single-character string, as explained above. But
1775 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1776 routine when it knows that this is safe. (The present implementation
1777 assumes that it is always safe to print a visible ASCII character.)
1778 @^system dependencies@>
1781 void mp_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
1784 mp_print_char(mp, ss[j]); incr(j);
1790 void mp_print (MP mp, const char *ss) {
1791 mp_do_print(mp, ss, strlen(ss));
1793 void mp_print_str (MP mp, str_number s) {
1794 pool_pointer j; /* current character code position */
1795 if ( (s<0)||(s>mp->max_str_ptr) ) {
1796 mp_do_print(mp,"???",3); /* this can't happen */
1800 mp_do_print(mp, (char *)(mp->str_pool+j), (str_stop(s)-j));
1804 @ Here is the very first thing that \MP\ prints: a headline that identifies
1805 the version number and base name. The |term_offset| variable is temporarily
1806 incorrect, but the discrepancy is not serious since we assume that the banner
1807 and mem identifier together will occupy at most |max_print_line|
1808 character positions.
1810 @<Initialize the output...@>=
1812 wterm (version_string);
1813 if (mp->mem_ident!=NULL)
1814 mp_print(mp,mp->mem_ident);
1818 @ The procedure |print_nl| is like |print|, but it makes sure that the
1819 string appears at the beginning of a new line.
1822 void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1823 switch(mp->selector) {
1825 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1828 if ( mp->file_offset>0 ) mp_print_ln(mp);
1831 if ( mp->term_offset>0 ) mp_print_ln(mp);
1837 } /* there are no other cases */
1841 @ An array of digits in the range |0..9| is printed by |print_the_digs|.
1844 void mp_print_the_digs (MP mp, eight_bits k) {
1845 /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */
1847 decr(k); mp_print_char(mp, '0'+mp->dig[k]);
1851 @ The following procedure, which prints out the decimal representation of a
1852 given integer |n|, has been written carefully so that it works properly
1853 if |n=0| or if |(-n)| would cause overflow. It does not apply |%| or |/|
1854 to negative arguments, since such operations are not implemented consistently
1858 void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1859 integer m; /* used to negate |n| in possibly dangerous cases */
1860 int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
1862 mp_print_char(mp, '-');
1863 if ( n>-100000000 ) {
1866 m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
1870 mp->dig[0]=0; incr(n);
1875 mp->dig[k]=n % 10; n=n / 10; incr(k);
1877 mp_print_the_digs(mp, k);
1881 void mp_print_int (MP mp,integer n);
1883 @ \MP\ also makes use of a trivial procedure to print two digits. The
1884 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1887 void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1889 mp_print_char(mp, '0'+(n / 10));
1890 mp_print_char(mp, '0'+(n % 10));
1895 void mp_print_dd (MP mp,integer n);
1897 @ Here is a procedure that asks the user to type a line of input,
1898 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1899 The input is placed into locations |first| through |last-1| of the
1900 |buffer| array, and echoed on the transcript file if appropriate.
1902 This procedure is never called when |interaction<mp_scroll_mode|.
1904 @d prompt_input(A) do {
1905 if (!mp->noninteractive) {
1906 wake_up_terminal; mp_print(mp, (A));
1909 } while (0) /* prints a string and gets a line of input */
1912 void mp_term_input (MP mp) { /* gets a line from the terminal */
1913 size_t k; /* index into |buffer| */
1914 update_terminal; /* Now the user sees the prompt for sure */
1915 if (!mp_input_ln(mp, mp->term_in )) {
1916 if (!mp->noninteractive) {
1917 mp_fatal_error(mp, "End of file on the terminal!");
1918 @.End of file on the terminal@>
1919 } else { /* we are done with this input chunk */
1920 longjmp(mp->jump_buf,1);
1923 if (!mp->noninteractive) {
1924 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1925 decr(mp->selector); /* prepare to echo the input */
1926 if ( mp->last!=mp->first ) {
1927 for (k=mp->first;k<=mp->last-1;k++) {
1928 mp_print_char(mp, mp->buffer[k]);
1932 mp->buffer[mp->last]='%';
1933 incr(mp->selector); /* restore previous status */
1937 @* \[6] Reporting errors.
1938 When something anomalous is detected, \MP\ typically does something like this:
1939 $$\vbox{\halign{#\hfil\cr
1940 |print_err("Something anomalous has been detected");|\cr
1941 |help3("This is the first line of my offer to help.")|\cr
1942 |("This is the second line. I'm trying to")|\cr
1943 |("explain the best way for you to proceed.");|\cr
1945 A two-line help message would be given using |help2|, etc.; these informal
1946 helps should use simple vocabulary that complements the words used in the
1947 official error message that was printed. (Outside the U.S.A., the help
1948 messages should preferably be translated into the local vernacular. Each
1949 line of help is at most 60 characters long, in the present implementation,
1950 so that |max_print_line| will not be exceeded.)
1952 The |print_err| procedure supplies a `\.!' before the official message,
1953 and makes sure that the terminal is awake if a stop is going to occur.
1954 The |error| procedure supplies a `\..' after the official message, then it
1955 shows the location of the error; and if |interaction=error_stop_mode|,
1956 it also enters into a dialog with the user, during which time the help
1957 message may be printed.
1958 @^system dependencies@>
1960 @ The global variable |interaction| has four settings, representing increasing
1961 amounts of user interaction:
1964 enum mp_interaction_mode {
1965 mp_unspecified_mode=0, /* extra value for command-line switch */
1966 mp_batch_mode, /* omits all stops and omits terminal output */
1967 mp_nonstop_mode, /* omits all stops */
1968 mp_scroll_mode, /* omits error stops */
1969 mp_error_stop_mode /* stops at every opportunity to interact */
1972 @ @<Option variables@>=
1973 int interaction; /* current level of interaction */
1974 int noninteractive; /* do we have a terminal? */
1976 @ Set it here so it can be overwritten by the commandline
1978 @<Allocate or initialize ...@>=
1979 mp->interaction=opt->interaction;
1980 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
1981 mp->interaction=mp_error_stop_mode;
1982 if (mp->interaction<mp_unspecified_mode)
1983 mp->interaction=mp_batch_mode;
1984 mp->noninteractive=opt->noninteractive;
1988 @d print_err(A) mp_print_err(mp,(A))
1991 void mp_print_err(MP mp, const char * A);
1994 void mp_print_err(MP mp, const char * A) {
1995 if ( mp->interaction==mp_error_stop_mode )
1997 mp_print_nl(mp, "! ");
2003 @ \MP\ is careful not to call |error| when the print |selector| setting
2004 might be unusual. The only possible values of |selector| at the time of
2007 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
2008 and |log_file| not yet open);
2010 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
2012 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
2014 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
2016 @<Initialize the print |selector| based on |interaction|@>=
2017 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
2019 @ A global variable |deletions_allowed| is set |false| if the |get_next|
2020 routine is active when |error| is called; this ensures that |get_next|
2021 will never be called recursively.
2024 The global variable |history| records the worst level of error that
2025 has been detected. It has four possible values: |spotless|, |warning_issued|,
2026 |error_message_issued|, and |fatal_error_stop|.
2028 Another global variable, |error_count|, is increased by one when an
2029 |error| occurs without an interactive dialog, and it is reset to zero at
2030 the end of every statement. If |error_count| reaches 100, \MP\ decides
2031 that there is no point in continuing further.
2034 enum mp_history_states {
2035 mp_spotless=0, /* |history| value when nothing has been amiss yet */
2036 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
2037 mp_error_message_issued, /* |history| value when |error| has been called */
2038 mp_fatal_error_stop, /* |history| value when termination was premature */
2039 mp_system_error_stop /* |history| value when termination was due to disaster */
2043 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
2044 int history; /* has the source input been clean so far? */
2045 int error_count; /* the number of scrolled errors since the last statement ended */
2047 @ The value of |history| is initially |fatal_error_stop|, but it will
2048 be changed to |spotless| if \MP\ survives the initialization process.
2050 @<Allocate or ...@>=
2051 mp->deletions_allowed=true; mp->error_count=0; /* |history| is initialized elsewhere */
2053 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2054 error procedures near the beginning of the program. But the error procedures
2055 in turn use some other procedures, which need to be declared |forward|
2056 before we get to |error| itself.
2058 It is possible for |error| to be called recursively if some error arises
2059 when |get_next| is being used to delete a token, and/or if some fatal error
2060 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2062 is never more than two levels deep.
2065 void mp_get_next (MP mp);
2066 void mp_term_input (MP mp);
2067 void mp_show_context (MP mp);
2068 void mp_begin_file_reading (MP mp);
2069 void mp_open_log_file (MP mp);
2070 void mp_clear_for_error_prompt (MP mp);
2071 void mp_debug_help (MP mp);
2072 @<Declare the procedure called |flush_string|@>
2075 void mp_normalize_selector (MP mp);
2077 @ Individual lines of help are recorded in the array |help_line|, which
2078 contains entries in positions |0..(help_ptr-1)|. They should be printed
2079 in reverse order, i.e., with |help_line[0]| appearing last.
2081 @d hlp1(A) mp->help_line[0]=(A); }
2082 @d hlp2(A) mp->help_line[1]=(A); hlp1
2083 @d hlp3(A) mp->help_line[2]=(A); hlp2
2084 @d hlp4(A) mp->help_line[3]=(A); hlp3
2085 @d hlp5(A) mp->help_line[4]=(A); hlp4
2086 @d hlp6(A) mp->help_line[5]=(A); hlp5
2087 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2088 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2089 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2090 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2091 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2092 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2093 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2096 const char * help_line[6]; /* helps for the next |error| */
2097 unsigned int help_ptr; /* the number of help lines present */
2098 boolean use_err_help; /* should the |err_help| string be shown? */
2099 str_number err_help; /* a string set up by \&{errhelp} */
2100 str_number filename_template; /* a string set up by \&{filenametemplate} */
2102 @ @<Allocate or ...@>=
2103 mp->help_ptr=0; mp->use_err_help=false; mp->err_help=0; mp->filename_template=0;
2105 @ The |jump_out| procedure just cuts across all active procedure levels and
2106 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2107 whole program. It is used when there is no recovery from a particular error.
2109 The program uses a |jump_buf| to handle this, this is initialized at three
2110 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2111 of |mp_run|. Those are the only library enty points.
2113 @^system dependencies@>
2118 @ @<Install and test the non-local jump buffer@>=
2119 if (setjmp(mp->jump_buf) != 0) { return mp->history; }
2121 @ @<Setup the non-local jump buffer in |mp_new|@>=
2122 if (setjmp(mp->jump_buf) != 0) return NULL;
2125 @ If the array of internals is still |NULL| when |jump_out| is called, a
2126 crash occured during initialization, and it is not safe to run the normal
2130 void mp_jump_out (MP mp) {
2131 if (mp->internal!=NULL && mp->history < mp_system_error_stop)
2132 mp_close_files_and_terminate(mp);
2133 longjmp(mp->jump_buf,1);
2136 @ Here now is the general |error| routine.
2139 void mp_error (MP mp) { /* completes the job of error reporting */
2140 ASCII_code c; /* what the user types */
2141 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2142 pool_pointer j; /* character position being printed */
2143 if ( mp->history<mp_error_message_issued )
2144 mp->history=mp_error_message_issued;
2145 mp_print_char(mp, '.'); mp_show_context(mp);
2146 if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
2147 @<Get user's advice and |return|@>;
2149 incr(mp->error_count);
2150 if ( mp->error_count==100 ) {
2151 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2152 @.That makes 100 errors...@>
2153 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2155 @<Put help message on the transcript file@>;
2157 void mp_warn (MP mp, const char *msg) {
2158 int saved_selector = mp->selector;
2159 mp_normalize_selector(mp);
2160 mp_print_nl(mp,"Warning: ");
2163 mp->selector = saved_selector;
2166 @ @<Exported function ...@>=
2167 void mp_error (MP mp);
2168 void mp_warn (MP mp, const char *msg);
2171 @ @<Get user's advice...@>=
2174 mp_clear_for_error_prompt(mp); prompt_input("? ");
2176 if ( mp->last==mp->first ) return;
2177 c=mp->buffer[mp->first];
2178 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2179 @<Interpret code |c| and |return| if done@>;
2182 @ It is desirable to provide an `\.E' option here that gives the user
2183 an easy way to return from \MP\ to the system editor, with the offending
2184 line ready to be edited. But such an extension requires some system
2185 wizardry, so the present implementation simply types out the name of the
2187 edited and the relevant line number.
2188 @^system dependencies@>
2191 typedef void (*mp_run_editor_command)(MP, char *, int);
2193 @ @<Option variables@>=
2194 mp_run_editor_command run_editor;
2196 @ @<Allocate or initialize ...@>=
2197 set_callback_option(run_editor);
2200 void mp_run_editor (MP mp, char *fname, int fline);
2202 @ @c void mp_run_editor (MP mp, char *fname, int fline) {
2203 mp_print_nl(mp, "You want to edit file ");
2204 @.You want to edit file x@>
2205 mp_print(mp, fname);
2206 mp_print(mp, " at line ");
2207 mp_print_int(mp, fline);
2208 mp->interaction=mp_scroll_mode;
2213 There is a secret `\.D' option available when the debugging routines haven't
2217 @<Interpret code |c| and |return| if done@>=
2219 case '0': case '1': case '2': case '3': case '4':
2220 case '5': case '6': case '7': case '8': case '9':
2221 if ( mp->deletions_allowed ) {
2222 @<Delete |c-"0"| tokens and |continue|@>;
2227 mp_debug_help(mp); continue;
2231 if ( mp->file_ptr>0 ){
2232 (mp->run_editor)(mp,
2233 str(mp->input_stack[mp->file_ptr].name_field),
2238 @<Print the help information and |continue|@>;
2241 @<Introduce new material from the terminal and |return|@>;
2243 case 'Q': case 'R': case 'S':
2244 @<Change the interaction level and |return|@>;
2247 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2252 @<Print the menu of available options@>
2254 @ @<Print the menu...@>=
2256 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2257 @.Type <return> to proceed...@>
2258 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2259 mp_print_nl(mp, "I to insert something, ");
2260 if ( mp->file_ptr>0 )
2261 mp_print(mp, "E to edit your file,");
2262 if ( mp->deletions_allowed )
2263 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2264 mp_print_nl(mp, "H for help, X to quit.");
2267 @ Here the author of \MP\ apologizes for making use of the numerical
2268 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2269 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2270 @^Knuth, Donald Ervin@>
2272 @<Change the interaction...@>=
2274 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2275 mp_print(mp, "OK, entering ");
2277 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2278 case 'R': mp_print(mp, "nonstopmode"); break;
2279 case 'S': mp_print(mp, "scrollmode"); break;
2280 } /* there are no other cases */
2281 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2284 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2285 contain the material inserted by the user; otherwise another prompt will
2286 be given. In order to understand this part of the program fully, you need
2287 to be familiar with \MP's input stacks.
2289 @<Introduce new material...@>=
2291 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2292 if ( mp->last>mp->first+1 ) {
2293 loc=mp->first+1; mp->buffer[mp->first]=' ';
2295 prompt_input("insert>"); loc=mp->first;
2298 mp->first=mp->last+1; mp->cur_input.limit_field=mp->last; return;
2301 @ We allow deletion of up to 99 tokens at a time.
2303 @<Delete |c-"0"| tokens...@>=
2305 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2306 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2307 c=c*10+mp->buffer[mp->first+1]-'0'*11;
2311 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2312 @<Decrease the string reference count, if the current token is a string@>;
2315 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2316 help2("I have just deleted some text, as you asked.")
2317 ("You can now delete more, or insert, or whatever.");
2318 mp_show_context(mp);
2322 @ @<Print the help info...@>=
2324 if ( mp->use_err_help ) {
2325 @<Print the string |err_help|, possibly on several lines@>;
2326 mp->use_err_help=false;
2328 if ( mp->help_ptr==0 ) {
2329 help2("Sorry, I don't know how to help in this situation.")
2330 ("Maybe you should try asking a human?");
2333 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2334 } while (mp->help_ptr!=0);
2336 help4("Sorry, I already gave what help I could...")
2337 ("Maybe you should try asking a human?")
2338 ("An error might have occurred before I noticed any problems.")
2339 ("``If all else fails, read the instructions.''");
2343 @ @<Print the string |err_help|, possibly on several lines@>=
2344 j=mp->str_start[mp->err_help];
2345 while ( j<str_stop(mp->err_help) ) {
2346 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2347 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2348 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2349 else { incr(j); mp_print_char(mp, '%'); };
2353 @ @<Put help message on the transcript file@>=
2354 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2355 if ( mp->use_err_help ) {
2356 mp_print_nl(mp, "");
2357 @<Print the string |err_help|, possibly on several lines@>;
2359 while ( mp->help_ptr>0 ){
2360 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2364 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2367 @ In anomalous cases, the print selector might be in an unknown state;
2368 the following subroutine is called to fix things just enough to keep
2369 running a bit longer.
2372 void mp_normalize_selector (MP mp) {
2373 if ( mp->log_opened ) mp->selector=term_and_log;
2374 else mp->selector=term_only;
2375 if ( mp->job_name==NULL ) mp_open_log_file(mp);
2376 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2379 @ The following procedure prints \MP's last words before dying.
2381 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2382 mp->interaction=mp_scroll_mode; /* no more interaction */
2383 if ( mp->log_opened ) mp_error(mp);
2384 /*| if ( mp->interaction>mp_batch_mode ) mp_debug_help(mp); |*/
2385 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2389 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2390 mp_normalize_selector(mp);
2391 print_err("Emergency stop"); help1(s); succumb;
2395 @ @<Exported function ...@>=
2396 void mp_fatal_error (MP mp, const char *s);
2399 @ Here is the most dreaded error message.
2402 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2403 mp_normalize_selector(mp);
2404 print_err("MetaPost capacity exceeded, sorry [");
2405 @.MetaPost capacity exceeded ...@>
2406 mp_print(mp, s); mp_print_char(mp, '='); mp_print_int(mp, n); mp_print_char(mp, ']');
2407 help2("If you really absolutely need more capacity,")
2408 ("you can ask a wizard to enlarge me.");
2412 @ @<Internal library declarations@>=
2413 void mp_overflow (MP mp, const char *s, integer n);
2415 @ The program might sometime run completely amok, at which point there is
2416 no choice but to stop. If no previous error has been detected, that's bad
2417 news; a message is printed that is really intended for the \MP\
2418 maintenance person instead of the user (unless the user has been
2419 particularly diabolical). The index entries for `this can't happen' may
2420 help to pinpoint the problem.
2423 @<Internal library ...@>=
2424 void mp_confusion (MP mp, const char *s);
2426 @ @<Error hand...@>=
2427 void mp_confusion (MP mp, const char *s) {
2428 /* consistency check violated; |s| tells where */
2429 mp_normalize_selector(mp);
2430 if ( mp->history<mp_error_message_issued ) {
2431 print_err("This can't happen ("); mp_print(mp, s); mp_print_char(mp, ')');
2432 @.This can't happen@>
2433 help1("I'm broken. Please show this to someone who can fix can fix");
2435 print_err("I can\'t go on meeting you like this");
2436 @.I can't go on...@>
2437 help2("One of your faux pas seems to have wounded me deeply...")
2438 ("in fact, I'm barely conscious. Please fix it and try again.");
2443 @ Users occasionally want to interrupt \MP\ while it's running.
2444 If the runtime system allows this, one can implement
2445 a routine that sets the global variable |interrupt| to some nonzero value
2446 when such an interrupt is signaled. Otherwise there is probably at least
2447 a way to make |interrupt| nonzero using the C debugger.
2448 @^system dependencies@>
2451 @d check_interrupt { if ( mp->interrupt!=0 )
2452 mp_pause_for_instructions(mp); }
2455 integer interrupt; /* should \MP\ pause for instructions? */
2456 boolean OK_to_interrupt; /* should interrupts be observed? */
2457 integer run_state; /* are we processing input ?*/
2459 @ @<Allocate or ...@>=
2460 mp->interrupt=0; mp->OK_to_interrupt=true; mp->run_state=0;
2462 @ When an interrupt has been detected, the program goes into its
2463 highest interaction level and lets the user have the full flexibility of
2464 the |error| routine. \MP\ checks for interrupts only at times when it is
2468 void mp_pause_for_instructions (MP mp) {
2469 if ( mp->OK_to_interrupt ) {
2470 mp->interaction=mp_error_stop_mode;
2471 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2473 print_err("Interruption");
2476 ("Try to insert some instructions for me (e.g.,`I show x'),")
2477 ("unless you just want to quit by typing `X'.");
2478 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2483 @ Many of \MP's error messages state that a missing token has been
2484 inserted behind the scenes. We can save string space and program space
2485 by putting this common code into a subroutine.
2488 void mp_missing_err (MP mp, const char *s) {
2489 print_err("Missing `"); mp_print(mp, s); mp_print(mp, "' has been inserted");
2490 @.Missing...inserted@>
2493 @* \[7] Arithmetic with scaled numbers.
2494 The principal computations performed by \MP\ are done entirely in terms of
2495 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2496 program can be carried out in exactly the same way on a wide variety of
2497 computers, including some small ones.
2500 But C does not rigidly define the |/| operation in the case of negative
2501 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2502 computers and |-n| on others (is this true ?). There are two principal
2503 types of arithmetic: ``translation-preserving,'' in which the identity
2504 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2505 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2506 different results, although the differences should be negligible when the
2507 language is being used properly. The \TeX\ processor has been defined
2508 carefully so that both varieties of arithmetic will produce identical
2509 output, but it would be too inefficient to constrain \MP\ in a similar way.
2511 @d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */
2513 @ One of \MP's most common operations is the calculation of
2514 $\lfloor{a+b\over2}\rfloor$,
2515 the midpoint of two given integers |a| and~|b|. The most decent way to do
2516 this is to write `|(a+b)/2|'; but on many machines it is more efficient
2517 to calculate `|(a+b)>>1|'.
2519 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2520 in this program. If \MP\ is being implemented with languages that permit
2521 binary shifting, the |half| macro should be changed to make this operation
2522 as efficient as possible. Since some systems have shift operators that can
2523 only be trusted to work on positive numbers, there is also a macro |halfp|
2524 that is used only when the quantity being halved is known to be positive
2527 @d half(A) ((A) / 2)
2528 @d halfp(A) ((A) >> 1)
2530 @ A single computation might use several subroutine calls, and it is
2531 desirable to avoid producing multiple error messages in case of arithmetic
2532 overflow. So the routines below set the global variable |arith_error| to |true|
2533 instead of reporting errors directly to the user.
2534 @^overflow in arithmetic@>
2537 boolean arith_error; /* has arithmetic overflow occurred recently? */
2539 @ @<Allocate or ...@>=
2540 mp->arith_error=false;
2542 @ At crucial points the program will say |check_arith|, to test if
2543 an arithmetic error has been detected.
2545 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2548 void mp_clear_arith (MP mp) {
2549 print_err("Arithmetic overflow");
2550 @.Arithmetic overflow@>
2551 help4("Uh, oh. A little while ago one of the quantities that I was")
2552 ("computing got too large, so I'm afraid your answers will be")
2553 ("somewhat askew. You'll probably have to adopt different")
2554 ("tactics next time. But I shall try to carry on anyway.");
2556 mp->arith_error=false;
2559 @ Addition is not always checked to make sure that it doesn't overflow,
2560 but in places where overflow isn't too unlikely the |slow_add| routine
2563 @c integer mp_slow_add (MP mp,integer x, integer y) {
2565 if ( y<=el_gordo-x ) {
2568 mp->arith_error=true;
2571 } else if ( -y<=el_gordo+x ) {
2574 mp->arith_error=true;
2579 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2580 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2581 positions from the right end of a binary computer word.
2583 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2584 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2585 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2586 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2587 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2588 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2591 typedef integer scaled; /* this type is used for scaled integers */
2592 typedef unsigned char small_number; /* this type is self-explanatory */
2594 @ The following function is used to create a scaled integer from a given decimal
2595 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2596 given in |dig[i]|, and the calculation produces a correctly rounded result.
2599 scaled mp_round_decimals (MP mp,small_number k) {
2600 /* converts a decimal fraction */
2601 integer a = 0; /* the accumulator */
2603 a=(a+mp->dig[k]*two) / 10;
2608 @ Conversely, here is a procedure analogous to |print_int|. If the output
2609 of this procedure is subsequently read by \MP\ and converted by the
2610 |round_decimals| routine above, it turns out that the original value will
2611 be reproduced exactly. A decimal point is printed only if the value is
2612 not an integer. If there is more than one way to print the result with
2613 the optimum number of digits following the decimal point, the closest
2614 possible value is given.
2616 The invariant relation in the \&{repeat} loop is that a sequence of
2617 decimal digits yet to be printed will yield the original number if and only if
2618 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2619 We can stop if and only if $f=0$ satisfies this condition; the loop will
2620 terminate before $s$ can possibly become zero.
2622 @<Basic printing...@>=
2623 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2624 scaled delta; /* amount of allowable inaccuracy */
2626 mp_print_char(mp, '-');
2627 negate(s); /* print the sign, if negative */
2629 mp_print_int(mp, s / unity); /* print the integer part */
2633 mp_print_char(mp, '.');
2636 s=s+0100000-(delta / 2); /* round the final digit */
2637 mp_print_char(mp, '0'+(s / unity));
2644 @ We often want to print two scaled quantities in parentheses,
2645 separated by a comma.
2647 @<Basic printing...@>=
2648 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2649 mp_print_char(mp, '(');
2650 mp_print_scaled(mp, x);
2651 mp_print_char(mp, ',');
2652 mp_print_scaled(mp, y);
2653 mp_print_char(mp, ')');
2656 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2657 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2658 arithmetic with 28~significant bits of precision. A |fraction| denotes
2659 a scaled integer whose binary point is assumed to be 28 bit positions
2662 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2663 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2664 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2665 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2666 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2669 typedef integer fraction; /* this type is used for scaled fractions */
2671 @ In fact, the two sorts of scaling discussed above aren't quite
2672 sufficient; \MP\ has yet another, used internally to keep track of angles
2673 in units of $2^{-20}$ degrees.
2675 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2676 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2677 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2678 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2681 typedef integer angle; /* this type is used for scaled angles */
2683 @ The |make_fraction| routine produces the |fraction| equivalent of
2684 |p/q|, given integers |p| and~|q|; it computes the integer
2685 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2686 positive. If |p| and |q| are both of the same scaled type |t|,
2687 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2688 and it's also possible to use the subroutine ``backwards,'' using
2689 the relation |make_fraction(t,fraction)=t| between scaled types.
2691 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2692 sets |arith_error:=true|. Most of \MP's internal computations have
2693 been designed to avoid this sort of error.
2695 If this subroutine were programmed in assembly language on a typical
2696 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2697 double-precision product can often be input to a fixed-point division
2698 instruction. But when we are restricted to int-eger arithmetic it
2699 is necessary either to resort to multiple-precision maneuvering
2700 or to use a simple but slow iteration. The multiple-precision technique
2701 would be about three times faster than the code adopted here, but it
2702 would be comparatively long and tricky, involving about sixteen
2703 additional multiplications and divisions.
2705 This operation is part of \MP's ``inner loop''; indeed, it will
2706 consume nearly 10\pct! of the running time (exclusive of input and output)
2707 if the code below is left unchanged. A machine-dependent recoding
2708 will therefore make \MP\ run faster. The present implementation
2709 is highly portable, but slow; it avoids multiplication and division
2710 except in the initial stage. System wizards should be careful to
2711 replace it with a routine that is guaranteed to produce identical
2712 results in all cases.
2713 @^system dependencies@>
2715 As noted below, a few more routines should also be replaced by machine-dependent
2716 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2717 such changes aren't advisable; simplicity and robustness are
2718 preferable to trickery, unless the cost is too high.
2722 fraction mp_make_fraction (MP mp,integer p, integer q);
2723 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2725 @ If FIXPT is not defined, we need these preprocessor values
2727 @d ELGORDO 0x7fffffff
2728 @d TWEXP31 2147483648.0
2729 @d TWEXP28 268435456.0
2731 @d TWEXP_16 (1.0/65536.0)
2732 @d TWEXP_28 (1.0/268435456.0)
2736 fraction mp_make_fraction (MP mp,integer p, integer q) {
2738 integer f; /* the fraction bits, with a leading 1 bit */
2739 integer n; /* the integer part of $\vert p/q\vert$ */
2740 integer be_careful; /* disables certain compiler optimizations */
2741 boolean negative = false; /* should the result be negated? */
2743 negate(p); negative=true;
2747 if ( q==0 ) mp_confusion(mp, '/');
2749 @:this can't happen /}{\quad \./@>
2750 negate(q); negative = ! negative;
2754 mp->arith_error=true;
2755 return ( negative ? -el_gordo : el_gordo);
2757 n=(n-1)*fraction_one;
2758 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2759 return (negative ? (-(f+n)) : (f+n));
2765 if (q==0) mp_confusion(mp,'/');
2767 d = TWEXP28 * (double)p /(double)q;
2770 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
2772 if (d==i && ( ((q>0 ? -q : q)&077777)
2773 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2776 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
2778 if (d==i && ( ((q>0 ? q : -q)&077777)
2779 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2785 @ The |repeat| loop here preserves the following invariant relations
2786 between |f|, |p|, and~|q|:
2787 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2788 $p_0$ is the original value of~$p$.
2790 Notice that the computation specifies
2791 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2792 Let us hope that optimizing compilers do not miss this point; a
2793 special variable |be_careful| is used to emphasize the necessary
2794 order of computation. Optimizing compilers should keep |be_careful|
2795 in a register, not store it in memory.
2798 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2802 be_careful=p-q; p=be_careful+p;
2808 } while (f<fraction_one);
2810 if ( be_careful+p>=0 ) incr(f);
2813 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2814 given integer~|q| by a fraction~|f|. When the operands are positive, it
2815 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2818 This routine is even more ``inner loopy'' than |make_fraction|;
2819 the present implementation consumes almost 20\pct! of \MP's computation
2820 time during typical jobs, so a machine-language substitute is advisable.
2821 @^inner loop@> @^system dependencies@>
2824 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2828 integer mp_take_fraction (MP mp,integer q, fraction f) {
2829 integer p; /* the fraction so far */
2830 boolean negative; /* should the result be negated? */
2831 integer n; /* additional multiple of $q$ */
2832 integer be_careful; /* disables certain compiler optimizations */
2833 @<Reduce to the case that |f>=0| and |q>=0|@>;
2834 if ( f<fraction_one ) {
2837 n=f / fraction_one; f=f % fraction_one;
2838 if ( q<=el_gordo / n ) {
2841 mp->arith_error=true; n=el_gordo;
2845 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2846 be_careful=n-el_gordo;
2847 if ( be_careful+p>0 ){
2848 mp->arith_error=true; n=el_gordo-p;
2855 integer mp_take_fraction (MP mp,integer p, fraction q) {
2858 d = (double)p * (double)q * TWEXP_28;
2862 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2863 mp->arith_error = true;
2867 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2871 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2872 mp->arith_error = true;
2876 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2882 @ @<Reduce to the case that |f>=0| and |q>=0|@>=
2886 negate( f); negative=true;
2889 negate(q); negative=! negative;
2892 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2893 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2894 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2897 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2898 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2899 if ( q<fraction_four ) {
2901 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2906 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2912 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2913 analogous to |take_fraction| but with a different scaling.
2914 Given positive operands, |take_scaled|
2915 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2917 Once again it is a good idea to use a machine-language replacement if
2918 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2919 when the Computer Modern fonts are being generated.
2924 integer mp_take_scaled (MP mp,integer q, scaled f) {
2925 integer p; /* the fraction so far */
2926 boolean negative; /* should the result be negated? */
2927 integer n; /* additional multiple of $q$ */
2928 integer be_careful; /* disables certain compiler optimizations */
2929 @<Reduce to the case that |f>=0| and |q>=0|@>;
2933 n=f / unity; f=f % unity;
2934 if ( q<=el_gordo / n ) {
2937 mp->arith_error=true; n=el_gordo;
2941 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2942 be_careful=n-el_gordo;
2943 if ( be_careful+p>0 ) {
2944 mp->arith_error=true; n=el_gordo-p;
2946 return ( negative ?(-(n+p)) :(n+p));
2948 integer mp_take_scaled (MP mp,integer p, scaled q) {
2951 d = (double)p * (double)q * TWEXP_16;
2955 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2956 mp->arith_error = true;
2960 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2964 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2965 mp->arith_error = true;
2969 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2975 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
2976 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
2978 if ( q<fraction_four ) {
2980 p = (odd(f) ? halfp(p+q) : halfp(p));
2985 p = (odd(f) ? p+halfp(q-p) : halfp(p));
2990 @ For completeness, there's also |make_scaled|, which computes a
2991 quotient as a |scaled| number instead of as a |fraction|.
2992 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
2993 operands are positive. \ (This procedure is not used especially often,
2994 so it is not part of \MP's inner loop.)
2996 @<Internal library ...@>=
2997 scaled mp_make_scaled (MP mp,integer p, integer q) ;
3000 scaled mp_make_scaled (MP mp,integer p, integer q) {
3002 integer f; /* the fraction bits, with a leading 1 bit */
3003 integer n; /* the integer part of $\vert p/q\vert$ */
3004 boolean negative; /* should the result be negated? */
3005 integer be_careful; /* disables certain compiler optimizations */
3006 if ( p>=0 ) negative=false;
3007 else { negate(p); negative=true; };
3010 if ( q==0 ) mp_confusion(mp, "/");
3011 @:this can't happen /}{\quad \./@>
3013 negate(q); negative=! negative;
3017 mp->arith_error=true;
3018 return (negative ? (-el_gordo) : el_gordo);
3021 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
3022 return ( negative ? (-(f+n)) :(f+n));
3028 if (q==0) mp_confusion(mp,"/");
3030 d = TWEXP16 * (double)p /(double)q;
3033 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
3035 if (d==i && ( ((q>0 ? -q : q)&077777)
3036 * (((i&037777)<<1)-1) & 04000)!=0) --i;
3039 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
3041 if (d==i && ( ((q>0 ? q : -q)&077777)
3042 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
3048 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
3051 be_careful=p-q; p=be_careful+p;
3052 if ( p>=0 ) f=f+f+1;
3053 else { f+=f; p=p+q; };
3056 if ( be_careful+p>=0 ) incr(f)
3058 @ Here is a typical example of how the routines above can be used.
3059 It computes the function
3060 $${1\over3\tau}f(\theta,\phi)=
3061 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3062 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3063 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3064 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3065 fudge factor for placing the first control point of a curve that starts
3066 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3067 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3069 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3070 (It's a sum of eight terms whose absolute values can be bounded using
3071 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3072 is positive; and since the tension $\tau$ is constrained to be at least
3073 $3\over4$, the numerator is less than $16\over3$. The denominator is
3074 nonnegative and at most~6. Hence the fixed-point calculations below
3075 are guaranteed to stay within the bounds of a 32-bit computer word.
3077 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3078 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3079 $\sin\phi$, and $\cos\phi$, respectively.
3082 fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3083 fraction cf, scaled t) {
3084 integer acc,num,denom; /* registers for intermediate calculations */
3085 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3086 acc=mp_take_fraction(mp, acc,ct-cf);
3087 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3088 /* $2^{28}\sqrt2\approx379625062.497$ */
3089 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3090 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3091 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3092 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3093 /* |make_scaled(fraction,scaled)=fraction| */
3094 if ( num / 4>=denom )
3095 return fraction_four;
3097 return mp_make_fraction(mp, num, denom);
3100 @ The following somewhat different subroutine tests rigorously if $ab$ is
3101 greater than, equal to, or less than~$cd$,
3102 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3103 The result is $+1$, 0, or~$-1$ in the three respective cases.
3105 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3108 integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3109 integer q,r; /* temporary registers */
3110 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3112 q = a / d; r = c / b;
3114 return ( q>r ? 1 : -1);
3115 q = a % d; r = c % b;
3118 if ( q==0 ) return -1;
3120 } /* now |a>d>0| and |c>b>0| */
3123 @ @<Reduce to the case that |a...@>=
3124 if ( a<0 ) { negate(a); negate(b); };
3125 if ( c<0 ) { negate(c); negate(d); };
3128 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3132 return ( a==0 ? 0 : -1);
3133 q=a; a=c; c=q; q=-b; b=-d; d=q;
3134 } else if ( b<=0 ) {
3135 if ( b<0 ) if ( a>0 ) return -1;
3136 return (c==0 ? 0 : -1);
3139 @ We conclude this set of elementary routines with some simple rounding
3140 and truncation operations.
3142 @<Internal library declarations@>=
3143 #define mp_floor_scaled(M,i) ((i)&(-65536))
3144 #define mp_round_unscaled(M,i) (((i>>15)+1)>>1)
3145 #define mp_round_fraction(M,i) (((i>>11)+1)>>1)
3148 @* \[8] Algebraic and transcendental functions.
3149 \MP\ computes all of the necessary special functions from scratch, without
3150 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3152 @ To get the square root of a |scaled| number |x|, we want to calculate
3153 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3154 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3155 determines $s$ by an iterative method that maintains the invariant
3156 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3157 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3158 might, however, be zero at the start of the first iteration.
3161 scaled mp_square_rt (MP mp,scaled x) ;
3164 scaled mp_square_rt (MP mp,scaled x) {
3165 small_number k; /* iteration control counter */
3166 integer y,q; /* registers for intermediate calculations */
3168 @<Handle square root of zero or negative argument@>;
3171 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3174 if ( x<fraction_four ) y=0;
3175 else { x=x-fraction_four; y=1; };
3177 @<Decrease |k| by 1, maintaining the invariant
3178 relations between |x|, |y|, and~|q|@>;
3184 @ @<Handle square root of zero...@>=
3187 print_err("Square root of ");
3188 @.Square root...replaced by 0@>
3189 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3190 help2("Since I don't take square roots of negative numbers,")
3191 ("I'm zeroing this one. Proceed, with fingers crossed.");
3197 @ @<Decrease |k| by 1, maintaining...@>=
3199 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3200 x=x-fraction_four; incr(y);
3202 x+=x; y=y+y-q; q+=q;
3203 if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
3204 if ( y>q ){ y=y-q; q=q+2; }
3205 else if ( y<=0 ) { q=q-2; y=y+q; };
3208 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3209 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3210 @^Moler, Cleve Barry@>
3211 @^Morrison, Donald Ross@>
3212 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3213 in such a way that their Pythagorean sum remains invariant, while the
3214 smaller argument decreases.
3216 @<Internal library ...@>=
3217 integer mp_pyth_add (MP mp,integer a, integer b);
3221 integer mp_pyth_add (MP mp,integer a, integer b) {
3222 fraction r; /* register used to transform |a| and |b| */
3223 boolean big; /* is the result dangerously near $2^{31}$? */
3225 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3227 if ( a<fraction_two ) {
3230 a=a / 4; b=b / 4; big=true;
3231 }; /* we reduced the precision to avoid arithmetic overflow */
3232 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3234 if ( a<fraction_two ) {
3237 mp->arith_error=true; a=el_gordo;
3244 @ The key idea here is to reflect the vector $(a,b)$ about the
3245 line through $(a,b/2)$.
3247 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3249 r=mp_make_fraction(mp, b,a);
3250 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3252 r=mp_make_fraction(mp, r,fraction_four+r);
3253 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3257 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3258 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3261 integer mp_pyth_sub (MP mp,integer a, integer b) {
3262 fraction r; /* register used to transform |a| and |b| */
3263 boolean big; /* is the input dangerously near $2^{31}$? */
3266 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3268 if ( a<fraction_four ) {
3271 a=halfp(a); b=halfp(b); big=true;
3273 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3274 if ( big ) double(a);
3279 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3281 r=mp_make_fraction(mp, b,a);
3282 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3284 r=mp_make_fraction(mp, r,fraction_four-r);
3285 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3288 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3291 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3292 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3293 mp_print(mp, " has been replaced by 0");
3295 help2("Since I don't take square roots of negative numbers,")
3296 ("I'm zeroing this one. Proceed, with fingers crossed.");
3302 @ The subroutines for logarithm and exponential involve two tables.
3303 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3304 a bit more calculation, which the author claims to have done correctly:
3305 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3306 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3309 @d two_to_the(A) (1<<(A))
3312 static const integer spec_log[29] = { 0, /* special logarithms */
3313 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3314 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3315 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3317 @ @<Local variables for initialization@>=
3318 integer k; /* all-purpose loop index */
3321 @ Here is the routine that calculates $2^8$ times the natural logarithm
3322 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3323 when |x| is a given positive integer.
3325 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3326 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3327 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3328 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3329 during the calculation, and sixteen auxiliary bits to extend |y| are
3330 kept in~|z| during the initial argument reduction. (We add
3331 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3332 not become negative; also, the actual amount subtracted from~|y| is~96,
3333 not~100, because we want to add~4 for rounding before the final division by~8.)
3336 scaled mp_m_log (MP mp,scaled x) {
3337 integer y,z; /* auxiliary registers */
3338 integer k; /* iteration counter */
3340 @<Handle non-positive logarithm@>;
3342 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3343 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3344 while ( x<fraction_four ) {
3345 double(x); y-=93032639; z-=48782;
3346 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3347 y=y+(z / unity); k=2;
3348 while ( x>fraction_four+4 ) {
3349 @<Increase |k| until |x| can be multiplied by a
3350 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3356 @ @<Increase |k| until |x| can...@>=
3358 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3359 while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
3360 y+=spec_log[k]; x-=z;
3363 @ @<Handle non-positive logarithm@>=
3365 print_err("Logarithm of ");
3366 @.Logarithm...replaced by 0@>
3367 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3368 help2("Since I don't take logs of non-positive numbers,")
3369 ("I'm zeroing this one. Proceed, with fingers crossed.");
3374 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3375 when |x| is |scaled|. The result is an integer approximation to
3376 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3379 scaled mp_m_exp (MP mp,scaled x) {
3380 small_number k; /* loop control index */
3381 integer y,z; /* auxiliary registers */
3382 if ( x>174436200 ) {
3383 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3384 mp->arith_error=true;
3386 } else if ( x<-197694359 ) {
3387 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3391 z=-8*x; y=04000000; /* $y=2^{20}$ */
3393 if ( x<=127919879 ) {
3395 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3397 z=8*(174436200-x); /* |z| is always nonnegative */
3401 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3403 return ((y+8) / 16);
3409 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3410 to multiplying |y| by $1-2^{-k}$.
3412 A subtle point (which had to be checked) was that if $x=127919879$, the
3413 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3414 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3415 and by~16 when |k=27|.
3417 @<Multiply |y| by...@>=
3420 while ( z>=spec_log[k] ) {
3422 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3427 @ The trigonometric subroutines use an auxiliary table such that
3428 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3429 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3432 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3433 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3434 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3436 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3437 returns the |angle| whose tangent points in the direction $(x,y)$.
3438 This subroutine first determines the correct octant, then solves the
3439 problem for |0<=y<=x|, then converts the result appropriately to
3440 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3441 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3442 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3444 The octants are represented in a ``Gray code,'' since that turns out
3445 to be computationally simplest.
3451 @d second_octant (first_octant+switch_x_and_y)
3452 @d third_octant (first_octant+switch_x_and_y+negate_x)
3453 @d fourth_octant (first_octant+negate_x)
3454 @d fifth_octant (first_octant+negate_x+negate_y)
3455 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3456 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3457 @d eighth_octant (first_octant+negate_y)
3460 angle mp_n_arg (MP mp,integer x, integer y) {
3461 angle z; /* auxiliary register */
3462 integer t; /* temporary storage */
3463 small_number k; /* loop counter */
3464 int octant; /* octant code */
3466 octant=first_octant;
3468 negate(x); octant=first_octant+negate_x;
3471 negate(y); octant=octant+negate_y;
3474 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3477 @<Handle undefined arg@>;
3479 @<Set variable |z| to the arg of $(x,y)$@>;
3480 @<Return an appropriate answer based on |z| and |octant|@>;
3484 @ @<Handle undefined arg@>=
3486 print_err("angle(0,0) is taken as zero");
3487 @.angle(0,0)...zero@>
3488 help2("The `angle' between two identical points is undefined.")
3489 ("I'm zeroing this one. Proceed, with fingers crossed.");
3494 @ @<Return an appropriate answer...@>=
3496 case first_octant: return z;
3497 case second_octant: return (ninety_deg-z);
3498 case third_octant: return (ninety_deg+z);
3499 case fourth_octant: return (one_eighty_deg-z);
3500 case fifth_octant: return (z-one_eighty_deg);
3501 case sixth_octant: return (-z-ninety_deg);
3502 case seventh_octant: return (z-ninety_deg);
3503 case eighth_octant: return (-z);
3504 }; /* there are no other cases */
3507 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3508 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3511 @<Set variable |z| to the arg...@>=
3512 while ( x>=fraction_two ) {
3513 x=halfp(x); y=halfp(y);
3517 while ( x<fraction_one ) {
3520 @<Increase |z| to the arg of $(x,y)$@>;
3523 @ During the calculations of this section, variables |x| and~|y|
3524 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3525 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3526 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3527 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3528 coordinates whose angle has decreased by~$\phi$; in the special case
3529 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3530 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3531 @^Meggitt, John E.@>
3532 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3534 The initial value of |x| will be multiplied by at most
3535 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3536 there is no chance of integer overflow.
3538 @<Increase |z|...@>=
3543 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3548 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3551 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3552 and cosine of that angle. The results of this routine are
3553 stored in global integer variables |n_sin| and |n_cos|.
3556 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3558 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3559 the purpose of |n_sin_cos(z)| is to set
3560 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3561 for some rather large number~|r|. The maximum of |x| and |y|
3562 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3563 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3566 void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3568 small_number k; /* loop control variable */
3569 int q; /* specifies the quadrant */
3570 fraction r; /* magnitude of |(x,y)| */
3571 integer x,y,t; /* temporary registers */
3572 while ( z<0 ) z=z+three_sixty_deg;
3573 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3574 q=z / forty_five_deg; z=z % forty_five_deg;
3575 x=fraction_one; y=x;
3576 if ( ! odd(q) ) z=forty_five_deg-z;
3577 @<Subtract angle |z| from |(x,y)|@>;
3578 @<Convert |(x,y)| to the octant determined by~|q|@>;
3579 r=mp_pyth_add(mp, x,y);
3580 mp->n_cos=mp_make_fraction(mp, x,r);
3581 mp->n_sin=mp_make_fraction(mp, y,r);
3584 @ In this case the octants are numbered sequentially.
3586 @<Convert |(x,...@>=
3589 case 1: t=x; x=y; y=t; break;
3590 case 2: t=x; x=-y; y=t; break;
3591 case 3: negate(x); break;
3592 case 4: negate(x); negate(y); break;
3593 case 5: t=x; x=-y; y=-t; break;
3594 case 6: t=x; x=y; y=-t; break;
3595 case 7: negate(y); break;
3596 } /* there are no other cases */
3598 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3599 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3600 that this loop is guaranteed to terminate before the (nonexistent) value
3601 |spec_atan[27]| would be required.
3603 @<Subtract angle |z|...@>=
3606 if ( z>=spec_atan[k] ) {
3607 z=z-spec_atan[k]; t=x;
3608 x=t+y / two_to_the(k);
3609 y=y-t / two_to_the(k);
3613 if ( y<0 ) y=0 /* this precaution may never be needed */
3615 @ And now let's complete our collection of numeric utility routines
3616 by considering random number generation.
3617 \MP\ generates pseudo-random numbers with the additive scheme recommended
3618 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3619 results are random fractions between 0 and |fraction_one-1|, inclusive.
3621 There's an auxiliary array |randoms| that contains 55 pseudo-random
3622 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3623 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3624 The global variable |j_random| tells which element has most recently
3626 The global variable |random_seed| was introduced in version 0.9,
3627 for the sole reason of stressing the fact that the initial value of the
3628 random seed is system-dependant. The initialization code below will initialize
3629 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3630 is not good enough on modern fast machines that are capable of running
3631 multiple MetaPost processes within the same second.
3632 @^system dependencies@>
3635 fraction randoms[55]; /* the last 55 random values generated */
3636 int j_random; /* the number of unused |randoms| */
3638 @ @<Option variables@>=
3639 int random_seed; /* the default random seed */
3641 @ @<Allocate or initialize ...@>=
3642 mp->random_seed = (scaled)opt->random_seed;
3644 @ To consume a random fraction, the program below will say `|next_random|'
3645 and then it will fetch |randoms[j_random]|.
3647 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3648 else decr(mp->j_random); }
3651 void mp_new_randoms (MP mp) {
3652 int k; /* index into |randoms| */
3653 fraction x; /* accumulator */
3654 for (k=0;k<=23;k++) {
3655 x=mp->randoms[k]-mp->randoms[k+31];
3656 if ( x<0 ) x=x+fraction_one;
3659 for (k=24;k<= 54;k++){
3660 x=mp->randoms[k]-mp->randoms[k-24];
3661 if ( x<0 ) x=x+fraction_one;
3668 void mp_init_randoms (MP mp,scaled seed);
3670 @ To initialize the |randoms| table, we call the following routine.
3673 void mp_init_randoms (MP mp,scaled seed) {
3674 fraction j,jj,k; /* more or less random integers */
3675 int i; /* index into |randoms| */
3677 while ( j>=fraction_one ) j=halfp(j);
3679 for (i=0;i<=54;i++ ){
3681 if ( k<0 ) k=k+fraction_one;
3682 mp->randoms[(i*21)% 55]=j;
3686 mp_new_randoms(mp); /* ``warm up'' the array */
3689 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3690 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3692 Note that the call of |take_fraction| will produce the values 0 and~|x|
3693 with about half the probability that it will produce any other particular
3694 values between 0 and~|x|, because it rounds its answers.
3697 scaled mp_unif_rand (MP mp,scaled x) {
3698 scaled y; /* trial value */
3699 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3700 if ( y==abs(x) ) return 0;
3701 else if ( x>0 ) return y;
3705 @ Finally, a normal deviate with mean zero and unit standard deviation
3706 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3707 {\sl The Art of Computer Programming\/}).
3710 scaled mp_norm_rand (MP mp) {
3711 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3715 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3716 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3717 next_random; u=mp->randoms[mp->j_random];
3718 } while (abs(x)>=u);
3719 x=mp_make_fraction(mp, x,u);
3720 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3721 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3725 @* \[9] Packed data.
3726 In order to make efficient use of storage space, \MP\ bases its major data
3727 structures on a |memory_word|, which contains either a (signed) integer,
3728 possibly scaled, or a small number of fields that are one half or one
3729 quarter of the size used for storing integers.
3731 If |x| is a variable of type |memory_word|, it contains up to four
3732 fields that can be referred to as follows:
3733 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3734 |x|&.|int|&(an |integer|)\cr
3735 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3736 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3737 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3739 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3740 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3741 This is somewhat cumbersome to write, and not very readable either, but
3742 macros will be used to make the notation shorter and more transparent.
3743 The code below gives a formal definition of |memory_word| and
3744 its subsidiary types, using packed variant records. \MP\ makes no
3745 assumptions about the relative positions of the fields within a word.
3747 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3748 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3750 @ Here are the inequalities that the quarterword and halfword values
3751 must satisfy (or rather, the inequalities that they mustn't satisfy):
3753 @<Check the ``constant''...@>=
3754 if (mp->ini_version) {
3755 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3757 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3759 if ( max_quarterword<255 ) mp->bad=9;
3760 if ( max_halfword<65535 ) mp->bad=10;
3761 if ( max_quarterword>max_halfword ) mp->bad=11;
3762 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3763 if ( mp->max_strings>max_halfword ) mp->bad=13;
3765 @ The macros |qi| and |qo| are used for input to and output
3766 from quarterwords. These are legacy macros.
3767 @^system dependencies@>
3769 @d qo(A) (A) /* to read eight bits from a quarterword */
3770 @d qi(A) (A) /* to store eight bits in a quarterword */
3772 @ The reader should study the following definitions closely:
3773 @^system dependencies@>
3775 @d sc cint /* |scaled| data is equivalent to |integer| */
3778 typedef short quarterword; /* 1/4 of a word */
3779 typedef int halfword; /* 1/2 of a word */
3784 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3791 quarterword B2, B3, B0, B1;
3806 @ When debugging, we may want to print a |memory_word| without knowing
3807 what type it is; so we print it in all modes.
3811 void mp_print_word (MP mp,memory_word w) {
3812 /* prints |w| in all ways */
3813 mp_print_int(mp, w.cint); mp_print_char(mp, ' ');
3814 mp_print_scaled(mp, w.sc); mp_print_char(mp, ' ');
3815 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3816 mp_print_int(mp, w.hh.lh); mp_print_char(mp, '=');
3817 mp_print_int(mp, w.hh.b0); mp_print_char(mp, ':');
3818 mp_print_int(mp, w.hh.b1); mp_print_char(mp, ';');
3819 mp_print_int(mp, w.hh.rh); mp_print_char(mp, ' ');
3820 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, ':');
3821 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, ':');
3822 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, ':');
3823 mp_print_int(mp, w.qqqq.b3);
3827 @* \[10] Dynamic memory allocation.
3829 The \MP\ system does nearly all of its own memory allocation, so that it
3830 can readily be transported into environments that do not have automatic
3831 facilities for strings, garbage collection, etc., and so that it can be in
3832 control of what error messages the user receives. The dynamic storage
3833 requirements of \MP\ are handled by providing a large array |mem| in
3834 which consecutive blocks of words are used as nodes by the \MP\ routines.
3836 Pointer variables are indices into this array, or into another array
3837 called |eqtb| that will be explained later. A pointer variable might
3838 also be a special flag that lies outside the bounds of |mem|, so we
3839 allow pointers to assume any |halfword| value. The minimum memory
3840 index represents a null pointer.
3842 @d null 0 /* the null pointer */
3843 @d mp_void (null+1) /* a null pointer different from |null| */
3847 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3849 @ The |mem| array is divided into two regions that are allocated separately,
3850 but the dividing line between these two regions is not fixed; they grow
3851 together until finding their ``natural'' size in a particular job.
3852 Locations less than or equal to |lo_mem_max| are used for storing
3853 variable-length records consisting of two or more words each. This region
3854 is maintained using an algorithm similar to the one described in exercise
3855 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3856 appears in the allocated nodes; the program is responsible for knowing the
3857 relevant size when a node is freed. Locations greater than or equal to
3858 |hi_mem_min| are used for storing one-word records; a conventional
3859 \.{AVAIL} stack is used for allocation in this region.
3861 Locations of |mem| between |0| and |mem_top| may be dumped as part
3862 of preloaded mem files, by the \.{INIMP} preprocessor.
3864 Production versions of \MP\ may extend the memory at the top end in order to
3865 provide more space; these locations, between |mem_top| and |mem_max|,
3866 are always used for single-word nodes.
3868 The key pointers that govern |mem| allocation have a prescribed order:
3869 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3872 memory_word *mem; /* the big dynamic storage area */
3873 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3874 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3878 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3879 @d xrealloc(P,A,B) mp_xrealloc(mp,P,A,B)
3880 @d xmalloc(A,B) mp_xmalloc(mp,A,B)
3881 @d xstrdup(A) mp_xstrdup(mp,A)
3882 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3884 @<Declare helpers@>=
3885 void mp_xfree (void *x);
3886 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3887 void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3888 char *mp_xstrdup(MP mp, const char *s);
3889 void mp_do_snprintf(char *str, int size, const char *fmt, ...);
3891 @ The |max_size_test| guards against overflow, on the assumption that
3892 |size_t| is at least 31bits wide.
3894 @d max_size_test 0x7FFFFFFF
3897 void mp_xfree (void *x) {
3898 if (x!=NULL) free(x);
3900 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3902 if ((max_size_test/size)<nmem) {
3903 do_fprintf(mp->err_out,"Memory size overflow!\n");
3904 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3906 w = realloc (p,(nmem*size));
3908 do_fprintf(mp->err_out,"Out of memory!\n");
3909 mp->history =mp_system_error_stop; mp_jump_out(mp);
3913 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
3915 if ((max_size_test/size)<nmem) {
3916 do_fprintf(mp->err_out,"Memory size overflow!\n");
3917 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3919 w = malloc (nmem*size);
3921 do_fprintf(mp->err_out,"Out of memory!\n");
3922 mp->history =mp_system_error_stop; mp_jump_out(mp);
3926 char *mp_xstrdup(MP mp, const char *s) {
3932 do_fprintf(mp->err_out,"Out of memory!\n");
3933 mp->history =mp_system_error_stop; mp_jump_out(mp);
3938 @ @<Internal library declarations@>=
3939 #ifdef HAVE_SNPRINTF
3940 #define mp_snprintf (void)snprintf
3942 #define mp_snprintf mp_do_snprintf
3945 @ This internal version is rather stupid, but good enough for its purpose.
3948 void mp_do_snprintf (char *str, int size, const char *format, ...) {
3953 work = (char *)workbuf;
3954 va_start(ap, format);
3956 for (fmt=format;*fmt!='\0';fmt++) {
3962 char *s = va_arg(ap, char *);
3965 if (size-->0) res++;
3972 sprintf(work,"%i",va_arg(ap, int));
3975 if (size-->0) res++;
3981 sprintf(work,"%g",va_arg(ap, double));
3984 if (size-->0) res++;
3990 if (size-->0) res++;
3998 if (size-->0) res++;
4006 @<Allocate or initialize ...@>=
4007 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
4008 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
4010 @ @<Dealloc variables@>=
4013 @ Users who wish to study the memory requirements of particular applications can
4014 can use optional special features that keep track of current and
4015 maximum memory usage. When code between the delimiters |stat| $\ldots$
4016 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
4017 report these statistics when |mp_tracing_stats| is positive.
4020 integer var_used; integer dyn_used; /* how much memory is in use */
4022 @ Let's consider the one-word memory region first, since it's the
4023 simplest. The pointer variable |mem_end| holds the highest-numbered location
4024 of |mem| that has ever been used. The free locations of |mem| that
4025 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
4026 |two_halves|, and we write |info(p)| and |link(p)| for the |lh|
4027 and |rh| fields of |mem[p]| when it is of this type. The single-word
4028 free locations form a linked list
4029 $$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
4030 terminated by |null|.
4032 @d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
4033 @d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
4036 pointer avail; /* head of the list of available one-word nodes */
4037 pointer mem_end; /* the last one-word node used in |mem| */
4039 @ If one-word memory is exhausted, it might mean that the user has forgotten
4040 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
4041 later that try to help pinpoint the trouble.
4044 @<Declare the procedure called |show_token_list|@>
4045 @<Declare the procedure called |runaway|@>
4047 @ The function |get_avail| returns a pointer to a new one-word node whose
4048 |link| field is null. However, \MP\ will halt if there is no more room left.
4052 pointer mp_get_avail (MP mp) { /* single-word node allocation */
4053 pointer p; /* the new node being got */
4054 p=mp->avail; /* get top location in the |avail| stack */
4056 mp->avail=link(mp->avail); /* and pop it off */
4057 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
4058 incr(mp->mem_end); p=mp->mem_end;
4060 decr(mp->hi_mem_min); p=mp->hi_mem_min;
4061 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
4062 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
4063 mp_overflow(mp, "main memory size",mp->mem_max);
4064 /* quit; all one-word nodes are busy */
4065 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4068 link(p)=null; /* provide an oft-desired initialization of the new node */
4069 incr(mp->dyn_used);/* maintain statistics */
4073 @ Conversely, a one-word node is recycled by calling |free_avail|.
4075 @d free_avail(A) /* single-word node liberation */
4076 { link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
4078 @ There's also a |fast_get_avail| routine, which saves the procedure-call
4079 overhead at the expense of extra programming. This macro is used in
4080 the places that would otherwise account for the most calls of |get_avail|.
4083 @d fast_get_avail(A) {
4084 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
4085 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4086 else { mp->avail=link((A)); link((A))=null; incr(mp->dyn_used); }
4089 @ The available-space list that keeps track of the variable-size portion
4090 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4091 pointed to by the roving pointer |rover|.
4093 Each empty node has size 2 or more; the first word contains the special
4094 value |max_halfword| in its |link| field and the size in its |info| field;
4095 the second word contains the two pointers for double linking.
4097 Each nonempty node also has size 2 or more. Its first word is of type
4098 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4099 Otherwise there is complete flexibility with respect to the contents
4100 of its other fields and its other words.
4102 (We require |mem_max<max_halfword| because terrible things can happen
4103 when |max_halfword| appears in the |link| field of a nonempty node.)
4105 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4106 @d is_empty(A) (link((A))==empty_flag) /* tests for empty node */
4107 @d node_size info /* the size field in empty variable-size nodes */
4108 @d llink(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
4109 @d rlink(A) link((A)+1) /* right link in doubly-linked list of empty nodes */
4112 pointer rover; /* points to some node in the list of empties */
4114 @ A call to |get_node| with argument |s| returns a pointer to a new node
4115 of size~|s|, which must be 2~or more. The |link| field of the first word
4116 of this new node is set to null. An overflow stop occurs if no suitable
4119 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4120 areas and returns the value |max_halfword|.
4122 @<Internal library declarations@>=
4123 pointer mp_get_node (MP mp,integer s) ;
4126 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4127 pointer p; /* the node currently under inspection */
4128 pointer q; /* the node physically after node |p| */
4129 integer r; /* the newly allocated node, or a candidate for this honor */
4130 integer t,tt; /* temporary registers */
4133 p=mp->rover; /* start at some free node in the ring */
4135 @<Try to allocate within node |p| and its physical successors,
4136 and |goto found| if allocation was possible@>;
4137 if (rlink(p)==null || (rlink(p)==p && p!=mp->rover)) {
4138 print_err("Free list garbled");
4139 help3("I found an entry in the list of free nodes that links")
4140 ("badly. I will try to ignore the broken link, but something")
4141 ("is seriously amiss. It is wise to warn the maintainers.")
4145 p=rlink(p); /* move to the next node in the ring */
4146 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4147 if ( s==010000000000 ) {
4148 return max_halfword;
4150 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4151 if ( mp->lo_mem_max+2<=max_halfword ) {
4152 @<Grow more variable-size memory and |goto restart|@>;
4155 mp_overflow(mp, "main memory size",mp->mem_max);
4156 /* sorry, nothing satisfactory is left */
4157 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4159 link(r)=null; /* this node is now nonempty */
4160 mp->var_used+=s; /* maintain usage statistics */
4164 @ The lower part of |mem| grows by 1000 words at a time, unless
4165 we are very close to going under. When it grows, we simply link
4166 a new node into the available-space list. This method of controlled
4167 growth helps to keep the |mem| usage consecutive when \MP\ is
4168 implemented on ``virtual memory'' systems.
4171 @<Grow more variable-size memory and |goto restart|@>=
4173 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4174 t=mp->lo_mem_max+1000;
4176 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4177 /* |lo_mem_max+2<=t<hi_mem_min| */
4179 if ( t>max_halfword ) t=max_halfword;
4180 p=llink(mp->rover); q=mp->lo_mem_max; rlink(p)=q; llink(mp->rover)=q;
4181 rlink(q)=mp->rover; llink(q)=p; link(q)=empty_flag;
4182 node_size(q)=t-mp->lo_mem_max;
4183 mp->lo_mem_max=t; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4188 @ @<Try to allocate...@>=
4189 q=p+node_size(p); /* find the physical successor */
4190 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4191 t=rlink(q); tt=llink(q);
4193 if ( q==mp->rover ) mp->rover=t;
4194 llink(t)=tt; rlink(tt)=t;
4199 @<Allocate from the top of node |p| and |goto found|@>;
4202 if ( rlink(p)!=p ) {
4203 @<Allocate entire node |p| and |goto found|@>;
4206 node_size(p)=q-p /* reset the size in case it grew */
4208 @ @<Allocate from the top...@>=
4210 node_size(p)=r-p; /* store the remaining size */
4211 mp->rover=p; /* start searching here next time */
4215 @ Here we delete node |p| from the ring, and let |rover| rove around.
4217 @<Allocate entire...@>=
4219 mp->rover=rlink(p); t=llink(p);
4220 llink(mp->rover)=t; rlink(t)=mp->rover;
4224 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4225 the operation |free_node(p,s)| will make its words available, by inserting
4226 |p| as a new empty node just before where |rover| now points.
4228 @<Internal library declarations@>=
4229 void mp_free_node (MP mp, pointer p, halfword s) ;
4232 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4234 pointer q; /* |llink(rover)| */
4235 node_size(p)=s; link(p)=empty_flag;
4237 q=llink(mp->rover); llink(p)=q; rlink(p)=mp->rover; /* set both links */
4238 llink(mp->rover)=p; rlink(q)=p; /* insert |p| into the ring */
4239 mp->var_used-=s; /* maintain statistics */
4242 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4243 available space list. The list is probably very short at such times, so a
4244 simple insertion sort is used. The smallest available location will be
4245 pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
4248 void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4250 pointer p,q,r; /* indices into |mem| */
4251 pointer old_rover; /* initial |rover| setting */
4252 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4253 p=rlink(mp->rover); rlink(mp->rover)=max_halfword; old_rover=mp->rover;
4254 while ( p!=old_rover ) {
4255 @<Sort |p| into the list starting at |rover|
4256 and advance |p| to |rlink(p)|@>;
4259 while ( rlink(p)!=max_halfword ) {
4260 llink(rlink(p))=p; p=rlink(p);
4262 rlink(p)=mp->rover; llink(mp->rover)=p;
4265 @ The following |while| loop is guaranteed to
4266 terminate, since the list that starts at
4267 |rover| ends with |max_halfword| during the sorting procedure.
4270 if ( p<mp->rover ) {
4271 q=p; p=rlink(q); rlink(q)=mp->rover; mp->rover=q;
4274 while ( rlink(q)<p ) q=rlink(q);
4275 r=rlink(p); rlink(p)=rlink(q); rlink(q)=p; p=r;
4278 @* \[11] Memory layout.
4279 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4280 more efficient than dynamic allocation when we can get away with it. For
4281 example, locations |0| to |1| are always used to store a
4282 two-word dummy token whose second word is zero.
4283 The following macro definitions accomplish the static allocation by giving
4284 symbolic names to the fixed positions. Static variable-size nodes appear
4285 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4286 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4288 @d null_dash (2) /* the first two words are reserved for a null value */
4289 @d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4290 @d zero_val (dep_head+2) /* two words for a permanently zero value */
4291 @d temp_val (zero_val+2) /* two words for a temporary value node */
4292 @d end_attr temp_val /* we use |end_attr+2| only */
4293 @d inf_val (end_attr+2) /* and |inf_val+1| only */
4294 @d test_pen (inf_val+2)
4295 /* nine words for a pen used when testing the turning number */
4296 @d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
4297 @d lo_mem_stat_max (bad_vardef+1) /* largest statically
4298 allocated word in the variable-size |mem| */
4300 @d sentinel mp->mem_top /* end of sorted lists */
4301 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4302 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4303 @d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4304 @d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4305 the one-word |mem| */
4307 @ The following code gets the dynamic part of |mem| off to a good start,
4308 when \MP\ is initializing itself the slow way.
4310 @<Initialize table entries (done by \.{INIMP} only)@>=
4311 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4312 link(mp->rover)=empty_flag;
4313 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4314 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
4315 mp->lo_mem_max=mp->rover+1000;
4316 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4317 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4318 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4320 mp->avail=null; mp->mem_end=mp->mem_top;
4321 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4322 mp->var_used=lo_mem_stat_max+1;
4323 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4324 @<Initialize a pen at |test_pen| so that it fits in nine words@>;
4326 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4327 nodes that starts at a given position, until coming to |sentinel| or a
4328 pointer that is not in the one-word region. Another procedure,
4329 |flush_node_list|, frees an entire linked list of one-word and two-word
4330 nodes, until coming to a |null| pointer.
4334 void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4335 pointer q,r; /* list traversers */
4336 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4341 if ( r<mp->hi_mem_min ) break;
4342 } while (r!=sentinel);
4343 /* now |q| is the last node on the list */
4344 link(q)=mp->avail; mp->avail=p;
4348 void mp_flush_node_list (MP mp,pointer p) {
4349 pointer q; /* the node being recycled */
4352 if ( q<mp->hi_mem_min )
4353 mp_free_node(mp, q,2);
4359 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4360 For example, some pointers might be wrong, or some ``dead'' nodes might not
4361 have been freed when the last reference to them disappeared. Procedures
4362 |check_mem| and |search_mem| are available to help diagnose such
4363 problems. These procedures make use of two arrays called |free| and
4364 |was_free| that are present only if \MP's debugging routines have
4365 been included. (You may want to decrease the size of |mem| while you
4369 Because |boolean|s are typedef-d as ints, it is better to use
4370 unsigned chars here.
4373 unsigned char *free; /* free cells */
4374 unsigned char *was_free; /* previously free cells */
4375 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4376 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4377 boolean panicking; /* do we want to check memory constantly? */
4379 @ @<Allocate or initialize ...@>=
4380 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4381 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4383 @ @<Dealloc variables@>=
4385 xfree(mp->was_free);
4387 @ @<Allocate or ...@>=
4388 mp->was_mem_end=0; /* indicate that everything was previously free */
4389 mp->was_lo_max=0; mp->was_hi_min=mp->mem_max;
4390 mp->panicking=false;
4392 @ @<Declare |mp_reallocate| functions@>=
4393 void mp_reallocate_memory(MP mp, int l) ;
4396 void mp_reallocate_memory(MP mp, int l) {
4397 XREALLOC(mp->free, l, unsigned char);
4398 XREALLOC(mp->was_free, l, unsigned char);
4400 int newarea = l-mp->mem_max;
4401 XREALLOC(mp->mem, l, memory_word);
4402 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4404 XREALLOC(mp->mem, l, memory_word);
4405 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4408 if (mp->ini_version)
4414 @ Procedure |check_mem| makes sure that the available space lists of
4415 |mem| are well formed, and it optionally prints out all locations
4416 that are reserved now but were free the last time this procedure was called.
4419 void mp_check_mem (MP mp,boolean print_locs ) {
4420 pointer p,q,r; /* current locations of interest in |mem| */
4421 boolean clobbered; /* is something amiss? */
4422 for (p=0;p<=mp->lo_mem_max;p++) {
4423 mp->free[p]=false; /* you can probably do this faster */
4425 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4426 mp->free[p]=false; /* ditto */
4428 @<Check single-word |avail| list@>;
4429 @<Check variable-size |avail| list@>;
4430 @<Check flags of unavailable nodes@>;
4431 @<Check the list of linear dependencies@>;
4433 @<Print newly busy locations@>;
4435 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4436 mp->was_mem_end=mp->mem_end;
4437 mp->was_lo_max=mp->lo_mem_max;
4438 mp->was_hi_min=mp->hi_mem_min;
4441 @ @<Check single-word...@>=
4442 p=mp->avail; q=null; clobbered=false;
4444 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4445 else if ( mp->free[p] ) clobbered=true;
4447 mp_print_nl(mp, "AVAIL list clobbered at ");
4448 @.AVAIL list clobbered...@>
4449 mp_print_int(mp, q); break;
4451 mp->free[p]=true; q=p; p=link(q);
4454 @ @<Check variable-size...@>=
4455 p=mp->rover; q=null; clobbered=false;
4457 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4458 else if ( (rlink(p)>=mp->lo_mem_max)||(rlink(p)<0) ) clobbered=true;
4459 else if ( !(is_empty(p))||(node_size(p)<2)||
4460 (p+node_size(p)>mp->lo_mem_max)|| (llink(rlink(p))!=p) ) clobbered=true;
4462 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4463 @.Double-AVAIL list clobbered...@>
4464 mp_print_int(mp, q); break;
4466 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4467 if ( mp->free[q] ) {
4468 mp_print_nl(mp, "Doubly free location at ");
4469 @.Doubly free location...@>
4470 mp_print_int(mp, q); break;
4475 } while (p!=mp->rover)
4478 @ @<Check flags...@>=
4480 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4481 if ( is_empty(p) ) {
4482 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4485 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
4486 while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
4489 @ @<Print newly busy...@>=
4491 @<Do intialization required before printing new busy locations@>;
4492 mp_print_nl(mp, "New busy locs:");
4494 for (p=0;p<= mp->lo_mem_max;p++ ) {
4495 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4496 @<Indicate that |p| is a new busy location@>;
4499 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4500 if ( ! mp->free[p] &&
4501 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4502 @<Indicate that |p| is a new busy location@>;
4505 @<Finish printing new busy locations@>;
4508 @ There might be many new busy locations so we are careful to print contiguous
4509 blocks compactly. During this operation |q| is the last new busy location and
4510 |r| is the start of the block containing |q|.
4512 @<Indicate that |p| is a new busy location@>=
4516 mp_print(mp, ".."); mp_print_int(mp, q);
4518 mp_print_char(mp, ' '); mp_print_int(mp, p);
4524 @ @<Do intialization required before printing new busy locations@>=
4525 q=mp->mem_max; r=mp->mem_max
4527 @ @<Finish printing new busy locations@>=
4529 mp_print(mp, ".."); mp_print_int(mp, q);
4532 @ The |search_mem| procedure attempts to answer the question ``Who points
4533 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4534 that might not be of type |two_halves|. Strictly speaking, this is
4535 undefined, and it can lead to ``false drops'' (words that seem to
4536 point to |p| purely by coincidence). But for debugging purposes, we want
4537 to rule out the places that do {\sl not\/} point to |p|, so a few false
4538 drops are tolerable.
4541 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4542 integer q; /* current position being searched */
4543 for (q=0;q<=mp->lo_mem_max;q++) {
4545 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4548 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4551 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4553 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4556 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4559 @<Search |eqtb| for equivalents equal to |p|@>;
4562 @* \[12] The command codes.
4563 Before we can go much further, we need to define symbolic names for the internal
4564 code numbers that represent the various commands obeyed by \MP. These codes
4565 are somewhat arbitrary, but not completely so. For example,
4566 some codes have been made adjacent so that |case| statements in the
4567 program need not consider cases that are widely spaced, or so that |case|
4568 statements can be replaced by |if| statements. A command can begin an
4569 expression if and only if its code lies between |min_primary_command| and
4570 |max_primary_command|, inclusive. The first token of a statement that doesn't
4571 begin with an expression has a command code between |min_command| and
4572 |max_statement_command|, inclusive. Anything less than |min_command| is
4573 eliminated during macro expansions, and anything no more than |max_pre_command|
4574 is eliminated when expanding \TeX\ material. Ranges such as
4575 |min_secondary_command..max_secondary_command| are used when parsing
4576 expressions, but the relative ordering within such a range is generally not
4579 The ordering of the highest-numbered commands
4580 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4581 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4582 for the smallest two commands. The ordering is also important in the ranges
4583 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4585 At any rate, here is the list, for future reference.
4587 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4588 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4589 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4590 @d max_pre_command mpx_break
4591 @d if_test 4 /* conditional text (\&{if}) */
4592 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
4593 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4594 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4595 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4596 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4597 @d relax 10 /* do nothing (\.{\char`\\}) */
4598 @d scan_tokens 11 /* put a string into the input buffer */
4599 @d expand_after 12 /* look ahead one token */
4600 @d defined_macro 13 /* a macro defined by the user */
4601 @d min_command (defined_macro+1)
4602 @d save_command 14 /* save a list of tokens (\&{save}) */
4603 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4604 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4605 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4606 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4607 @d ship_out_command 19 /* output a character (\&{shipout}) */
4608 @d add_to_command 20 /* add to edges (\&{addto}) */
4609 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4610 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4611 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4612 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4613 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4614 @d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
4615 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4616 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4617 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4618 @d special_command 30 /* output special info (\&{special})
4619 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4620 @d write_command 31 /* write text to a file (\&{write}) */
4621 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
4622 @d max_statement_command type_name
4623 @d min_primary_command type_name
4624 @d left_delimiter 33 /* the left delimiter of a matching pair */
4625 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4626 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4627 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4628 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4629 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4630 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4631 @d capsule_token 40 /* a value that has been put into a token list */
4632 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4633 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4634 @d min_suffix_token internal_quantity
4635 @d tag_token 43 /* a symbolic token without a primitive meaning */
4636 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4637 @d max_suffix_token numeric_token
4638 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4639 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4640 @d min_tertiary_command plus_or_minus
4641 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4642 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4643 @d max_tertiary_command tertiary_binary
4644 @d left_brace 48 /* the operator `\.{\char`\{}' */
4645 @d min_expression_command left_brace
4646 @d path_join 49 /* the operator `\.{..}' */
4647 @d ampersand 50 /* the operator `\.\&' */
4648 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4649 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4650 @d equals 53 /* the operator `\.=' */
4651 @d max_expression_command equals
4652 @d and_command 54 /* the operator `\&{and}' */
4653 @d min_secondary_command and_command
4654 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4655 @d slash 56 /* the operator `\./' */
4656 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4657 @d max_secondary_command secondary_binary
4658 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4659 @d controls 59 /* specify control points explicitly (\&{controls}) */
4660 @d tension 60 /* specify tension between knots (\&{tension}) */
4661 @d at_least 61 /* bounded tension value (\&{atleast}) */
4662 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4663 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4664 @d right_delimiter 64 /* the right delimiter of a matching pair */
4665 @d left_bracket 65 /* the operator `\.[' */
4666 @d right_bracket 66 /* the operator `\.]' */
4667 @d right_brace 67 /* the operator `\.{\char`\}}' */
4668 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4670 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4671 @d of_token 70 /* the operator `\&{of}' */
4672 @d to_token 71 /* the operator `\&{to}' */
4673 @d step_token 72 /* the operator `\&{step}' */
4674 @d until_token 73 /* the operator `\&{until}' */
4675 @d within_token 74 /* the operator `\&{within}' */
4676 @d lig_kern_token 75
4677 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
4678 @d assignment 76 /* the operator `\.{:=}' */
4679 @d skip_to 77 /* the operation `\&{skipto}' */
4680 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4681 @d double_colon 79 /* the operator `\.{::}' */
4682 @d colon 80 /* the operator `\.:' */
4684 @d comma 81 /* the operator `\.,', must be |colon+1| */
4685 @d end_of_statement (mp->cur_cmd>comma)
4686 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4687 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4688 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4689 @d max_command_code stop
4690 @d outer_tag (max_command_code+1) /* protection code added to command code */
4693 typedef int command_code;
4695 @ Variables and capsules in \MP\ have a variety of ``types,''
4696 distinguished by the code numbers defined here. These numbers are also
4697 not completely arbitrary. Things that get expanded must have types
4698 |>mp_independent|; a type remaining after expansion is numeric if and only if
4699 its code number is at least |numeric_type|; objects containing numeric
4700 parts must have types between |transform_type| and |pair_type|;
4701 all other types must be smaller than |transform_type|; and among the types
4702 that are not unknown or vacuous, the smallest two must be |boolean_type|
4703 and |string_type| in that order.
4705 @d undefined 0 /* no type has been declared */
4706 @d unknown_tag 1 /* this constant is added to certain type codes below */
4707 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4708 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4711 enum mp_variable_type {
4712 mp_vacuous=1, /* no expression was present */
4713 mp_boolean_type, /* \&{boolean} with a known value */
4715 mp_string_type, /* \&{string} with a known value */
4717 mp_pen_type, /* \&{pen} with a known value */
4719 mp_path_type, /* \&{path} with a known value */
4721 mp_picture_type, /* \&{picture} with a known value */
4723 mp_transform_type, /* \&{transform} variable or capsule */
4724 mp_color_type, /* \&{color} variable or capsule */
4725 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4726 mp_pair_type, /* \&{pair} variable or capsule */
4727 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4728 mp_known, /* \&{numeric} with a known value */
4729 mp_dependent, /* a linear combination with |fraction| coefficients */
4730 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4731 mp_independent, /* \&{numeric} with unknown value */
4732 mp_token_list, /* variable name or suffix argument or text argument */
4733 mp_structured, /* variable with subscripts and attributes */
4734 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4735 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4739 void mp_print_type (MP mp,small_number t) ;
4741 @ @<Basic printing procedures@>=
4742 void mp_print_type (MP mp,small_number t) {
4744 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4745 case mp_boolean_type:mp_print(mp, "boolean"); break;
4746 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4747 case mp_string_type:mp_print(mp, "string"); break;
4748 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4749 case mp_pen_type:mp_print(mp, "pen"); break;
4750 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4751 case mp_path_type:mp_print(mp, "path"); break;
4752 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4753 case mp_picture_type:mp_print(mp, "picture"); break;
4754 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4755 case mp_transform_type:mp_print(mp, "transform"); break;
4756 case mp_color_type:mp_print(mp, "color"); break;
4757 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4758 case mp_pair_type:mp_print(mp, "pair"); break;
4759 case mp_known:mp_print(mp, "known numeric"); break;
4760 case mp_dependent:mp_print(mp, "dependent"); break;
4761 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4762 case mp_numeric_type:mp_print(mp, "numeric"); break;
4763 case mp_independent:mp_print(mp, "independent"); break;
4764 case mp_token_list:mp_print(mp, "token list"); break;
4765 case mp_structured:mp_print(mp, "mp_structured"); break;
4766 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4767 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4768 default: mp_print(mp, "undefined"); break;
4772 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4773 as well as a |type|. The possibilities for |name_type| are defined
4774 here; they will be explained in more detail later.
4778 mp_root=0, /* |name_type| at the top level of a variable */
4779 mp_saved_root, /* same, when the variable has been saved */
4780 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4781 mp_subscr, /* |name_type| in a subscript node */
4782 mp_attr, /* |name_type| in an attribute node */
4783 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4784 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4785 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4786 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4787 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4788 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4789 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4790 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4791 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4792 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4793 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4794 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4795 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4796 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4797 mp_capsule, /* |name_type| in stashed-away subexpressions */
4798 mp_token /* |name_type| in a numeric token or string token */
4801 @ Primitive operations that produce values have a secondary identification
4802 code in addition to their command code; it's something like genera and species.
4803 For example, `\.*' has the command code |primary_binary|, and its
4804 secondary identification is |times|. The secondary codes start at 30 so that
4805 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4806 are used as operators as well as type identifications. The relative values
4807 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4808 and |filled_op..bounded_op|. The restrictions are that
4809 |and_op-false_code=or_op-true_code|, that the ordering of
4810 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4811 and the ordering of |filled_op..bounded_op| must match that of the code
4812 values they test for.
4814 @d true_code 30 /* operation code for \.{true} */
4815 @d false_code 31 /* operation code for \.{false} */
4816 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4817 @d null_pen_code 33 /* operation code for \.{nullpen} */
4818 @d job_name_op 34 /* operation code for \.{jobname} */
4819 @d read_string_op 35 /* operation code for \.{readstring} */
4820 @d pen_circle 36 /* operation code for \.{pencircle} */
4821 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4822 @d read_from_op 38 /* operation code for \.{readfrom} */
4823 @d close_from_op 39 /* operation code for \.{closefrom} */
4824 @d odd_op 40 /* operation code for \.{odd} */
4825 @d known_op 41 /* operation code for \.{known} */
4826 @d unknown_op 42 /* operation code for \.{unknown} */
4827 @d not_op 43 /* operation code for \.{not} */
4828 @d decimal 44 /* operation code for \.{decimal} */
4829 @d reverse 45 /* operation code for \.{reverse} */
4830 @d make_path_op 46 /* operation code for \.{makepath} */
4831 @d make_pen_op 47 /* operation code for \.{makepen} */
4832 @d oct_op 48 /* operation code for \.{oct} */
4833 @d hex_op 49 /* operation code for \.{hex} */
4834 @d ASCII_op 50 /* operation code for \.{ASCII} */
4835 @d char_op 51 /* operation code for \.{char} */
4836 @d length_op 52 /* operation code for \.{length} */
4837 @d turning_op 53 /* operation code for \.{turningnumber} */
4838 @d color_model_part 54 /* operation code for \.{colormodel} */
4839 @d x_part 55 /* operation code for \.{xpart} */
4840 @d y_part 56 /* operation code for \.{ypart} */
4841 @d xx_part 57 /* operation code for \.{xxpart} */
4842 @d xy_part 58 /* operation code for \.{xypart} */
4843 @d yx_part 59 /* operation code for \.{yxpart} */
4844 @d yy_part 60 /* operation code for \.{yypart} */
4845 @d red_part 61 /* operation code for \.{redpart} */
4846 @d green_part 62 /* operation code for \.{greenpart} */
4847 @d blue_part 63 /* operation code for \.{bluepart} */
4848 @d cyan_part 64 /* operation code for \.{cyanpart} */
4849 @d magenta_part 65 /* operation code for \.{magentapart} */
4850 @d yellow_part 66 /* operation code for \.{yellowpart} */
4851 @d black_part 67 /* operation code for \.{blackpart} */
4852 @d grey_part 68 /* operation code for \.{greypart} */
4853 @d font_part 69 /* operation code for \.{fontpart} */
4854 @d text_part 70 /* operation code for \.{textpart} */
4855 @d path_part 71 /* operation code for \.{pathpart} */
4856 @d pen_part 72 /* operation code for \.{penpart} */
4857 @d dash_part 73 /* operation code for \.{dashpart} */
4858 @d sqrt_op 74 /* operation code for \.{sqrt} */
4859 @d m_exp_op 75 /* operation code for \.{mexp} */
4860 @d m_log_op 76 /* operation code for \.{mlog} */
4861 @d sin_d_op 77 /* operation code for \.{sind} */
4862 @d cos_d_op 78 /* operation code for \.{cosd} */
4863 @d floor_op 79 /* operation code for \.{floor} */
4864 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4865 @d char_exists_op 81 /* operation code for \.{charexists} */
4866 @d font_size 82 /* operation code for \.{fontsize} */
4867 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4868 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4869 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4870 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4871 @d arc_length 87 /* operation code for \.{arclength} */
4872 @d angle_op 88 /* operation code for \.{angle} */
4873 @d cycle_op 89 /* operation code for \.{cycle} */
4874 @d filled_op 90 /* operation code for \.{filled} */
4875 @d stroked_op 91 /* operation code for \.{stroked} */
4876 @d textual_op 92 /* operation code for \.{textual} */
4877 @d clipped_op 93 /* operation code for \.{clipped} */
4878 @d bounded_op 94 /* operation code for \.{bounded} */
4879 @d plus 95 /* operation code for \.+ */
4880 @d minus 96 /* operation code for \.- */
4881 @d times 97 /* operation code for \.* */
4882 @d over 98 /* operation code for \./ */
4883 @d pythag_add 99 /* operation code for \.{++} */
4884 @d pythag_sub 100 /* operation code for \.{+-+} */
4885 @d or_op 101 /* operation code for \.{or} */
4886 @d and_op 102 /* operation code for \.{and} */
4887 @d less_than 103 /* operation code for \.< */
4888 @d less_or_equal 104 /* operation code for \.{<=} */
4889 @d greater_than 105 /* operation code for \.> */
4890 @d greater_or_equal 106 /* operation code for \.{>=} */
4891 @d equal_to 107 /* operation code for \.= */
4892 @d unequal_to 108 /* operation code for \.{<>} */
4893 @d concatenate 109 /* operation code for \.\& */
4894 @d rotated_by 110 /* operation code for \.{rotated} */
4895 @d slanted_by 111 /* operation code for \.{slanted} */
4896 @d scaled_by 112 /* operation code for \.{scaled} */
4897 @d shifted_by 113 /* operation code for \.{shifted} */
4898 @d transformed_by 114 /* operation code for \.{transformed} */
4899 @d x_scaled 115 /* operation code for \.{xscaled} */
4900 @d y_scaled 116 /* operation code for \.{yscaled} */
4901 @d z_scaled 117 /* operation code for \.{zscaled} */
4902 @d in_font 118 /* operation code for \.{infont} */
4903 @d intersect 119 /* operation code for \.{intersectiontimes} */
4904 @d double_dot 120 /* operation code for improper \.{..} */
4905 @d substring_of 121 /* operation code for \.{substring} */
4906 @d min_of substring_of
4907 @d subpath_of 122 /* operation code for \.{subpath} */
4908 @d direction_time_of 123 /* operation code for \.{directiontime} */
4909 @d point_of 124 /* operation code for \.{point} */
4910 @d precontrol_of 125 /* operation code for \.{precontrol} */
4911 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4912 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4913 @d arc_time_of 128 /* operation code for \.{arctime} */
4914 @d mp_version 129 /* operation code for \.{mpversion} */
4915 @d envelope_of 130 /* operation code for \.{envelope} */
4917 @c void mp_print_op (MP mp,quarterword c) {
4918 if (c<=mp_numeric_type ) {
4919 mp_print_type(mp, c);
4922 case true_code:mp_print(mp, "true"); break;
4923 case false_code:mp_print(mp, "false"); break;
4924 case null_picture_code:mp_print(mp, "nullpicture"); break;
4925 case null_pen_code:mp_print(mp, "nullpen"); break;
4926 case job_name_op:mp_print(mp, "jobname"); break;
4927 case read_string_op:mp_print(mp, "readstring"); break;
4928 case pen_circle:mp_print(mp, "pencircle"); break;
4929 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4930 case read_from_op:mp_print(mp, "readfrom"); break;
4931 case close_from_op:mp_print(mp, "closefrom"); break;
4932 case odd_op:mp_print(mp, "odd"); break;
4933 case known_op:mp_print(mp, "known"); break;
4934 case unknown_op:mp_print(mp, "unknown"); break;
4935 case not_op:mp_print(mp, "not"); break;
4936 case decimal:mp_print(mp, "decimal"); break;
4937 case reverse:mp_print(mp, "reverse"); break;
4938 case make_path_op:mp_print(mp, "makepath"); break;
4939 case make_pen_op:mp_print(mp, "makepen"); break;
4940 case oct_op:mp_print(mp, "oct"); break;
4941 case hex_op:mp_print(mp, "hex"); break;
4942 case ASCII_op:mp_print(mp, "ASCII"); break;
4943 case char_op:mp_print(mp, "char"); break;
4944 case length_op:mp_print(mp, "length"); break;
4945 case turning_op:mp_print(mp, "turningnumber"); break;
4946 case x_part:mp_print(mp, "xpart"); break;
4947 case y_part:mp_print(mp, "ypart"); break;
4948 case xx_part:mp_print(mp, "xxpart"); break;
4949 case xy_part:mp_print(mp, "xypart"); break;
4950 case yx_part:mp_print(mp, "yxpart"); break;
4951 case yy_part:mp_print(mp, "yypart"); break;
4952 case red_part:mp_print(mp, "redpart"); break;
4953 case green_part:mp_print(mp, "greenpart"); break;
4954 case blue_part:mp_print(mp, "bluepart"); break;
4955 case cyan_part:mp_print(mp, "cyanpart"); break;
4956 case magenta_part:mp_print(mp, "magentapart"); break;
4957 case yellow_part:mp_print(mp, "yellowpart"); break;
4958 case black_part:mp_print(mp, "blackpart"); break;
4959 case grey_part:mp_print(mp, "greypart"); break;
4960 case color_model_part:mp_print(mp, "colormodel"); break;
4961 case font_part:mp_print(mp, "fontpart"); break;
4962 case text_part:mp_print(mp, "textpart"); break;
4963 case path_part:mp_print(mp, "pathpart"); break;
4964 case pen_part:mp_print(mp, "penpart"); break;
4965 case dash_part:mp_print(mp, "dashpart"); break;
4966 case sqrt_op:mp_print(mp, "sqrt"); break;
4967 case m_exp_op:mp_print(mp, "mexp"); break;
4968 case m_log_op:mp_print(mp, "mlog"); break;
4969 case sin_d_op:mp_print(mp, "sind"); break;
4970 case cos_d_op:mp_print(mp, "cosd"); break;
4971 case floor_op:mp_print(mp, "floor"); break;
4972 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4973 case char_exists_op:mp_print(mp, "charexists"); break;
4974 case font_size:mp_print(mp, "fontsize"); break;
4975 case ll_corner_op:mp_print(mp, "llcorner"); break;
4976 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4977 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4978 case ur_corner_op:mp_print(mp, "urcorner"); break;
4979 case arc_length:mp_print(mp, "arclength"); break;
4980 case angle_op:mp_print(mp, "angle"); break;
4981 case cycle_op:mp_print(mp, "cycle"); break;
4982 case filled_op:mp_print(mp, "filled"); break;
4983 case stroked_op:mp_print(mp, "stroked"); break;
4984 case textual_op:mp_print(mp, "textual"); break;
4985 case clipped_op:mp_print(mp, "clipped"); break;
4986 case bounded_op:mp_print(mp, "bounded"); break;
4987 case plus:mp_print_char(mp, '+'); break;
4988 case minus:mp_print_char(mp, '-'); break;
4989 case times:mp_print_char(mp, '*'); break;
4990 case over:mp_print_char(mp, '/'); break;
4991 case pythag_add:mp_print(mp, "++"); break;
4992 case pythag_sub:mp_print(mp, "+-+"); break;
4993 case or_op:mp_print(mp, "or"); break;
4994 case and_op:mp_print(mp, "and"); break;
4995 case less_than:mp_print_char(mp, '<'); break;
4996 case less_or_equal:mp_print(mp, "<="); break;
4997 case greater_than:mp_print_char(mp, '>'); break;
4998 case greater_or_equal:mp_print(mp, ">="); break;
4999 case equal_to:mp_print_char(mp, '='); break;
5000 case unequal_to:mp_print(mp, "<>"); break;
5001 case concatenate:mp_print(mp, "&"); break;
5002 case rotated_by:mp_print(mp, "rotated"); break;
5003 case slanted_by:mp_print(mp, "slanted"); break;
5004 case scaled_by:mp_print(mp, "scaled"); break;
5005 case shifted_by:mp_print(mp, "shifted"); break;
5006 case transformed_by:mp_print(mp, "transformed"); break;
5007 case x_scaled:mp_print(mp, "xscaled"); break;
5008 case y_scaled:mp_print(mp, "yscaled"); break;
5009 case z_scaled:mp_print(mp, "zscaled"); break;
5010 case in_font:mp_print(mp, "infont"); break;
5011 case intersect:mp_print(mp, "intersectiontimes"); break;
5012 case substring_of:mp_print(mp, "substring"); break;
5013 case subpath_of:mp_print(mp, "subpath"); break;
5014 case direction_time_of:mp_print(mp, "directiontime"); break;
5015 case point_of:mp_print(mp, "point"); break;
5016 case precontrol_of:mp_print(mp, "precontrol"); break;
5017 case postcontrol_of:mp_print(mp, "postcontrol"); break;
5018 case pen_offset_of:mp_print(mp, "penoffset"); break;
5019 case arc_time_of:mp_print(mp, "arctime"); break;
5020 case mp_version:mp_print(mp, "mpversion"); break;
5021 case envelope_of:mp_print(mp, "envelope"); break;
5022 default: mp_print(mp, ".."); break;
5027 @ \MP\ also has a bunch of internal parameters that a user might want to
5028 fuss with. Every such parameter has an identifying code number, defined here.
5031 enum mp_given_internal {
5032 mp_tracing_titles=1, /* show titles online when they appear */
5033 mp_tracing_equations, /* show each variable when it becomes known */
5034 mp_tracing_capsules, /* show capsules too */
5035 mp_tracing_choices, /* show the control points chosen for paths */
5036 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
5037 mp_tracing_commands, /* show commands and operations before they are performed */
5038 mp_tracing_restores, /* show when a variable or internal is restored */
5039 mp_tracing_macros, /* show macros before they are expanded */
5040 mp_tracing_output, /* show digitized edges as they are output */
5041 mp_tracing_stats, /* show memory usage at end of job */
5042 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
5043 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
5044 mp_year, /* the current year (e.g., 1984) */
5045 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
5046 mp_day, /* the current day of the month */
5047 mp_time, /* the number of minutes past midnight when this job started */
5048 mp_char_code, /* the number of the next character to be output */
5049 mp_char_ext, /* the extension code of the next character to be output */
5050 mp_char_wd, /* the width of the next character to be output */
5051 mp_char_ht, /* the height of the next character to be output */
5052 mp_char_dp, /* the depth of the next character to be output */
5053 mp_char_ic, /* the italic correction of the next character to be output */
5054 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
5055 mp_pausing, /* positive to display lines on the terminal before they are read */
5056 mp_showstopping, /* positive to stop after each \&{show} command */
5057 mp_fontmaking, /* positive if font metric output is to be produced */
5058 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
5059 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
5060 mp_miterlimit, /* controls miter length as in \ps */
5061 mp_warning_check, /* controls error message when variable value is large */
5062 mp_boundary_char, /* the right boundary character for ligatures */
5063 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
5064 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
5065 mp_default_color_model, /* the default color model for unspecified items */
5066 mp_restore_clip_color,
5067 mp_procset, /* wether or not create PostScript command shortcuts */
5068 mp_gtroffmode /* whether the user specified |-troff| on the command line */
5073 @d max_given_internal mp_gtroffmode
5076 scaled *internal; /* the values of internal quantities */
5077 char **int_name; /* their names */
5078 int int_ptr; /* the maximum internal quantity defined so far */
5079 int max_internal; /* current maximum number of internal quantities */
5081 @ @<Option variables@>=
5084 @ @<Allocate or initialize ...@>=
5085 mp->max_internal=2*max_given_internal;
5086 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
5087 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
5088 mp->troff_mode=(opt->troff_mode>0 ? true : false);
5090 @ @<Exported function ...@>=
5091 int mp_troff_mode(MP mp);
5094 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5096 @ @<Set initial ...@>=
5097 for (k=0;k<= mp->max_internal; k++ ) {
5099 mp->int_name[k]=NULL;
5101 mp->int_ptr=max_given_internal;
5103 @ The symbolic names for internal quantities are put into \MP's hash table
5104 by using a routine called |primitive|, which will be defined later. Let us
5105 enter them now, so that we don't have to list all those names again
5108 @<Put each of \MP's primitives into the hash table@>=
5109 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5110 @:tracingtitles_}{\&{tracingtitles} primitive@>
5111 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5112 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5113 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5114 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5115 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5116 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5117 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5118 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5119 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5120 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5121 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5122 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5123 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5124 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5125 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5126 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5127 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5128 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5129 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5130 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5131 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5132 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5133 mp_primitive(mp, "year",internal_quantity,mp_year);
5134 @:mp_year_}{\&{year} primitive@>
5135 mp_primitive(mp, "month",internal_quantity,mp_month);
5136 @:mp_month_}{\&{month} primitive@>
5137 mp_primitive(mp, "day",internal_quantity,mp_day);
5138 @:mp_day_}{\&{day} primitive@>
5139 mp_primitive(mp, "time",internal_quantity,mp_time);
5140 @:time_}{\&{time} primitive@>
5141 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5142 @:mp_char_code_}{\&{charcode} primitive@>
5143 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5144 @:mp_char_ext_}{\&{charext} primitive@>
5145 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5146 @:mp_char_wd_}{\&{charwd} primitive@>
5147 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5148 @:mp_char_ht_}{\&{charht} primitive@>
5149 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5150 @:mp_char_dp_}{\&{chardp} primitive@>
5151 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5152 @:mp_char_ic_}{\&{charic} primitive@>
5153 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5154 @:mp_design_size_}{\&{designsize} primitive@>
5155 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5156 @:mp_pausing_}{\&{pausing} primitive@>
5157 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5158 @:mp_showstopping_}{\&{showstopping} primitive@>
5159 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5160 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5161 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5162 @:mp_linejoin_}{\&{linejoin} primitive@>
5163 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5164 @:mp_linecap_}{\&{linecap} primitive@>
5165 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5166 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5167 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5168 @:mp_warning_check_}{\&{warningcheck} primitive@>
5169 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5170 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5171 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5172 @:mp_prologues_}{\&{prologues} primitive@>
5173 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5174 @:mp_true_corners_}{\&{truecorners} primitive@>
5175 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5176 @:mp_procset_}{\&{mpprocset} primitive@>
5177 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5178 @:troffmode_}{\&{troffmode} primitive@>
5179 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5180 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5181 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5182 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5184 @ Colors can be specified in four color models. In the special
5185 case of |no_model|, MetaPost does not output any color operator to
5186 the postscript output.
5188 Note: these values are passed directly on to |with_option|. This only
5189 works because the other possible values passed to |with_option| are
5190 8 and 10 respectively (from |with_pen| and |with_picture|).
5192 There is a first state, that is only used for |gs_colormodel|. It flags
5193 the fact that there has not been any kind of color specification by
5194 the user so far in the game.
5197 enum mp_color_model {
5202 mp_uninitialized_model=9
5206 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5207 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5208 mp->internal[mp_restore_clip_color]=unity;
5210 @ Well, we do have to list the names one more time, for use in symbolic
5213 @<Initialize table...@>=
5214 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5215 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5216 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5217 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5218 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5219 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5220 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5221 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5222 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5223 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5224 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5225 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5226 mp->int_name[mp_year]=xstrdup("year");
5227 mp->int_name[mp_month]=xstrdup("month");
5228 mp->int_name[mp_day]=xstrdup("day");
5229 mp->int_name[mp_time]=xstrdup("time");
5230 mp->int_name[mp_char_code]=xstrdup("charcode");
5231 mp->int_name[mp_char_ext]=xstrdup("charext");
5232 mp->int_name[mp_char_wd]=xstrdup("charwd");
5233 mp->int_name[mp_char_ht]=xstrdup("charht");
5234 mp->int_name[mp_char_dp]=xstrdup("chardp");
5235 mp->int_name[mp_char_ic]=xstrdup("charic");
5236 mp->int_name[mp_design_size]=xstrdup("designsize");
5237 mp->int_name[mp_pausing]=xstrdup("pausing");
5238 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5239 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5240 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5241 mp->int_name[mp_linecap]=xstrdup("linecap");
5242 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5243 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5244 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5245 mp->int_name[mp_prologues]=xstrdup("prologues");
5246 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5247 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5248 mp->int_name[mp_procset]=xstrdup("mpprocset");
5249 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5250 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5252 @ The following procedure, which is called just before \MP\ initializes its
5253 input and output, establishes the initial values of the date and time.
5254 @^system dependencies@>
5256 Note that the values are |scaled| integers. Hence \MP\ can no longer
5257 be used after the year 32767.
5260 void mp_fix_date_and_time (MP mp) {
5261 time_t aclock = time ((time_t *) 0);
5262 struct tm *tmptr = localtime (&aclock);
5263 mp->internal[mp_time]=
5264 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5265 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5266 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5267 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5271 void mp_fix_date_and_time (MP mp) ;
5273 @ \MP\ is occasionally supposed to print diagnostic information that
5274 goes only into the transcript file, unless |mp_tracing_online| is positive.
5275 Now that we have defined |mp_tracing_online| we can define
5276 two routines that adjust the destination of print commands:
5279 void mp_begin_diagnostic (MP mp) ;
5280 void mp_end_diagnostic (MP mp,boolean blank_line);
5281 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
5283 @ @<Basic printing...@>=
5284 @<Declare a function called |true_line|@>
5285 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5286 mp->old_setting=mp->selector;
5287 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5289 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5293 void mp_end_diagnostic (MP mp,boolean blank_line) {
5294 /* restore proper conditions after tracing */
5295 mp_print_nl(mp, "");
5296 if ( blank_line ) mp_print_ln(mp);
5297 mp->selector=mp->old_setting;
5303 unsigned int old_setting;
5305 @ We will occasionally use |begin_diagnostic| in connection with line-number
5306 printing, as follows. (The parameter |s| is typically |"Path"| or
5307 |"Cycle spec"|, etc.)
5309 @<Basic printing...@>=
5310 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
5311 mp_begin_diagnostic(mp);
5312 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5313 mp_print(mp, " at line ");
5314 mp_print_int(mp, mp_true_line(mp));
5315 mp_print(mp, t); mp_print_char(mp, ':');
5318 @ The 256 |ASCII_code| characters are grouped into classes by means of
5319 the |char_class| table. Individual class numbers have no semantic
5320 or syntactic significance, except in a few instances defined here.
5321 There's also |max_class|, which can be used as a basis for additional
5322 class numbers in nonstandard extensions of \MP.
5324 @d digit_class 0 /* the class number of \.{0123456789} */
5325 @d period_class 1 /* the class number of `\..' */
5326 @d space_class 2 /* the class number of spaces and nonstandard characters */
5327 @d percent_class 3 /* the class number of `\.\%' */
5328 @d string_class 4 /* the class number of `\."' */
5329 @d right_paren_class 8 /* the class number of `\.)' */
5330 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5331 @d letter_class 9 /* letters and the underline character */
5332 @d left_bracket_class 17 /* `\.[' */
5333 @d right_bracket_class 18 /* `\.]' */
5334 @d invalid_class 20 /* bad character in the input */
5335 @d max_class 20 /* the largest class number */
5338 int char_class[256]; /* the class numbers */
5340 @ If changes are made to accommodate non-ASCII character sets, they should
5341 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5342 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5343 @^system dependencies@>
5345 @<Set initial ...@>=
5346 for (k='0';k<='9';k++)
5347 mp->char_class[k]=digit_class;
5348 mp->char_class['.']=period_class;
5349 mp->char_class[' ']=space_class;
5350 mp->char_class['%']=percent_class;
5351 mp->char_class['"']=string_class;
5352 mp->char_class[',']=5;
5353 mp->char_class[';']=6;
5354 mp->char_class['(']=7;
5355 mp->char_class[')']=right_paren_class;
5356 for (k='A';k<= 'Z';k++ )
5357 mp->char_class[k]=letter_class;
5358 for (k='a';k<='z';k++)
5359 mp->char_class[k]=letter_class;
5360 mp->char_class['_']=letter_class;
5361 mp->char_class['<']=10;
5362 mp->char_class['=']=10;
5363 mp->char_class['>']=10;
5364 mp->char_class[':']=10;
5365 mp->char_class['|']=10;
5366 mp->char_class['`']=11;
5367 mp->char_class['\'']=11;
5368 mp->char_class['+']=12;
5369 mp->char_class['-']=12;
5370 mp->char_class['/']=13;
5371 mp->char_class['*']=13;
5372 mp->char_class['\\']=13;
5373 mp->char_class['!']=14;
5374 mp->char_class['?']=14;
5375 mp->char_class['#']=15;
5376 mp->char_class['&']=15;
5377 mp->char_class['@@']=15;
5378 mp->char_class['$']=15;
5379 mp->char_class['^']=16;
5380 mp->char_class['~']=16;
5381 mp->char_class['[']=left_bracket_class;
5382 mp->char_class[']']=right_bracket_class;
5383 mp->char_class['{']=19;
5384 mp->char_class['}']=19;
5386 mp->char_class[k]=invalid_class;
5387 mp->char_class['\t']=space_class;
5388 mp->char_class['\f']=space_class;
5389 for (k=127;k<=255;k++)
5390 mp->char_class[k]=invalid_class;
5392 @* \[13] The hash table.
5393 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5394 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5395 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5396 table, it is never removed.
5398 The actual sequence of characters forming a symbolic token is
5399 stored in the |str_pool| array together with all the other strings. An
5400 auxiliary array |hash| consists of items with two halfword fields per
5401 word. The first of these, called |next(p)|, points to the next identifier
5402 belonging to the same coalesced list as the identifier corresponding to~|p|;
5403 and the other, called |text(p)|, points to the |str_start| entry for
5404 |p|'s identifier. If position~|p| of the hash table is empty, we have
5405 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5406 hash list, we have |next(p)=0|.
5408 An auxiliary pointer variable called |hash_used| is maintained in such a
5409 way that all locations |p>=hash_used| are nonempty. The global variable
5410 |st_count| tells how many symbolic tokens have been defined, if statistics
5413 The first 256 locations of |hash| are reserved for symbols of length one.
5415 There's a parallel array called |eqtb| that contains the current equivalent
5416 values of each symbolic token. The entries of this array consist of
5417 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5418 piece of information that qualifies the |eq_type|).
5420 @d next(A) mp->hash[(A)].lh /* link for coalesced lists */
5421 @d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5422 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5423 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5424 @d hash_base 257 /* hashing actually starts here */
5425 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5428 pointer hash_used; /* allocation pointer for |hash| */
5429 integer st_count; /* total number of known identifiers */
5431 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5432 since they are used in error recovery.
5434 @d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
5435 @d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5436 @d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5437 @d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5438 @d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5439 @d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5440 @d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5441 @d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5442 @d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5443 @d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5444 @d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5445 @d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5446 @d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5447 @d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5448 @d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5449 @d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5450 @d hash_end (hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5453 two_halves *hash; /* the hash table */
5454 two_halves *eqtb; /* the equivalents */
5456 @ @<Allocate or initialize ...@>=
5457 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5458 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5460 @ @<Dealloc variables@>=
5465 next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5466 for (k=2;k<=hash_end;k++) {
5467 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5470 @ @<Initialize table entries...@>=
5471 mp->hash_used=frozen_inaccessible; /* nothing is used */
5473 text(frozen_bad_vardef)=intern("a bad variable");
5474 text(frozen_etex)=intern("etex");
5475 text(frozen_mpx_break)=intern("mpxbreak");
5476 text(frozen_fi)=intern("fi");
5477 text(frozen_end_group)=intern("endgroup");
5478 text(frozen_end_def)=intern("enddef");
5479 text(frozen_end_for)=intern("endfor");
5480 text(frozen_semicolon)=intern(";");
5481 text(frozen_colon)=intern(":");
5482 text(frozen_slash)=intern("/");
5483 text(frozen_left_bracket)=intern("[");
5484 text(frozen_right_delimiter)=intern(")");
5485 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5486 eq_type(frozen_right_delimiter)=right_delimiter;
5488 @ @<Check the ``constant'' values...@>=
5489 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5491 @ Here is the subroutine that searches the hash table for an identifier
5492 that matches a given string of length~|l| appearing in |buffer[j..
5493 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5494 will always be found, and the corresponding hash table address
5498 pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5499 integer h; /* hash code */
5500 pointer p; /* index in |hash| array */
5501 pointer k; /* index in |buffer| array */
5503 @<Treat special case of length 1 and |break|@>;
5505 @<Compute the hash code |h|@>;
5506 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5508 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5511 @<Insert a new symbolic token after |p|, then
5512 make |p| point to it and |break|@>;
5519 @ @<Treat special case of length 1...@>=
5520 p=mp->buffer[j]+1; text(p)=p-1; return p;
5523 @ @<Insert a new symbolic...@>=
5528 mp_overflow(mp, "hash size",mp->hash_size);
5529 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5530 decr(mp->hash_used);
5531 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5532 next(p)=mp->hash_used;
5536 for (k=j;k<=j+l-1;k++) {
5537 append_char(mp->buffer[k]);
5539 text(p)=mp_make_string(mp);
5540 mp->str_ref[text(p)]=max_str_ref;
5546 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5547 should be a prime number. The theory of hashing tells us to expect fewer
5548 than two table probes, on the average, when the search is successful.
5549 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5550 @^Vitter, Jeffrey Scott@>
5552 @<Compute the hash code |h|@>=
5554 for (k=j+1;k<=j+l-1;k++){
5555 h=h+h+mp->buffer[k];
5556 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5559 @ @<Search |eqtb| for equivalents equal to |p|@>=
5560 for (q=1;q<=hash_end;q++) {
5561 if ( equiv(q)==p ) {
5562 mp_print_nl(mp, "EQUIV(");
5563 mp_print_int(mp, q);
5564 mp_print_char(mp, ')');
5568 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5569 table, together with their command code (which will be the |eq_type|)
5570 and an operand (which will be the |equiv|). The |primitive| procedure
5571 does this, in a way that no \MP\ user can. The global value |cur_sym|
5572 contains the new |eqtb| pointer after |primitive| has acted.
5575 void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
5576 pool_pointer k; /* index into |str_pool| */
5577 small_number j; /* index into |buffer| */
5578 small_number l; /* length of the string */
5581 k=mp->str_start[s]; l=str_stop(s)-k;
5582 /* we will move |s| into the (empty) |buffer| */
5583 for (j=0;j<=l-1;j++) {
5584 mp->buffer[j]=mp->str_pool[k+j];
5586 mp->cur_sym=mp_id_lookup(mp, 0,l);
5587 if ( s>=256 ) { /* we don't want to have the string twice */
5588 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5590 eq_type(mp->cur_sym)=c;
5591 equiv(mp->cur_sym)=o;
5595 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5596 by their |eq_type| alone. These primitives are loaded into the hash table
5599 @<Put each of \MP's primitives into the hash table@>=
5600 mp_primitive(mp, "..",path_join,0);
5601 @:.._}{\.{..} primitive@>
5602 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5603 @:[ }{\.{[} primitive@>
5604 mp_primitive(mp, "]",right_bracket,0);
5605 @:] }{\.{]} primitive@>
5606 mp_primitive(mp, "}",right_brace,0);
5607 @:]]}{\.{\char`\}} primitive@>
5608 mp_primitive(mp, "{",left_brace,0);
5609 @:][}{\.{\char`\{} primitive@>
5610 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5611 @:: }{\.{:} primitive@>
5612 mp_primitive(mp, "::",double_colon,0);
5613 @::: }{\.{::} primitive@>
5614 mp_primitive(mp, "||:",bchar_label,0);
5615 @:::: }{\.{\char'174\char'174:} primitive@>
5616 mp_primitive(mp, ":=",assignment,0);
5617 @::=_}{\.{:=} primitive@>
5618 mp_primitive(mp, ",",comma,0);
5619 @:, }{\., primitive@>
5620 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5621 @:; }{\.; primitive@>
5622 mp_primitive(mp, "\\",relax,0);
5623 @:]]\\}{\.{\char`\\} primitive@>
5625 mp_primitive(mp, "addto",add_to_command,0);
5626 @:add_to_}{\&{addto} primitive@>
5627 mp_primitive(mp, "atleast",at_least,0);
5628 @:at_least_}{\&{atleast} primitive@>
5629 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5630 @:begin_group_}{\&{begingroup} primitive@>
5631 mp_primitive(mp, "controls",controls,0);
5632 @:controls_}{\&{controls} primitive@>
5633 mp_primitive(mp, "curl",curl_command,0);
5634 @:curl_}{\&{curl} primitive@>
5635 mp_primitive(mp, "delimiters",delimiters,0);
5636 @:delimiters_}{\&{delimiters} primitive@>
5637 mp_primitive(mp, "endgroup",end_group,0);
5638 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5639 @:endgroup_}{\&{endgroup} primitive@>
5640 mp_primitive(mp, "everyjob",every_job_command,0);
5641 @:every_job_}{\&{everyjob} primitive@>
5642 mp_primitive(mp, "exitif",exit_test,0);
5643 @:exit_if_}{\&{exitif} primitive@>
5644 mp_primitive(mp, "expandafter",expand_after,0);
5645 @:expand_after_}{\&{expandafter} primitive@>
5646 mp_primitive(mp, "interim",interim_command,0);
5647 @:interim_}{\&{interim} primitive@>
5648 mp_primitive(mp, "let",let_command,0);
5649 @:let_}{\&{let} primitive@>
5650 mp_primitive(mp, "newinternal",new_internal,0);
5651 @:new_internal_}{\&{newinternal} primitive@>
5652 mp_primitive(mp, "of",of_token,0);
5653 @:of_}{\&{of} primitive@>
5654 mp_primitive(mp, "randomseed",mp_random_seed,0);
5655 @:mp_random_seed_}{\&{randomseed} primitive@>
5656 mp_primitive(mp, "save",save_command,0);
5657 @:save_}{\&{save} primitive@>
5658 mp_primitive(mp, "scantokens",scan_tokens,0);
5659 @:scan_tokens_}{\&{scantokens} primitive@>
5660 mp_primitive(mp, "shipout",ship_out_command,0);
5661 @:ship_out_}{\&{shipout} primitive@>
5662 mp_primitive(mp, "skipto",skip_to,0);
5663 @:skip_to_}{\&{skipto} primitive@>
5664 mp_primitive(mp, "special",special_command,0);
5665 @:special}{\&{special} primitive@>
5666 mp_primitive(mp, "fontmapfile",special_command,1);
5667 @:fontmapfile}{\&{fontmapfile} primitive@>
5668 mp_primitive(mp, "fontmapline",special_command,2);
5669 @:fontmapline}{\&{fontmapline} primitive@>
5670 mp_primitive(mp, "step",step_token,0);
5671 @:step_}{\&{step} primitive@>
5672 mp_primitive(mp, "str",str_op,0);
5673 @:str_}{\&{str} primitive@>
5674 mp_primitive(mp, "tension",tension,0);
5675 @:tension_}{\&{tension} primitive@>
5676 mp_primitive(mp, "to",to_token,0);
5677 @:to_}{\&{to} primitive@>
5678 mp_primitive(mp, "until",until_token,0);
5679 @:until_}{\&{until} primitive@>
5680 mp_primitive(mp, "within",within_token,0);
5681 @:within_}{\&{within} primitive@>
5682 mp_primitive(mp, "write",write_command,0);
5683 @:write_}{\&{write} primitive@>
5685 @ Each primitive has a corresponding inverse, so that it is possible to
5686 display the cryptic numeric contents of |eqtb| in symbolic form.
5687 Every call of |primitive| in this program is therefore accompanied by some
5688 straightforward code that forms part of the |print_cmd_mod| routine
5691 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5692 case add_to_command:mp_print(mp, "addto"); break;
5693 case assignment:mp_print(mp, ":="); break;
5694 case at_least:mp_print(mp, "atleast"); break;
5695 case bchar_label:mp_print(mp, "||:"); break;
5696 case begin_group:mp_print(mp, "begingroup"); break;
5697 case colon:mp_print(mp, ":"); break;
5698 case comma:mp_print(mp, ","); break;
5699 case controls:mp_print(mp, "controls"); break;
5700 case curl_command:mp_print(mp, "curl"); break;
5701 case delimiters:mp_print(mp, "delimiters"); break;
5702 case double_colon:mp_print(mp, "::"); break;
5703 case end_group:mp_print(mp, "endgroup"); break;
5704 case every_job_command:mp_print(mp, "everyjob"); break;
5705 case exit_test:mp_print(mp, "exitif"); break;
5706 case expand_after:mp_print(mp, "expandafter"); break;
5707 case interim_command:mp_print(mp, "interim"); break;
5708 case left_brace:mp_print(mp, "{"); break;
5709 case left_bracket:mp_print(mp, "["); break;
5710 case let_command:mp_print(mp, "let"); break;
5711 case new_internal:mp_print(mp, "newinternal"); break;
5712 case of_token:mp_print(mp, "of"); break;
5713 case path_join:mp_print(mp, ".."); break;
5714 case mp_random_seed:mp_print(mp, "randomseed"); break;
5715 case relax:mp_print_char(mp, '\\'); break;
5716 case right_brace:mp_print(mp, "}"); break;
5717 case right_bracket:mp_print(mp, "]"); break;
5718 case save_command:mp_print(mp, "save"); break;
5719 case scan_tokens:mp_print(mp, "scantokens"); break;
5720 case semicolon:mp_print(mp, ";"); break;
5721 case ship_out_command:mp_print(mp, "shipout"); break;
5722 case skip_to:mp_print(mp, "skipto"); break;
5723 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5724 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5725 mp_print(mp, "special"); break;
5726 case step_token:mp_print(mp, "step"); break;
5727 case str_op:mp_print(mp, "str"); break;
5728 case tension:mp_print(mp, "tension"); break;
5729 case to_token:mp_print(mp, "to"); break;
5730 case until_token:mp_print(mp, "until"); break;
5731 case within_token:mp_print(mp, "within"); break;
5732 case write_command:mp_print(mp, "write"); break;
5734 @ We will deal with the other primitives later, at some point in the program
5735 where their |eq_type| and |equiv| values are more meaningful. For example,
5736 the primitives for macro definitions will be loaded when we consider the
5737 routines that define macros.
5738 It is easy to find where each particular
5739 primitive was treated by looking in the index at the end; for example, the
5740 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5742 @* \[14] Token lists.
5743 A \MP\ token is either symbolic or numeric or a string, or it denotes
5744 a macro parameter or capsule; so there are five corresponding ways to encode it
5746 internally: (1)~A symbolic token whose hash code is~|p|
5747 is represented by the number |p|, in the |info| field of a single-word
5748 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5749 represented in a two-word node of~|mem|; the |type| field is |known|,
5750 the |name_type| field is |token|, and the |value| field holds~|v|.
5751 The fact that this token appears in a two-word node rather than a
5752 one-word node is, of course, clear from the node address.
5753 (3)~A string token is also represented in a two-word node; the |type|
5754 field is |mp_string_type|, the |name_type| field is |token|, and the
5755 |value| field holds the corresponding |str_number|. (4)~Capsules have
5756 |name_type=capsule|, and their |type| and |value| fields represent
5757 arbitrary values (in ways to be explained later). (5)~Macro parameters
5758 are like symbolic tokens in that they appear in |info| fields of
5759 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5760 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5761 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5762 Actual values of these parameters are kept in a separate stack, as we will
5763 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5764 of course, chosen so that there will be no confusion between symbolic
5765 tokens and parameters of various types.
5768 the `\\{type}' field of a node has nothing to do with ``type'' in a
5769 printer's sense. It's curious that the same word is used in such different ways.
5771 @d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5772 @d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5773 @d token_node_size 2 /* the number of words in a large token node */
5774 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5775 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5776 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5777 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5778 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5780 @<Check the ``constant''...@>=
5781 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5783 @ We have set aside a two word node beginning at |null| so that we can have
5784 |value(null)=0|. We will make use of this coincidence later.
5786 @<Initialize table entries...@>=
5787 link(null)=null; value(null)=0;
5789 @ A numeric token is created by the following trivial routine.
5792 pointer mp_new_num_tok (MP mp,scaled v) {
5793 pointer p; /* the new node */
5794 p=mp_get_node(mp, token_node_size); value(p)=v;
5795 type(p)=mp_known; name_type(p)=mp_token;
5799 @ A token list is a singly linked list of nodes in |mem|, where
5800 each node contains a token and a link. Here's a subroutine that gets rid
5801 of a token list when it is no longer needed.
5803 @c void mp_flush_token_list (MP mp,pointer p) {
5804 pointer q; /* the node being recycled */
5807 if ( q>=mp->hi_mem_min ) {
5811 case mp_vacuous: case mp_boolean_type: case mp_known:
5813 case mp_string_type:
5814 delete_str_ref(value(q));
5816 case unknown_types: case mp_pen_type: case mp_path_type:
5817 case mp_picture_type: case mp_pair_type: case mp_color_type:
5818 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5819 case mp_proto_dependent: case mp_independent:
5820 mp_recycle_value(mp,q);
5822 default: mp_confusion(mp, "token");
5823 @:this can't happen token}{\quad token@>
5825 mp_free_node(mp, q,token_node_size);
5830 @ The procedure |show_token_list|, which prints a symbolic form of
5831 the token list that starts at a given node |p|, illustrates these
5832 conventions. The token list being displayed should not begin with a reference
5833 count. However, the procedure is intended to be fairly robust, so that if the
5834 memory links are awry or if |p| is not really a pointer to a token list,
5835 almost nothing catastrophic can happen.
5837 An additional parameter |q| is also given; this parameter is either null
5838 or it points to a node in the token list where a certain magic computation
5839 takes place that will be explained later. (Basically, |q| is non-null when
5840 we are printing the two-line context information at the time of an error
5841 message; |q| marks the place corresponding to where the second line
5844 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5845 of printing exceeds a given limit~|l|; the length of printing upon entry is
5846 assumed to be a given amount called |null_tally|. (Note that
5847 |show_token_list| sometimes uses itself recursively to print
5848 variable names within a capsule.)
5851 Unusual entries are printed in the form of all-caps tokens
5852 preceded by a space, e.g., `\.{\char`\ BAD}'.
5854 @<Declare the procedure called |show_token_list|@>=
5855 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5856 integer null_tally) ;
5859 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5860 integer null_tally) {
5861 small_number class,c; /* the |char_class| of previous and new tokens */
5862 integer r,v; /* temporary registers */
5863 class=percent_class;
5864 mp->tally=null_tally;
5865 while ( (p!=null) && (mp->tally<l) ) {
5867 @<Do magic computation@>;
5868 @<Display token |p| and set |c| to its class;
5869 but |return| if there are problems@>;
5873 mp_print(mp, " ETC.");
5878 @ @<Display token |p| and set |c| to its class...@>=
5879 c=letter_class; /* the default */
5880 if ( (p<0)||(p>mp->mem_end) ) {
5881 mp_print(mp, " CLOBBERED"); return;
5884 if ( p<mp->hi_mem_min ) {
5885 @<Display two-word token@>;
5888 if ( r>=expr_base ) {
5889 @<Display a parameter token@>;
5893 @<Display a collective subscript@>
5895 mp_print(mp, " IMPOSSIBLE");
5900 if ( (r<0)||(r>mp->max_str_ptr) ) {
5901 mp_print(mp, " NONEXISTENT");
5904 @<Print string |r| as a symbolic token
5905 and set |c| to its class@>;
5911 @ @<Display two-word token@>=
5912 if ( name_type(p)==mp_token ) {
5913 if ( type(p)==mp_known ) {
5914 @<Display a numeric token@>;
5915 } else if ( type(p)!=mp_string_type ) {
5916 mp_print(mp, " BAD");
5919 mp_print_char(mp, '"'); mp_print_str(mp, value(p)); mp_print_char(mp, '"');
5922 } else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
5923 mp_print(mp, " BAD");
5925 mp_print_capsule(mp,p); c=right_paren_class;
5928 @ @<Display a numeric token@>=
5929 if ( class==digit_class )
5930 mp_print_char(mp, ' ');
5933 if ( class==left_bracket_class )
5934 mp_print_char(mp, ' ');
5935 mp_print_char(mp, '['); mp_print_scaled(mp, v); mp_print_char(mp, ']');
5936 c=right_bracket_class;
5938 mp_print_scaled(mp, v); c=digit_class;
5942 @ Strictly speaking, a genuine token will never have |info(p)=0|.
5943 But we will see later (in the |print_variable_name| routine) that
5944 it is convenient to let |info(p)=0| stand for `\.{[]}'.
5946 @<Display a collective subscript@>=
5948 if ( class==left_bracket_class )
5949 mp_print_char(mp, ' ');
5950 mp_print(mp, "[]"); c=right_bracket_class;
5953 @ @<Display a parameter token@>=
5955 if ( r<suffix_base ) {
5956 mp_print(mp, "(EXPR"); r=r-(expr_base);
5958 } else if ( r<text_base ) {
5959 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5962 mp_print(mp, "(TEXT"); r=r-(text_base);
5965 mp_print_int(mp, r); mp_print_char(mp, ')'); c=right_paren_class;
5969 @ @<Print string |r| as a symbolic token...@>=
5971 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5974 case letter_class:mp_print_char(mp, '.'); break;
5975 case isolated_classes: break;
5976 default: mp_print_char(mp, ' '); break;
5979 mp_print_str(mp, r);
5983 void mp_print_capsule (MP mp, pointer p);
5985 @ @<Declare miscellaneous procedures that were declared |forward|@>=
5986 void mp_print_capsule (MP mp, pointer p) {
5987 mp_print_char(mp, '('); mp_print_exp(mp,p,0); mp_print_char(mp, ')');
5990 @ Macro definitions are kept in \MP's memory in the form of token lists
5991 that have a few extra one-word nodes at the beginning.
5993 The first node contains a reference count that is used to tell when the
5994 list is no longer needed. To emphasize the fact that a reference count is
5995 present, we shall refer to the |info| field of this special node as the
5997 @^reference counts@>
5999 The next node or nodes after the reference count serve to describe the
6000 formal parameters. They consist of zero or more parameter tokens followed
6001 by a code for the type of macro.
6004 /* reference count preceding a macro definition or picture header */
6005 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
6006 @d general_macro 0 /* preface to a macro defined with a parameter list */
6007 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
6008 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
6009 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
6010 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
6011 @d of_macro 5 /* preface to a macro with
6012 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
6013 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
6014 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
6017 void mp_delete_mac_ref (MP mp,pointer p) {
6018 /* |p| points to the reference count of a macro list that is
6019 losing one reference */
6020 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
6021 else decr(ref_count(p));
6024 @ The following subroutine displays a macro, given a pointer to its
6028 @<Declare the procedure called |print_cmd_mod|@>
6029 void mp_show_macro (MP mp, pointer p, integer q, integer l) {
6030 pointer r; /* temporary storage */
6031 p=link(p); /* bypass the reference count */
6032 while ( info(p)>text_macro ){
6033 r=link(p); link(p)=null;
6034 mp_show_token_list(mp, p,null,l,0); link(p)=r; p=r;
6035 if ( l>0 ) l=l-mp->tally; else return;
6036 } /* control printing of `\.{ETC.}' */
6040 case general_macro:mp_print(mp, "->"); break;
6042 case primary_macro: case secondary_macro: case tertiary_macro:
6043 mp_print_char(mp, '<');
6044 mp_print_cmd_mod(mp, param_type,info(p));
6045 mp_print(mp, ">->");
6047 case expr_macro:mp_print(mp, "<expr>->"); break;
6048 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
6049 case suffix_macro:mp_print(mp, "<suffix>->"); break;
6050 case text_macro:mp_print(mp, "<text>->"); break;
6051 } /* there are no other cases */
6052 mp_show_token_list(mp, link(p),q,l-mp->tally,0);
6055 @* \[15] Data structures for variables.
6056 The variables of \MP\ programs can be simple, like `\.x', or they can
6057 combine the structural properties of arrays and records, like `\.{x20a.b}'.
6058 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
6059 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
6060 things are represented inside of the computer.
6062 Each variable value occupies two consecutive words, either in a two-word
6063 node called a value node, or as a two-word subfield of a larger node. One
6064 of those two words is called the |value| field; it is an integer,
6065 containing either a |scaled| numeric value or the representation of some
6066 other type of quantity. (It might also be subdivided into halfwords, in
6067 which case it is referred to by other names instead of |value|.) The other
6068 word is broken into subfields called |type|, |name_type|, and |link|. The
6069 |type| field is a quarterword that specifies the variable's type, and
6070 |name_type| is a quarterword from which \MP\ can reconstruct the
6071 variable's name (sometimes by using the |link| field as well). Thus, only
6072 1.25 words are actually devoted to the value itself; the other
6073 three-quarters of a word are overhead, but they aren't wasted because they
6074 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6076 In this section we shall be concerned only with the structural aspects of
6077 variables, not their values. Later parts of the program will change the
6078 |type| and |value| fields, but we shall treat those fields as black boxes
6079 whose contents should not be touched.
6081 However, if the |type| field is |mp_structured|, there is no |value| field,
6082 and the second word is broken into two pointer fields called |attr_head|
6083 and |subscr_head|. Those fields point to additional nodes that
6084 contain structural information, as we shall see.
6086 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6087 @d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
6088 @d subscr_head(A) link(subscr_head_loc((A))) /* pointer to subscript info */
6089 @d value_node_size 2 /* the number of words in a value node */
6091 @ An attribute node is three words long. Two of these words contain |type|
6092 and |value| fields as described above, and the third word contains
6093 additional information: There is an |attr_loc| field, which contains the
6094 hash address of the token that names this attribute; and there's also a
6095 |parent| field, which points to the value node of |mp_structured| type at the
6096 next higher level (i.e., at the level to which this attribute is
6097 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6098 |link| field points to the next attribute with the same parent; these are
6099 arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
6100 final attribute node links to the constant |end_attr|, whose |attr_loc|
6101 field is greater than any legal hash address. The |attr_head| in the
6102 parent points to a node whose |name_type| is |mp_structured_root|; this
6103 node represents the null attribute, i.e., the variable that is relevant
6104 when no attributes are attached to the parent. The |attr_head| node
6105 has the fields of either
6106 a value node, a subscript node, or an attribute node, depending on what
6107 the parent would be if it were not structured; but the subscript and
6108 attribute fields are ignored, so it effectively contains only the data of
6109 a value node. The |link| field in this special node points to an attribute
6110 node whose |attr_loc| field is zero; the latter node represents a collective
6111 subscript `\.{[]}' attached to the parent, and its |link| field points to
6112 the first non-special attribute node (or to |end_attr| if there are none).
6114 A subscript node likewise occupies three words, with |type| and |value| fields
6115 plus extra information; its |name_type| is |subscr|. In this case the
6116 third word is called the |subscript| field, which is a |scaled| integer.
6117 The |link| field points to the subscript node with the next larger
6118 subscript, if any; otherwise the |link| points to the attribute node
6119 for collective subscripts at this level. We have seen that the latter node
6120 contains an upward pointer, so that the parent can be deduced.
6122 The |name_type| in a parent-less value node is |root|, and the |link|
6123 is the hash address of the token that names this value.
6125 In other words, variables have a hierarchical structure that includes
6126 enough threads running around so that the program is able to move easily
6127 between siblings, parents, and children. An example should be helpful:
6128 (The reader is advised to draw a picture while reading the following
6129 description, since that will help to firm up the ideas.)
6130 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6131 and `\.{x20b}' have been mentioned in a user's program, where
6132 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6133 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6134 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6135 node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=mp_structured|,
6136 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6137 node and |r| to a subscript node. (Are you still following this? Use
6138 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6139 |type(q)| and |value(q)|; furthermore
6140 |name_type(q)=mp_structured_root| and |link(q)=q1|, where |q1| points
6141 to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
6142 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6143 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6144 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
6145 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
6146 with no further attributes), |name_type(qq)=structured_root|,
6147 |attr_loc(qq)=0|, |parent(qq)=p|, and
6148 |link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6149 an attribute node representing `\.{x[][]}', which has never yet
6150 occurred; its |type| field is |undefined|, and its |value| field is
6151 undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6152 |parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
6153 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6154 |parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
6155 (Maybe colored lines will help untangle your picture.)
6156 Node |r| is a subscript node with |type| and |value|
6157 representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
6158 and |link(r)=r1| is another subscript node. To complete the picture,
6159 see if you can guess what |link(r1)| is; give up? It's~|q1|.
6160 Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
6161 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6162 and we finish things off with three more nodes
6163 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6164 with a larger sheet of paper.) The value of variable \.{x20b}
6165 appears in node~|qqq2|, as you can well imagine.
6167 If the example in the previous paragraph doesn't make things crystal
6168 clear, a glance at some of the simpler subroutines below will reveal how
6169 things work out in practice.
6171 The only really unusual thing about these conventions is the use of
6172 collective subscript attributes. The idea is to avoid repeating a lot of
6173 type information when many elements of an array are identical macros
6174 (for which distinct values need not be stored) or when they don't have
6175 all of the possible attributes. Branches of the structure below collective
6176 subscript attributes do not carry actual values except for macro identifiers;
6177 branches of the structure below subscript nodes do not carry significant
6178 information in their collective subscript attributes.
6180 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6181 @d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
6182 @d parent(A) link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6183 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6184 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6185 @d attr_node_size 3 /* the number of words in an attribute node */
6186 @d subscr_node_size 3 /* the number of words in a subscript node */
6187 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6189 @<Initialize table...@>=
6190 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6192 @ Variables of type \&{pair} will have values that point to four-word
6193 nodes containing two numeric values. The first of these values has
6194 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6195 the |link| in the first points back to the node whose |value| points
6196 to this four-word node.
6198 Variables of type \&{transform} are similar, but in this case their
6199 |value| points to a 12-word node containing six values, identified by
6200 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6201 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6202 Finally, variables of type \&{color} have 3~values in 6~words
6203 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6205 When an entire structured variable is saved, the |root| indication
6206 is temporarily replaced by |saved_root|.
6208 Some variables have no name; they just are used for temporary storage
6209 while expressions are being evaluated. We call them {\sl capsules}.
6211 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6212 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6213 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6214 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6215 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6216 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6217 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6218 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6219 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6220 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6221 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6222 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6223 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6224 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6226 @d pair_node_size 4 /* the number of words in a pair node */
6227 @d transform_node_size 12 /* the number of words in a transform node */
6228 @d color_node_size 6 /* the number of words in a color node */
6229 @d cmykcolor_node_size 8 /* the number of words in a color node */
6232 small_number big_node_size[mp_pair_type+1];
6233 small_number sector0[mp_pair_type+1];
6234 small_number sector_offset[mp_black_part_sector+1];
6236 @ The |sector0| array gives for each big node type, |name_type| values
6237 for its first subfield; the |sector_offset| array gives for each
6238 |name_type| value, the offset from the first subfield in words;
6239 and the |big_node_size| array gives the size in words for each type of
6243 mp->big_node_size[mp_transform_type]=transform_node_size;
6244 mp->big_node_size[mp_pair_type]=pair_node_size;
6245 mp->big_node_size[mp_color_type]=color_node_size;
6246 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6247 mp->sector0[mp_transform_type]=mp_x_part_sector;
6248 mp->sector0[mp_pair_type]=mp_x_part_sector;
6249 mp->sector0[mp_color_type]=mp_red_part_sector;
6250 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6251 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6252 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6254 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6255 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6257 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6258 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6261 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6262 procedure call |init_big_node(p)| will allocate a pair or transform node
6263 for~|p|. The individual parts of such nodes are initially of type
6267 void mp_init_big_node (MP mp,pointer p) {
6268 pointer q; /* the new node */
6269 small_number s; /* its size */
6270 s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
6273 @<Make variable |q+s| newly independent@>;
6274 name_type(q+s)=halfp(s)+mp->sector0[type(p)];
6277 link(q)=p; value(p)=q;
6280 @ The |id_transform| function creates a capsule for the
6281 identity transformation.
6284 pointer mp_id_transform (MP mp) {
6285 pointer p,q,r; /* list manipulation registers */
6286 p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
6287 name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6288 r=q+transform_node_size;
6291 type(r)=mp_known; value(r)=0;
6293 value(xx_part_loc(q))=unity;
6294 value(yy_part_loc(q))=unity;
6298 @ Tokens are of type |tag_token| when they first appear, but they point
6299 to |null| until they are first used as the root of a variable.
6300 The following subroutine establishes the root node on such grand occasions.
6303 void mp_new_root (MP mp,pointer x) {
6304 pointer p; /* the new node */
6305 p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
6306 link(p)=x; equiv(x)=p;
6309 @ These conventions for variable representation are illustrated by the
6310 |print_variable_name| routine, which displays the full name of a
6311 variable given only a pointer to its two-word value packet.
6314 void mp_print_variable_name (MP mp, pointer p);
6317 void mp_print_variable_name (MP mp, pointer p) {
6318 pointer q; /* a token list that will name the variable's suffix */
6319 pointer r; /* temporary for token list creation */
6320 while ( name_type(p)>=mp_x_part_sector ) {
6321 @<Preface the output with a part specifier; |return| in the
6322 case of a capsule@>;
6325 while ( name_type(p)>mp_saved_root ) {
6326 @<Ascend one level, pushing a token onto list |q|
6327 and replacing |p| by its parent@>;
6329 r=mp_get_avail(mp); info(r)=link(p); link(r)=q;
6330 if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6332 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6333 mp_flush_token_list(mp, r);
6336 @ @<Ascend one level, pushing a token onto list |q|...@>=
6338 if ( name_type(p)==mp_subscr ) {
6339 r=mp_new_num_tok(mp, subscript(p));
6342 } while (name_type(p)!=mp_attr);
6343 } else if ( name_type(p)==mp_structured_root ) {
6344 p=link(p); goto FOUND;
6346 if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6347 @:this can't happen var}{\quad var@>
6348 r=mp_get_avail(mp); info(r)=attr_loc(p);
6355 @ @<Preface the output with a part specifier...@>=
6356 { switch (name_type(p)) {
6357 case mp_x_part_sector: mp_print_char(mp, 'x'); break;
6358 case mp_y_part_sector: mp_print_char(mp, 'y'); break;
6359 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6360 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6361 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6362 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6363 case mp_red_part_sector: mp_print(mp, "red"); break;
6364 case mp_green_part_sector: mp_print(mp, "green"); break;
6365 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6366 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6367 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6368 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6369 case mp_black_part_sector: mp_print(mp, "black"); break;
6370 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6372 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6375 } /* there are no other cases */
6376 mp_print(mp, "part ");
6377 p=link(p-mp->sector_offset[name_type(p)]);
6380 @ The |interesting| function returns |true| if a given variable is not
6381 in a capsule, or if the user wants to trace capsules.
6384 boolean mp_interesting (MP mp,pointer p) {
6385 small_number t; /* a |name_type| */
6386 if ( mp->internal[mp_tracing_capsules]>0 ) {
6390 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6391 t=name_type(link(p-mp->sector_offset[t]));
6392 return (t!=mp_capsule);
6396 @ Now here is a subroutine that converts an unstructured type into an
6397 equivalent structured type, by inserting a |mp_structured| node that is
6398 capable of growing. This operation is done only when |name_type(p)=root|,
6399 |subscr|, or |attr|.
6401 The procedure returns a pointer to the new node that has taken node~|p|'s
6402 place in the structure. Node~|p| itself does not move, nor are its
6403 |value| or |type| fields changed in any way.
6406 pointer mp_new_structure (MP mp,pointer p) {
6407 pointer q,r=0; /* list manipulation registers */
6408 switch (name_type(p)) {
6410 q=link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6413 @<Link a new subscript node |r| in place of node |p|@>;
6416 @<Link a new attribute node |r| in place of node |p|@>;
6419 mp_confusion(mp, "struct");
6420 @:this can't happen struct}{\quad struct@>
6423 link(r)=link(p); type(r)=mp_structured; name_type(r)=name_type(p);
6424 attr_head(r)=p; name_type(p)=mp_structured_root;
6425 q=mp_get_node(mp, attr_node_size); link(p)=q; subscr_head(r)=q;
6426 parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; link(q)=end_attr;
6427 attr_loc(q)=collective_subscript;
6431 @ @<Link a new subscript node |r| in place of node |p|@>=
6436 } while (name_type(q)!=mp_attr);
6437 q=parent(q); r=subscr_head_loc(q); /* |link(r)=subscr_head(q)| */
6441 r=mp_get_node(mp, subscr_node_size);
6442 link(q)=r; subscript(r)=subscript(p);
6445 @ If the attribute is |collective_subscript|, there are two pointers to
6446 node~|p|, so we must change both of them.
6448 @<Link a new attribute node |r| in place of node |p|@>=
6450 q=parent(p); r=attr_head(q);
6454 r=mp_get_node(mp, attr_node_size); link(q)=r;
6455 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6456 if ( attr_loc(p)==collective_subscript ) {
6457 q=subscr_head_loc(parent(p));
6458 while ( link(q)!=p ) q=link(q);
6463 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6464 list of suffixes; it returns a pointer to the corresponding two-word
6465 value. For example, if |t| points to token \.x followed by a numeric
6466 token containing the value~7, |find_variable| finds where the value of
6467 \.{x7} is stored in memory. This may seem a simple task, and it
6468 usually is, except when \.{x7} has never been referenced before.
6469 Indeed, \.x may never have even been subscripted before; complexities
6470 arise with respect to updating the collective subscript information.
6472 If a macro type is detected anywhere along path~|t|, or if the first
6473 item on |t| isn't a |tag_token|, the value |null| is returned.
6474 Otherwise |p| will be a non-null pointer to a node such that
6475 |undefined<type(p)<mp_structured|.
6477 @d abort_find { return null; }
6480 pointer mp_find_variable (MP mp,pointer t) {
6481 pointer p,q,r,s; /* nodes in the ``value'' line */
6482 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6483 integer n; /* subscript or attribute */
6484 memory_word save_word; /* temporary storage for a word of |mem| */
6486 p=info(t); t=link(t);
6487 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6488 if ( equiv(p)==null ) mp_new_root(mp, p);
6491 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6492 if ( t<mp->hi_mem_min ) {
6493 @<Descend one level for the subscript |value(t)|@>
6495 @<Descend one level for the attribute |info(t)|@>;
6499 if ( type(pp)>=mp_structured ) {
6500 if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6502 if ( type(p)==mp_structured ) p=attr_head(p);
6503 if ( type(p)==undefined ) {
6504 if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
6505 type(p)=type(pp); value(p)=null;
6510 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6511 |pp|~stays in the collective line while |p|~goes through actual subscript
6514 @<Make sure that both nodes |p| and |pp|...@>=
6515 if ( type(pp)!=mp_structured ) {
6516 if ( type(pp)>mp_structured ) abort_find;
6517 ss=mp_new_structure(mp, pp);
6520 }; /* now |type(pp)=mp_structured| */
6521 if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6522 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6524 @ We want this part of the program to be reasonably fast, in case there are
6526 lots of subscripts at the same level of the data structure. Therefore
6527 we store an ``infinite'' value in the word that appears at the end of the
6528 subscript list, even though that word isn't part of a subscript node.
6530 @<Descend one level for the subscript |value(t)|@>=
6533 pp=link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6534 q=link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6535 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |link(s)=subscr_head(p)| */
6538 } while (n>subscript(s));
6539 if ( n==subscript(s) ) {
6542 p=mp_get_node(mp, subscr_node_size); link(r)=p; link(p)=s;
6543 subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
6545 mp->mem[subscript_loc(q)]=save_word;
6548 @ @<Descend one level for the attribute |info(t)|@>=
6554 } while (n>attr_loc(ss));
6555 if ( n<attr_loc(ss) ) {
6556 qq=mp_get_node(mp, attr_node_size); link(rr)=qq; link(qq)=ss;
6557 attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
6558 parent(qq)=pp; ss=qq;
6563 pp=ss; s=attr_head(p);
6566 } while (n>attr_loc(s));
6567 if ( n==attr_loc(s) ) {
6570 q=mp_get_node(mp, attr_node_size); link(r)=q; link(q)=s;
6571 attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
6577 @ Variables lose their former values when they appear in a type declaration,
6578 or when they are defined to be macros or \&{let} equal to something else.
6579 A subroutine will be defined later that recycles the storage associated
6580 with any particular |type| or |value|; our goal now is to study a higher
6581 level process called |flush_variable|, which selectively frees parts of a
6584 This routine has some complexity because of examples such as
6585 `\hbox{\tt numeric x[]a[]b}'
6586 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6587 `\hbox{\tt vardef x[]a[]=...}'
6588 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6589 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6590 to handle such examples is to use recursion; so that's what we~do.
6593 Parameter |p| points to the root information of the variable;
6594 parameter |t| points to a list of one-word nodes that represent
6595 suffixes, with |info=collective_subscript| for subscripts.
6598 @<Declare subroutines for printing expressions@>
6599 @<Declare basic dependency-list subroutines@>
6600 @<Declare the recycling subroutines@>
6601 void mp_flush_cur_exp (MP mp,scaled v) ;
6602 @<Declare the procedure called |flush_below_variable|@>
6605 void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6606 pointer q,r; /* list manipulation */
6607 halfword n; /* attribute to match */
6609 if ( type(p)!=mp_structured ) return;
6610 n=info(t); t=link(t);
6611 if ( n==collective_subscript ) {
6612 r=subscr_head_loc(p); q=link(r); /* |q=subscr_head(p)| */
6613 while ( name_type(q)==mp_subscr ){
6614 mp_flush_variable(mp, q,t,discard_suffixes);
6616 if ( type(q)==mp_structured ) r=q;
6617 else { link(r)=link(q); mp_free_node(mp, q,subscr_node_size); }
6627 } while (attr_loc(p)<n);
6628 if ( attr_loc(p)!=n ) return;
6630 if ( discard_suffixes ) {
6631 mp_flush_below_variable(mp, p);
6633 if ( type(p)==mp_structured ) p=attr_head(p);
6634 mp_recycle_value(mp, p);
6638 @ The next procedure is simpler; it wipes out everything but |p| itself,
6639 which becomes undefined.
6641 @<Declare the procedure called |flush_below_variable|@>=
6642 void mp_flush_below_variable (MP mp, pointer p);
6645 void mp_flush_below_variable (MP mp,pointer p) {
6646 pointer q,r; /* list manipulation registers */
6647 if ( type(p)!=mp_structured ) {
6648 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6651 while ( name_type(q)==mp_subscr ) {
6652 mp_flush_below_variable(mp, q); r=q; q=link(q);
6653 mp_free_node(mp, r,subscr_node_size);
6655 r=attr_head(p); q=link(r); mp_recycle_value(mp, r);
6656 if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6657 else mp_free_node(mp, r,subscr_node_size);
6658 /* we assume that |subscr_node_size=attr_node_size| */
6660 mp_flush_below_variable(mp, q); r=q; q=link(q); mp_free_node(mp, r,attr_node_size);
6661 } while (q!=end_attr);
6666 @ Just before assigning a new value to a variable, we will recycle the
6667 old value and make the old value undefined. The |und_type| routine
6668 determines what type of undefined value should be given, based on
6669 the current type before recycling.
6672 small_number mp_und_type (MP mp,pointer p) {
6674 case undefined: case mp_vacuous:
6676 case mp_boolean_type: case mp_unknown_boolean:
6677 return mp_unknown_boolean;
6678 case mp_string_type: case mp_unknown_string:
6679 return mp_unknown_string;
6680 case mp_pen_type: case mp_unknown_pen:
6681 return mp_unknown_pen;
6682 case mp_path_type: case mp_unknown_path:
6683 return mp_unknown_path;
6684 case mp_picture_type: case mp_unknown_picture:
6685 return mp_unknown_picture;
6686 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6687 case mp_pair_type: case mp_numeric_type:
6689 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6690 return mp_numeric_type;
6691 } /* there are no other cases */
6695 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6696 of a symbolic token. It must remove any variable structure or macro
6697 definition that is currently attached to that symbol. If the |saving|
6698 parameter is true, a subsidiary structure is saved instead of destroyed.
6701 void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6702 pointer q; /* |equiv(p)| */
6704 switch (eq_type(p) % outer_tag) {
6706 case secondary_primary_macro:
6707 case tertiary_secondary_macro:
6708 case expression_tertiary_macro:
6709 if ( ! saving ) mp_delete_mac_ref(mp, q);
6714 name_type(q)=mp_saved_root;
6716 mp_flush_below_variable(mp, q);
6717 mp_free_node(mp,q,value_node_size);
6724 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6727 @* \[16] Saving and restoring equivalents.
6728 The nested structure given by \&{begingroup} and \&{endgroup}
6729 allows |eqtb| entries to be saved and restored, so that temporary changes
6730 can be made without difficulty. When the user requests a current value to
6731 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6732 \&{endgroup} ultimately causes the old values to be removed from the save
6733 stack and put back in their former places.
6735 The save stack is a linked list containing three kinds of entries,
6736 distinguished by their |info| fields. If |p| points to a saved item,
6740 |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6741 such an item to the save stack and each \&{endgroup} cuts back the stack
6742 until the most recent such entry has been removed.
6745 |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6746 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6750 |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6751 integer to be restored to internal parameter number~|q|. Such entries
6752 are generated by \&{interim} commands.
6755 The global variable |save_ptr| points to the top item on the save stack.
6757 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6758 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6759 @d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
6760 link((A))=mp->save_ptr; mp->save_ptr=(A);
6764 pointer save_ptr; /* the most recently saved item */
6766 @ @<Set init...@>=mp->save_ptr=null;
6768 @ The |save_variable| routine is given a hash address |q|; it salts this
6769 address in the save stack, together with its current equivalent,
6770 then makes token~|q| behave as though it were brand new.
6772 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6773 things from the stack when the program is not inside a group, so there's
6774 no point in wasting the space.
6776 @c void mp_save_variable (MP mp,pointer q) {
6777 pointer p; /* temporary register */
6778 if ( mp->save_ptr!=null ){
6779 p=mp_get_node(mp, save_node_size); info(p)=q; link(p)=mp->save_ptr;
6780 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6782 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6785 @ Similarly, |save_internal| is given the location |q| of an internal
6786 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6789 @c void mp_save_internal (MP mp,halfword q) {
6790 pointer p; /* new item for the save stack */
6791 if ( mp->save_ptr!=null ){
6792 p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
6793 link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6797 @ At the end of a group, the |unsave| routine restores all of the saved
6798 equivalents in reverse order. This routine will be called only when there
6799 is at least one boundary item on the save stack.
6802 void mp_unsave (MP mp) {
6803 pointer q; /* index to saved item */
6804 pointer p; /* temporary register */
6805 while ( info(mp->save_ptr)!=0 ) {
6806 q=info(mp->save_ptr);
6808 if ( mp->internal[mp_tracing_restores]>0 ) {
6809 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6810 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, '=');
6811 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, '}');
6812 mp_end_diagnostic(mp, false);
6814 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6816 if ( mp->internal[mp_tracing_restores]>0 ) {
6817 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6818 mp_print_text(q); mp_print_char(mp, '}');
6819 mp_end_diagnostic(mp, false);
6821 mp_clear_symbol(mp, q,false);
6822 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6823 if ( eq_type(q) % outer_tag==tag_token ) {
6825 if ( p!=null ) name_type(p)=mp_root;
6828 p=link(mp->save_ptr);
6829 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6831 p=link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6834 @* \[17] Data structures for paths.
6835 When a \MP\ user specifies a path, \MP\ will create a list of knots
6836 and control points for the associated cubic spline curves. If the
6837 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6838 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6839 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6840 @:Bezier}{B\'ezier, Pierre Etienne@>
6841 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6842 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6845 There is a 8-word node for each knot $z_k$, containing one word of
6846 control information and six words for the |x| and |y| coordinates of
6847 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6848 |left_type| and |right_type| fields, which each occupy a quarter of
6849 the first word in the node; they specify properties of the curve as it
6850 enters and leaves the knot. There's also a halfword |link| field,
6851 which points to the following knot, and a final supplementary word (of
6852 which only a quarter is used).
6854 If the path is a closed contour, knots 0 and |n| are identical;
6855 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6856 is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
6857 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6858 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6860 @d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6861 @d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6862 @d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6863 @d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6864 @d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6865 @d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6866 @d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6867 @d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6868 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6869 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6870 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6871 @d left_coord(A) mp->mem[(A)+2].sc
6872 /* coordinate of previous control point given |x_loc| or |y_loc| */
6873 @d right_coord(A) mp->mem[(A)+4].sc
6874 /* coordinate of next control point given |x_loc| or |y_loc| */
6875 @d knot_node_size 8 /* number of words in a knot node */
6879 mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
6880 mp_explicit, /* |left_type| or |right_type| when control points are known */
6881 mp_given, /* |left_type| or |right_type| when a direction is given */
6882 mp_curl, /* |left_type| or |right_type| when a curl is desired */
6883 mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
6887 @ Before the B\'ezier control points have been calculated, the memory
6888 space they will ultimately occupy is taken up by information that can be
6889 used to compute them. There are four cases:
6892 \textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
6893 the knot in the same direction it entered; \MP\ will figure out a
6897 \textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
6898 knot in a direction depending on the angle at which it enters the next
6899 knot and on the curl parameter stored in |right_curl|.
6902 \textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
6903 knot in a nonzero direction stored as an |angle| in |right_given|.
6906 \textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
6907 point for leaving this knot has already been computed; it is in the
6908 |right_x| and |right_y| fields.
6911 The rules for |left_type| are similar, but they refer to the curve entering
6912 the knot, and to \\{left} fields instead of \\{right} fields.
6914 Non-|explicit| control points will be chosen based on ``tension'' parameters
6915 in the |left_tension| and |right_tension| fields. The
6916 `\&{atleast}' option is represented by negative tension values.
6917 @:at_least_}{\&{atleast} primitive@>
6919 For example, the \MP\ path specification
6920 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6922 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6924 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6925 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6926 |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
6928 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6929 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6930 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6931 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6932 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6933 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6934 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6935 Of course, this example is more complicated than anything a normal user
6938 These types must satisfy certain restrictions because of the form of \MP's
6940 (i)~|open| type never appears in the same node together with |endpoint|,
6942 (ii)~The |right_type| of a node is |explicit| if and only if the
6943 |left_type| of the following node is |explicit|.
6944 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6946 @d left_curl left_x /* curl information when entering this knot */
6947 @d left_given left_x /* given direction when entering this knot */
6948 @d left_tension left_y /* tension information when entering this knot */
6949 @d right_curl right_x /* curl information when leaving this knot */
6950 @d right_given right_x /* given direction when leaving this knot */
6951 @d right_tension right_y /* tension information when leaving this knot */
6953 @ Knots can be user-supplied, or they can be created by program code,
6954 like the |split_cubic| function, or |copy_path|. The distinction is
6955 needed for the cleanup routine that runs after |split_cubic|, because
6956 it should only delete knots it has previously inserted, and never
6957 anything that was user-supplied. In order to be able to differentiate
6958 one knot from another, we will set |originator(p):=mp_metapost_user| when
6959 it appeared in the actual metapost program, and
6960 |originator(p):=mp_program_code| in all other cases.
6962 @d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6966 mp_program_code=0, /* not created by a user */
6967 mp_metapost_user /* created by a user */
6970 @ Here is a routine that prints a given knot list
6971 in symbolic form. It illustrates the conventions discussed above,
6972 and checks for anomalies that might arise while \MP\ is being debugged.
6974 @<Declare subroutines for printing expressions@>=
6975 void mp_pr_path (MP mp,pointer h);
6978 void mp_pr_path (MP mp,pointer h) {
6979 pointer p,q; /* for list traversal */
6983 if ( (p==null)||(q==null) ) {
6984 mp_print_nl(mp, "???"); return; /* this won't happen */
6987 @<Print information for adjacent knots |p| and |q|@>;
6990 if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
6991 @<Print two dots, followed by |given| or |curl| if present@>;
6994 if ( left_type(h)!=mp_endpoint )
6995 mp_print(mp, "cycle");
6998 @ @<Print information for adjacent knots...@>=
6999 mp_print_two(mp, x_coord(p),y_coord(p));
7000 switch (right_type(p)) {
7002 if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
7004 if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
7008 @<Print control points between |p| and |q|, then |goto done1|@>;
7011 @<Print information for a curve that begins |open|@>;
7015 @<Print information for a curve that begins |curl| or |given|@>;
7018 mp_print(mp, "???"); /* can't happen */
7022 if ( left_type(q)<=mp_explicit ) {
7023 mp_print(mp, "..control?"); /* can't happen */
7025 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
7026 @<Print tension between |p| and |q|@>;
7029 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
7030 were |scaled|, the magnitude of a |given| direction vector will be~4096.
7032 @<Print two dots...@>=
7034 mp_print_nl(mp, " ..");
7035 if ( left_type(p)==mp_given ) {
7036 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, '{');
7037 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7038 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, '}');
7039 } else if ( left_type(p)==mp_curl ){
7040 mp_print(mp, "{curl ");
7041 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, '}');
7045 @ @<Print tension between |p| and |q|@>=
7047 mp_print(mp, "..tension ");
7048 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
7049 mp_print_scaled(mp, abs(right_tension(p)));
7050 if ( right_tension(p)!=left_tension(q) ){
7051 mp_print(mp, " and ");
7052 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
7053 mp_print_scaled(mp, abs(left_tension(q)));
7057 @ @<Print control points between |p| and |q|, then |goto done1|@>=
7059 mp_print(mp, "..controls ");
7060 mp_print_two(mp, right_x(p),right_y(p));
7061 mp_print(mp, " and ");
7062 if ( left_type(q)!=mp_explicit ) {
7063 mp_print(mp, "??"); /* can't happen */
7066 mp_print_two(mp, left_x(q),left_y(q));
7071 @ @<Print information for a curve that begins |open|@>=
7072 if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
7073 mp_print(mp, "{open?}"); /* can't happen */
7077 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7078 \MP's default curl is present.
7080 @<Print information for a curve that begins |curl|...@>=
7082 if ( left_type(p)==mp_open )
7083 mp_print(mp, "??"); /* can't happen */
7085 if ( right_type(p)==mp_curl ) {
7086 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7088 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, '{');
7089 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7090 mp_print_scaled(mp, mp->n_sin);
7092 mp_print_char(mp, '}');
7095 @ It is convenient to have another version of |pr_path| that prints the path
7096 as a diagnostic message.
7098 @<Declare subroutines for printing expressions@>=
7099 void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
7100 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7103 mp_end_diagnostic(mp, true);
7106 @ If we want to duplicate a knot node, we can say |copy_knot|:
7109 pointer mp_copy_knot (MP mp,pointer p) {
7110 pointer q; /* the copy */
7111 int k; /* runs through the words of a knot node */
7112 q=mp_get_node(mp, knot_node_size);
7113 for (k=0;k<knot_node_size;k++) {
7114 mp->mem[q+k]=mp->mem[p+k];
7116 originator(q)=originator(p);
7120 @ The |copy_path| routine makes a clone of a given path.
7123 pointer mp_copy_path (MP mp, pointer p) {
7124 pointer q,pp,qq; /* for list manipulation */
7125 q=mp_copy_knot(mp, p);
7128 link(qq)=mp_copy_knot(mp, pp);
7137 @ Just before |ship_out|, knot lists are exported for printing.
7139 The |gr_XXXX| macros are defined in |mppsout.h|.
7142 mp_knot *mp_export_knot (MP mp,pointer p) {
7143 mp_knot *q; /* the copy */
7146 q = mp_xmalloc(mp, 1, sizeof (mp_knot));
7147 memset(q,0,sizeof (mp_knot));
7148 gr_left_type(q) = left_type(p);
7149 gr_right_type(q) = right_type(p);
7150 gr_x_coord(q) = x_coord(p);
7151 gr_y_coord(q) = y_coord(p);
7152 gr_left_x(q) = left_x(p);
7153 gr_left_y(q) = left_y(p);
7154 gr_right_x(q) = right_x(p);
7155 gr_right_y(q) = right_y(p);
7156 gr_originator(q) = originator(p);
7160 @ The |export_knot_list| routine therefore also makes a clone
7164 mp_knot *mp_export_knot_list (MP mp, pointer p) {
7165 mp_knot *q, *qq; /* for list manipulation */
7166 pointer pp; /* for list manipulation */
7169 q=mp_export_knot(mp, p);
7172 gr_next_knot(qq)=mp_export_knot(mp, pp);
7173 qq=gr_next_knot(qq);
7181 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7182 returns a pointer to the first node of the copy, if the path is a cycle,
7183 but to the final node of a non-cyclic copy. The global
7184 variable |path_tail| will point to the final node of the original path;
7185 this trick makes it easier to implement `\&{doublepath}'.
7187 All node types are assumed to be |endpoint| or |explicit| only.
7190 pointer mp_htap_ypoc (MP mp,pointer p) {
7191 pointer q,pp,qq,rr; /* for list manipulation */
7192 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7195 right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
7196 x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
7197 right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
7198 left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
7199 originator(qq)=originator(pp);
7200 if ( link(pp)==p ) {
7201 link(q)=qq; mp->path_tail=pp; return q;
7203 rr=mp_get_node(mp, knot_node_size); link(rr)=qq; qq=rr; pp=link(pp);
7208 pointer path_tail; /* the node that links to the beginning of a path */
7210 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7211 calling the following subroutine.
7213 @<Declare the recycling subroutines@>=
7214 void mp_toss_knot_list (MP mp,pointer p) ;
7217 void mp_toss_knot_list (MP mp,pointer p) {
7218 pointer q; /* the node being freed */
7219 pointer r; /* the next node */
7223 mp_free_node(mp, q,knot_node_size); q=r;
7227 @* \[18] Choosing control points.
7228 Now we must actually delve into one of \MP's more difficult routines,
7229 the |make_choices| procedure that chooses angles and control points for
7230 the splines of a curve when the user has not specified them explicitly.
7231 The parameter to |make_choices| points to a list of knots and
7232 path information, as described above.
7234 A path decomposes into independent segments at ``breakpoint'' knots,
7235 which are knots whose left and right angles are both prespecified in
7236 some way (i.e., their |left_type| and |right_type| aren't both open).
7239 @<Declare the procedure called |solve_choices|@>
7240 void mp_make_choices (MP mp,pointer knots) {
7241 pointer h; /* the first breakpoint */
7242 pointer p,q; /* consecutive breakpoints being processed */
7243 @<Other local variables for |make_choices|@>;
7244 check_arith; /* make sure that |arith_error=false| */
7245 if ( mp->internal[mp_tracing_choices]>0 )
7246 mp_print_path(mp, knots,", before choices",true);
7247 @<If consecutive knots are equal, join them explicitly@>;
7248 @<Find the first breakpoint, |h|, on the path;
7249 insert an artificial breakpoint if the path is an unbroken cycle@>;
7252 @<Fill in the control points between |p| and the next breakpoint,
7253 then advance |p| to that breakpoint@>;
7255 if ( mp->internal[mp_tracing_choices]>0 )
7256 mp_print_path(mp, knots,", after choices",true);
7257 if ( mp->arith_error ) {
7258 @<Report an unexpected problem during the choice-making@>;
7262 @ @<Report an unexpected problem during the choice...@>=
7264 print_err("Some number got too big");
7265 @.Some number got too big@>
7266 help2("The path that I just computed is out of range.")
7267 ("So it will probably look funny. Proceed, for a laugh.");
7268 mp_put_get_error(mp); mp->arith_error=false;
7271 @ Two knots in a row with the same coordinates will always be joined
7272 by an explicit ``curve'' whose control points are identical with the
7275 @<If consecutive knots are equal, join them explicitly@>=
7279 if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
7280 right_type(p)=mp_explicit;
7281 if ( left_type(p)==mp_open ) {
7282 left_type(p)=mp_curl; left_curl(p)=unity;
7284 left_type(q)=mp_explicit;
7285 if ( right_type(q)==mp_open ) {
7286 right_type(q)=mp_curl; right_curl(q)=unity;
7288 right_x(p)=x_coord(p); left_x(q)=x_coord(p);
7289 right_y(p)=y_coord(p); left_y(q)=y_coord(p);
7294 @ If there are no breakpoints, it is necessary to compute the direction
7295 angles around an entire cycle. In this case the |left_type| of the first
7296 node is temporarily changed to |end_cycle|.
7298 @<Find the first breakpoint, |h|, on the path...@>=
7301 if ( left_type(h)!=mp_open ) break;
7302 if ( right_type(h)!=mp_open ) break;
7305 left_type(h)=mp_end_cycle; break;
7309 @ If |right_type(p)<given| and |q=link(p)|, we must have
7310 |right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
7312 @<Fill in the control points between |p| and the next breakpoint...@>=
7314 if ( right_type(p)>=mp_given ) {
7315 while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=link(q);
7316 @<Fill in the control information between
7317 consecutive breakpoints |p| and |q|@>;
7318 } else if ( right_type(p)==mp_endpoint ) {
7319 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7323 @ This step makes it possible to transform an explicitly computed path without
7324 checking the |left_type| and |right_type| fields.
7326 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7328 right_x(p)=x_coord(p); right_y(p)=y_coord(p);
7329 left_x(q)=x_coord(q); left_y(q)=y_coord(q);
7332 @ Before we can go further into the way choices are made, we need to
7333 consider the underlying theory. The basic ideas implemented in |make_choices|
7334 are due to John Hobby, who introduced the notion of ``mock curvature''
7335 @^Hobby, John Douglas@>
7336 at a knot. Angles are chosen so that they preserve mock curvature when
7337 a knot is passed, and this has been found to produce excellent results.
7339 It is convenient to introduce some notations that simplify the necessary
7340 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7341 between knots |k| and |k+1|; and let
7342 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7343 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7344 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7345 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7346 $$\eqalign{z_k^+&=z_k+
7347 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7349 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7350 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7351 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7352 corresponding ``offset angles.'' These angles satisfy the condition
7353 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7354 whenever the curve leaves an intermediate knot~|k| in the direction that
7357 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7358 the curve at its beginning and ending points. This means that
7359 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7360 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7361 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7362 z\k^-,z\k^{\phantom+};t)$
7365 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7366 \qquad{\rm and}\qquad
7367 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7368 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7370 approximation to this true curvature that arises in the limit for
7371 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7372 The standard velocity function satisfies
7373 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7374 hence the mock curvatures are respectively
7375 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7376 \qquad{\rm and}\qquad
7377 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7379 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7380 determines $\phi_k$ when $\theta_k$ is known, so the task of
7381 angle selection is essentially to choose appropriate values for each
7382 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7383 from $(**)$, we obtain a system of linear equations of the form
7384 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7386 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7387 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7388 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7389 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7390 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7391 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7392 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7393 hence they have a unique solution. Moreover, in most cases the tensions
7394 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7395 solution numerically stable, and there is an exponential damping
7396 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7397 a factor of~$O(2^{-j})$.
7399 @ However, we still must consider the angles at the starting and ending
7400 knots of a non-cyclic path. These angles might be given explicitly, or
7401 they might be specified implicitly in terms of an amount of ``curl.''
7403 Let's assume that angles need to be determined for a non-cyclic path
7404 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7405 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7406 have been given for $0<k<n$, and it will be convenient to introduce
7407 equations of the same form for $k=0$ and $k=n$, where
7408 $$A_0=B_0=C_n=D_n=0.$$
7409 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7410 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7411 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7412 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7413 mock curvature at $z_1$; i.e.,
7414 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7415 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7416 This equation simplifies to
7417 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7418 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7419 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7420 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7421 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7422 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7423 hence the linear equations remain nonsingular.
7425 Similar considerations apply at the right end, when the final angle $\phi_n$
7426 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7427 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7429 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7430 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7431 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7433 When |make_choices| chooses angles, it must compute the coefficients of
7434 these linear equations, then solve the equations. To compute the coefficients,
7435 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7436 When the equations are solved, the chosen directions $\theta_k$ are put
7437 back into the form of control points by essentially computing sines and
7440 @ OK, we are ready to make the hard choices of |make_choices|.
7441 Most of the work is relegated to an auxiliary procedure
7442 called |solve_choices|, which has been introduced to keep
7443 |make_choices| from being extremely long.
7445 @<Fill in the control information between...@>=
7446 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7447 set $n$ to the length of the path@>;
7448 @<Remove |open| types at the breakpoints@>;
7449 mp_solve_choices(mp, p,q,n)
7451 @ It's convenient to precompute quantities that will be needed several
7452 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7453 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7454 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7455 and $z\k-z_k$ will be stored in |psi[k]|.
7458 int path_size; /* maximum number of knots between breakpoints of a path */
7461 scaled *delta; /* knot differences */
7462 angle *psi; /* turning angles */
7464 @ @<Allocate or initialize ...@>=
7470 @ @<Dealloc variables@>=
7476 @ @<Other local variables for |make_choices|@>=
7477 int k,n; /* current and final knot numbers */
7478 pointer s,t; /* registers for list traversal */
7479 scaled delx,dely; /* directions where |open| meets |explicit| */
7480 fraction sine,cosine; /* trig functions of various angles */
7482 @ @<Calculate the turning angles...@>=
7485 k=0; s=p; n=mp->path_size;
7488 mp->delta_x[k]=x_coord(t)-x_coord(s);
7489 mp->delta_y[k]=y_coord(t)-y_coord(s);
7490 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7492 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7493 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7494 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7495 mp_take_fraction(mp, mp->delta_y[k],sine),
7496 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7497 mp_take_fraction(mp, mp->delta_x[k],sine));
7500 if ( k==mp->path_size ) {
7501 mp_reallocate_paths(mp, mp->path_size+(mp->path_size>>2));
7502 goto RESTART; /* retry, loop size has changed */
7505 } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
7506 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7509 @ When we get to this point of the code, |right_type(p)| is either
7510 |given| or |curl| or |open|. If it is |open|, we must have
7511 |left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
7512 case, the |open| type is converted to |given|; however, if the
7513 velocity coming into this knot is zero, the |open| type is
7514 converted to a |curl|, since we don't know the incoming direction.
7516 Similarly, |left_type(q)| is either |given| or |curl| or |open| or
7517 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7519 @<Remove |open| types at the breakpoints@>=
7520 if ( left_type(q)==mp_open ) {
7521 delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
7522 if ( (delx==0)&&(dely==0) ) {
7523 left_type(q)=mp_curl; left_curl(q)=unity;
7525 left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7528 if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
7529 delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
7530 if ( (delx==0)&&(dely==0) ) {
7531 right_type(p)=mp_curl; right_curl(p)=unity;
7533 right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7537 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7538 and exactly one of the breakpoints involves a curl. The simplest case occurs
7539 when |n=1| and there is a curl at both breakpoints; then we simply draw
7542 But before coding up the simple cases, we might as well face the general case,
7543 since we must deal with it sooner or later, and since the general case
7544 is likely to give some insight into the way simple cases can be handled best.
7546 When there is no cycle, the linear equations to be solved form a tridiagonal
7547 system, and we can apply the standard technique of Gaussian elimination
7548 to convert that system to a sequence of equations of the form
7549 $$\theta_0+u_0\theta_1=v_0,\quad
7550 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7551 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7553 It is possible to do this diagonalization while generating the equations.
7554 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7555 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7557 The procedure is slightly more complex when there is a cycle, but the
7558 basic idea will be nearly the same. In the cyclic case the right-hand
7559 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7560 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7561 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7562 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7563 eliminate the $w$'s from the system, after which the solution can be
7566 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7567 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7568 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7569 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7572 angle *theta; /* values of $\theta_k$ */
7573 fraction *uu; /* values of $u_k$ */
7574 angle *vv; /* values of $v_k$ */
7575 fraction *ww; /* values of $w_k$ */
7577 @ @<Allocate or initialize ...@>=
7583 @ @<Dealloc variables@>=
7589 @ @<Declare |mp_reallocate| functions@>=
7590 void mp_reallocate_paths (MP mp, int l);
7593 void mp_reallocate_paths (MP mp, int l) {
7594 XREALLOC (mp->delta_x, l, scaled);
7595 XREALLOC (mp->delta_y, l, scaled);
7596 XREALLOC (mp->delta, l, scaled);
7597 XREALLOC (mp->psi, l, angle);
7598 XREALLOC (mp->theta, l, angle);
7599 XREALLOC (mp->uu, l, fraction);
7600 XREALLOC (mp->vv, l, angle);
7601 XREALLOC (mp->ww, l, fraction);
7605 @ Our immediate problem is to get the ball rolling by setting up the
7606 first equation or by realizing that no equations are needed, and to fit
7607 this initialization into a framework suitable for the overall computation.
7609 @<Declare the procedure called |solve_choices|@>=
7610 @<Declare subroutines needed by |solve_choices|@>
7611 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7612 int k; /* current knot number */
7613 pointer r,s,t; /* registers for list traversal */
7614 @<Other local variables for |solve_choices|@>;
7619 @<Get the linear equations started; or |return|
7620 with the control points in place, if linear equations
7623 switch (left_type(s)) {
7624 case mp_end_cycle: case mp_open:
7625 @<Set up equation to match mock curvatures
7626 at $z_k$; then |goto found| with $\theta_n$
7627 adjusted to equal $\theta_0$, if a cycle has ended@>;
7630 @<Set up equation for a curl at $\theta_n$
7634 @<Calculate the given value of $\theta_n$
7637 } /* there are no other cases */
7642 @<Finish choosing angles and assigning control points@>;
7645 @ On the first time through the loop, we have |k=0| and |r| is not yet
7646 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7648 @<Get the linear equations started...@>=
7649 switch (right_type(s)) {
7651 if ( left_type(t)==mp_given ) {
7652 @<Reduce to simple case of two givens and |return|@>
7654 @<Set up the equation for a given value of $\theta_0$@>;
7658 if ( left_type(t)==mp_curl ) {
7659 @<Reduce to simple case of straight line and |return|@>
7661 @<Set up the equation for a curl at $\theta_0$@>;
7665 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7666 /* this begins a cycle */
7668 } /* there are no other cases */
7670 @ The general equation that specifies equality of mock curvature at $z_k$ is
7671 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7672 as derived above. We want to combine this with the already-derived equation
7673 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7675 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7677 $$(B_k-u_{k-1}A_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k-A_kv_{k-1}
7678 -A_kw_{k-1}\theta_0$$
7679 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7680 fixed-point arithmetic, avoiding the chance of overflow while retaining
7683 The calculations will be performed in several registers that
7684 provide temporary storage for intermediate quantities.
7686 @<Other local variables for |solve_choices|@>=
7687 fraction aa,bb,cc,ff,acc; /* temporary registers */
7688 scaled dd,ee; /* likewise, but |scaled| */
7689 scaled lt,rt; /* tension values */
7691 @ @<Set up equation to match mock curvatures...@>=
7692 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7693 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7694 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7695 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7696 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7697 @<Calculate the values of $v_k$ and $w_k$@>;
7698 if ( left_type(s)==mp_end_cycle ) {
7699 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7703 @ Since tension values are never less than 3/4, the values |aa| and
7704 |bb| computed here are never more than 4/5.
7706 @<Calculate the values $\\{aa}=...@>=
7707 if ( abs(right_tension(r))==unity) {
7708 aa=fraction_half; dd=2*mp->delta[k];
7710 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7711 dd=mp_take_fraction(mp, mp->delta[k],
7712 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7714 if ( abs(left_tension(t))==unity ){
7715 bb=fraction_half; ee=2*mp->delta[k-1];
7717 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7718 ee=mp_take_fraction(mp, mp->delta[k-1],
7719 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7721 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7723 @ The ratio to be calculated in this step can be written in the form
7724 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7725 \\{cc}\cdot\\{dd},$$
7726 because of the quantities just calculated. The values of |dd| and |ee|
7727 will not be needed after this step has been performed.
7729 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7730 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7731 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7733 ff=mp_make_fraction(mp, lt,rt);
7734 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7735 dd=mp_take_fraction(mp, dd,ff);
7737 ff=mp_make_fraction(mp, rt,lt);
7738 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7739 ee=mp_take_fraction(mp, ee,ff);
7742 ff=mp_make_fraction(mp, ee,ee+dd)
7744 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7745 equation was specified by a curl. In that case we must use a special
7746 method of computation to prevent overflow.
7748 Fortunately, the calculations turn out to be even simpler in this ``hard''
7749 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7750 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7752 @<Calculate the values of $v_k$ and $w_k$@>=
7753 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7754 if ( right_type(r)==mp_curl ) {
7756 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7758 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7759 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7760 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7761 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7762 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7763 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7764 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7767 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7768 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7769 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7770 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7773 The idea in the following code is to observe that
7774 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7775 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7776 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7777 so we can solve for $\theta_n=\theta_0$.
7779 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7781 aa=0; bb=fraction_one; /* we have |k=n| */
7784 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7785 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7786 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7787 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7788 mp->theta[n]=aa; mp->vv[0]=aa;
7789 for (k=1;k<=n-1;k++) {
7790 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7795 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7796 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7798 @<Calculate the given value of $\theta_n$...@>=
7800 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7801 reduce_angle(mp->theta[n]);
7805 @ @<Set up the equation for a given value of $\theta_0$@>=
7807 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7808 reduce_angle(mp->vv[0]);
7809 mp->uu[0]=0; mp->ww[0]=0;
7812 @ @<Set up the equation for a curl at $\theta_0$@>=
7813 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7814 if ( (rt==unity)&&(lt==unity) )
7815 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7817 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7818 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7821 @ @<Set up equation for a curl at $\theta_n$...@>=
7822 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7823 if ( (rt==unity)&&(lt==unity) )
7824 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7826 ff=mp_curl_ratio(mp, cc,lt,rt);
7827 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7828 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7832 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7833 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7834 a somewhat tedious program to calculate
7835 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7836 \alpha^3\gamma+(3-\beta)\beta^2},$$
7837 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7838 is necessary only if the curl and tension are both large.)
7839 The values of $\alpha$ and $\beta$ will be at most~4/3.
7841 @<Declare subroutines needed by |solve_choices|@>=
7842 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7844 fraction alpha,beta,num,denom,ff; /* registers */
7845 alpha=mp_make_fraction(mp, unity,a_tension);
7846 beta=mp_make_fraction(mp, unity,b_tension);
7847 if ( alpha<=beta ) {
7848 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7849 gamma=mp_take_fraction(mp, gamma,ff);
7850 beta=beta / 010000; /* convert |fraction| to |scaled| */
7851 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7852 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7854 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7855 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7856 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7857 /* $1365\approx 2^{12}/3$ */
7858 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7860 if ( num>=denom+denom+denom+denom ) return fraction_four;
7861 else return mp_make_fraction(mp, num,denom);
7864 @ We're in the home stretch now.
7866 @<Finish choosing angles and assigning control points@>=
7867 for (k=n-1;k>=0;k--) {
7868 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7873 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7874 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7875 mp_set_controls(mp, s,t,k);
7879 @ The |set_controls| routine actually puts the control points into
7880 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7881 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7882 $\cos\phi$ needed in this calculation.
7888 fraction cf; /* sines and cosines */
7890 @ @<Declare subroutines needed by |solve_choices|@>=
7891 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7892 fraction rr,ss; /* velocities, divided by thrice the tension */
7893 scaled lt,rt; /* tensions */
7894 fraction sine; /* $\sin(\theta+\phi)$ */
7895 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7896 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7897 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7898 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7899 @<Decrease the velocities,
7900 if necessary, to stay inside the bounding triangle@>;
7902 right_x(p)=x_coord(p)+mp_take_fraction(mp,
7903 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7904 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7905 right_y(p)=y_coord(p)+mp_take_fraction(mp,
7906 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7907 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7908 left_x(q)=x_coord(q)-mp_take_fraction(mp,
7909 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7910 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7911 left_y(q)=y_coord(q)-mp_take_fraction(mp,
7912 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7913 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7914 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7917 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7918 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7919 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7920 there is no ``bounding triangle.''
7922 @<Decrease the velocities, if necessary...@>=
7923 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7924 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7925 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7927 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7928 if ( right_tension(p)<0 )
7929 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7930 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7931 if ( left_tension(q)<0 )
7932 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7933 ss=mp_make_fraction(mp, abs(mp->st),sine);
7937 @ Only the simple cases remain to be handled.
7939 @<Reduce to simple case of two givens and |return|@>=
7941 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7942 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7943 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7944 mp_set_controls(mp, p,q,0); return;
7947 @ @<Reduce to simple case of straight line and |return|@>=
7949 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7950 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7952 if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
7953 else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
7954 if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
7955 else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
7957 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7958 right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7959 right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7962 if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
7963 else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
7964 if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
7965 else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
7967 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7968 left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7969 left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7974 @* \[19] Measuring paths.
7975 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7976 allow the user to measure the bounding box of anything that can go into a
7977 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7978 by just finding the bounding box of the knots and the control points. We
7979 need a more accurate version of the bounding box, but we can still use the
7980 easy estimate to save time by focusing on the interesting parts of the path.
7982 @ Computing an accurate bounding box involves a theme that will come up again
7983 and again. Given a Bernshte{\u\i}n polynomial
7984 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
7985 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
7986 we can conveniently bisect its range as follows:
7989 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
7992 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
7993 |0<=k<n-j|, for |0<=j<n|.
7997 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
7998 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
7999 This formula gives us the coefficients of polynomials to use over the ranges
8000 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
8002 @ Now here's a subroutine that's handy for all sorts of path computations:
8003 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
8004 returns the unique |fraction| value |t| between 0 and~1 at which
8005 $B(a,b,c;t)$ changes from positive to negative, or returns
8006 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
8007 is already negative at |t=0|), |crossing_point| returns the value zero.
8009 @d no_crossing { return (fraction_one+1); }
8010 @d one_crossing { return fraction_one; }
8011 @d zero_crossing { return 0; }
8012 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
8014 @c fraction mp_do_crossing_point (integer a, integer b, integer c) {
8015 integer d; /* recursive counter */
8016 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
8017 if ( a<0 ) zero_crossing;
8020 if ( c>0 ) { no_crossing; }
8021 else if ( (a==0)&&(b==0) ) { no_crossing;}
8022 else { one_crossing; }
8024 if ( a==0 ) zero_crossing;
8025 } else if ( a==0 ) {
8026 if ( b<=0 ) zero_crossing;
8028 @<Use bisection to find the crossing point, if one exists@>;
8031 @ The general bisection method is quite simple when $n=2$, hence
8032 |crossing_point| does not take much time. At each stage in the
8033 recursion we have a subinterval defined by |l| and~|j| such that
8034 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
8035 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
8037 It is convenient for purposes of calculation to combine the values
8038 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
8039 of bisection then corresponds simply to doubling $d$ and possibly
8040 adding~1. Furthermore it proves to be convenient to modify
8041 our previous conventions for bisection slightly, maintaining the
8042 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
8043 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
8044 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
8046 The following code maintains the invariant relations
8047 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
8048 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
8049 it has been constructed in such a way that no arithmetic overflow
8050 will occur if the inputs satisfy
8051 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
8053 @<Use bisection to find the crossing point...@>=
8054 d=1; x0=a; x1=a-b; x2=b-c;
8065 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
8069 } while (d<fraction_one);
8070 return (d-fraction_one)
8072 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
8073 a cubic corresponding to the |fraction| value~|t|.
8075 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
8076 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
8078 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
8080 @c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
8081 scaled x1,x2,x3; /* intermediate values */
8082 x1=t_of_the_way(knot_coord(p),right_coord(p));
8083 x2=t_of_the_way(right_coord(p),left_coord(q));
8084 x3=t_of_the_way(left_coord(q),knot_coord(q));
8085 x1=t_of_the_way(x1,x2);
8086 x2=t_of_the_way(x2,x3);
8087 return t_of_the_way(x1,x2);
8090 @ The actual bounding box information is stored in global variables.
8091 Since it is convenient to address the $x$ and $y$ information
8092 separately, we define arrays indexed by |x_code..y_code| and use
8093 macros to give them more convenient names.
8097 mp_x_code=0, /* index for |minx| and |maxx| */
8098 mp_y_code /* index for |miny| and |maxy| */
8102 @d minx mp->bbmin[mp_x_code]
8103 @d maxx mp->bbmax[mp_x_code]
8104 @d miny mp->bbmin[mp_y_code]
8105 @d maxy mp->bbmax[mp_y_code]
8108 scaled bbmin[mp_y_code+1];
8109 scaled bbmax[mp_y_code+1];
8110 /* the result of procedures that compute bounding box information */
8112 @ Now we're ready for the key part of the bounding box computation.
8113 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
8114 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
8115 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8117 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8118 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8119 The |c| parameter is |x_code| or |y_code|.
8121 @c void mp_bound_cubic (MP mp,pointer p, pointer q, small_number c) {
8122 boolean wavy; /* whether we need to look for extremes */
8123 scaled del1,del2,del3,del,dmax; /* proportional to the control
8124 points of a quadratic derived from a cubic */
8125 fraction t,tt; /* where a quadratic crosses zero */
8126 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8128 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8129 @<Check the control points against the bounding box and set |wavy:=true|
8130 if any of them lie outside@>;
8132 del1=right_coord(p)-knot_coord(p);
8133 del2=left_coord(q)-right_coord(p);
8134 del3=knot_coord(q)-left_coord(q);
8135 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8136 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8138 negate(del1); negate(del2); negate(del3);
8140 t=mp_crossing_point(mp, del1,del2,del3);
8141 if ( t<fraction_one ) {
8142 @<Test the extremes of the cubic against the bounding box@>;
8147 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8148 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8149 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8151 @ @<Check the control points against the bounding box and set...@>=
8153 if ( mp->bbmin[c]<=right_coord(p) )
8154 if ( right_coord(p)<=mp->bbmax[c] )
8155 if ( mp->bbmin[c]<=left_coord(q) )
8156 if ( left_coord(q)<=mp->bbmax[c] )
8159 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8160 section. We just set |del=0| in that case.
8162 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8163 if ( del1!=0 ) del=del1;
8164 else if ( del2!=0 ) del=del2;
8168 if ( abs(del2)>dmax ) dmax=abs(del2);
8169 if ( abs(del3)>dmax ) dmax=abs(del3);
8170 while ( dmax<fraction_half ) {
8171 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8175 @ Since |crossing_point| has tried to choose |t| so that
8176 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8177 slope, the value of |del2| computed below should not be positive.
8178 But rounding error could make it slightly positive in which case we
8179 must cut it to zero to avoid confusion.
8181 @<Test the extremes of the cubic against the bounding box@>=
8183 x=mp_eval_cubic(mp, p,q,t);
8184 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8185 del2=t_of_the_way(del2,del3);
8186 /* now |0,del2,del3| represent the derivative on the remaining interval */
8187 if ( del2>0 ) del2=0;
8188 tt=mp_crossing_point(mp, 0,-del2,-del3);
8189 if ( tt<fraction_one ) {
8190 @<Test the second extreme against the bounding box@>;
8194 @ @<Test the second extreme against the bounding box@>=
8196 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8197 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8200 @ Finding the bounding box of a path is basically a matter of applying
8201 |bound_cubic| twice for each pair of adjacent knots.
8203 @c void mp_path_bbox (MP mp,pointer h) {
8204 pointer p,q; /* a pair of adjacent knots */
8205 minx=x_coord(h); miny=y_coord(h);
8206 maxx=minx; maxy=miny;
8209 if ( right_type(p)==mp_endpoint ) return;
8211 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8212 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8217 @ Another important way to measure a path is to find its arc length. This
8218 is best done by using the general bisection algorithm to subdivide the path
8219 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8222 Since the arc length is the integral with respect to time of the magnitude of
8223 the velocity, it is natural to use Simpson's rule for the approximation.
8225 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8226 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8227 for the arc length of a path of length~1. For a cubic spline
8228 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8229 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8231 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8233 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8234 is the result of the bisection algorithm.
8236 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8237 This could be done via the theoretical error bound for Simpson's rule,
8239 but this is impractical because it requires an estimate of the fourth
8240 derivative of the quantity being integrated. It is much easier to just perform
8241 a bisection step and see how much the arc length estimate changes. Since the
8242 error for Simpson's rule is proportional to the fourth power of the sample
8243 spacing, the remaining error is typically about $1\over16$ of the amount of
8244 the change. We say ``typically'' because the error has a pseudo-random behavior
8245 that could cause the two estimates to agree when each contain large errors.
8247 To protect against disasters such as undetected cusps, the bisection process
8248 should always continue until all the $dz_i$ vectors belong to a single
8249 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8250 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8251 If such a spline happens to produce an erroneous arc length estimate that
8252 is little changed by bisection, the amount of the error is likely to be fairly
8253 small. We will try to arrange things so that freak accidents of this type do
8254 not destroy the inverse relationship between the \&{arclength} and
8255 \&{arctime} operations.
8256 @:arclength_}{\&{arclength} primitive@>
8257 @:arctime_}{\&{arctime} primitive@>
8259 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8261 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8262 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8263 returns the time when the arc length reaches |a_goal| if there is such a time.
8264 Thus the return value is either an arc length less than |a_goal| or, if the
8265 arc length would be at least |a_goal|, it returns a time value decreased by
8266 |two|. This allows the caller to use the sign of the result to distinguish
8267 between arc lengths and time values. On certain types of overflow, it is
8268 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8269 Otherwise, the result is always less than |a_goal|.
8271 Rather than halving the control point coordinates on each recursive call to
8272 |arc_test|, it is better to keep them proportional to velocity on the original
8273 curve and halve the results instead. This means that recursive calls can
8274 potentially use larger error tolerances in their arc length estimates. How
8275 much larger depends on to what extent the errors behave as though they are
8276 independent of each other. To save computing time, we use optimistic assumptions
8277 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8280 In addition to the tolerance parameter, |arc_test| should also have parameters
8281 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8282 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8283 and they are needed in different instances of |arc_test|.
8285 @c @<Declare subroutines needed by |arc_test|@>
8286 scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8287 scaled dx2, scaled dy2, scaled v0, scaled v02,
8288 scaled v2, scaled a_goal, scaled tol) {
8289 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8290 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8292 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8293 scaled arc; /* best arc length estimate before recursion */
8294 @<Other local variables in |arc_test|@>;
8295 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8297 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8298 set |arc_test| and |return|@>;
8299 @<Test if the control points are confined to one quadrant or rotating them
8300 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8301 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8302 if ( arc < a_goal ) {
8305 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8306 that time minus |two|@>;
8309 @<Use one or two recursive calls to compute the |arc_test| function@>;
8313 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8314 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8315 |make_fraction| in this inner loop.
8318 @<Use one or two recursive calls to compute the |arc_test| function@>=
8320 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8321 large as possible@>;
8322 tol = tol + halfp(tol);
8323 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8324 halfp(v02), a_new, tol);
8326 return (-halfp(two-a));
8328 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8329 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8330 halfp(v02), v022, v2, a_new, tol);
8332 return (-halfp(-b) - half_unit);
8334 return (a + half(b-a));
8338 @ @<Other local variables in |arc_test|@>=
8339 scaled a,b; /* results of recursive calls */
8340 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8342 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8343 a_aux = el_gordo - a_goal;
8344 if ( a_goal > a_aux ) {
8345 a_aux = a_goal - a_aux;
8348 a_new = a_goal + a_goal;
8352 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8353 to force the additions and subtractions to be done in an order that avoids
8356 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8359 a_new = a_new + a_aux;
8362 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8363 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8364 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8365 this bound. Note that recursive calls will maintain this invariant.
8367 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8368 dx01 = half(dx0 + dx1);
8369 dx12 = half(dx1 + dx2);
8370 dx02 = half(dx01 + dx12);
8371 dy01 = half(dy0 + dy1);
8372 dy12 = half(dy1 + dy2);
8373 dy02 = half(dy01 + dy12)
8375 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8376 |a_goal=el_gordo| is guaranteed to yield the arc length.
8378 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8379 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8380 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8382 arc1 = v002 + half(halfp(v0+tmp) - v002);
8383 arc = v022 + half(halfp(v2+tmp) - v022);
8384 if ( (arc < el_gordo-arc1) ) {
8387 mp->arith_error = true;
8388 if ( a_goal==el_gordo ) return (el_gordo);
8392 @ @<Other local variables in |arc_test|@>=
8393 scaled tmp, tmp2; /* all purpose temporary registers */
8394 scaled arc1; /* arc length estimate for the first half */
8396 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8397 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8398 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8400 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8401 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8403 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8404 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8406 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8407 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8410 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8412 it is appropriate to use the same approximation to decide when the integral
8413 reaches the intermediate value |a_goal|. At this point
8415 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8416 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8417 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8418 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8419 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8423 $$ {\vb\dot B(t)\vb\over 3} \approx
8424 \cases{B\left(\hbox{|v0|},
8425 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8426 {1\over 2}\hbox{|v02|}; 2t \right)&
8427 if $t\le{1\over 2}$\cr
8428 B\left({1\over 2}\hbox{|v02|},
8429 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8430 \hbox{|v2|}; 2t-1 \right)&
8431 if $t\ge{1\over 2}$.\cr}
8434 We can integrate $\vb\dot B(t)\vb$ by using
8435 $$\int 3B(a,b,c;\tau)\,dt =
8436 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8439 This construction allows us to find the time when the arc length reaches
8440 |a_goal| by solving a cubic equation of the form
8441 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8442 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8443 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8444 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8445 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8446 $\tau$ given $a$, $b$, $c$, and $x$.
8448 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8450 tmp = (v02 + 2) / 4;
8451 if ( a_goal<=arc1 ) {
8454 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8457 return ((half_unit - two) +
8458 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8462 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8463 $$ B(0, a, a+b, a+b+c; t) = x. $$
8464 This routine is based on |crossing_point| but is simplified by the
8465 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8466 If rounding error causes this condition to be violated slightly, we just ignore
8467 it and proceed with binary search. This finds a time when the function value
8468 reaches |x| and the slope is positive.
8470 @<Declare subroutines needed by |arc_test|@>=
8471 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8472 scaled ab, bc, ac; /* bisection results */
8473 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8474 integer xx; /* temporary for updating |x| */
8475 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8476 @:this can't happen rising?}{\quad rising?@>
8479 } else if ( x >= a+b+c ) {
8483 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8487 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8488 xx = x - a - ab - ac;
8489 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8490 else { x = x + xx; a=ac; b=bc; t = t+1; };
8491 } while (t < unity);
8496 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8501 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8503 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8504 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8511 @ It is convenient to have a simpler interface to |arc_test| that requires no
8512 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8513 length less than |fraction_four|.
8515 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8517 @c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8518 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8519 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8520 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8521 v0 = mp_pyth_add(mp, dx0,dy0);
8522 v1 = mp_pyth_add(mp, dx1,dy1);
8523 v2 = mp_pyth_add(mp, dx2,dy2);
8524 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8525 mp->arith_error = true;
8526 if ( a_goal==el_gordo ) return el_gordo;
8529 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8530 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8531 v0, v02, v2, a_goal, arc_tol));
8535 @ Now it is easy to find the arc length of an entire path.
8537 @c scaled mp_get_arc_length (MP mp,pointer h) {
8538 pointer p,q; /* for traversing the path */
8539 scaled a,a_tot; /* current and total arc lengths */
8542 while ( right_type(p)!=mp_endpoint ){
8544 a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8545 left_x(q)-right_x(p), left_y(q)-right_y(p),
8546 x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
8547 a_tot = mp_slow_add(mp, a, a_tot);
8548 if ( q==h ) break; else p=q;
8554 @ The inverse operation of finding the time on a path~|h| when the arc length
8555 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8556 is required to handle very large times or negative times on cyclic paths. For
8557 non-cyclic paths, |arc0| values that are negative or too large cause
8558 |get_arc_time| to return 0 or the length of path~|h|.
8560 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8561 time value greater than the length of the path. Since it could be much greater,
8562 we must be prepared to compute the arc length of path~|h| and divide this into
8563 |arc0| to find how many multiples of the length of path~|h| to add.
8565 @c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8566 pointer p,q; /* for traversing the path */
8567 scaled t_tot; /* accumulator for the result */
8568 scaled t; /* the result of |do_arc_test| */
8569 scaled arc; /* portion of |arc0| not used up so far */
8570 integer n; /* number of extra times to go around the cycle */
8572 @<Deal with a negative |arc0| value and |return|@>;
8574 if ( arc0==el_gordo ) decr(arc0);
8578 while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
8580 t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8581 left_x(q)-right_x(p), left_y(q)-right_y(p),
8582 x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
8583 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8585 @<Update |t_tot| and |arc| to avoid going around the cyclic
8586 path too many times but set |arith_error:=true| and |goto done| on
8595 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8596 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8597 else { t_tot = t_tot + unity; arc = arc - t; }
8599 @ @<Deal with a negative |arc0| value and |return|@>=
8601 if ( left_type(h)==mp_endpoint ) {
8604 p = mp_htap_ypoc(mp, h);
8605 t_tot = -mp_get_arc_time(mp, p, -arc0);
8606 mp_toss_knot_list(mp, p);
8612 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8614 n = arc / (arc0 - arc);
8615 arc = arc - n*(arc0 - arc);
8616 if ( t_tot > (el_gordo / (n+1)) ) {
8619 t_tot = (n + 1)*t_tot;
8622 @* \[20] Data structures for pens.
8623 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8624 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8625 @:stroke}{\&{stroke} command@>
8626 converted into an area fill as described in the next part of this program.
8627 The mathematics behind this process is based on simple aspects of the theory
8628 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8629 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8630 Foundations of Computer Science {\bf 24} (1983), 100--111].
8632 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8633 @:makepen_}{\&{makepen} primitive@>
8634 This path representation is almost sufficient for our purposes except that
8635 a pen path should always be a convex polygon with the vertices in
8636 counter-clockwise order.
8637 Since we will need to scan pen polygons both forward and backward, a pen
8638 should be represented as a doubly linked ring of knot nodes. There is
8639 room for the extra back pointer because we do not need the
8640 |left_type| or |right_type| fields. In fact, we don't need the |left_x|,
8641 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
8642 so that certain procedures can operate on both pens and paths. In particular,
8643 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8646 /* this replaces the |left_type| and |right_type| fields in a pen knot */
8648 @ The |make_pen| procedure turns a path into a pen by initializing
8649 the |knil| pointers and making sure the knots form a convex polygon.
8650 Thus each cubic in the given path becomes a straight line and the control
8651 points are ignored. If the path is not cyclic, the ends are connected by a
8654 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8656 @c @<Declare a function called |convex_hull|@>
8657 pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8658 pointer p,q; /* two consecutive knots */
8665 h=mp_convex_hull(mp, h);
8666 @<Make sure |h| isn't confused with an elliptical pen@>;
8671 @ The only information required about an elliptical pen is the overall
8672 transformation that has been applied to the original \&{pencircle}.
8673 @:pencircle_}{\&{pencircle} primitive@>
8674 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8675 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8676 knot node and transformed as if it were a path.
8678 @d pen_is_elliptical(A) ((A)==link((A)))
8680 @c pointer mp_get_pen_circle (MP mp,scaled diam) {
8681 pointer h; /* the knot node to return */
8682 h=mp_get_node(mp, knot_node_size);
8683 link(h)=h; knil(h)=h;
8684 originator(h)=mp_program_code;
8685 x_coord(h)=0; y_coord(h)=0;
8686 left_x(h)=diam; left_y(h)=0;
8687 right_x(h)=0; right_y(h)=diam;
8691 @ If the polygon being returned by |make_pen| has only one vertex, it will
8692 be interpreted as an elliptical pen. This is no problem since a degenerate
8693 polygon can equally well be thought of as a degenerate ellipse. We need only
8694 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
8696 @<Make sure |h| isn't confused with an elliptical pen@>=
8697 if ( pen_is_elliptical( h) ){
8698 left_x(h)=x_coord(h); left_y(h)=y_coord(h);
8699 right_x(h)=x_coord(h); right_y(h)=y_coord(h);
8702 @ We have to cheat a little here but most operations on pens only use
8703 the first three words in each knot node.
8704 @^data structure assumptions@>
8706 @<Initialize a pen at |test_pen| so that it fits in nine words@>=
8707 x_coord(test_pen)=-half_unit;
8708 y_coord(test_pen)=0;
8709 x_coord(test_pen+3)=half_unit;
8710 y_coord(test_pen+3)=0;
8711 x_coord(test_pen+6)=0;
8712 y_coord(test_pen+6)=unity;
8713 link(test_pen)=test_pen+3;
8714 link(test_pen+3)=test_pen+6;
8715 link(test_pen+6)=test_pen;
8716 knil(test_pen)=test_pen+6;
8717 knil(test_pen+3)=test_pen;
8718 knil(test_pen+6)=test_pen+3
8720 @ Printing a polygonal pen is very much like printing a path
8722 @<Declare subroutines for printing expressions@>=
8723 void mp_pr_pen (MP mp,pointer h) {
8724 pointer p,q; /* for list traversal */
8725 if ( pen_is_elliptical(h) ) {
8726 @<Print the elliptical pen |h|@>;
8730 mp_print_two(mp, x_coord(p),y_coord(p));
8731 mp_print_nl(mp, " .. ");
8732 @<Advance |p| making sure the links are OK and |return| if there is
8735 mp_print(mp, "cycle");
8739 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8741 if ( (q==null) || (knil(q)!=p) ) {
8742 mp_print_nl(mp, "???"); return; /* this won't happen */
8747 @ @<Print the elliptical pen |h|@>=
8749 mp_print(mp, "pencircle transformed (");
8750 mp_print_scaled(mp, x_coord(h));
8751 mp_print_char(mp, ',');
8752 mp_print_scaled(mp, y_coord(h));
8753 mp_print_char(mp, ',');
8754 mp_print_scaled(mp, left_x(h)-x_coord(h));
8755 mp_print_char(mp, ',');
8756 mp_print_scaled(mp, right_x(h)-x_coord(h));
8757 mp_print_char(mp, ',');
8758 mp_print_scaled(mp, left_y(h)-y_coord(h));
8759 mp_print_char(mp, ',');
8760 mp_print_scaled(mp, right_y(h)-y_coord(h));
8761 mp_print_char(mp, ')');
8764 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8767 @<Declare subroutines for printing expressions@>=
8768 void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
8769 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8772 mp_end_diagnostic(mp, true);
8775 @ Making a polygonal pen into a path involves restoring the |left_type| and
8776 |right_type| fields and setting the control points so as to make a polygonal
8780 void mp_make_path (MP mp,pointer h) {
8781 pointer p; /* for traversing the knot list */
8782 small_number k; /* a loop counter */
8783 @<Other local variables in |make_path|@>;
8784 if ( pen_is_elliptical(h) ) {
8785 @<Make the elliptical pen |h| into a path@>;
8789 left_type(p)=mp_explicit;
8790 right_type(p)=mp_explicit;
8791 @<copy the coordinates of knot |p| into its control points@>;
8797 @ @<copy the coordinates of knot |p| into its control points@>=
8798 left_x(p)=x_coord(p);
8799 left_y(p)=y_coord(p);
8800 right_x(p)=x_coord(p);
8801 right_y(p)=y_coord(p)
8803 @ We need an eight knot path to get a good approximation to an ellipse.
8805 @<Make the elliptical pen |h| into a path@>=
8807 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8809 for (k=0;k<=7;k++ ) {
8810 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8811 transforming it appropriately@>;
8812 if ( k==7 ) link(p)=h; else link(p)=mp_get_node(mp, knot_node_size);
8817 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8818 center_x=x_coord(h);
8819 center_y=y_coord(h);
8820 width_x=left_x(h)-center_x;
8821 width_y=left_y(h)-center_y;
8822 height_x=right_x(h)-center_x;
8823 height_y=right_y(h)-center_y
8825 @ @<Other local variables in |make_path|@>=
8826 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8827 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8828 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8829 scaled dx,dy; /* the vector from knot |p| to its right control point */
8831 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8833 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8834 find the point $k/8$ of the way around the circle and the direction vector
8837 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8839 x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8840 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8841 y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8842 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8843 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8844 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8845 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8846 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8847 right_x(p)=x_coord(p)+dx;
8848 right_y(p)=y_coord(p)+dy;
8849 left_x(p)=x_coord(p)-dx;
8850 left_y(p)=y_coord(p)-dy;
8851 left_type(p)=mp_explicit;
8852 right_type(p)=mp_explicit;
8853 originator(p)=mp_program_code
8856 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8857 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8859 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8860 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8861 function for $\theta=\phi=22.5^\circ$. This comes out to be
8862 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8863 \approx 0.132608244919772.
8867 mp->half_cos[0]=fraction_half;
8868 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8870 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8871 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8873 for (k=3;k<= 4;k++ ) {
8874 mp->half_cos[k]=-mp->half_cos[4-k];
8875 mp->d_cos[k]=-mp->d_cos[4-k];
8877 for (k=5;k<= 7;k++ ) {
8878 mp->half_cos[k]=mp->half_cos[8-k];
8879 mp->d_cos[k]=mp->d_cos[8-k];
8882 @ The |convex_hull| function forces a pen polygon to be convex when it is
8883 returned by |make_pen| and after any subsequent transformation where rounding
8884 error might allow the convexity to be lost.
8885 The convex hull algorithm used here is described by F.~P. Preparata and
8886 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8888 @<Declare a function called |convex_hull|@>=
8889 @<Declare a procedure called |move_knot|@>
8890 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8891 pointer l,r; /* the leftmost and rightmost knots */
8892 pointer p,q; /* knots being scanned */
8893 pointer s; /* the starting point for an upcoming scan */
8894 scaled dx,dy; /* a temporary pointer */
8895 if ( pen_is_elliptical(h) ) {
8898 @<Set |l| to the leftmost knot in polygon~|h|@>;
8899 @<Set |r| to the rightmost knot in polygon~|h|@>;
8902 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8903 move them past~|r|@>;
8904 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8905 move them past~|l|@>;
8906 @<Sort the path from |l| to |r| by increasing $x$@>;
8907 @<Sort the path from |r| to |l| by decreasing $x$@>;
8910 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8916 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8918 @<Set |l| to the leftmost knot in polygon~|h|@>=
8922 if ( x_coord(p)<=x_coord(l) )
8923 if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
8928 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8932 if ( x_coord(p)>=x_coord(r) )
8933 if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
8938 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8939 dx=x_coord(r)-x_coord(l);
8940 dy=y_coord(r)-y_coord(l);
8944 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
8945 mp_move_knot(mp, p, r);
8949 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8952 @ @<Declare a procedure called |move_knot|@>=
8953 void mp_move_knot (MP mp,pointer p, pointer q) {
8954 link(knil(p))=link(p);
8955 knil(link(p))=knil(p);
8962 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8966 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
8967 mp_move_knot(mp, p,l);
8971 @ The list is likely to be in order already so we just do linear insertions.
8972 Secondary comparisons on $y$ ensure that the sort is consistent with the
8973 choice of |l| and |r|.
8975 @<Sort the path from |l| to |r| by increasing $x$@>=
8979 while ( x_coord(q)>x_coord(p) ) q=knil(q);
8980 while ( x_coord(q)==x_coord(p) ) {
8981 if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
8983 if ( q==knil(p) ) p=link(p);
8984 else { p=link(p); mp_move_knot(mp, knil(p),q); };
8987 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
8991 while ( x_coord(q)<x_coord(p) ) q=knil(q);
8992 while ( x_coord(q)==x_coord(p) ) {
8993 if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
8995 if ( q==knil(p) ) p=link(p);
8996 else { p=link(p); mp_move_knot(mp, knil(p),q); };
8999 @ The condition involving |ab_vs_cd| tests if there is not a left turn
9000 at knot |q|. There usually will be a left turn so we streamline the case
9001 where the |then| clause is not executed.
9003 @<Do a Gramm scan and remove vertices where there...@>=
9007 dx=x_coord(q)-x_coord(p);
9008 dy=y_coord(q)-y_coord(p);
9012 if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
9013 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
9018 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
9021 mp_free_node(mp, p,knot_node_size);
9022 link(s)=q; knil(q)=s;
9024 else { p=knil(s); q=s; };
9027 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
9028 offset associated with the given direction |(x,y)|. If two different offsets
9029 apply, it chooses one of them.
9032 void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
9033 pointer p,q; /* consecutive knots */
9035 /* the transformation matrix for an elliptical pen */
9036 fraction xx,yy; /* untransformed offset for an elliptical pen */
9037 fraction d; /* a temporary register */
9038 if ( pen_is_elliptical(h) ) {
9039 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
9044 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
9047 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
9048 mp->cur_x=x_coord(p);
9049 mp->cur_y=y_coord(p);
9055 scaled cur_y; /* all-purpose return value registers */
9057 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
9058 if ( (x==0) && (y==0) ) {
9059 mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
9061 @<Find the non-constant part of the transformation for |h|@>;
9062 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
9065 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
9066 untransformed version of |(x,y)|@>;
9067 mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
9068 mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
9071 @ @<Find the non-constant part of the transformation for |h|@>=
9072 wx=left_x(h)-x_coord(h);
9073 wy=left_y(h)-y_coord(h);
9074 hx=right_x(h)-x_coord(h);
9075 hy=right_y(h)-y_coord(h)
9077 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
9078 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
9079 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
9080 d=mp_pyth_add(mp, xx,yy);
9082 xx=half(mp_make_fraction(mp, xx,d));
9083 yy=half(mp_make_fraction(mp, yy,d));
9086 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
9087 But we can handle that case by just calling |find_offset| twice. The answer
9088 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
9091 void mp_pen_bbox (MP mp,pointer h) {
9092 pointer p; /* for scanning the knot list */
9093 if ( pen_is_elliptical(h) ) {
9094 @<Find the bounding box of an elliptical pen@>;
9096 minx=x_coord(h); maxx=minx;
9097 miny=y_coord(h); maxy=miny;
9100 if ( x_coord(p)<minx ) minx=x_coord(p);
9101 if ( y_coord(p)<miny ) miny=y_coord(p);
9102 if ( x_coord(p)>maxx ) maxx=x_coord(p);
9103 if ( y_coord(p)>maxy ) maxy=y_coord(p);
9109 @ @<Find the bounding box of an elliptical pen@>=
9111 mp_find_offset(mp, 0,fraction_one,h);
9113 minx=2*x_coord(h)-mp->cur_x;
9114 mp_find_offset(mp, -fraction_one,0,h);
9116 miny=2*y_coord(h)-mp->cur_y;
9119 @* \[21] Edge structures.
9120 Now we come to \MP's internal scheme for representing pictures.
9121 The representation is very different from \MF's edge structures
9122 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9123 images. However, the basic idea is somewhat similar in that shapes
9124 are represented via their boundaries.
9126 The main purpose of edge structures is to keep track of graphical objects
9127 until it is time to translate them into \ps. Since \MP\ does not need to
9128 know anything about an edge structure other than how to translate it into
9129 \ps\ and how to find its bounding box, edge structures can be just linked
9130 lists of graphical objects. \MP\ has no easy way to determine whether
9131 two such objects overlap, but it suffices to draw the first one first and
9132 let the second one overwrite it if necessary.
9135 enum mp_graphical_object_code {
9136 @<Graphical object codes@>
9140 @ Let's consider the types of graphical objects one at a time.
9141 First of all, a filled contour is represented by a eight-word node. The first
9142 word contains |type| and |link| fields, and the next six words contain a
9143 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9144 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9145 give the relevant information.
9147 @d path_p(A) link((A)+1)
9148 /* a pointer to the path that needs filling */
9149 @d pen_p(A) info((A)+1)
9150 /* a pointer to the pen to fill or stroke with */
9151 @d color_model(A) type((A)+2) /* the color model */
9152 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9153 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9154 @d obj_grey_loc obj_red_loc /* the location for the color */
9155 @d red_val(A) mp->mem[(A)+3].sc
9156 /* the red component of the color in the range $0\ldots1$ */
9159 @d green_val(A) mp->mem[(A)+4].sc
9160 /* the green component of the color in the range $0\ldots1$ */
9161 @d magenta_val green_val
9162 @d blue_val(A) mp->mem[(A)+5].sc
9163 /* the blue component of the color in the range $0\ldots1$ */
9164 @d yellow_val blue_val
9165 @d black_val(A) mp->mem[(A)+6].sc
9166 /* the blue component of the color in the range $0\ldots1$ */
9167 @d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
9168 @:mp_linejoin_}{\&{linejoin} primitive@>
9169 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9170 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9171 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9172 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9173 @d pre_script(A) mp->mem[(A)+8].hh.lh
9174 @d post_script(A) mp->mem[(A)+8].hh.rh
9177 @ @<Graphical object codes@>=
9181 pointer mp_new_fill_node (MP mp,pointer p) {
9182 /* make a fill node for cyclic path |p| and color black */
9183 pointer t; /* the new node */
9184 t=mp_get_node(mp, fill_node_size);
9185 type(t)=mp_fill_code;
9187 pen_p(t)=null; /* |null| means don't use a pen */
9192 color_model(t)=mp_uninitialized_model;
9194 post_script(t)=null;
9195 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9199 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9200 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9201 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9202 else ljoin_val(t)=0;
9203 if ( mp->internal[mp_miterlimit]<unity )
9204 miterlim_val(t)=unity;
9206 miterlim_val(t)=mp->internal[mp_miterlimit]
9208 @ A stroked path is represented by an eight-word node that is like a filled
9209 contour node except that it contains the current \&{linecap} value, a scale
9210 factor for the dash pattern, and a pointer that is non-null if the stroke
9211 is to be dashed. The purpose of the scale factor is to allow a picture to
9212 be transformed without touching the picture that |dash_p| points to.
9214 @d dash_p(A) link((A)+9)
9215 /* a pointer to the edge structure that gives the dash pattern */
9216 @d lcap_val(A) type((A)+9)
9217 /* the value of \&{linecap} */
9218 @:mp_linecap_}{\&{linecap} primitive@>
9219 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9220 @d stroked_node_size 11
9222 @ @<Graphical object codes@>=
9226 pointer mp_new_stroked_node (MP mp,pointer p) {
9227 /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
9228 pointer t; /* the new node */
9229 t=mp_get_node(mp, stroked_node_size);
9230 type(t)=mp_stroked_code;
9231 path_p(t)=p; pen_p(t)=null;
9233 dash_scale(t)=unity;
9238 color_model(t)=mp_uninitialized_model;
9240 post_script(t)=null;
9241 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9242 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9243 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9248 @ When a dashed line is computed in a transformed coordinate system, the dash
9249 lengths get scaled like the pen shape and we need to compensate for this. Since
9250 there is no unique scale factor for an arbitrary transformation, we use the
9251 the square root of the determinant. The properties of the determinant make it
9252 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9253 except for the initialization of the scale factor |s|. The factor of 64 is
9254 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9255 to counteract the effect of |take_fraction|.
9257 @<Declare subroutines needed by |print_edges|@>=
9258 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9259 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9260 integer s; /* amount by which the result of |square_rt| needs to be scaled */
9261 @<Initialize |maxabs|@>;
9263 while ( (maxabs<fraction_one) && (s>1) ){
9264 a+=a; b+=b; c+=c; d+=d;
9265 maxabs+=maxabs; s=halfp(s);
9267 return s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)));
9270 scaled mp_get_pen_scale (MP mp,pointer p) {
9271 return mp_sqrt_det(mp,
9272 left_x(p)-x_coord(p), right_x(p)-x_coord(p),
9273 left_y(p)-y_coord(p), right_y(p)-y_coord(p));
9276 @ @<Internal library ...@>=
9277 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9280 @ @<Initialize |maxabs|@>=
9282 if ( abs(b)>maxabs ) maxabs=abs(b);
9283 if ( abs(c)>maxabs ) maxabs=abs(c);
9284 if ( abs(d)>maxabs ) maxabs=abs(d)
9286 @ When a picture contains text, this is represented by a fourteen-word node
9287 where the color information and |type| and |link| fields are augmented by
9288 additional fields that describe the text and how it is transformed.
9289 The |path_p| and |pen_p| pointers are replaced by a number that identifies
9290 the font and a string number that gives the text to be displayed.
9291 The |width|, |height|, and |depth| fields
9292 give the dimensions of the text at its design size, and the remaining six
9293 words give a transformation to be applied to the text. The |new_text_node|
9294 function initializes everything to default values so that the text comes out
9295 black with its reference point at the origin.
9297 @d text_p(A) link((A)+1) /* a string pointer for the text to display */
9298 @d font_n(A) info((A)+1) /* the font number */
9299 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9300 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9301 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9302 @d text_tx_loc(A) ((A)+11)
9303 /* the first of six locations for transformation parameters */
9304 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9305 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9306 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9307 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9308 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9309 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9310 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9311 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9312 @d text_node_size 17
9314 @ @<Graphical object codes@>=
9317 @ @c @<Declare text measuring subroutines@>
9318 pointer mp_new_text_node (MP mp,char *f,str_number s) {
9319 /* make a text node for font |f| and text string |s| */
9320 pointer t; /* the new node */
9321 t=mp_get_node(mp, text_node_size);
9322 type(t)=mp_text_code;
9324 font_n(t)=mp_find_font(mp, f); /* this identifies the font */
9329 color_model(t)=mp_uninitialized_model;
9331 post_script(t)=null;
9332 tx_val(t)=0; ty_val(t)=0;
9333 txx_val(t)=unity; txy_val(t)=0;
9334 tyx_val(t)=0; tyy_val(t)=unity;
9335 mp_set_text_box(mp, t); /* this finds the bounding box */
9339 @ The last two types of graphical objects that can occur in an edge structure
9340 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9341 @:set_bounds_}{\&{setbounds} primitive@>
9342 to implement because we must keep track of exactly what is being clipped or
9343 bounded when pictures get merged together. For this reason, each clipping or
9344 \&{setbounds} operation is represented by a pair of nodes: first comes a
9345 two-word node whose |path_p| gives the relevant path, then there is the list
9346 of objects to clip or bound followed by a two-word node whose second word is
9349 Using at least two words for each graphical object node allows them all to be
9350 allocated and deallocated similarly with a global array |gr_object_size| to
9351 give the size in words for each object type.
9353 @d start_clip_size 2
9354 @d start_bounds_size 2
9355 @d stop_clip_size 2 /* the second word is not used here */
9356 @d stop_bounds_size 2 /* the second word is not used here */
9358 @d stop_type(A) ((A)+2)
9359 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9360 @d has_color(A) (type((A))<mp_start_clip_code)
9361 /* does a graphical object have color fields? */
9362 @d has_pen(A) (type((A))<mp_text_code)
9363 /* does a graphical object have a |pen_p| field? */
9364 @d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
9365 @d is_stop(A) (type((A))>=mp_stop_clip_code)
9367 @ @<Graphical object codes@>=
9368 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9369 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9370 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9371 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9374 pointer mp_new_bounds_node (MP mp,pointer p, small_number c) {
9375 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9376 pointer t; /* the new node */
9377 t=mp_get_node(mp, mp->gr_object_size[c]);
9383 @ We need an array to keep track of the sizes of graphical objects.
9386 small_number gr_object_size[mp_stop_bounds_code+1];
9389 mp->gr_object_size[mp_fill_code]=fill_node_size;
9390 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9391 mp->gr_object_size[mp_text_code]=text_node_size;
9392 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9393 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9394 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9395 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9397 @ All the essential information in an edge structure is encoded as a linked list
9398 of graphical objects as we have just seen, but it is helpful to add some
9399 redundant information. A single edge structure might be used as a dash pattern
9400 many times, and it would be nice to avoid scanning the same structure
9401 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9402 has a header that gives a list of dashes in a sorted order designed for rapid
9403 translation into \ps.
9405 Each dash is represented by a three-word node containing the initial and final
9406 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9407 the dash node with the next higher $x$-coordinates and the final link points
9408 to a special location called |null_dash|. (There should be no overlap between
9409 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9410 the period of repetition, this needs to be stored in the edge header along
9411 with a pointer to the list of dash nodes.
9413 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9414 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9417 /* in an edge header this points to the first dash node */
9418 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9420 @ It is also convenient for an edge header to contain the bounding
9421 box information needed by the \&{llcorner} and \&{urcorner} operators
9422 so that this does not have to be recomputed unnecessarily. This is done by
9423 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9424 how far the bounding box computation has gotten. Thus if the user asks for
9425 the bounding box and then adds some more text to the picture before asking
9426 for more bounding box information, the second computation need only look at
9427 the additional text.
9429 When the bounding box has not been computed, the |bblast| pointer points
9430 to a dummy link at the head of the graphical object list while the |minx_val|
9431 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9432 fields contain |-el_gordo|.
9434 Since the bounding box of pictures containing objects of type
9435 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9436 @:mp_true_corners_}{\&{truecorners} primitive@>
9437 data might not be valid for all values of this parameter. Hence, the |bbtype|
9438 field is needed to keep track of this.
9440 @d minx_val(A) mp->mem[(A)+2].sc
9441 @d miny_val(A) mp->mem[(A)+3].sc
9442 @d maxx_val(A) mp->mem[(A)+4].sc
9443 @d maxy_val(A) mp->mem[(A)+5].sc
9444 @d bblast(A) link((A)+6) /* last item considered in bounding box computation */
9445 @d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9446 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9448 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9450 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9452 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9455 void mp_init_bbox (MP mp,pointer h) {
9456 /* Initialize the bounding box information in edge structure |h| */
9457 bblast(h)=dummy_loc(h);
9458 bbtype(h)=no_bounds;
9459 minx_val(h)=el_gordo;
9460 miny_val(h)=el_gordo;
9461 maxx_val(h)=-el_gordo;
9462 maxy_val(h)=-el_gordo;
9465 @ The only other entries in an edge header are a reference count in the first
9466 word and a pointer to the tail of the object list in the last word.
9468 @d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
9469 @d edge_header_size 8
9472 void mp_init_edges (MP mp,pointer h) {
9473 /* initialize an edge header to null values */
9474 dash_list(h)=null_dash;
9475 obj_tail(h)=dummy_loc(h);
9476 link(dummy_loc(h))=null;
9478 mp_init_bbox(mp, h);
9481 @ Here is how edge structures are deleted. The process can be recursive because
9482 of the need to dereference edge structures that are used as dash patterns.
9485 @d add_edge_ref(A) incr(ref_count(A))
9486 @d delete_edge_ref(A) {
9487 if ( ref_count((A))==null )
9488 mp_toss_edges(mp, A);
9493 @<Declare the recycling subroutines@>=
9494 void mp_flush_dash_list (MP mp,pointer h);
9495 pointer mp_toss_gr_object (MP mp,pointer p) ;
9496 void mp_toss_edges (MP mp,pointer h) ;
9498 @ @c void mp_toss_edges (MP mp,pointer h) {
9499 pointer p,q; /* pointers that scan the list being recycled */
9500 pointer r; /* an edge structure that object |p| refers to */
9501 mp_flush_dash_list(mp, h);
9502 q=link(dummy_loc(h));
9503 while ( (q!=null) ) {
9505 r=mp_toss_gr_object(mp, p);
9506 if ( r!=null ) delete_edge_ref(r);
9508 mp_free_node(mp, h,edge_header_size);
9510 void mp_flush_dash_list (MP mp,pointer h) {
9511 pointer p,q; /* pointers that scan the list being recycled */
9513 while ( q!=null_dash ) {
9515 mp_free_node(mp, p,dash_node_size);
9517 dash_list(h)=null_dash;
9519 pointer mp_toss_gr_object (MP mp,pointer p) {
9520 /* returns an edge structure that needs to be dereferenced */
9521 pointer e; /* the edge structure to return */
9523 @<Prepare to recycle graphical object |p|@>;
9524 mp_free_node(mp, p,mp->gr_object_size[type(p)]);
9528 @ @<Prepare to recycle graphical object |p|@>=
9531 mp_toss_knot_list(mp, path_p(p));
9532 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9533 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9534 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9536 case mp_stroked_code:
9537 mp_toss_knot_list(mp, path_p(p));
9538 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9539 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9540 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9544 delete_str_ref(text_p(p));
9545 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9546 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9548 case mp_start_clip_code:
9549 case mp_start_bounds_code:
9550 mp_toss_knot_list(mp, path_p(p));
9552 case mp_stop_clip_code:
9553 case mp_stop_bounds_code:
9555 } /* there are no other cases */
9557 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9558 to be done before making a significant change to an edge structure. Much of
9559 the work is done in a separate routine |copy_objects| that copies a list of
9560 graphical objects into a new edge header.
9562 @c @<Declare a function called |copy_objects|@>
9563 pointer mp_private_edges (MP mp,pointer h) {
9564 /* make a private copy of the edge structure headed by |h| */
9565 pointer hh; /* the edge header for the new copy */
9566 pointer p,pp; /* pointers for copying the dash list */
9567 if ( ref_count(h)==null ) {
9571 hh=mp_copy_objects(mp, link(dummy_loc(h)),null);
9572 @<Copy the dash list from |h| to |hh|@>;
9573 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9574 point into the new object list@>;
9579 @ Here we use the fact that |dash_list(hh)=link(hh)|.
9580 @^data structure assumptions@>
9582 @<Copy the dash list from |h| to |hh|@>=
9583 pp=hh; p=dash_list(h);
9584 while ( (p!=null_dash) ) {
9585 link(pp)=mp_get_node(mp, dash_node_size);
9587 start_x(pp)=start_x(p);
9588 stop_x(pp)=stop_x(p);
9592 dash_y(hh)=dash_y(h)
9595 @ |h| is an edge structure
9598 mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
9601 scaled scf; /* scale factor */
9602 scaled *dashes = NULL;
9605 if (h==null || dash_list(h)==null_dash)
9608 scf=mp_get_pen_scale(mp, pen_p(q));
9610 if (*w==0) scf = dash_scale(q); else return NULL;
9612 scf=mp_make_scaled(mp, *w,scf);
9613 scf=mp_take_scaled(mp, scf,dash_scale(q));
9616 d = mp_xmalloc(mp,1,sizeof(mp_dash_object));
9617 start_x(null_dash)=start_x(p)+dash_y(h);
9618 while (p != null_dash) {
9619 dashes = mp_xrealloc(mp, dashes, num_dashes+2, sizeof(scaled));
9620 dashes[(num_dashes-1)] =
9621 mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
9622 dashes[(num_dashes)] =
9623 mp_take_scaled(mp,(start_x(link(p))-stop_x(p)),scf);
9624 dashes[(num_dashes+1)] = -1; /* terminus */
9628 d->array_field = dashes;
9630 mp_take_scaled(mp,mp_dash_offset(mp, h),scf);
9636 @ @<Copy the bounding box information from |h| to |hh|...@>=
9637 minx_val(hh)=minx_val(h);
9638 miny_val(hh)=miny_val(h);
9639 maxx_val(hh)=maxx_val(h);
9640 maxy_val(hh)=maxy_val(h);
9641 bbtype(hh)=bbtype(h);
9642 p=dummy_loc(h); pp=dummy_loc(hh);
9643 while ((p!=bblast(h)) ) {
9644 if ( p==null ) mp_confusion(mp, "bblast");
9645 @:this can't happen bblast}{\quad bblast@>
9646 p=link(p); pp=link(pp);
9650 @ Here is the promised routine for copying graphical objects into a new edge
9651 structure. It starts copying at object~|p| and stops just before object~|q|.
9652 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9653 structure requires further initialization by |init_bbox|.
9655 @<Declare a function called |copy_objects|@>=
9656 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9657 pointer hh; /* the new edge header */
9658 pointer pp; /* the last newly copied object */
9659 small_number k; /* temporary register */
9660 hh=mp_get_node(mp, edge_header_size);
9661 dash_list(hh)=null_dash;
9665 @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9672 @ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9673 { k=mp->gr_object_size[type(p)];
9674 link(pp)=mp_get_node(mp, k);
9676 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9677 @<Fix anything in graphical object |pp| that should differ from the
9678 corresponding field in |p|@>;
9682 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9684 case mp_start_clip_code:
9685 case mp_start_bounds_code:
9686 path_p(pp)=mp_copy_path(mp, path_p(p));
9689 path_p(pp)=mp_copy_path(mp, path_p(p));
9690 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9691 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9692 if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
9694 case mp_stroked_code:
9695 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9696 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9697 path_p(pp)=mp_copy_path(mp, path_p(p));
9698 pen_p(pp)=copy_pen(pen_p(p));
9699 if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
9702 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9703 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9704 add_str_ref(text_p(pp));
9706 case mp_stop_clip_code:
9707 case mp_stop_bounds_code:
9709 } /* there are no other cases */
9711 @ Here is one way to find an acceptable value for the second argument to
9712 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9713 skips past one picture component, where a ``picture component'' is a single
9714 graphical object, or a start bounds or start clip object and everything up
9715 through the matching stop bounds or stop clip object. The macro version avoids
9716 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9717 unless |p| points to a stop bounds or stop clip node, in which case it executes
9720 @d skip_component(A)
9721 if ( ! is_start_or_stop((A)) ) (A)=link((A));
9722 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9726 pointer mp_skip_1component (MP mp,pointer p) {
9727 integer lev; /* current nesting level */
9730 if ( is_start_or_stop(p) ) {
9731 if ( is_stop(p) ) decr(lev); else incr(lev);
9738 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9740 @<Declare subroutines for printing expressions@>=
9741 @<Declare subroutines needed by |print_edges|@>
9742 void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
9743 pointer p; /* a graphical object to be printed */
9744 pointer hh,pp; /* temporary pointers */
9745 scaled scf; /* a scale factor for the dash pattern */
9746 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9747 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9749 while ( link(p)!=null ) {
9753 @<Cases for printing graphical object node |p|@>;
9755 mp_print(mp, "[unknown object type!]");
9759 mp_print_nl(mp, "End edges");
9760 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9762 mp_end_diagnostic(mp, true);
9765 @ @<Cases for printing graphical object node |p|@>=
9767 mp_print(mp, "Filled contour ");
9768 mp_print_obj_color(mp, p);
9769 mp_print_char(mp, ':'); mp_print_ln(mp);
9770 mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
9771 if ( (pen_p(p)!=null) ) {
9772 @<Print join type for graphical object |p|@>;
9773 mp_print(mp, " with pen"); mp_print_ln(mp);
9774 mp_pr_pen(mp, pen_p(p));
9778 @ @<Print join type for graphical object |p|@>=
9779 switch (ljoin_val(p)) {
9781 mp_print(mp, "mitered joins limited ");
9782 mp_print_scaled(mp, miterlim_val(p));
9785 mp_print(mp, "round joins");
9788 mp_print(mp, "beveled joins");
9791 mp_print(mp, "?? joins");
9796 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9798 @<Print join and cap types for stroked node |p|@>=
9799 switch (lcap_val(p)) {
9800 case 0:mp_print(mp, "butt"); break;
9801 case 1:mp_print(mp, "round"); break;
9802 case 2:mp_print(mp, "square"); break;
9803 default: mp_print(mp, "??"); break;
9806 mp_print(mp, " ends, ");
9807 @<Print join type for graphical object |p|@>
9809 @ Here is a routine that prints the color of a graphical object if it isn't
9810 black (the default color).
9812 @<Declare subroutines needed by |print_edges|@>=
9813 @<Declare a procedure called |print_compact_node|@>
9814 void mp_print_obj_color (MP mp,pointer p) {
9815 if ( color_model(p)==mp_grey_model ) {
9816 if ( grey_val(p)>0 ) {
9817 mp_print(mp, "greyed ");
9818 mp_print_compact_node(mp, obj_grey_loc(p),1);
9820 } else if ( color_model(p)==mp_cmyk_model ) {
9821 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9822 (yellow_val(p)>0) || (black_val(p)>0) ) {
9823 mp_print(mp, "processcolored ");
9824 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9826 } else if ( color_model(p)==mp_rgb_model ) {
9827 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9828 mp_print(mp, "colored ");
9829 mp_print_compact_node(mp, obj_red_loc(p),3);
9834 @ We also need a procedure for printing consecutive scaled values as if they
9835 were a known big node.
9837 @<Declare a procedure called |print_compact_node|@>=
9838 void mp_print_compact_node (MP mp,pointer p, small_number k) {
9839 pointer q; /* last location to print */
9841 mp_print_char(mp, '(');
9843 mp_print_scaled(mp, mp->mem[p].sc);
9844 if ( p<q ) mp_print_char(mp, ',');
9847 mp_print_char(mp, ')');
9850 @ @<Cases for printing graphical object node |p|@>=
9851 case mp_stroked_code:
9852 mp_print(mp, "Filled pen stroke ");
9853 mp_print_obj_color(mp, p);
9854 mp_print_char(mp, ':'); mp_print_ln(mp);
9855 mp_pr_path(mp, path_p(p));
9856 if ( dash_p(p)!=null ) {
9857 mp_print_nl(mp, "dashed (");
9858 @<Finish printing the dash pattern that |p| refers to@>;
9861 @<Print join and cap types for stroked node |p|@>;
9862 mp_print(mp, " with pen"); mp_print_ln(mp);
9863 if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9865 else mp_pr_pen(mp, pen_p(p));
9868 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9869 when it is not known to define a suitable dash pattern. This is disallowed
9870 here because the |dash_p| field should never point to such an edge header.
9871 Note that memory is allocated for |start_x(null_dash)| and we are free to
9872 give it any convenient value.
9874 @<Finish printing the dash pattern that |p| refers to@>=
9875 ok_to_dash=pen_is_elliptical(pen_p(p));
9876 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9879 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9880 mp_print(mp, " ??");
9881 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9882 while ( pp!=null_dash ) {
9883 mp_print(mp, "on ");
9884 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9885 mp_print(mp, " off ");
9886 mp_print_scaled(mp, mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
9888 if ( pp!=null_dash ) mp_print_char(mp, ' ');
9890 mp_print(mp, ") shifted ");
9891 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9892 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9895 @ @<Declare subroutines needed by |print_edges|@>=
9896 scaled mp_dash_offset (MP mp,pointer h) {
9897 scaled x; /* the answer */
9898 if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
9899 @:this can't happen dash0}{\quad dash0@>
9900 if ( dash_y(h)==0 ) {
9903 x=-(start_x(dash_list(h)) % dash_y(h));
9904 if ( x<0 ) x=x+dash_y(h);
9909 @ @<Cases for printing graphical object node |p|@>=
9911 mp_print_char(mp, '"'); mp_print_str(mp,text_p(p));
9912 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
9913 mp_print_char(mp, '"'); mp_print_ln(mp);
9914 mp_print_obj_color(mp, p);
9915 mp_print(mp, "transformed ");
9916 mp_print_compact_node(mp, text_tx_loc(p),6);
9919 @ @<Cases for printing graphical object node |p|@>=
9920 case mp_start_clip_code:
9921 mp_print(mp, "clipping path:");
9923 mp_pr_path(mp, path_p(p));
9925 case mp_stop_clip_code:
9926 mp_print(mp, "stop clipping");
9929 @ @<Cases for printing graphical object node |p|@>=
9930 case mp_start_bounds_code:
9931 mp_print(mp, "setbounds path:");
9933 mp_pr_path(mp, path_p(p));
9935 case mp_stop_bounds_code:
9936 mp_print(mp, "end of setbounds");
9939 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9940 subroutine that scans an edge structure and tries to interpret it as a dash
9941 pattern. This can only be done when there are no filled regions or clipping
9942 paths and all the pen strokes have the same color. The first step is to let
9943 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9944 project all the pen stroke paths onto the line $y=y_0$ and require that there
9945 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9946 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9947 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9949 @c @<Declare a procedure called |x_retrace_error|@>
9950 pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9951 pointer p; /* this scans the stroked nodes in the object list */
9952 pointer p0; /* if not |null| this points to the first stroked node */
9953 pointer pp,qq,rr; /* pointers into |path_p(p)| */
9954 pointer d,dd; /* pointers used to create the dash list */
9956 @<Other local variables in |make_dashes|@>;
9957 y0=0; /* the initial $y$ coordinate */
9958 if ( dash_list(h)!=null_dash )
9961 p=link(dummy_loc(h));
9963 if ( type(p)!=mp_stroked_code ) {
9964 @<Compain that the edge structure contains a node of the wrong type
9965 and |goto not_found|@>;
9968 if ( p0==null ){ p0=p; y0=y_coord(pp); };
9969 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9970 or |goto not_found| if there is an error@>;
9971 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9974 if ( dash_list(h)==null_dash )
9975 goto NOT_FOUND; /* No error message */
9976 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9977 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
9980 @<Flush the dash list, recycle |h| and return |null|@>;
9983 @ @<Compain that the edge structure contains a node of the wrong type...@>=
9985 print_err("Picture is too complicated to use as a dash pattern");
9986 help3("When you say `dashed p', picture p should not contain any")
9987 ("text, filled regions, or clipping paths. This time it did")
9988 ("so I'll just make it a solid line instead.");
9989 mp_put_get_error(mp);
9993 @ A similar error occurs when monotonicity fails.
9995 @<Declare a procedure called |x_retrace_error|@>=
9996 void mp_x_retrace_error (MP mp) {
9997 print_err("Picture is too complicated to use as a dash pattern");
9998 help3("When you say `dashed p', every path in p should be monotone")
9999 ("in x and there must be no overlapping. This failed")
10000 ("so I'll just make it a solid line instead.");
10001 mp_put_get_error(mp);
10004 @ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
10005 handle the case where the pen stroke |p| is itself dashed.
10007 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
10008 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
10011 if ( link(pp)!=pp ) {
10013 qq=rr; rr=link(rr);
10014 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
10015 if there is a problem@>;
10016 } while (right_type(rr)!=mp_endpoint);
10018 d=mp_get_node(mp, dash_node_size);
10019 if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
10020 if ( x_coord(pp)<x_coord(rr) ) {
10021 start_x(d)=x_coord(pp);
10022 stop_x(d)=x_coord(rr);
10024 start_x(d)=x_coord(rr);
10025 stop_x(d)=x_coord(pp);
10028 @ We also need to check for the case where the segment from |qq| to |rr| is
10029 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
10031 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
10036 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
10037 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
10038 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
10039 mp_x_retrace_error(mp); goto NOT_FOUND;
10043 if ( (x_coord(pp)>x0) || (x0>x3) ) {
10044 if ( (x_coord(pp)<x0) || (x0<x3) ) {
10045 mp_x_retrace_error(mp); goto NOT_FOUND;
10049 @ @<Other local variables in |make_dashes|@>=
10050 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
10052 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
10053 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
10054 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
10055 print_err("Picture is too complicated to use as a dash pattern");
10056 help3("When you say `dashed p', everything in picture p should")
10057 ("be the same color. I can\'t handle your color changes")
10058 ("so I'll just make it a solid line instead.");
10059 mp_put_get_error(mp);
10063 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
10064 start_x(null_dash)=stop_x(d);
10065 dd=h; /* this makes |link(dd)=dash_list(h)| */
10066 while ( start_x(link(dd))<stop_x(d) )
10069 if ( (stop_x(dd)>start_x(d)) )
10070 { mp_x_retrace_error(mp); goto NOT_FOUND; };
10075 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
10077 while ( (link(d)!=null_dash) )
10080 dash_y(h)=stop_x(d)-start_x(dd);
10081 if ( abs(y0)>dash_y(h) ) {
10083 } else if ( d!=dd ) {
10084 dash_list(h)=link(dd);
10085 stop_x(d)=stop_x(dd)+dash_y(h);
10086 mp_free_node(mp, dd,dash_node_size);
10089 @ We get here when the argument is a null picture or when there is an error.
10090 Recovering from an error involves making |dash_list(h)| empty to indicate
10091 that |h| is not known to be a valid dash pattern. We also dereference |h|
10092 since it is not being used for the return value.
10094 @<Flush the dash list, recycle |h| and return |null|@>=
10095 mp_flush_dash_list(mp, h);
10096 delete_edge_ref(h);
10099 @ Having carefully saved the dashed stroked nodes in the
10100 corresponding dash nodes, we must be prepared to break up these dashes into
10103 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
10104 d=h; /* now |link(d)=dash_list(h)| */
10105 while ( link(d)!=null_dash ) {
10111 hsf=dash_scale(ds);
10112 if ( (hh==null) ) mp_confusion(mp, "dash1");
10113 @:this can't happen dash0}{\quad dash1@>
10114 if ( dash_y(hh)==0 ) {
10117 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
10118 @:this can't happen dash0}{\quad dash1@>
10119 @<Replace |link(d)| by a dashed version as determined by edge header
10120 |hh| and scale factor |ds|@>;
10125 @ @<Other local variables in |make_dashes|@>=
10126 pointer dln; /* |link(d)| */
10127 pointer hh; /* an edge header that tells how to break up |dln| */
10128 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
10129 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
10130 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
10132 @ @<Replace |link(d)| by a dashed version as determined by edge header...@>=
10135 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
10136 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
10137 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
10138 +mp_take_scaled(mp, hsf,dash_y(hh));
10139 stop_x(null_dash)=start_x(null_dash);
10140 @<Advance |dd| until finding the first dash that overlaps |dln| when
10141 offset by |xoff|@>;
10142 while ( start_x(dln)<=stop_x(dln) ) {
10143 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
10144 @<Insert a dash between |d| and |dln| for the overlap with the offset version
10147 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10150 mp_free_node(mp, dln,dash_node_size)
10152 @ The name of this module is a bit of a lie because we just find the
10153 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
10154 overlap possible. It could be that the unoffset version of dash |dln| falls
10155 in the gap between |dd| and its predecessor.
10157 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
10158 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
10162 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
10163 if ( dd==null_dash ) {
10165 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10168 @ At this point we already know that
10169 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10171 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10172 if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
10173 link(d)=mp_get_node(mp, dash_node_size);
10176 if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
10177 start_x(d)=start_x(dln);
10179 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10180 if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
10181 stop_x(d)=stop_x(dln);
10183 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10186 @ The next major task is to update the bounding box information in an edge
10187 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10188 header's bounding box to accommodate the box computed by |path_bbox| or
10189 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10192 @c void mp_adjust_bbox (MP mp,pointer h) {
10193 if ( minx<minx_val(h) ) minx_val(h)=minx;
10194 if ( miny<miny_val(h) ) miny_val(h)=miny;
10195 if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
10196 if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
10199 @ Here is a special routine for updating the bounding box information in
10200 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10201 that is to be stroked with the pen~|pp|.
10203 @c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10204 pointer q; /* a knot node adjacent to knot |p| */
10205 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10206 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10207 scaled z; /* a coordinate being tested against the bounding box */
10208 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10209 integer i; /* a loop counter */
10210 if ( right_type(p)!=mp_endpoint ) {
10213 @<Make |(dx,dy)| the final direction for the path segment from
10214 |q| to~|p|; set~|d|@>;
10215 d=mp_pyth_add(mp, dx,dy);
10217 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10218 for (i=1;i<= 2;i++) {
10219 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10220 update the bounding box to accommodate it@>;
10224 if ( right_type(p)==mp_endpoint ) {
10227 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10233 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10234 if ( q==link(p) ) {
10235 dx=x_coord(p)-right_x(p);
10236 dy=y_coord(p)-right_y(p);
10237 if ( (dx==0)&&(dy==0) ) {
10238 dx=x_coord(p)-left_x(q);
10239 dy=y_coord(p)-left_y(q);
10242 dx=x_coord(p)-left_x(p);
10243 dy=y_coord(p)-left_y(p);
10244 if ( (dx==0)&&(dy==0) ) {
10245 dx=x_coord(p)-right_x(q);
10246 dy=y_coord(p)-right_y(q);
10249 dx=x_coord(p)-x_coord(q);
10250 dy=y_coord(p)-y_coord(q)
10252 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10253 dx=mp_make_fraction(mp, dx,d);
10254 dy=mp_make_fraction(mp, dy,d);
10255 mp_find_offset(mp, -dy,dx,pp);
10256 xx=mp->cur_x; yy=mp->cur_y
10258 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10259 mp_find_offset(mp, dx,dy,pp);
10260 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10261 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10262 mp_confusion(mp, "box_ends");
10263 @:this can't happen box ends}{\quad\\{box\_ends}@>
10264 z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10265 if ( z<minx_val(h) ) minx_val(h)=z;
10266 if ( z>maxx_val(h) ) maxx_val(h)=z;
10267 z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10268 if ( z<miny_val(h) ) miny_val(h)=z;
10269 if ( z>maxy_val(h) ) maxy_val(h)=z
10271 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10275 } while (right_type(p)!=mp_endpoint)
10277 @ The major difficulty in finding the bounding box of an edge structure is the
10278 effect of clipping paths. We treat them conservatively by only clipping to the
10279 clipping path's bounding box, but this still
10280 requires recursive calls to |set_bbox| in order to find the bounding box of
10282 the objects to be clipped. Such calls are distinguished by the fact that the
10283 boolean parameter |top_level| is false.
10285 @c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10286 pointer p; /* a graphical object being considered */
10287 scaled sminx,sminy,smaxx,smaxy;
10288 /* for saving the bounding box during recursive calls */
10289 scaled x0,x1,y0,y1; /* temporary registers */
10290 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10291 @<Wipe out any existing bounding box information if |bbtype(h)| is
10292 incompatible with |internal[mp_true_corners]|@>;
10293 while ( link(bblast(h))!=null ) {
10297 case mp_stop_clip_code:
10298 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10299 @:this can't happen bbox}{\quad bbox@>
10301 @<Other cases for updating the bounding box based on the type of object |p|@>;
10302 } /* all cases are enumerated above */
10304 if ( ! top_level ) mp_confusion(mp, "bbox");
10307 @ @<Internal library declarations@>=
10308 void mp_set_bbox (MP mp,pointer h, boolean top_level);
10310 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10311 switch (bbtype(h)) {
10315 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10318 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10320 } /* there are no other cases */
10322 @ @<Other cases for updating the bounding box...@>=
10324 mp_path_bbox(mp, path_p(p));
10325 if ( pen_p(p)!=null ) {
10328 mp_pen_bbox(mp, pen_p(p));
10334 mp_adjust_bbox(mp, h);
10337 @ @<Other cases for updating the bounding box...@>=
10338 case mp_start_bounds_code:
10339 if ( mp->internal[mp_true_corners]>0 ) {
10340 bbtype(h)=bounds_unset;
10342 bbtype(h)=bounds_set;
10343 mp_path_bbox(mp, path_p(p));
10344 mp_adjust_bbox(mp, h);
10345 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10349 case mp_stop_bounds_code:
10350 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10351 @:this can't happen bbox2}{\quad bbox2@>
10354 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10357 if ( link(p)==null ) mp_confusion(mp, "bbox2");
10358 @:this can't happen bbox2}{\quad bbox2@>
10360 if ( type(p)==mp_start_bounds_code ) incr(lev);
10361 else if ( type(p)==mp_stop_bounds_code ) decr(lev);
10365 @ It saves a lot of grief here to be slightly conservative and not account for
10366 omitted parts of dashed lines. We also don't worry about the material omitted
10367 when using butt end caps. The basic computation is for round end caps and
10368 |box_ends| augments it for square end caps.
10370 @<Other cases for updating the bounding box...@>=
10371 case mp_stroked_code:
10372 mp_path_bbox(mp, path_p(p));
10375 mp_pen_bbox(mp, pen_p(p));
10380 mp_adjust_bbox(mp, h);
10381 if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10382 mp_box_ends(mp, path_p(p), pen_p(p), h);
10385 @ The height width and depth information stored in a text node determines a
10386 rectangle that needs to be transformed according to the transformation
10387 parameters stored in the text node.
10389 @<Other cases for updating the bounding box...@>=
10391 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10392 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10393 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10396 if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
10397 else { minx=minx+y1; maxx=maxx+y0; }
10398 if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
10399 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10400 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10401 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10404 if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
10405 else { miny=miny+y1; maxy=maxy+y0; }
10406 if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
10407 mp_adjust_bbox(mp, h);
10410 @ This case involves a recursive call that advances |bblast(h)| to the node of
10411 type |mp_stop_clip_code| that matches |p|.
10413 @<Other cases for updating the bounding box...@>=
10414 case mp_start_clip_code:
10415 mp_path_bbox(mp, path_p(p));
10418 sminx=minx_val(h); sminy=miny_val(h);
10419 smaxx=maxx_val(h); smaxy=maxy_val(h);
10420 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10421 starting at |link(p)|@>;
10422 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10424 minx=sminx; miny=sminy;
10425 maxx=smaxx; maxy=smaxy;
10426 mp_adjust_bbox(mp, h);
10429 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10430 minx_val(h)=el_gordo;
10431 miny_val(h)=el_gordo;
10432 maxx_val(h)=-el_gordo;
10433 maxy_val(h)=-el_gordo;
10434 mp_set_bbox(mp, h,false)
10436 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10437 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10438 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10439 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10440 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10442 @* \[22] Finding an envelope.
10443 When \MP\ has a path and a polygonal pen, it needs to express the desired
10444 shape in terms of things \ps\ can understand. The present task is to compute
10445 a new path that describes the region to be filled. It is convenient to
10446 define this as a two step process where the first step is determining what
10447 offset to use for each segment of the path.
10449 @ Given a pointer |c| to a cyclic path,
10450 and a pointer~|h| to the first knot of a pen polygon,
10451 the |offset_prep| routine changes the path into cubics that are
10452 associated with particular pen offsets. Thus if the cubic between |p|
10453 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10454 has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
10455 to because |l-k| could be negative.)
10457 After overwriting the type information with offset differences, we no longer
10458 have a true path so we refer to the knot list returned by |offset_prep| as an
10461 Since an envelope spec only determines relative changes in pen offsets,
10462 |offset_prep| sets a global variable |spec_offset| to the relative change from
10463 |h| to the first offset.
10465 @d zero_off 16384 /* added to offset changes to make them positive */
10468 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10470 @ @c @<Declare subroutines needed by |offset_prep|@>
10471 pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10472 halfword n; /* the number of vertices in the pen polygon */
10473 pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
10474 integer k_needed; /* amount to be added to |info(p)| when it is computed */
10475 pointer w0; /* a pointer to pen offset to use just before |p| */
10476 scaled dxin,dyin; /* the direction into knot |p| */
10477 integer turn_amt; /* change in pen offsets for the current cubic */
10478 @<Other local variables for |offset_prep|@>;
10480 @<Initialize the pen size~|n|@>;
10481 @<Initialize the incoming direction and pen offset at |c|@>;
10482 p=c; c0=c; k_needed=0;
10485 @<Split the cubic between |p| and |q|, if necessary, into cubics
10486 associated with single offsets, after which |q| should
10487 point to the end of the final such cubic@>;
10489 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10490 might have been introduced by the splitting process@>;
10492 @<Fix the offset change in |info(c)| and set |c| to the return value of
10497 @ We shall want to keep track of where certain knots on the cyclic path
10498 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10499 knot nodes because some nodes are deleted while removing dead cubics. Thus
10500 |offset_prep| updates the following pointers
10504 pointer spec_p2; /* pointers to distinguished knots */
10507 mp->spec_p1=null; mp->spec_p2=null;
10509 @ @<Initialize the pen size~|n|@>=
10516 @ Since the true incoming direction isn't known yet, we just pick a direction
10517 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10520 @<Initialize the incoming direction and pen offset at |c|@>=
10521 dxin=x_coord(link(h))-x_coord(knil(h));
10522 dyin=y_coord(link(h))-y_coord(knil(h));
10523 if ( (dxin==0)&&(dyin==0) ) {
10524 dxin=y_coord(knil(h))-y_coord(h);
10525 dyin=x_coord(h)-x_coord(knil(h));
10529 @ We must be careful not to remove the only cubic in a cycle.
10531 But we must also be careful for another reason. If the user-supplied
10532 path starts with a set of degenerate cubics, the target node |q| can
10533 be collapsed to the initial node |p| which might be the same as the
10534 initial node |c| of the curve. This would cause the |offset_prep| routine
10535 to bail out too early, causing distress later on. (See for example
10536 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10539 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10543 if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
10544 x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
10545 x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
10547 @<Remove the cubic following |p| and update the data structures
10548 to merge |r| into |p|@>;
10552 /* Check if we removed too much */
10553 if ((q!=q0)&&(q!=c||c==c0))
10556 @ @<Remove the cubic following |p| and update the data structures...@>=
10557 { k_needed=info(p)-zero_off;
10561 info(p)=k_needed+info(r);
10564 if ( r==c ) { info(p)=info(c); c=p; };
10565 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10566 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10567 r=p; mp_remove_cubic(mp, p);
10570 @ Not setting the |info| field of the newly created knot allows the splitting
10571 routine to work for paths.
10573 @<Declare subroutines needed by |offset_prep|@>=
10574 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10575 scaled v; /* an intermediate value */
10576 pointer q,r; /* for list manipulation */
10577 q=link(p); r=mp_get_node(mp, knot_node_size); link(p)=r; link(r)=q;
10578 originator(r)=mp_program_code;
10579 left_type(r)=mp_explicit; right_type(r)=mp_explicit;
10580 v=t_of_the_way(right_x(p),left_x(q));
10581 right_x(p)=t_of_the_way(x_coord(p),right_x(p));
10582 left_x(q)=t_of_the_way(left_x(q),x_coord(q));
10583 left_x(r)=t_of_the_way(right_x(p),v);
10584 right_x(r)=t_of_the_way(v,left_x(q));
10585 x_coord(r)=t_of_the_way(left_x(r),right_x(r));
10586 v=t_of_the_way(right_y(p),left_y(q));
10587 right_y(p)=t_of_the_way(y_coord(p),right_y(p));
10588 left_y(q)=t_of_the_way(left_y(q),y_coord(q));
10589 left_y(r)=t_of_the_way(right_y(p),v);
10590 right_y(r)=t_of_the_way(v,left_y(q));
10591 y_coord(r)=t_of_the_way(left_y(r),right_y(r));
10594 @ This does not set |info(p)| or |right_type(p)|.
10596 @<Declare subroutines needed by |offset_prep|@>=
10597 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10598 pointer q; /* the node that disappears */
10599 q=link(p); link(p)=link(q);
10600 right_x(p)=right_x(q); right_y(p)=right_y(q);
10601 mp_free_node(mp, q,knot_node_size);
10604 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10605 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10606 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10607 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10608 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10609 When listed by increasing $k$, these directions occur in counter-clockwise
10610 order so that $d_k\preceq d\k$ for all~$k$.
10611 The goal of |offset_prep| is to find an offset index~|k| to associate with
10612 each cubic, such that the direction $d(t)$ of the cubic satisfies
10613 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10614 We may have to split a cubic into many pieces before each
10615 piece corresponds to a unique offset.
10617 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10618 info(p)=zero_off+k_needed;
10620 @<Prepare for derivative computations;
10621 |goto not_found| if the current cubic is dead@>;
10622 @<Find the initial direction |(dx,dy)|@>;
10623 @<Update |info(p)| and find the offset $w_k$ such that
10624 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10625 the direction change at |p|@>;
10626 @<Find the final direction |(dxin,dyin)|@>;
10627 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10628 @<Complete the offset splitting process@>;
10629 w0=mp_pen_walk(mp, w0,turn_amt)
10631 @ @<Declare subroutines needed by |offset_prep|@>=
10632 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10633 /* walk |k| steps around a pen from |w| */
10634 while ( k>0 ) { w=link(w); decr(k); };
10635 while ( k<0 ) { w=knil(w); incr(k); };
10639 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10640 calculated from the quadratic polynomials
10641 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10642 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10643 Since we may be calculating directions from several cubics
10644 split from the current one, it is desirable to do these calculations
10645 without losing too much precision. ``Scaled up'' values of the
10646 derivatives, which will be less tainted by accumulated errors than
10647 derivatives found from the cubics themselves, are maintained in
10648 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10649 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10650 represent $Y_0=2^l(y_1-y_0)$, $Y_1=2^l(y_2-y_1)$, and $Y_2=2^l(y_3-y_2)$.
10652 @<Other local variables for |offset_prep|@>=
10653 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10654 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10655 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10656 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10657 integer max_coef; /* used while scaling */
10658 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10659 fraction t; /* where the derivative passes through zero */
10660 fraction s; /* a temporary value */
10662 @ @<Prepare for derivative computations...@>=
10663 x0=right_x(p)-x_coord(p);
10664 x2=x_coord(q)-left_x(q);
10665 x1=left_x(q)-right_x(p);
10666 y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
10667 y1=left_y(q)-right_y(p);
10669 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10670 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10671 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10672 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10673 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10674 if ( max_coef==0 ) goto NOT_FOUND;
10675 while ( max_coef<fraction_half ) {
10677 double(x0); double(x1); double(x2);
10678 double(y0); double(y1); double(y2);
10681 @ Let us first solve a special case of the problem: Suppose we
10682 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10683 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10684 $d(0)\succ d_{k-1}$.
10685 Then, in a sense, we're halfway done, since one of the two relations
10686 in $(*)$ is satisfied, and the other couldn't be satisfied for
10687 any other value of~|k|.
10689 Actually, the conditions can be relaxed somewhat since a relation such as
10690 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10691 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10692 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10693 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10694 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10695 counterclockwise direction.
10697 The |fin_offset_prep| subroutine solves the stated subproblem.
10698 It has a parameter called |rise| that is |1| in
10699 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10700 the derivative of the cubic following |p|.
10701 The |w| parameter should point to offset~$w_k$ and |info(p)| should already
10702 be set properly. The |turn_amt| parameter gives the absolute value of the
10703 overall net change in pen offsets.
10705 @<Declare subroutines needed by |offset_prep|@>=
10706 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10707 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10708 integer rise, integer turn_amt) {
10709 pointer ww; /* for list manipulation */
10710 scaled du,dv; /* for slope calculation */
10711 integer t0,t1,t2; /* test coefficients */
10712 fraction t; /* place where the derivative passes a critical slope */
10713 fraction s; /* slope or reciprocal slope */
10714 integer v; /* intermediate value for updating |x0..y2| */
10715 pointer q; /* original |link(p)| */
10718 if ( rise>0 ) ww=link(w); /* a pointer to $w\k$ */
10719 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10720 @<Compute test coefficients |(t0,t1,t2)|
10721 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10722 t=mp_crossing_point(mp, t0,t1,t2);
10723 if ( t>=fraction_one ) {
10724 if ( turn_amt>0 ) t=fraction_one; else return;
10726 @<Split the cubic at $t$,
10727 and split off another cubic if the derivative crosses back@>;
10732 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10733 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10734 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10737 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10738 du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
10739 if ( abs(du)>=abs(dv) ) {
10740 s=mp_make_fraction(mp, dv,du);
10741 t0=mp_take_fraction(mp, x0,s)-y0;
10742 t1=mp_take_fraction(mp, x1,s)-y1;
10743 t2=mp_take_fraction(mp, x2,s)-y2;
10744 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10746 s=mp_make_fraction(mp, du,dv);
10747 t0=x0-mp_take_fraction(mp, y0,s);
10748 t1=x1-mp_take_fraction(mp, y1,s);
10749 t2=x2-mp_take_fraction(mp, y2,s);
10750 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10752 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10754 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10755 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
10756 respectively, yielding another solution of $(*)$.
10758 @<Split the cubic at $t$, and split off another...@>=
10760 mp_split_cubic(mp, p,t); p=link(p); info(p)=zero_off+rise;
10762 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10763 x0=t_of_the_way(v,x1);
10764 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10765 y0=t_of_the_way(v,y1);
10766 if ( turn_amt<0 ) {
10767 t1=t_of_the_way(t1,t2);
10768 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10769 t=mp_crossing_point(mp, 0,-t1,-t2);
10770 if ( t>fraction_one ) t=fraction_one;
10772 if ( (t==fraction_one)&&(link(p)!=q) ) {
10773 info(link(p))=info(link(p))-rise;
10775 mp_split_cubic(mp, p,t); info(link(p))=zero_off-rise;
10776 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10777 x2=t_of_the_way(x1,v);
10778 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10779 y2=t_of_the_way(y1,v);
10784 @ Now we must consider the general problem of |offset_prep|, when
10785 nothing is known about a given cubic. We start by finding its
10786 direction in the vicinity of |t=0|.
10788 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10789 has not yet introduced any more numerical errors. Thus we can compute
10790 the true initial direction for the given cubic, even if it is almost
10793 @<Find the initial direction |(dx,dy)|@>=
10795 if ( dx==0 && dy==0 ) {
10797 if ( dx==0 && dy==0 ) {
10801 if ( p==c ) { dx0=dx; dy0=dy; }
10803 @ @<Find the final direction |(dxin,dyin)|@>=
10805 if ( dxin==0 && dyin==0 ) {
10807 if ( dxin==0 && dyin==0 ) {
10812 @ The next step is to bracket the initial direction between consecutive
10813 edges of the pen polygon. We must be careful to turn clockwise only if
10814 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10815 counter-clockwise in order to make \&{doublepath} envelopes come out
10816 @:double_path_}{\&{doublepath} primitive@>
10817 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10819 @<Update |info(p)| and find the offset $w_k$ such that...@>=
10820 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10821 w=mp_pen_walk(mp, w0, turn_amt);
10823 info(p)=info(p)+turn_amt
10825 @ Decide how many pen offsets to go away from |w| in order to find the offset
10826 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10827 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10828 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10830 If the pen polygon has only two edges, they could both be parallel
10831 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10832 such edge in order to avoid an infinite loop.
10834 @<Declare subroutines needed by |offset_prep|@>=
10835 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10836 scaled dy, boolean ccw) {
10837 pointer ww; /* a neighbor of knot~|w| */
10838 integer s; /* turn amount so far */
10839 integer t; /* |ab_vs_cd| result */
10844 t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
10845 dx,(y_coord(ww)-y_coord(w)));
10852 while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
10853 dx,(y_coord(w)-y_coord(ww))) < 0) {
10861 @ When we're all done, the final offset is |w0| and the final curve direction
10862 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10863 can correct |info(c)| which was erroneously based on an incoming offset
10866 @d fix_by(A) info(c)=info(c)+(A)
10868 @<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
10869 mp->spec_offset=info(c)-zero_off;
10870 if ( link(c)==c ) {
10871 info(c)=zero_off+n;
10874 while ( w0!=h ) { fix_by(1); w0=link(w0); };
10875 while ( info(c)<=zero_off-n ) fix_by(n);
10876 while ( info(c)>zero_off ) fix_by(-n);
10877 if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10880 @ Finally we want to reduce the general problem to situations that
10881 |fin_offset_prep| can handle. We split the cubic into at most three parts
10882 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10884 @<Complete the offset splitting process@>=
10886 @<Compute test coeff...@>;
10887 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10888 |t:=fraction_one+1|@>;
10889 if ( t>fraction_one ) {
10890 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10892 mp_split_cubic(mp, p,t); r=link(p);
10893 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10894 x2a=t_of_the_way(x1a,x1);
10895 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10896 y2a=t_of_the_way(y1a,y1);
10897 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10898 info(r)=zero_off-1;
10899 if ( turn_amt>=0 ) {
10900 t1=t_of_the_way(t1,t2);
10902 t=mp_crossing_point(mp, 0,-t1,-t2);
10903 if ( t>fraction_one ) t=fraction_one;
10904 @<Split off another rising cubic for |fin_offset_prep|@>;
10905 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10907 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10911 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10912 mp_split_cubic(mp, r,t); info(link(r))=zero_off+1;
10913 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10914 x0a=t_of_the_way(x1,x1a);
10915 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10916 y0a=t_of_the_way(y1,y1a);
10917 mp_fin_offset_prep(mp, link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10920 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10921 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10922 need to decide whether the directions are parallel or antiparallel. We
10923 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10924 should be avoided when the value of |turn_amt| already determines the
10925 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10926 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10927 crossing and the first crossing cannot be antiparallel.
10929 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10930 t=mp_crossing_point(mp, t0,t1,t2);
10931 if ( turn_amt>=0 ) {
10935 u0=t_of_the_way(x0,x1);
10936 u1=t_of_the_way(x1,x2);
10937 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10938 v0=t_of_the_way(y0,y1);
10939 v1=t_of_the_way(y1,y2);
10940 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10941 if ( ss<0 ) t=fraction_one+1;
10943 } else if ( t>fraction_one ) {
10947 @ @<Other local variables for |offset_prep|@>=
10948 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10949 integer ss = 0; /* the part of the dot product computed so far */
10950 int d_sign; /* sign of overall change in direction for this cubic */
10952 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10953 problem to decide which way it loops around but that's OK as long we're
10954 consistent. To make \&{doublepath} envelopes work properly, reversing
10955 the path should always change the sign of |turn_amt|.
10957 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10958 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10960 @<Check rotation direction based on node position@>
10964 if ( dy>0 ) d_sign=1; else d_sign=-1;
10966 if ( dx>0 ) d_sign=1; else d_sign=-1;
10969 @<Make |ss| negative if and only if the total change in direction is
10970 more than $180^\circ$@>;
10971 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10972 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
10974 @ We check rotation direction by looking at the vector connecting the current
10975 node with the next. If its angle with incoming and outgoing tangents has the
10976 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
10977 Otherwise we proceed to the cusp code.
10979 @<Check rotation direction based on node position@>=
10980 u0=x_coord(q)-x_coord(p);
10981 u1=y_coord(q)-y_coord(p);
10982 d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
10983 mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
10985 @ In order to be invariant under path reversal, the result of this computation
10986 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
10987 then swapped with |(x2,y2)|. We make use of the identities
10988 |take_fraction(-a,-b)=take_fraction(a,b)| and
10989 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
10991 @<Make |ss| negative if and only if the total change in direction is...@>=
10992 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
10993 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
10994 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
10996 t=mp_crossing_point(mp, t0,t1,-t0);
10997 u0=t_of_the_way(x0,x1);
10998 u1=t_of_the_way(x1,x2);
10999 v0=t_of_the_way(y0,y1);
11000 v1=t_of_the_way(y1,y2);
11002 t=mp_crossing_point(mp, -t0,t1,t0);
11003 u0=t_of_the_way(x2,x1);
11004 u1=t_of_the_way(x1,x0);
11005 v0=t_of_the_way(y2,y1);
11006 v1=t_of_the_way(y1,y0);
11008 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
11009 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
11011 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
11012 that the |cur_pen| has not been walked around to the first offset.
11015 void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
11016 pointer p,q; /* list traversal */
11017 pointer w; /* the current pen offset */
11018 mp_print_diagnostic(mp, "Envelope spec",s,true);
11019 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
11021 mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
11022 mp_print(mp, " % beginning with offset ");
11023 mp_print_two(mp, x_coord(w),y_coord(w));
11027 @<Print the cubic between |p| and |q|@>;
11029 if ((p==cur_spec) || (info(p)!=zero_off))
11032 if ( info(p)!=zero_off ) {
11033 @<Update |w| as indicated by |info(p)| and print an explanation@>;
11035 } while (p!=cur_spec);
11036 mp_print_nl(mp, " & cycle");
11037 mp_end_diagnostic(mp, true);
11040 @ @<Update |w| as indicated by |info(p)| and print an explanation@>=
11042 w=mp_pen_walk(mp, w, (info(p)-zero_off));
11043 mp_print(mp, " % ");
11044 if ( info(p)>zero_off ) mp_print(mp, "counter");
11045 mp_print(mp, "clockwise to offset ");
11046 mp_print_two(mp, x_coord(w),y_coord(w));
11049 @ @<Print the cubic between |p| and |q|@>=
11051 mp_print_nl(mp, " ..controls ");
11052 mp_print_two(mp, right_x(p),right_y(p));
11053 mp_print(mp, " and ");
11054 mp_print_two(mp, left_x(q),left_y(q));
11055 mp_print_nl(mp, " ..");
11056 mp_print_two(mp, x_coord(q),y_coord(q));
11059 @ Once we have an envelope spec, the remaining task to construct the actual
11060 envelope by offsetting each cubic as determined by the |info| fields in
11061 the knots. First we use |offset_prep| to convert the |c| into an envelope
11062 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
11065 The |ljoin| and |miterlim| parameters control the treatment of points where the
11066 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
11067 The endpoints are easily located because |c| is given in undoubled form
11068 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
11069 track of the endpoints and treat them like very sharp corners.
11070 Butt end caps are treated like beveled joins; round end caps are treated like
11071 round joins; and square end caps are achieved by setting |join_type:=3|.
11073 None of these parameters apply to inside joins where the convolution tracing
11074 has retrograde lines. In such cases we use a simple connect-the-endpoints
11075 approach that is achieved by setting |join_type:=2|.
11077 @c @<Declare a function called |insert_knot|@>
11078 pointer mp_make_envelope (MP mp,pointer c, pointer h, small_number ljoin,
11079 small_number lcap, scaled miterlim) {
11080 pointer p,q,r,q0; /* for manipulating the path */
11081 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
11082 pointer w,w0; /* the pen knot for the current offset */
11083 scaled qx,qy; /* unshifted coordinates of |q| */
11084 halfword k,k0; /* controls pen edge insertion */
11085 @<Other local variables for |make_envelope|@>;
11086 dxin=0; dyin=0; dxout=0; dyout=0;
11087 mp->spec_p1=null; mp->spec_p2=null;
11088 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
11089 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
11090 the initial offset@>;
11095 qx=x_coord(q); qy=y_coord(q);
11098 if ( k!=zero_off ) {
11099 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
11101 @<Add offset |w| to the cubic from |p| to |q|@>;
11102 while ( k!=zero_off ) {
11103 @<Step |w| and move |k| one step closer to |zero_off|@>;
11104 if ( (join_type==1)||(k==zero_off) )
11105 q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
11107 if ( q!=link(p) ) {
11108 @<Set |p=link(p)| and add knots between |p| and |q| as
11109 required by |join_type|@>;
11116 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
11117 c=mp_offset_prep(mp, c,h);
11118 if ( mp->internal[mp_tracing_specs]>0 )
11119 mp_print_spec(mp, c,h,"");
11120 h=mp_pen_walk(mp, h,mp->spec_offset)
11122 @ Mitered and squared-off joins depend on path directions that are difficult to
11123 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
11124 have degenerate cubics only if the entire cycle collapses to a single
11125 degenerate cubic. Setting |join_type:=2| in this case makes the computed
11126 envelope degenerate as well.
11128 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
11129 if ( k<zero_off ) {
11132 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
11133 else if ( lcap==2 ) join_type=3;
11134 else join_type=2-lcap;
11135 if ( (join_type==0)||(join_type==3) ) {
11136 @<Set the incoming and outgoing directions at |q|; in case of
11137 degeneracy set |join_type:=2|@>;
11138 if ( join_type==0 ) {
11139 @<If |miterlim| is less than the secant of half the angle at |q|
11140 then set |join_type:=2|@>;
11145 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
11147 tmp=mp_take_fraction(mp, miterlim,fraction_half+
11148 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
11150 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
11153 @ @<Other local variables for |make_envelope|@>=
11154 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
11155 scaled tmp; /* a temporary value */
11157 @ The coordinates of |p| have already been shifted unless |p| is the first
11158 knot in which case they get shifted at the very end.
11160 @<Add offset |w| to the cubic from |p| to |q|@>=
11161 right_x(p)=right_x(p)+x_coord(w);
11162 right_y(p)=right_y(p)+y_coord(w);
11163 left_x(q)=left_x(q)+x_coord(w);
11164 left_y(q)=left_y(q)+y_coord(w);
11165 x_coord(q)=x_coord(q)+x_coord(w);
11166 y_coord(q)=y_coord(q)+y_coord(w);
11167 left_type(q)=mp_explicit;
11168 right_type(q)=mp_explicit
11170 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
11171 if ( k>zero_off ){ w=link(w); decr(k); }
11172 else { w=knil(w); incr(k); }
11174 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
11175 the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
11176 case the cubic containing these control points is ``yet to be examined.''
11178 @<Declare a function called |insert_knot|@>=
11179 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
11180 /* returns the inserted knot */
11181 pointer r; /* the new knot */
11182 r=mp_get_node(mp, knot_node_size);
11183 link(r)=link(q); link(q)=r;
11184 right_x(r)=right_x(q);
11185 right_y(r)=right_y(q);
11188 right_x(q)=x_coord(q);
11189 right_y(q)=y_coord(q);
11190 left_x(r)=x_coord(r);
11191 left_y(r)=y_coord(r);
11192 left_type(r)=mp_explicit;
11193 right_type(r)=mp_explicit;
11194 originator(r)=mp_program_code;
11198 @ After setting |p:=link(p)|, either |join_type=1| or |q=link(p)|.
11200 @<Set |p=link(p)| and add knots between |p| and |q| as...@>=
11203 if ( (join_type==0)||(join_type==3) ) {
11204 if ( join_type==0 ) {
11205 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11207 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11211 right_x(r)=x_coord(r);
11212 right_y(r)=y_coord(r);
11217 @ For very small angles, adding a knot is unnecessary and would cause numerical
11218 problems, so we just set |r:=null| in that case.
11220 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11222 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11223 if ( abs(det)<26844 ) {
11224 r=null; /* sine $<10^{-4}$ */
11226 tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
11227 mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
11228 tmp=mp_make_fraction(mp, tmp,det);
11229 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11230 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11234 @ @<Other local variables for |make_envelope|@>=
11235 fraction det; /* a determinant used for mitered join calculations */
11237 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11239 ht_x=y_coord(w)-y_coord(w0);
11240 ht_y=x_coord(w0)-x_coord(w);
11241 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11242 ht_x+=ht_x; ht_y+=ht_y;
11244 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11245 product with |(ht_x,ht_y)|@>;
11246 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11247 mp_take_fraction(mp, dyin,ht_y));
11248 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11249 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11250 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11251 mp_take_fraction(mp, dyout,ht_y));
11252 r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11253 y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11256 @ @<Other local variables for |make_envelope|@>=
11257 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11258 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11259 halfword kk; /* keeps track of the pen vertices being scanned */
11260 pointer ww; /* the pen vertex being tested */
11262 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11263 from zero to |max_ht|.
11265 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11270 @<Step |ww| and move |kk| one step closer to |k0|@>;
11271 if ( kk==k0 ) break;
11272 tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
11273 mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
11274 if ( tmp>max_ht ) max_ht=tmp;
11278 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11279 if ( kk>k0 ) { ww=link(ww); decr(kk); }
11280 else { ww=knil(ww); incr(kk); }
11282 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11283 if ( left_type(c)==mp_endpoint ) {
11284 mp->spec_p1=mp_htap_ypoc(mp, c);
11285 mp->spec_p2=mp->path_tail;
11286 originator(mp->spec_p1)=mp_program_code;
11287 link(mp->spec_p2)=link(mp->spec_p1);
11288 link(mp->spec_p1)=c;
11289 mp_remove_cubic(mp, mp->spec_p1);
11291 if ( c!=link(c) ) {
11292 originator(mp->spec_p2)=mp_program_code;
11293 mp_remove_cubic(mp, mp->spec_p2);
11295 @<Make |c| look like a cycle of length one@>;
11299 @ @<Make |c| look like a cycle of length one@>=
11301 left_type(c)=mp_explicit; right_type(c)=mp_explicit;
11302 left_x(c)=x_coord(c); left_y(c)=y_coord(c);
11303 right_x(c)=x_coord(c); right_y(c)=y_coord(c);
11306 @ In degenerate situations we might have to look at the knot preceding~|q|.
11307 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11309 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11310 dxin=x_coord(q)-left_x(q);
11311 dyin=y_coord(q)-left_y(q);
11312 if ( (dxin==0)&&(dyin==0) ) {
11313 dxin=x_coord(q)-right_x(p);
11314 dyin=y_coord(q)-right_y(p);
11315 if ( (dxin==0)&&(dyin==0) ) {
11316 dxin=x_coord(q)-x_coord(p);
11317 dyin=y_coord(q)-y_coord(p);
11318 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11319 dxin=dxin+x_coord(w);
11320 dyin=dyin+y_coord(w);
11324 tmp=mp_pyth_add(mp, dxin,dyin);
11328 dxin=mp_make_fraction(mp, dxin,tmp);
11329 dyin=mp_make_fraction(mp, dyin,tmp);
11330 @<Set the outgoing direction at |q|@>;
11333 @ If |q=c| then the coordinates of |r| and the control points between |q|
11334 and~|r| have already been offset by |h|.
11336 @<Set the outgoing direction at |q|@>=
11337 dxout=right_x(q)-x_coord(q);
11338 dyout=right_y(q)-y_coord(q);
11339 if ( (dxout==0)&&(dyout==0) ) {
11341 dxout=left_x(r)-x_coord(q);
11342 dyout=left_y(r)-y_coord(q);
11343 if ( (dxout==0)&&(dyout==0) ) {
11344 dxout=x_coord(r)-x_coord(q);
11345 dyout=y_coord(r)-y_coord(q);
11349 dxout=dxout-x_coord(h);
11350 dyout=dyout-y_coord(h);
11352 tmp=mp_pyth_add(mp, dxout,dyout);
11353 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11354 @:this can't happen degerate spec}{\quad degenerate spec@>
11355 dxout=mp_make_fraction(mp, dxout,tmp);
11356 dyout=mp_make_fraction(mp, dyout,tmp)
11358 @* \[23] Direction and intersection times.
11359 A path of length $n$ is defined parametrically by functions $x(t)$ and
11360 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11361 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11362 we shall consider operations that determine special times associated with
11363 given paths: the first time that a path travels in a given direction, and
11364 a pair of times at which two paths cross each other.
11366 @ Let's start with the easier task. The function |find_direction_time| is
11367 given a direction |(x,y)| and a path starting at~|h|. If the path never
11368 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11369 it will be nonnegative.
11371 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11372 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11373 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11374 assumed to match any given direction at time~|t|.
11376 The routine solves this problem in nondegenerate cases by rotating the path
11377 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11378 to find when a given path first travels ``due east.''
11381 scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11382 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11383 pointer p,q; /* for list traversal */
11384 scaled n; /* the direction time at knot |p| */
11385 scaled tt; /* the direction time within a cubic */
11386 @<Other local variables for |find_direction_time|@>;
11387 @<Normalize the given direction for better accuracy;
11388 but |return| with zero result if it's zero@>;
11391 if ( right_type(p)==mp_endpoint ) break;
11393 @<Rotate the cubic between |p| and |q|; then
11394 |goto found| if the rotated cubic travels due east at some time |tt|;
11395 but |break| if an entire cyclic path has been traversed@>;
11403 @ @<Normalize the given direction for better accuracy...@>=
11404 if ( abs(x)<abs(y) ) {
11405 x=mp_make_fraction(mp, x,abs(y));
11406 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11407 } else if ( x==0 ) {
11410 y=mp_make_fraction(mp, y,abs(x));
11411 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11414 @ Since we're interested in the tangent directions, we work with the
11415 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
11416 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11417 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11418 in order to achieve better accuracy.
11420 The given path may turn abruptly at a knot, and it might pass the critical
11421 tangent direction at such a time. Therefore we remember the direction |phi|
11422 in which the previous rotated cubic was traveling. (The value of |phi| will be
11423 undefined on the first cubic, i.e., when |n=0|.)
11425 @<Rotate the cubic between |p| and |q|; then...@>=
11427 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11428 points of the rotated derivatives@>;
11429 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11431 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11434 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11435 @<Exit to |found| if the curve whose derivatives are specified by
11436 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11438 @ @<Other local variables for |find_direction_time|@>=
11439 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11440 angle theta,phi; /* angles of exit and entry at a knot */
11441 fraction t; /* temp storage */
11443 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11444 x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
11445 x3=x_coord(q)-left_x(q);
11446 y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
11447 y3=y_coord(q)-left_y(q);
11449 if ( abs(x2)>max ) max=abs(x2);
11450 if ( abs(x3)>max ) max=abs(x3);
11451 if ( abs(y1)>max ) max=abs(y1);
11452 if ( abs(y2)>max ) max=abs(y2);
11453 if ( abs(y3)>max ) max=abs(y3);
11454 if ( max==0 ) goto FOUND;
11455 while ( max<fraction_half ){
11456 max+=max; x1+=x1; x2+=x2; x3+=x3;
11457 y1+=y1; y2+=y2; y3+=y3;
11459 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11460 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11461 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11462 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11463 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11464 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11466 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11467 theta=mp_n_arg(mp, x1,y1);
11468 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11469 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11471 @ In this step we want to use the |crossing_point| routine to find the
11472 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11473 Several complications arise: If the quadratic equation has a double root,
11474 the curve never crosses zero, and |crossing_point| will find nothing;
11475 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11476 equation has simple roots, or only one root, we may have to negate it
11477 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11478 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11481 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11482 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11483 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11484 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11485 either |goto found| or |goto done|@>;
11488 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11489 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11491 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11492 $B(x_1,x_2,x_3;t)\ge0$@>;
11495 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11496 two roots, because we know that it isn't identically zero.
11498 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11499 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11500 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11501 subject to rounding errors. Yet this code optimistically tries to
11502 do the right thing.
11504 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11506 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11507 t=mp_crossing_point(mp, y1,y2,y3);
11508 if ( t>fraction_one ) goto DONE;
11509 y2=t_of_the_way(y2,y3);
11510 x1=t_of_the_way(x1,x2);
11511 x2=t_of_the_way(x2,x3);
11512 x1=t_of_the_way(x1,x2);
11513 if ( x1>=0 ) we_found_it;
11515 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11516 if ( t>fraction_one ) goto DONE;
11517 x1=t_of_the_way(x1,x2);
11518 x2=t_of_the_way(x2,x3);
11519 if ( t_of_the_way(x1,x2)>=0 ) {
11520 t=t_of_the_way(tt,fraction_one); we_found_it;
11523 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11524 either |goto found| or |goto done|@>=
11526 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11527 t=mp_make_fraction(mp, y1,y1-y2);
11528 x1=t_of_the_way(x1,x2);
11529 x2=t_of_the_way(x2,x3);
11530 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11531 } else if ( y3==0 ) {
11533 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11534 } else if ( x3>=0 ) {
11535 tt=unity; goto FOUND;
11541 @ At this point we know that the derivative of |y(t)| is identically zero,
11542 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11545 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11547 t=mp_crossing_point(mp, -x1,-x2,-x3);
11548 if ( t<=fraction_one ) we_found_it;
11549 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11550 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11554 @ The intersection of two cubics can be found by an interesting variant
11555 of the general bisection scheme described in the introduction to
11557 Given $w(t)=B(w_0,w_1,w_2,w_3;t)$ and $z(t)=B(z_0,z_1,z_2,z_3;t)$,
11558 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11559 if an intersection exists. First we find the smallest rectangle that
11560 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11561 the smallest rectangle that encloses
11562 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11563 But if the rectangles do overlap, we bisect the intervals, getting
11564 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11565 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11566 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11567 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11568 levels of bisection we will have determined the intersection times $t_1$
11569 and~$t_2$ to $l$~bits of accuracy.
11571 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11572 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11573 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11574 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11575 to determine when the enclosing rectangles overlap. Here's why:
11576 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11577 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11578 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11579 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11580 overlap if and only if $u\submin\L x\submax$ and
11581 $x\submin\L u\submax$. Letting
11582 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11583 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11584 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11586 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11587 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11588 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11589 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11590 because of the overlap condition; i.e., we know that $X\submin$,
11591 $X\submax$, and their relatives are bounded, hence $X\submax-
11592 U\submin$ and $X\submin-U\submax$ are bounded.
11594 @ Incidentally, if the given cubics intersect more than once, the process
11595 just sketched will not necessarily find the lexicographically smallest pair
11596 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11597 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11598 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11599 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11600 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11601 Shuffled order agrees with lexicographic order if all pairs of solutions
11602 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11603 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11604 and the bisection algorithm would be substantially less efficient if it were
11605 constrained by lexicographic order.
11607 For example, suppose that an overlap has been found for $l=3$ and
11608 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11609 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11610 Then there is probably an intersection in one of the subintervals
11611 $(.1011,.011x)$; but lexicographic order would require us to explore
11612 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11613 want to store all of the subdivision data for the second path, so the
11614 subdivisions would have to be regenerated many times. Such inefficiencies
11615 would be associated with every `1' in the binary representation of~$t_1$.
11617 @ The subdivision process introduces rounding errors, hence we need to
11618 make a more liberal test for overlap. It is not hard to show that the
11619 computed values of $U_i$ differ from the truth by at most~$l$, on
11620 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11621 If $\beta$ is an upper bound on the absolute error in the computed
11622 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11623 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11624 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11626 More accuracy is obtained if we try the algorithm first with |tol=0|;
11627 the more liberal tolerance is used only if an exact approach fails.
11628 It is convenient to do this double-take by letting `3' in the preceding
11629 paragraph be a parameter, which is first 0, then 3.
11632 unsigned int tol_step; /* either 0 or 3, usually */
11634 @ We shall use an explicit stack to implement the recursive bisection
11635 method described above. The |bisect_stack| array will contain numerous 5-word
11636 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11637 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11639 The following macros define the allocation of stack positions to
11640 the quantities needed for bisection-intersection.
11642 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11643 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11644 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11645 @d stack_min(A) mp->bisect_stack[(A)+3]
11646 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11647 @d stack_max(A) mp->bisect_stack[(A)+4]
11648 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11649 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11651 @d u_packet(A) ((A)-5)
11652 @d v_packet(A) ((A)-10)
11653 @d x_packet(A) ((A)-15)
11654 @d y_packet(A) ((A)-20)
11655 @d l_packets (mp->bisect_ptr-int_packets)
11656 @d r_packets mp->bisect_ptr
11657 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11658 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11659 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11660 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11661 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11662 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11663 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11664 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11666 @d u1l stack_1(ul_packet) /* $U'_1$ */
11667 @d u2l stack_2(ul_packet) /* $U'_2$ */
11668 @d u3l stack_3(ul_packet) /* $U'_3$ */
11669 @d v1l stack_1(vl_packet) /* $V'_1$ */
11670 @d v2l stack_2(vl_packet) /* $V'_2$ */
11671 @d v3l stack_3(vl_packet) /* $V'_3$ */
11672 @d x1l stack_1(xl_packet) /* $X'_1$ */
11673 @d x2l stack_2(xl_packet) /* $X'_2$ */
11674 @d x3l stack_3(xl_packet) /* $X'_3$ */
11675 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11676 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11677 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11678 @d u1r stack_1(ur_packet) /* $U''_1$ */
11679 @d u2r stack_2(ur_packet) /* $U''_2$ */
11680 @d u3r stack_3(ur_packet) /* $U''_3$ */
11681 @d v1r stack_1(vr_packet) /* $V''_1$ */
11682 @d v2r stack_2(vr_packet) /* $V''_2$ */
11683 @d v3r stack_3(vr_packet) /* $V''_3$ */
11684 @d x1r stack_1(xr_packet) /* $X''_1$ */
11685 @d x2r stack_2(xr_packet) /* $X''_2$ */
11686 @d x3r stack_3(xr_packet) /* $X''_3$ */
11687 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11688 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11689 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11691 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11692 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11693 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11694 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11695 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11696 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11699 integer *bisect_stack;
11700 unsigned int bisect_ptr;
11702 @ @<Allocate or initialize ...@>=
11703 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11705 @ @<Dealloc variables@>=
11706 xfree(mp->bisect_stack);
11708 @ @<Check the ``constant''...@>=
11709 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11711 @ Computation of the min and max is a tedious but fairly fast sequence of
11712 instructions; exactly four comparisons are made in each branch.
11715 if ( stack_1((A))<0 ) {
11716 if ( stack_3((A))>=0 ) {
11717 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11718 else stack_min((A))=stack_1((A));
11719 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11720 if ( stack_max((A))<0 ) stack_max((A))=0;
11722 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11723 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11724 stack_max((A))=stack_1((A))+stack_2((A));
11725 if ( stack_max((A))<0 ) stack_max((A))=0;
11727 } else if ( stack_3((A))<=0 ) {
11728 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11729 else stack_max((A))=stack_1((A));
11730 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11731 if ( stack_min((A))>0 ) stack_min((A))=0;
11733 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11734 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11735 stack_min((A))=stack_1((A))+stack_2((A));
11736 if ( stack_min((A))>0 ) stack_min((A))=0;
11739 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11740 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11741 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11742 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11743 plus the |scaled| values of $t_1$ and~$t_2$.
11745 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11746 finds no intersection. The routine gives up and gives an approximate answer
11747 if it has backtracked
11748 more than 5000 times (otherwise there are cases where several minutes
11749 of fruitless computation would be possible).
11751 @d max_patience 5000
11754 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11755 integer time_to_go; /* this many backtracks before giving up */
11756 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11758 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11759 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
11760 and |(pp,link(pp))|, respectively.
11762 @c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11763 pointer q,qq; /* |link(p)|, |link(pp)| */
11764 mp->time_to_go=max_patience; mp->max_t=2;
11765 @<Initialize for intersections at level zero@>;
11768 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11769 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11770 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11771 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11773 if ( mp->cur_t>=mp->max_t ){
11774 if ( mp->max_t==two ) { /* we've done 17 bisections */
11775 mp->cur_t=halfp(mp->cur_t+1);
11776 mp->cur_tt=halfp(mp->cur_tt+1);
11779 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11781 @<Subdivide for a new level of intersection@>;
11784 if ( mp->time_to_go>0 ) {
11785 decr(mp->time_to_go);
11787 while ( mp->appr_t<unity ) {
11788 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11790 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11792 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11796 @ The following variables are global, although they are used only by
11797 |cubic_intersection|, because it is necessary on some machines to
11798 split |cubic_intersection| up into two procedures.
11801 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11802 integer tol; /* bound on the uncertainty in the overlap test */
11804 unsigned int xy; /* pointers to the current packets of interest */
11805 integer three_l; /* |tol_step| times the bisection level */
11806 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11808 @ We shall assume that the coordinates are sufficiently non-extreme that
11809 integer overflow will not occur.
11810 @^overflow in arithmetic@>
11812 @<Initialize for intersections at level zero@>=
11813 q=link(p); qq=link(pp); mp->bisect_ptr=int_packets;
11814 u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
11815 u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
11816 v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
11817 v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
11818 x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
11819 x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
11820 y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
11821 y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
11822 mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
11823 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11824 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11826 @ @<Subdivide for a new level of intersection@>=
11827 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11828 stack_uv=mp->uv; stack_xy=mp->xy;
11829 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11830 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11831 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11832 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11833 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11834 u3l=half(u2l+u2r); u1r=u3l;
11835 set_min_max(ul_packet); set_min_max(ur_packet);
11836 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11837 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11838 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11839 v3l=half(v2l+v2r); v1r=v3l;
11840 set_min_max(vl_packet); set_min_max(vr_packet);
11841 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11842 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11843 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11844 x3l=half(x2l+x2r); x1r=x3l;
11845 set_min_max(xl_packet); set_min_max(xr_packet);
11846 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11847 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11848 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11849 y3l=half(y2l+y2r); y1r=y3l;
11850 set_min_max(yl_packet); set_min_max(yr_packet);
11851 mp->uv=l_packets; mp->xy=l_packets;
11852 mp->delx+=mp->delx; mp->dely+=mp->dely;
11853 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11854 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11856 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11858 if ( odd(mp->cur_tt) ) {
11859 if ( odd(mp->cur_t) ) {
11860 @<Descend to the previous level and |goto not_found|@>;
11863 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11864 +stack_3(u_packet(mp->uv));
11865 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11866 +stack_3(v_packet(mp->uv));
11867 mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
11868 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11869 /* switch from |r_packets| to |l_packets| */
11870 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11871 +stack_3(x_packet(mp->xy));
11872 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11873 +stack_3(y_packet(mp->xy));
11876 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11877 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11878 -stack_3(x_packet(mp->xy));
11879 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11880 -stack_3(y_packet(mp->xy));
11881 mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
11884 @ @<Descend to the previous level...@>=
11886 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11887 if ( mp->cur_t==0 ) return;
11888 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11889 mp->three_l=mp->three_l-mp->tol_step;
11890 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11891 mp->uv=stack_uv; mp->xy=stack_xy;
11895 @ The |path_intersection| procedure is much simpler.
11896 It invokes |cubic_intersection| in lexicographic order until finding a
11897 pair of cubics that intersect. The final intersection times are placed in
11898 |cur_t| and~|cur_tt|.
11900 @c void mp_path_intersection (MP mp,pointer h, pointer hh) {
11901 pointer p,pp; /* link registers that traverse the given paths */
11902 integer n,nn; /* integer parts of intersection times, minus |unity| */
11903 @<Change one-point paths into dead cycles@>;
11908 if ( right_type(p)!=mp_endpoint ) {
11911 if ( right_type(pp)!=mp_endpoint ) {
11912 mp_cubic_intersection(mp, p,pp);
11913 if ( mp->cur_t>0 ) {
11914 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11918 nn=nn+unity; pp=link(pp);
11921 n=n+unity; p=link(p);
11923 mp->tol_step=mp->tol_step+3;
11924 } while (mp->tol_step<=3);
11925 mp->cur_t=-unity; mp->cur_tt=-unity;
11928 @ @<Change one-point paths...@>=
11929 if ( right_type(h)==mp_endpoint ) {
11930 right_x(h)=x_coord(h); left_x(h)=x_coord(h);
11931 right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
11933 if ( right_type(hh)==mp_endpoint ) {
11934 right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
11935 right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
11938 @* \[24] Dynamic linear equations.
11939 \MP\ users define variables implicitly by stating equations that should be
11940 satisfied; the computer is supposed to be smart enough to solve those equations.
11941 And indeed, the computer tries valiantly to do so, by distinguishing five
11942 different types of numeric values:
11945 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11946 of the variable whose address is~|p|.
11949 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11950 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11951 as a |scaled| number plus a sum of independent variables with |fraction|
11955 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11956 number'' reflecting the time this variable was first used in an equation;
11957 also |0<=m<64|, and each dependent variable
11958 that refers to this one is actually referring to the future value of
11959 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11960 scaling are sometimes needed to keep the coefficients in dependency lists
11961 from getting too large. The value of~|m| will always be even.)
11964 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11965 equation before, but it has been explicitly declared to be numeric.
11968 |type(p)=undefined| means that variable |p| hasn't appeared before.
11970 \smallskip\noindent
11971 We have actually discussed these five types in the reverse order of their
11972 history during a computation: Once |known|, a variable never again
11973 becomes |dependent|; once |dependent|, it almost never again becomes
11974 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
11975 and once |mp_numeric_type|, it never again becomes |undefined| (except
11976 of course when the user specifically decides to scrap the old value
11977 and start again). A backward step may, however, take place: Sometimes
11978 a |dependent| variable becomes |mp_independent| again, when one of the
11979 independent variables it depends on is reverting to |undefined|.
11982 The next patch detects overflow of independent-variable serial
11983 numbers. Diagnosed and patched by Thorsten Dahlheimer.
11985 @d s_scale 64 /* the serial numbers are multiplied by this factor */
11986 @d new_indep(A) /* create a new independent variable */
11987 { if ( mp->serial_no>el_gordo-s_scale )
11988 mp_fatal_error(mp, "variable instance identifiers exhausted");
11989 type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
11990 value((A))=mp->serial_no;
11994 integer serial_no; /* the most recent serial number, times |s_scale| */
11996 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
11998 @ But how are dependency lists represented? It's simple: The linear combination
11999 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
12000 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
12001 @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
12002 of $\alpha_1$; and |link(p)| points to the dependency list
12003 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
12004 then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
12005 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
12006 they appear in decreasing order of their |value| fields (i.e., of
12007 their serial numbers). \ (It is convenient to use decreasing order,
12008 since |value(null)=0|. If the independent variables were not sorted by
12009 serial number but by some other criterion, such as their location in |mem|,
12010 the equation-solving mechanism would be too system-dependent, because
12011 the ordering can affect the computed results.)
12013 The |link| field in the node that contains the constant term $\beta$ is
12014 called the {\sl final link\/} of the dependency list. \MP\ maintains
12015 a doubly-linked master list of all dependency lists, in terms of a permanently
12017 in |mem| called |dep_head|. If there are no dependencies, we have
12018 |link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
12019 otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
12020 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
12021 points to its dependency list. If the final link of that dependency list
12022 occurs in location~|q|, then |link(q)| points to the next dependent
12023 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
12025 @d dep_list(A) link(value_loc((A)))
12026 /* half of the |value| field in a |dependent| variable */
12027 @d prev_dep(A) info(value_loc((A)))
12028 /* the other half; makes a doubly linked list */
12029 @d dep_node_size 2 /* the number of words per dependency node */
12031 @<Initialize table entries...@>= mp->serial_no=0;
12032 link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
12033 info(dep_head)=null; dep_list(dep_head)=null;
12035 @ Actually the description above contains a little white lie. There's
12036 another kind of variable called |mp_proto_dependent|, which is
12037 just like a |dependent| one except that the $\alpha$ coefficients
12038 in its dependency list are |scaled| instead of being fractions.
12039 Proto-dependency lists are mixed with dependency lists in the
12040 nodes reachable from |dep_head|.
12042 @ Here is a procedure that prints a dependency list in symbolic form.
12043 The second parameter should be either |dependent| or |mp_proto_dependent|,
12044 to indicate the scaling of the coefficients.
12046 @<Declare subroutines for printing expressions@>=
12047 void mp_print_dependency (MP mp,pointer p, small_number t) {
12048 integer v; /* a coefficient */
12049 pointer pp,q; /* for list manipulation */
12052 v=abs(value(p)); q=info(p);
12053 if ( q==null ) { /* the constant term */
12054 if ( (v!=0)||(p==pp) ) {
12055 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, '+');
12056 mp_print_scaled(mp, value(p));
12060 @<Print the coefficient, unless it's $\pm1.0$@>;
12061 if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
12062 @:this can't happen dep}{\quad dep@>
12063 mp_print_variable_name(mp, q); v=value(q) % s_scale;
12064 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
12069 @ @<Print the coefficient, unless it's $\pm1.0$@>=
12070 if ( value(p)<0 ) mp_print_char(mp, '-');
12071 else if ( p!=pp ) mp_print_char(mp, '+');
12072 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
12073 if ( v!=unity ) mp_print_scaled(mp, v)
12075 @ The maximum absolute value of a coefficient in a given dependency list
12076 is returned by the following simple function.
12078 @c fraction mp_max_coef (MP mp,pointer p) {
12079 fraction x; /* the maximum so far */
12081 while ( info(p)!=null ) {
12082 if ( abs(value(p))>x ) x=abs(value(p));
12088 @ One of the main operations needed on dependency lists is to add a multiple
12089 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
12090 to dependency lists and |f| is a fraction.
12092 If the coefficient of any independent variable becomes |coef_bound| or
12093 more, in absolute value, this procedure changes the type of that variable
12094 to `|independent_needing_fix|', and sets the global variable |fix_needed|
12095 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
12096 $\mu^2+\mu<8$; this means that the numbers we deal with won't
12097 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
12098 2.3723$, the safer value 7/3 is taken as the threshold.)
12100 The changes mentioned in the preceding paragraph are actually done only if
12101 the global variable |watch_coefs| is |true|. But it usually is; in fact,
12102 it is |false| only when \MP\ is making a dependency list that will soon
12103 be equated to zero.
12105 Several procedures that act on dependency lists, including |p_plus_fq|,
12106 set the global variable |dep_final| to the final (constant term) node of
12107 the dependency list that they produce.
12109 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
12110 @d independent_needing_fix 0
12113 boolean fix_needed; /* does at least one |independent| variable need scaling? */
12114 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
12115 pointer dep_final; /* location of the constant term and final link */
12118 mp->fix_needed=false; mp->watch_coefs=true;
12120 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
12121 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
12122 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
12123 should be |mp_proto_dependent| if |q| is a proto-dependency list.
12125 List |q| is unchanged by the operation; but list |p| is totally destroyed.
12127 The final link of the dependency list or proto-dependency list returned
12128 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
12129 constant term of the result will be located in the same |mem| location
12130 as the original constant term of~|p|.
12132 Coefficients of the result are assumed to be zero if they are less than
12133 a certain threshold. This compensates for inevitable rounding errors,
12134 and tends to make more variables `|known|'. The threshold is approximately
12135 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
12136 proto-dependencies.
12138 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
12139 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
12140 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
12141 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
12143 @<Declare basic dependency-list subroutines@>=
12144 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12145 pointer q, small_number t, small_number tt) ;
12148 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12149 pointer q, small_number t, small_number tt) {
12150 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12151 pointer r,s; /* for list manipulation */
12152 integer threshold; /* defines a neighborhood of zero */
12153 integer v; /* temporary register */
12154 if ( t==mp_dependent ) threshold=fraction_threshold;
12155 else threshold=scaled_threshold;
12156 r=temp_head; pp=info(p); qq=info(q);
12162 @<Contribute a term from |p|, plus |f| times the
12163 corresponding term from |q|@>
12165 } else if ( value(pp)<value(qq) ) {
12166 @<Contribute a term from |q|, multiplied by~|f|@>
12168 link(r)=p; r=p; p=link(p); pp=info(p);
12171 if ( t==mp_dependent )
12172 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
12174 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
12175 link(r)=p; mp->dep_final=p;
12176 return link(temp_head);
12179 @ @<Contribute a term from |p|, plus |f|...@>=
12181 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
12182 else v=value(p)+mp_take_scaled(mp, f,value(q));
12183 value(p)=v; s=p; p=link(p);
12184 if ( abs(v)<threshold ) {
12185 mp_free_node(mp, s,dep_node_size);
12187 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12188 type(qq)=independent_needing_fix; mp->fix_needed=true;
12192 pp=info(p); q=link(q); qq=info(q);
12195 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12197 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12198 else v=mp_take_scaled(mp, f,value(q));
12199 if ( abs(v)>halfp(threshold) ) {
12200 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
12201 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12202 type(qq)=independent_needing_fix; mp->fix_needed=true;
12206 q=link(q); qq=info(q);
12209 @ It is convenient to have another subroutine for the special case
12210 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12211 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12213 @c pointer mp_p_plus_q (MP mp,pointer p, pointer q, small_number t) {
12214 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12215 pointer r,s; /* for list manipulation */
12216 integer threshold; /* defines a neighborhood of zero */
12217 integer v; /* temporary register */
12218 if ( t==mp_dependent ) threshold=fraction_threshold;
12219 else threshold=scaled_threshold;
12220 r=temp_head; pp=info(p); qq=info(q);
12226 @<Contribute a term from |p|, plus the
12227 corresponding term from |q|@>
12230 if ( value(pp)<value(qq) ) {
12231 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
12232 q=link(q); qq=info(q); link(r)=s; r=s;
12234 link(r)=p; r=p; p=link(p); pp=info(p);
12238 value(p)=mp_slow_add(mp, value(p),value(q));
12239 link(r)=p; mp->dep_final=p;
12240 return link(temp_head);
12243 @ @<Contribute a term from |p|, plus the...@>=
12245 v=value(p)+value(q);
12246 value(p)=v; s=p; p=link(p); pp=info(p);
12247 if ( abs(v)<threshold ) {
12248 mp_free_node(mp, s,dep_node_size);
12250 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12251 type(qq)=independent_needing_fix; mp->fix_needed=true;
12255 q=link(q); qq=info(q);
12258 @ A somewhat simpler routine will multiply a dependency list
12259 by a given constant~|v|. The constant is either a |fraction| less than
12260 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12261 convert a dependency list to a proto-dependency list.
12262 Parameters |t0| and |t1| are the list types before and after;
12263 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12264 and |v_is_scaled=true|.
12266 @c pointer mp_p_times_v (MP mp,pointer p, integer v, small_number t0,
12267 small_number t1, boolean v_is_scaled) {
12268 pointer r,s; /* for list manipulation */
12269 integer w; /* tentative coefficient */
12271 boolean scaling_down;
12272 if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
12273 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12274 else threshold=half_scaled_threshold;
12276 while ( info(p)!=null ) {
12277 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12278 else w=mp_take_scaled(mp, v,value(p));
12279 if ( abs(w)<=threshold ) {
12280 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12282 if ( abs(w)>=coef_bound ) {
12283 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12285 link(r)=p; r=p; value(p)=w; p=link(p);
12289 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12290 else value(p)=mp_take_fraction(mp, value(p),v);
12291 return link(temp_head);
12294 @ Similarly, we sometimes need to divide a dependency list
12295 by a given |scaled| constant.
12297 @<Declare basic dependency-list subroutines@>=
12298 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12299 t0, small_number t1) ;
12302 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12303 t0, small_number t1) {
12304 pointer r,s; /* for list manipulation */
12305 integer w; /* tentative coefficient */
12307 boolean scaling_down;
12308 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12309 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12310 else threshold=half_scaled_threshold;
12312 while ( info( p)!=null ) {
12313 if ( scaling_down ) {
12314 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12315 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12317 w=mp_make_scaled(mp, value(p),v);
12319 if ( abs(w)<=threshold ) {
12320 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12322 if ( abs(w)>=coef_bound ) {
12323 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12325 link(r)=p; r=p; value(p)=w; p=link(p);
12328 link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12329 return link(temp_head);
12332 @ Here's another utility routine for dependency lists. When an independent
12333 variable becomes dependent, we want to remove it from all existing
12334 dependencies. The |p_with_x_becoming_q| function computes the
12335 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12337 This procedure has basically the same calling conventions as |p_plus_fq|:
12338 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12339 final link are inherited from~|p|; and the fourth parameter tells whether
12340 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12341 is not altered if |x| does not occur in list~|p|.
12343 @c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12344 pointer x, pointer q, small_number t) {
12345 pointer r,s; /* for list manipulation */
12346 integer v; /* coefficient of |x| */
12347 integer sx; /* serial number of |x| */
12348 s=p; r=temp_head; sx=value(x);
12349 while ( value(info(s))>sx ) { r=s; s=link(s); };
12350 if ( info(s)!=x ) {
12353 link(temp_head)=p; link(r)=link(s); v=value(s);
12354 mp_free_node(mp, s,dep_node_size);
12355 return mp_p_plus_fq(mp, link(temp_head),v,q,t,mp_dependent);
12359 @ Here's a simple procedure that reports an error when a variable
12360 has just received a known value that's out of the required range.
12362 @<Declare basic dependency-list subroutines@>=
12363 void mp_val_too_big (MP mp,scaled x) ;
12365 @ @c void mp_val_too_big (MP mp,scaled x) {
12366 if ( mp->internal[mp_warning_check]>0 ) {
12367 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, ')');
12368 @.Value is too large@>
12369 help4("The equation I just processed has given some variable")
12370 ("a value of 4096 or more. Continue and I'll try to cope")
12371 ("with that big value; but it might be dangerous.")
12372 ("(Set warningcheck:=0 to suppress this message.)");
12377 @ When a dependent variable becomes known, the following routine
12378 removes its dependency list. Here |p| points to the variable, and
12379 |q| points to the dependency list (which is one node long).
12381 @<Declare basic dependency-list subroutines@>=
12382 void mp_make_known (MP mp,pointer p, pointer q) ;
12384 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12385 int t; /* the previous type */
12386 prev_dep(link(q))=prev_dep(p);
12387 link(prev_dep(p))=link(q); t=type(p);
12388 type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12389 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12390 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12391 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12392 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12393 mp_print_variable_name(mp, p);
12394 mp_print_char(mp, '='); mp_print_scaled(mp, value(p));
12395 mp_end_diagnostic(mp, false);
12397 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12398 mp->cur_type=mp_known; mp->cur_exp=value(p);
12399 mp_free_node(mp, p,value_node_size);
12403 @ The |fix_dependencies| routine is called into action when |fix_needed|
12404 has been triggered. The program keeps a list~|s| of independent variables
12405 whose coefficients must be divided by~4.
12407 In unusual cases, this fixup process might reduce one or more coefficients
12408 to zero, so that a variable will become known more or less by default.
12410 @<Declare basic dependency-list subroutines@>=
12411 void mp_fix_dependencies (MP mp);
12413 @ @c void mp_fix_dependencies (MP mp) {
12414 pointer p,q,r,s,t; /* list manipulation registers */
12415 pointer x; /* an independent variable */
12416 r=link(dep_head); s=null;
12417 while ( r!=dep_head ){
12419 @<Run through the dependency list for variable |t|, fixing
12420 all nodes, and ending with final link~|q|@>;
12422 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12424 while ( s!=null ) {
12425 p=link(s); x=info(s); free_avail(s); s=p;
12426 type(x)=mp_independent; value(x)=value(x)+2;
12428 mp->fix_needed=false;
12431 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12433 @<Run through the dependency list for variable |t|...@>=
12434 r=value_loc(t); /* |link(r)=dep_list(t)| */
12436 q=link(r); x=info(q);
12437 if ( x==null ) break;
12438 if ( type(x)<=independent_being_fixed ) {
12439 if ( type(x)<independent_being_fixed ) {
12440 p=mp_get_avail(mp); link(p)=s; s=p;
12441 info(s)=x; type(x)=independent_being_fixed;
12443 value(q)=value(q) / 4;
12444 if ( value(q)==0 ) {
12445 link(r)=link(q); mp_free_node(mp, q,dep_node_size); q=r;
12452 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12453 linking it into the list of all known dependencies. We assume that
12454 |dep_final| points to the final node of list~|p|.
12456 @c void mp_new_dep (MP mp,pointer q, pointer p) {
12457 pointer r; /* what used to be the first dependency */
12458 dep_list(q)=p; prev_dep(q)=dep_head;
12459 r=link(dep_head); link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12463 @ Here is one of the ways a dependency list gets started.
12464 The |const_dependency| routine produces a list that has nothing but
12467 @c pointer mp_const_dependency (MP mp, scaled v) {
12468 mp->dep_final=mp_get_node(mp, dep_node_size);
12469 value(mp->dep_final)=v; info(mp->dep_final)=null;
12470 return mp->dep_final;
12473 @ And here's a more interesting way to start a dependency list from scratch:
12474 The parameter to |single_dependency| is the location of an
12475 independent variable~|x|, and the result is the simple dependency list
12478 In the unlikely event that the given independent variable has been doubled so
12479 often that we can't refer to it with a nonzero coefficient,
12480 |single_dependency| returns the simple list `0'. This case can be
12481 recognized by testing that the returned list pointer is equal to
12484 @c pointer mp_single_dependency (MP mp,pointer p) {
12485 pointer q; /* the new dependency list */
12486 integer m; /* the number of doublings */
12487 m=value(p) % s_scale;
12489 return mp_const_dependency(mp, 0);
12491 q=mp_get_node(mp, dep_node_size);
12492 value(q)=two_to_the(28-m); info(q)=p;
12493 link(q)=mp_const_dependency(mp, 0);
12498 @ We sometimes need to make an exact copy of a dependency list.
12500 @c pointer mp_copy_dep_list (MP mp,pointer p) {
12501 pointer q; /* the new dependency list */
12502 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12504 info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
12505 if ( info(mp->dep_final)==null ) break;
12506 link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12507 mp->dep_final=link(mp->dep_final); p=link(p);
12512 @ But how do variables normally become known? Ah, now we get to the heart of the
12513 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12514 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12515 appears. It equates this list to zero, by choosing an independent variable
12516 with the largest coefficient and making it dependent on the others. The
12517 newly dependent variable is eliminated from all current dependencies,
12518 thereby possibly making other dependent variables known.
12520 The given list |p| is, of course, totally destroyed by all this processing.
12522 @c void mp_linear_eq (MP mp, pointer p, small_number t) {
12523 pointer q,r,s; /* for link manipulation */
12524 pointer x; /* the variable that loses its independence */
12525 integer n; /* the number of times |x| had been halved */
12526 integer v; /* the coefficient of |x| in list |p| */
12527 pointer prev_r; /* lags one step behind |r| */
12528 pointer final_node; /* the constant term of the new dependency list */
12529 integer w; /* a tentative coefficient */
12530 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12531 x=info(q); n=value(x) % s_scale;
12532 @<Divide list |p| by |-v|, removing node |q|@>;
12533 if ( mp->internal[mp_tracing_equations]>0 ) {
12534 @<Display the new dependency@>;
12536 @<Simplify all existing dependencies by substituting for |x|@>;
12537 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12538 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12541 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12542 q=p; r=link(p); v=value(q);
12543 while ( info(r)!=null ) {
12544 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12548 @ Here we want to change the coefficients from |scaled| to |fraction|,
12549 except in the constant term. In the common case of a trivial equation
12550 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12552 @<Divide list |p| by |-v|, removing node |q|@>=
12553 s=temp_head; link(s)=p; r=p;
12556 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12558 w=mp_make_fraction(mp, value(r),v);
12559 if ( abs(w)<=half_fraction_threshold ) {
12560 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12566 } while (info(r)!=null);
12567 if ( t==mp_proto_dependent ) {
12568 value(r)=-mp_make_scaled(mp, value(r),v);
12569 } else if ( v!=-fraction_one ) {
12570 value(r)=-mp_make_fraction(mp, value(r),v);
12572 final_node=r; p=link(temp_head)
12574 @ @<Display the new dependency@>=
12575 if ( mp_interesting(mp, x) ) {
12576 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12577 mp_print_variable_name(mp, x);
12578 @:]]]\#\#_}{\.{\#\#}@>
12580 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12581 mp_print_char(mp, '='); mp_print_dependency(mp, p,mp_dependent);
12582 mp_end_diagnostic(mp, false);
12585 @ @<Simplify all existing dependencies by substituting for |x|@>=
12586 prev_r=dep_head; r=link(dep_head);
12587 while ( r!=dep_head ) {
12588 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
12589 if ( info(q)==null ) {
12590 mp_make_known(mp, r,q);
12593 do { q=link(q); } while (info(q)!=null);
12599 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12600 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12601 if ( info(p)==null ) {
12604 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12605 mp_free_node(mp, p,dep_node_size);
12606 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12607 mp->cur_exp=value(x); mp->cur_type=mp_known;
12608 mp_free_node(mp, x,value_node_size);
12611 type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12612 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12615 @ @<Divide list |p| by $2^n$@>=
12617 s=temp_head; link(temp_head)=p; r=p;
12620 else w=value(r) / two_to_the(n);
12621 if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
12623 mp_free_node(mp, r,dep_node_size);
12628 } while (info(s)!=null);
12632 @ The |check_mem| procedure, which is used only when \MP\ is being
12633 debugged, makes sure that the current dependency lists are well formed.
12635 @<Check the list of linear dependencies@>=
12636 q=dep_head; p=link(q);
12637 while ( p!=dep_head ) {
12638 if ( prev_dep(p)!=q ) {
12639 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12644 r=info(p); q=p; p=link(q);
12645 if ( r==null ) break;
12646 if ( value(info(p))>=value(r) ) {
12647 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12648 @.Out of order...@>
12653 @* \[25] Dynamic nonlinear equations.
12654 Variables of numeric type are maintained by the general scheme of
12655 independent, dependent, and known values that we have just studied;
12656 and the components of pair and transform variables are handled in the
12657 same way. But \MP\ also has five other types of values: \&{boolean},
12658 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12660 Equations are allowed between nonlinear quantities, but only in a
12661 simple form. Two variables that haven't yet been assigned values are
12662 either equal to each other, or they're not.
12664 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12665 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12666 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12667 |null| (which means that no other variables are equivalent to this one), or
12668 it points to another variable of the same undefined type. The pointers in the
12669 latter case form a cycle of nodes, which we shall call a ``ring.''
12670 Rings of undefined variables may include capsules, which arise as
12671 intermediate results within expressions or as \&{expr} parameters to macros.
12673 When one member of a ring receives a value, the same value is given to
12674 all the other members. In the case of paths and pictures, this implies
12675 making separate copies of a potentially large data structure; users should
12676 restrain their enthusiasm for such generality, unless they have lots and
12677 lots of memory space.
12679 @ The following procedure is called when a capsule node is being
12680 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12682 @c pointer mp_new_ring_entry (MP mp,pointer p) {
12683 pointer q; /* the new capsule node */
12684 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
12686 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12691 @ Conversely, we might delete a capsule or a variable before it becomes known.
12692 The following procedure simply detaches a quantity from its ring,
12693 without recycling the storage.
12695 @<Declare the recycling subroutines@>=
12696 void mp_ring_delete (MP mp,pointer p) {
12699 if ( q!=null ) if ( q!=p ){
12700 while ( value(q)!=p ) q=value(q);
12705 @ Eventually there might be an equation that assigns values to all of the
12706 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12707 propagation of values.
12709 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12710 value, it will soon be recycled.
12712 @c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12713 small_number t; /* the type of ring |p| */
12714 pointer q,r; /* link manipulation registers */
12715 t=type(p)-unknown_tag; q=value(p);
12716 if ( flush_p ) type(p)=mp_vacuous; else p=q;
12718 r=value(q); type(q)=t;
12720 case mp_boolean_type: value(q)=v; break;
12721 case mp_string_type: value(q)=v; add_str_ref(v); break;
12722 case mp_pen_type: value(q)=copy_pen(v); break;
12723 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12724 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12725 } /* there ain't no more cases */
12730 @ If two members of rings are equated, and if they have the same type,
12731 the |ring_merge| procedure is called on to make them equivalent.
12733 @c void mp_ring_merge (MP mp,pointer p, pointer q) {
12734 pointer r; /* traverses one list */
12738 @<Exclaim about a redundant equation@>;
12743 r=value(p); value(p)=value(q); value(q)=r;
12746 @ @<Exclaim about a redundant equation@>=
12748 print_err("Redundant equation");
12749 @.Redundant equation@>
12750 help2("I already knew that this equation was true.")
12751 ("But perhaps no harm has been done; let's continue.");
12752 mp_put_get_error(mp);
12755 @* \[26] Introduction to the syntactic routines.
12756 Let's pause a moment now and try to look at the Big Picture.
12757 The \MP\ program consists of three main parts: syntactic routines,
12758 semantic routines, and output routines. The chief purpose of the
12759 syntactic routines is to deliver the user's input to the semantic routines,
12760 while parsing expressions and locating operators and operands. The
12761 semantic routines act as an interpreter responding to these operators,
12762 which may be regarded as commands. And the output routines are
12763 periodically called on to produce compact font descriptions that can be
12764 used for typesetting or for making interim proof drawings. We have
12765 discussed the basic data structures and many of the details of semantic
12766 operations, so we are good and ready to plunge into the part of \MP\ that
12767 actually controls the activities.
12769 Our current goal is to come to grips with the |get_next| procedure,
12770 which is the keystone of \MP's input mechanism. Each call of |get_next|
12771 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12772 representing the next input token.
12773 $$\vbox{\halign{#\hfil\cr
12774 \hbox{|cur_cmd| denotes a command code from the long list of codes
12776 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12777 \hbox{|cur_sym| is the hash address of the symbolic token that was
12779 \hbox{\qquad or zero in the case of a numeric or string
12780 or capsule token.}\cr}}$$
12781 Underlying this external behavior of |get_next| is all the machinery
12782 necessary to convert from character files to tokens. At a given time we
12783 may be only partially finished with the reading of several files (for
12784 which \&{input} was specified), and partially finished with the expansion
12785 of some user-defined macros and/or some macro parameters, and partially
12786 finished reading some text that the user has inserted online,
12787 and so on. When reading a character file, the characters must be
12788 converted to tokens; comments and blank spaces must
12789 be removed, numeric and string tokens must be evaluated.
12791 To handle these situations, which might all be present simultaneously,
12792 \MP\ uses various stacks that hold information about the incomplete
12793 activities, and there is a finite state control for each level of the
12794 input mechanism. These stacks record the current state of an implicitly
12795 recursive process, but the |get_next| procedure is not recursive.
12798 eight_bits cur_cmd; /* current command set by |get_next| */
12799 integer cur_mod; /* operand of current command */
12800 halfword cur_sym; /* hash address of current symbol */
12802 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12803 command code and its modifier.
12804 It consists of a rather tedious sequence of print
12805 commands, and most of it is essentially an inverse to the |primitive|
12806 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12807 all of this procedure appears elsewhere in the program, together with the
12808 corresponding |primitive| calls.
12810 @<Declare the procedure called |print_cmd_mod|@>=
12811 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12813 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12814 default: mp_print(mp, "[unknown command code!]"); break;
12818 @ Here is a procedure that displays a given command in braces, in the
12819 user's transcript file.
12821 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12824 void mp_show_cmd_mod (MP mp,integer c, integer m) {
12825 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12826 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, '}');
12827 mp_end_diagnostic(mp, false);
12830 @* \[27] Input stacks and states.
12831 The state of \MP's input mechanism appears in the input stack, whose
12832 entries are records with five fields, called |index|, |start|, |loc|,
12833 |limit|, and |name|. The top element of this stack is maintained in a
12834 global variable for which no subscripting needs to be done; the other
12835 elements of the stack appear in an array. Hence the stack is declared thus:
12839 quarterword index_field;
12840 halfword start_field, loc_field, limit_field, name_field;
12844 in_state_record *input_stack;
12845 integer input_ptr; /* first unused location of |input_stack| */
12846 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12847 in_state_record cur_input; /* the ``top'' input state */
12848 int stack_size; /* maximum number of simultaneous input sources */
12850 @ @<Allocate or initialize ...@>=
12851 mp->stack_size = 300;
12852 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12854 @ @<Dealloc variables@>=
12855 xfree(mp->input_stack);
12857 @ We've already defined the special variable |loc==cur_input.loc_field|
12858 in our discussion of basic input-output routines. The other components of
12859 |cur_input| are defined in the same way:
12861 @d index mp->cur_input.index_field /* reference for buffer information */
12862 @d start mp->cur_input.start_field /* starting position in |buffer| */
12863 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12864 @d name mp->cur_input.name_field /* name of the current file */
12866 @ Let's look more closely now at the five control variables
12867 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12868 assuming that \MP\ is reading a line of characters that have been input
12869 from some file or from the user's terminal. There is an array called
12870 |buffer| that acts as a stack of all lines of characters that are
12871 currently being read from files, including all lines on subsidiary
12872 levels of the input stack that are not yet completed. \MP\ will return to
12873 the other lines when it is finished with the present input file.
12875 (Incidentally, on a machine with byte-oriented addressing, it would be
12876 appropriate to combine |buffer| with the |str_pool| array,
12877 letting the buffer entries grow downward from the top of the string pool
12878 and checking that these two tables don't bump into each other.)
12880 The line we are currently working on begins in position |start| of the
12881 buffer; the next character we are about to read is |buffer[loc]|; and
12882 |limit| is the location of the last character present. We always have
12883 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12884 that the end of a line is easily sensed.
12886 The |name| variable is a string number that designates the name of
12887 the current file, if we are reading an ordinary text file. Special codes
12888 |is_term..max_spec_src| indicate other sources of input text.
12890 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12891 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12892 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12893 @d max_spec_src is_scantok
12895 @ Additional information about the current line is available via the
12896 |index| variable, which counts how many lines of characters are present
12897 in the buffer below the current level. We have |index=0| when reading
12898 from the terminal and prompting the user for each line; then if the user types,
12899 e.g., `\.{input figs}', we will have |index=1| while reading
12900 the file \.{figs.mp}. However, it does not follow that |index| is the
12901 same as the input stack pointer, since many of the levels on the input
12902 stack may come from token lists and some |index| values may correspond
12903 to \.{MPX} files that are not currently on the stack.
12905 The global variable |in_open| is equal to the highest |index| value counting
12906 \.{MPX} files but excluding token-list input levels. Thus, the number of
12907 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12908 when we are not reading a token list.
12910 If we are not currently reading from the terminal,
12911 we are reading from the file variable |input_file[index]|. We use
12912 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12913 and |cur_file| as an abbreviation for |input_file[index]|.
12915 When \MP\ is not reading from the terminal, the global variable |line| contains
12916 the line number in the current file, for use in error messages. More precisely,
12917 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12918 the line number for each file in the |input_file| array.
12920 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12921 array so that the name doesn't get lost when the file is temporarily removed
12922 from the input stack.
12923 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12924 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12925 Since this is not an \.{MPX} file, we have
12926 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12927 This |name| field is set to |finished| when |input_file[k]| is completely
12930 If more information about the input state is needed, it can be
12931 included in small arrays like those shown here. For example,
12932 the current page or segment number in the input file might be put
12933 into a variable |page|, that is really a macro for the current entry
12934 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12935 by analogy with |line_stack|.
12936 @^system dependencies@>
12938 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12939 @d cur_file mp->input_file[index] /* the current |void *| variable */
12940 @d line mp->line_stack[index] /* current line number in the current source file */
12941 @d in_name mp->iname_stack[index] /* a string used to construct \.{MPX} file names */
12942 @d in_area mp->iarea_stack[index] /* another string for naming \.{MPX} files */
12943 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12944 @d mpx_reading (mp->mpx_name[index]>absent)
12945 /* when reading a file, is it an \.{MPX} file? */
12947 /* |name_field| value when the corresponding \.{MPX} file is finished */
12950 integer in_open; /* the number of lines in the buffer, less one */
12951 unsigned int open_parens; /* the number of open text files */
12952 void * *input_file ;
12953 integer *line_stack ; /* the line number for each file */
12954 char * *iname_stack; /* used for naming \.{MPX} files */
12955 char * *iarea_stack; /* used for naming \.{MPX} files */
12956 halfword*mpx_name ;
12958 @ @<Allocate or ...@>=
12959 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
12960 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
12961 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12962 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12963 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
12966 for (k=0;k<=mp->max_in_open;k++) {
12967 mp->iname_stack[k] =NULL;
12968 mp->iarea_stack[k] =NULL;
12972 @ @<Dealloc variables@>=
12975 for (l=0;l<=mp->max_in_open;l++) {
12976 xfree(mp->iname_stack[l]);
12977 xfree(mp->iarea_stack[l]);
12980 xfree(mp->input_file);
12981 xfree(mp->line_stack);
12982 xfree(mp->iname_stack);
12983 xfree(mp->iarea_stack);
12984 xfree(mp->mpx_name);
12987 @ However, all this discussion about input state really applies only to the
12988 case that we are inputting from a file. There is another important case,
12989 namely when we are currently getting input from a token list. In this case
12990 |index>max_in_open|, and the conventions about the other state variables
12993 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
12994 the node that will be read next. If |loc=null|, the token list has been
12997 \yskip\hang|start| points to the first node of the token list; this node
12998 may or may not contain a reference count, depending on the type of token
13001 \yskip\hang|token_type|, which takes the place of |index| in the
13002 discussion above, is a code number that explains what kind of token list
13005 \yskip\hang|name| points to the |eqtb| address of the control sequence
13006 being expanded, if the current token list is a macro not defined by
13007 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
13008 can be deduced by looking at their first two parameters.
13010 \yskip\hang|param_start|, which takes the place of |limit|, tells where
13011 the parameters of the current macro or loop text begin in the |param_stack|.
13013 \yskip\noindent The |token_type| can take several values, depending on
13014 where the current token list came from:
13017 \indent|forever_text|, if the token list being scanned is the body of
13018 a \&{forever} loop;
13020 \indent|loop_text|, if the token list being scanned is the body of
13021 a \&{for} or \&{forsuffixes} loop;
13023 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
13025 \indent|backed_up|, if the token list being scanned has been inserted as
13026 `to be read again'.
13028 \indent|inserted|, if the token list being scanned has been inserted as
13029 part of error recovery;
13031 \indent|macro|, if the expansion of a user-defined symbolic token is being
13035 The token list begins with a reference count if and only if |token_type=
13037 @^reference counts@>
13039 @d token_type index /* type of current token list */
13040 @d token_state (index>(int)mp->max_in_open) /* are we scanning a token list? */
13041 @d file_state (index<=(int)mp->max_in_open) /* are we scanning a file line? */
13042 @d param_start limit /* base of macro parameters in |param_stack| */
13043 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
13044 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
13045 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
13046 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
13047 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
13048 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
13050 @ The |param_stack| is an auxiliary array used to hold pointers to the token
13051 lists for parameters at the current level and subsidiary levels of input.
13052 This stack grows at a different rate from the others.
13055 pointer *param_stack; /* token list pointers for parameters */
13056 integer param_ptr; /* first unused entry in |param_stack| */
13057 integer max_param_stack; /* largest value of |param_ptr| */
13059 @ @<Allocate or initialize ...@>=
13060 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
13062 @ @<Dealloc variables@>=
13063 xfree(mp->param_stack);
13065 @ Notice that the |line| isn't valid when |token_state| is true because it
13066 depends on |index|. If we really need to know the line number for the
13067 topmost file in the index stack we use the following function. If a page
13068 number or other information is needed, this routine should be modified to
13069 compute it as well.
13070 @^system dependencies@>
13072 @<Declare a function called |true_line|@>=
13073 integer mp_true_line (MP mp) {
13074 int k; /* an index into the input stack */
13075 if ( file_state && (name>max_spec_src) ) {
13080 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
13081 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
13084 return (k>0 ? mp->line_stack[(k-1)] : 0 );
13088 @ Thus, the ``current input state'' can be very complicated indeed; there
13089 can be many levels and each level can arise in a variety of ways. The
13090 |show_context| procedure, which is used by \MP's error-reporting routine to
13091 print out the current input state on all levels down to the most recent
13092 line of characters from an input file, illustrates most of these conventions.
13093 The global variable |file_ptr| contains the lowest level that was
13094 displayed by this procedure.
13097 integer file_ptr; /* shallowest level shown by |show_context| */
13099 @ The status at each level is indicated by printing two lines, where the first
13100 line indicates what was read so far and the second line shows what remains
13101 to be read. The context is cropped, if necessary, so that the first line
13102 contains at most |half_error_line| characters, and the second contains
13103 at most |error_line|. Non-current input levels whose |token_type| is
13104 `|backed_up|' are shown only if they have not been fully read.
13106 @c void mp_show_context (MP mp) { /* prints where the scanner is */
13107 int old_setting; /* saved |selector| setting */
13108 @<Local variables for formatting calculations@>
13109 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
13110 /* store current state */
13112 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
13113 @<Display the current context@>;
13115 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
13116 decr(mp->file_ptr);
13118 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
13121 @ @<Display the current context@>=
13122 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
13123 (token_type!=backed_up) || (loc!=null) ) {
13124 /* we omit backed-up token lists that have already been read */
13125 mp->tally=0; /* get ready to count characters */
13126 old_setting=mp->selector;
13127 if ( file_state ) {
13128 @<Print location of current line@>;
13129 @<Pseudoprint the line@>;
13131 @<Print type of token list@>;
13132 @<Pseudoprint the token list@>;
13134 mp->selector=old_setting; /* stop pseudoprinting */
13135 @<Print two lines using the tricky pseudoprinted information@>;
13138 @ This routine should be changed, if necessary, to give the best possible
13139 indication of where the current line resides in the input file.
13140 For example, on some systems it is best to print both a page and line number.
13141 @^system dependencies@>
13143 @<Print location of current line@>=
13144 if ( name>max_spec_src ) {
13145 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
13146 } else if ( terminal_input ) {
13147 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
13148 else mp_print_nl(mp, "<insert>");
13149 } else if ( name==is_scantok ) {
13150 mp_print_nl(mp, "<scantokens>");
13152 mp_print_nl(mp, "<read>");
13154 mp_print_char(mp, ' ')
13156 @ Can't use case statement here because the |token_type| is not
13157 a constant expression.
13159 @<Print type of token list@>=
13161 if(token_type==forever_text) {
13162 mp_print_nl(mp, "<forever> ");
13163 } else if (token_type==loop_text) {
13164 @<Print the current loop value@>;
13165 } else if (token_type==parameter) {
13166 mp_print_nl(mp, "<argument> ");
13167 } else if (token_type==backed_up) {
13168 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
13169 else mp_print_nl(mp, "<to be read again> ");
13170 } else if (token_type==inserted) {
13171 mp_print_nl(mp, "<inserted text> ");
13172 } else if (token_type==macro) {
13174 if ( name!=null ) mp_print_text(name);
13175 else @<Print the name of a \&{vardef}'d macro@>;
13176 mp_print(mp, "->");
13178 mp_print_nl(mp, "?");/* this should never happen */
13183 @ The parameter that corresponds to a loop text is either a token list
13184 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13185 We'll discuss capsules later; for now, all we need to know is that
13186 the |link| field in a capsule parameter is |void| and that
13187 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13189 @<Print the current loop value@>=
13190 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13192 if ( link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13193 else mp_show_token_list(mp, p,null,20,mp->tally);
13195 mp_print(mp, ")> ");
13198 @ The first two parameters of a macro defined by \&{vardef} will be token
13199 lists representing the macro's prefix and ``at point.'' By putting these
13200 together, we get the macro's full name.
13202 @<Print the name of a \&{vardef}'d macro@>=
13203 { p=mp->param_stack[param_start];
13205 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13208 while ( link(q)!=null ) q=link(q);
13209 link(q)=mp->param_stack[param_start+1];
13210 mp_show_token_list(mp, p,null,20,mp->tally);
13215 @ Now it is necessary to explain a little trick. We don't want to store a long
13216 string that corresponds to a token list, because that string might take up
13217 lots of memory; and we are printing during a time when an error message is
13218 being given, so we dare not do anything that might overflow one of \MP's
13219 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13220 that stores characters into a buffer of length |error_line|, where character
13221 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13222 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13223 |tally:=0| and |trick_count:=1000000|; then when we reach the
13224 point where transition from line 1 to line 2 should occur, we
13225 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13226 tally+1+error_line-half_error_line)|. At the end of the
13227 pseudoprinting, the values of |first_count|, |tally|, and
13228 |trick_count| give us all the information we need to print the two lines,
13229 and all of the necessary text is in |trick_buf|.
13231 Namely, let |l| be the length of the descriptive information that appears
13232 on the first line. The length of the context information gathered for that
13233 line is |k=first_count|, and the length of the context information
13234 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13235 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13236 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13237 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13238 and print `\.{...}' followed by
13239 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13240 where subscripts of |trick_buf| are circular modulo |error_line|. The
13241 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13242 unless |n+m>error_line|; in the latter case, further cropping is done.
13243 This is easier to program than to explain.
13245 @<Local variables for formatting...@>=
13246 int i; /* index into |buffer| */
13247 integer l; /* length of descriptive information on line 1 */
13248 integer m; /* context information gathered for line 2 */
13249 int n; /* length of line 1 */
13250 integer p; /* starting or ending place in |trick_buf| */
13251 integer q; /* temporary index */
13253 @ The following code tells the print routines to gather
13254 the desired information.
13256 @d begin_pseudoprint {
13257 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13258 mp->trick_count=1000000;
13260 @d set_trick_count {
13261 mp->first_count=mp->tally;
13262 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13263 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13266 @ And the following code uses the information after it has been gathered.
13268 @<Print two lines using the tricky pseudoprinted information@>=
13269 if ( mp->trick_count==1000000 ) set_trick_count;
13270 /* |set_trick_count| must be performed */
13271 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13272 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13273 if ( l+mp->first_count<=mp->half_error_line ) {
13274 p=0; n=l+mp->first_count;
13276 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13277 n=mp->half_error_line;
13279 for (q=p;q<=mp->first_count-1;q++) {
13280 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13283 for (q=1;q<=n;q++) {
13284 mp_print_char(mp, ' '); /* print |n| spaces to begin line~2 */
13286 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13287 else p=mp->first_count+(mp->error_line-n-3);
13288 for (q=mp->first_count;q<=p-1;q++) {
13289 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13291 if ( m+n>mp->error_line ) mp_print(mp, "...")
13293 @ But the trick is distracting us from our current goal, which is to
13294 understand the input state. So let's concentrate on the data structures that
13295 are being pseudoprinted as we finish up the |show_context| procedure.
13297 @<Pseudoprint the line@>=
13300 for (i=start;i<=limit-1;i++) {
13301 if ( i==loc ) set_trick_count;
13302 mp_print_str(mp, mp->buffer[i]);
13306 @ @<Pseudoprint the token list@>=
13308 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13309 else mp_show_macro(mp, start,loc,100000)
13311 @ Here is the missing piece of |show_token_list| that is activated when the
13312 token beginning line~2 is about to be shown:
13314 @<Do magic computation@>=set_trick_count
13316 @* \[28] Maintaining the input stacks.
13317 The following subroutines change the input status in commonly needed ways.
13319 First comes |push_input|, which stores the current state and creates a
13320 new level (having, initially, the same properties as the old).
13322 @d push_input { /* enter a new input level, save the old */
13323 if ( mp->input_ptr>mp->max_in_stack ) {
13324 mp->max_in_stack=mp->input_ptr;
13325 if ( mp->input_ptr==mp->stack_size ) {
13326 int l = (mp->stack_size+(mp->stack_size>>2));
13327 XREALLOC(mp->input_stack, l, in_state_record);
13328 mp->stack_size = l;
13331 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13332 incr(mp->input_ptr);
13335 @ And of course what goes up must come down.
13337 @d pop_input { /* leave an input level, re-enter the old */
13338 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13341 @ Here is a procedure that starts a new level of token-list input, given
13342 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13343 set |name|, reset~|loc|, and increase the macro's reference count.
13345 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13347 @c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13348 push_input; start=p; token_type=t;
13349 param_start=mp->param_ptr; loc=p;
13352 @ When a token list has been fully scanned, the following computations
13353 should be done as we leave that level of input.
13356 @c void mp_end_token_list (MP mp) { /* leave a token-list input level */
13357 pointer p; /* temporary register */
13358 if ( token_type>=backed_up ) { /* token list to be deleted */
13359 if ( token_type<=inserted ) {
13360 mp_flush_token_list(mp, start); goto DONE;
13362 mp_delete_mac_ref(mp, start); /* update reference count */
13365 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13366 decr(mp->param_ptr);
13367 p=mp->param_stack[mp->param_ptr];
13369 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
13370 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13372 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13377 pop_input; check_interrupt;
13380 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13381 token by the |cur_tok| routine.
13384 @c @<Declare the procedure called |make_exp_copy|@>
13385 pointer mp_cur_tok (MP mp) {
13386 pointer p; /* a new token node */
13387 small_number save_type; /* |cur_type| to be restored */
13388 integer save_exp; /* |cur_exp| to be restored */
13389 if ( mp->cur_sym==0 ) {
13390 if ( mp->cur_cmd==capsule_token ) {
13391 save_type=mp->cur_type; save_exp=mp->cur_exp;
13392 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); link(p)=null;
13393 mp->cur_type=save_type; mp->cur_exp=save_exp;
13395 p=mp_get_node(mp, token_node_size);
13396 value(p)=mp->cur_mod; name_type(p)=mp_token;
13397 if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
13398 else type(p)=mp_string_type;
13401 fast_get_avail(p); info(p)=mp->cur_sym;
13406 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13407 seen. The |back_input| procedure takes care of this by putting the token
13408 just scanned back into the input stream, ready to be read again.
13409 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13412 void mp_back_input (MP mp);
13414 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13415 pointer p; /* a token list of length one */
13417 while ( token_state &&(loc==null) )
13418 mp_end_token_list(mp); /* conserve stack space */
13422 @ The |back_error| routine is used when we want to restore or replace an
13423 offending token just before issuing an error message. We disable interrupts
13424 during the call of |back_input| so that the help message won't be lost.
13427 void mp_error (MP mp);
13428 void mp_back_error (MP mp);
13430 @ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
13431 mp->OK_to_interrupt=false;
13433 mp->OK_to_interrupt=true; mp_error(mp);
13435 void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13436 mp->OK_to_interrupt=false;
13437 mp_back_input(mp); token_type=inserted;
13438 mp->OK_to_interrupt=true; mp_error(mp);
13441 @ The |begin_file_reading| procedure starts a new level of input for lines
13442 of characters to be read from a file, or as an insertion from the
13443 terminal. It does not take care of opening the file, nor does it set |loc|
13444 or |limit| or |line|.
13445 @^system dependencies@>
13447 @c void mp_begin_file_reading (MP mp) {
13448 if ( mp->in_open==mp->max_in_open )
13449 mp_overflow(mp, "text input levels",mp->max_in_open);
13450 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13451 if ( mp->first==mp->buf_size )
13452 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13453 incr(mp->in_open); push_input; index=mp->in_open;
13454 mp->mpx_name[index]=absent;
13456 name=is_term; /* |terminal_input| is now |true| */
13459 @ Conversely, the variables must be downdated when such a level of input
13460 is finished. Any associated \.{MPX} file must also be closed and popped
13461 off the file stack.
13463 @c void mp_end_file_reading (MP mp) {
13464 if ( mp->in_open>index ) {
13465 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13466 mp_confusion(mp, "endinput");
13467 @:this can't happen endinput}{\quad endinput@>
13469 (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13470 delete_str_ref(mp->mpx_name[mp->in_open]);
13475 if ( index!=mp->in_open ) mp_confusion(mp, "endinput");
13476 if ( name>max_spec_src ) {
13477 (mp->close_file)(mp,cur_file);
13478 delete_str_ref(name);
13482 pop_input; decr(mp->in_open);
13485 @ Here is a function that tries to resume input from an \.{MPX} file already
13486 associated with the current input file. It returns |false| if this doesn't
13489 @c boolean mp_begin_mpx_reading (MP mp) {
13490 if ( mp->in_open!=index+1 ) {
13493 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13494 @:this can't happen mpx}{\quad mpx@>
13495 if ( mp->first==mp->buf_size )
13496 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13497 push_input; index=mp->in_open;
13499 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13500 @<Put an empty line in the input buffer@>;
13505 @ This procedure temporarily stops reading an \.{MPX} file.
13507 @c void mp_end_mpx_reading (MP mp) {
13508 if ( mp->in_open!=index ) mp_confusion(mp, "mpx");
13509 @:this can't happen mpx}{\quad mpx@>
13511 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13517 @ Here we enforce a restriction that simplifies the input stacks considerably.
13518 This should not inconvenience the user because \.{MPX} files are generated
13519 by an auxiliary program called \.{DVItoMP}.
13521 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13523 print_err("`mpxbreak' must be at the end of a line");
13524 help4("This file contains picture expressions for btex...etex")
13525 ("blocks. Such files are normally generated automatically")
13526 ("but this one seems to be messed up. I'm going to ignore")
13527 ("the rest of this line.");
13531 @ In order to keep the stack from overflowing during a long sequence of
13532 inserted `\.{show}' commands, the following routine removes completed
13533 error-inserted lines from memory.
13535 @c void mp_clear_for_error_prompt (MP mp) {
13536 while ( file_state && terminal_input &&
13537 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13538 mp_print_ln(mp); clear_terminal;
13541 @ To get \MP's whole input mechanism going, we perform the following
13544 @<Initialize the input routines@>=
13545 { mp->input_ptr=0; mp->max_in_stack=0;
13546 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13547 mp->param_ptr=0; mp->max_param_stack=0;
13549 start=1; index=0; line=0; name=is_term;
13550 mp->mpx_name[0]=absent;
13551 mp->force_eof=false;
13552 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13553 limit=mp->last; mp->first=mp->last+1;
13554 /* |init_terminal| has set |loc| and |last| */
13557 @* \[29] Getting the next token.
13558 The heart of \MP's input mechanism is the |get_next| procedure, which
13559 we shall develop in the next few sections of the program. Perhaps we
13560 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13561 eyes and mouth, reading the source files and gobbling them up. And it also
13562 helps \MP\ to regurgitate stored token lists that are to be processed again.
13564 The main duty of |get_next| is to input one token and to set |cur_cmd|
13565 and |cur_mod| to that token's command code and modifier. Furthermore, if
13566 the input token is a symbolic token, that token's |hash| address
13567 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13569 Underlying this simple description is a certain amount of complexity
13570 because of all the cases that need to be handled.
13571 However, the inner loop of |get_next| is reasonably short and fast.
13573 @ Before getting into |get_next|, we need to consider a mechanism by which
13574 \MP\ helps keep errors from propagating too far. Whenever the program goes
13575 into a mode where it keeps calling |get_next| repeatedly until a certain
13576 condition is met, it sets |scanner_status| to some value other than |normal|.
13577 Then if an input file ends, or if an `\&{outer}' symbol appears,
13578 an appropriate error recovery will be possible.
13580 The global variable |warning_info| helps in this error recovery by providing
13581 additional information. For example, |warning_info| might indicate the
13582 name of a macro whose replacement text is being scanned.
13584 @d normal 0 /* |scanner_status| at ``quiet times'' */
13585 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13586 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13587 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13588 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13589 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13590 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13591 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13594 integer scanner_status; /* are we scanning at high speed? */
13595 integer warning_info; /* if so, what else do we need to know,
13596 in case an error occurs? */
13598 @ @<Initialize the input routines@>=
13599 mp->scanner_status=normal;
13601 @ The following subroutine
13602 is called when an `\&{outer}' symbolic token has been scanned or
13603 when the end of a file has been reached. These two cases are distinguished
13604 by |cur_sym|, which is zero at the end of a file.
13606 @c boolean mp_check_outer_validity (MP mp) {
13607 pointer p; /* points to inserted token list */
13608 if ( mp->scanner_status==normal ) {
13610 } else if ( mp->scanner_status==tex_flushing ) {
13611 @<Check if the file has ended while flushing \TeX\ material and set the
13612 result value for |check_outer_validity|@>;
13614 mp->deletions_allowed=false;
13615 @<Back up an outer symbolic token so that it can be reread@>;
13616 if ( mp->scanner_status>skipping ) {
13617 @<Tell the user what has run away and try to recover@>;
13619 print_err("Incomplete if; all text was ignored after line ");
13620 @.Incomplete if...@>
13621 mp_print_int(mp, mp->warning_info);
13622 help3("A forbidden `outer' token occurred in skipped text.")
13623 ("This kind of error happens when you say `if...' and forget")
13624 ("the matching `fi'. I've inserted a `fi'; this might work.");
13625 if ( mp->cur_sym==0 )
13626 mp->help_line[2]="The file ended while I was skipping conditional text.";
13627 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13629 mp->deletions_allowed=true;
13634 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13635 if ( mp->cur_sym!=0 ) {
13638 mp->deletions_allowed=false;
13639 print_err("TeX mode didn't end; all text was ignored after line ");
13640 mp_print_int(mp, mp->warning_info);
13641 help2("The file ended while I was looking for the `etex' to")
13642 ("finish this TeX material. I've inserted `etex' now.");
13643 mp->cur_sym = frozen_etex;
13645 mp->deletions_allowed=true;
13649 @ @<Back up an outer symbolic token so that it can be reread@>=
13650 if ( mp->cur_sym!=0 ) {
13651 p=mp_get_avail(mp); info(p)=mp->cur_sym;
13652 back_list(p); /* prepare to read the symbolic token again */
13655 @ @<Tell the user what has run away...@>=
13657 mp_runaway(mp); /* print the definition-so-far */
13658 if ( mp->cur_sym==0 ) {
13659 print_err("File ended");
13660 @.File ended while scanning...@>
13662 print_err("Forbidden token found");
13663 @.Forbidden token found...@>
13665 mp_print(mp, " while scanning ");
13666 help4("I suspect you have forgotten an `enddef',")
13667 ("causing me to read past where you wanted me to stop.")
13668 ("I'll try to recover; but if the error is serious,")
13669 ("you'd better type `E' or `X' now and fix your file.");
13670 switch (mp->scanner_status) {
13671 @<Complete the error message,
13672 and set |cur_sym| to a token that might help recover from the error@>
13673 } /* there are no other cases */
13677 @ As we consider various kinds of errors, it is also appropriate to
13678 change the first line of the help message just given; |help_line[3]|
13679 points to the string that might be changed.
13681 @<Complete the error message,...@>=
13683 mp_print(mp, "to the end of the statement");
13684 mp->help_line[3]="A previous error seems to have propagated,";
13685 mp->cur_sym=frozen_semicolon;
13688 mp_print(mp, "a text argument");
13689 mp->help_line[3]="It seems that a right delimiter was left out,";
13690 if ( mp->warning_info==0 ) {
13691 mp->cur_sym=frozen_end_group;
13693 mp->cur_sym=frozen_right_delimiter;
13694 equiv(frozen_right_delimiter)=mp->warning_info;
13699 mp_print(mp, "the definition of ");
13700 if ( mp->scanner_status==op_defining )
13701 mp_print_text(mp->warning_info);
13703 mp_print_variable_name(mp, mp->warning_info);
13704 mp->cur_sym=frozen_end_def;
13706 case loop_defining:
13707 mp_print(mp, "the text of a ");
13708 mp_print_text(mp->warning_info);
13709 mp_print(mp, " loop");
13710 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13711 mp->cur_sym=frozen_end_for;
13714 @ The |runaway| procedure displays the first part of the text that occurred
13715 when \MP\ began its special |scanner_status|, if that text has been saved.
13717 @<Declare the procedure called |runaway|@>=
13718 void mp_runaway (MP mp) {
13719 if ( mp->scanner_status>flushing ) {
13720 mp_print_nl(mp, "Runaway ");
13721 switch (mp->scanner_status) {
13722 case absorbing: mp_print(mp, "text?"); break;
13724 case op_defining: mp_print(mp,"definition?"); break;
13725 case loop_defining: mp_print(mp, "loop?"); break;
13726 } /* there are no other cases */
13728 mp_show_token_list(mp, link(hold_head),null,mp->error_line-10,0);
13732 @ We need to mention a procedure that may be called by |get_next|.
13735 void mp_firm_up_the_line (MP mp);
13737 @ And now we're ready to take the plunge into |get_next| itself.
13738 Note that the behavior depends on the |scanner_status| because percent signs
13739 and double quotes need to be passed over when skipping TeX material.
13742 void mp_get_next (MP mp) {
13743 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13745 /*restart*/ /* go here to get the next input token */
13746 /*exit*/ /* go here when the next input token has been got */
13747 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13748 /*found*/ /* go here when the end of a symbolic token has been found */
13749 /*switch*/ /* go here to branch on the class of an input character */
13750 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13751 /* go here at crucial stages when scanning a number */
13752 int k; /* an index into |buffer| */
13753 ASCII_code c; /* the current character in the buffer */
13754 ASCII_code class; /* its class number */
13755 integer n,f; /* registers for decimal-to-binary conversion */
13758 if ( file_state ) {
13759 @<Input from external file; |goto restart| if no input found,
13760 or |return| if a non-symbolic token is found@>;
13762 @<Input from token list; |goto restart| if end of list or
13763 if a parameter needs to be expanded,
13764 or |return| if a non-symbolic token is found@>;
13767 @<Finish getting the symbolic token in |cur_sym|;
13768 |goto restart| if it is illegal@>;
13771 @ When a symbolic token is declared to be `\&{outer}', its command code
13772 is increased by |outer_tag|.
13775 @<Finish getting the symbolic token in |cur_sym|...@>=
13776 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13777 if ( mp->cur_cmd>=outer_tag ) {
13778 if ( mp_check_outer_validity(mp) )
13779 mp->cur_cmd=mp->cur_cmd-outer_tag;
13784 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13785 to have a special test for end-of-line.
13788 @<Input from external file;...@>=
13791 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13793 case digit_class: goto START_NUMERIC_TOKEN; break;
13795 class=mp->char_class[mp->buffer[loc]];
13796 if ( class>period_class ) {
13798 } else if ( class<period_class ) { /* |class=digit_class| */
13799 n=0; goto START_DECIMAL_TOKEN;
13803 case space_class: goto SWITCH; break;
13804 case percent_class:
13805 if ( mp->scanner_status==tex_flushing ) {
13806 if ( loc<limit ) goto SWITCH;
13808 @<Move to next line of file, or |goto restart| if there is no next line@>;
13813 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13814 else @<Get a string token and |return|@>;
13816 case isolated_classes:
13817 k=loc-1; goto FOUND; break;
13818 case invalid_class:
13819 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13820 else @<Decry the invalid character and |goto restart|@>;
13822 default: break; /* letters, etc. */
13825 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13827 START_NUMERIC_TOKEN:
13828 @<Get the integer part |n| of a numeric token;
13829 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13830 START_DECIMAL_TOKEN:
13831 @<Get the fraction part |f| of a numeric token@>;
13833 @<Pack the numeric and fraction parts of a numeric token
13836 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13839 @ We go to |restart| instead of to |SWITCH|, because we might enter
13840 |token_state| after the error has been dealt with
13841 (cf.\ |clear_for_error_prompt|).
13843 @<Decry the invalid...@>=
13845 print_err("Text line contains an invalid character");
13846 @.Text line contains...@>
13847 help2("A funny symbol that I can\'t read has just been input.")
13848 ("Continue, and I'll forget that it ever happened.");
13849 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13853 @ @<Get a string token and |return|@>=
13855 if ( mp->buffer[loc]=='"' ) {
13856 mp->cur_mod=rts("");
13858 k=loc; mp->buffer[limit+1]='"';
13861 } while (mp->buffer[loc]!='"');
13863 @<Decry the missing string delimiter and |goto restart|@>;
13866 mp->cur_mod=mp->buffer[k];
13870 append_char(mp->buffer[k]); incr(k);
13872 mp->cur_mod=mp_make_string(mp);
13875 incr(loc); mp->cur_cmd=string_token;
13879 @ We go to |restart| after this error message, not to |SWITCH|,
13880 because the |clear_for_error_prompt| routine might have reinstated
13881 |token_state| after |error| has finished.
13883 @<Decry the missing string delimiter and |goto restart|@>=
13885 loc=limit; /* the next character to be read on this line will be |"%"| */
13886 print_err("Incomplete string token has been flushed");
13887 @.Incomplete string token...@>
13888 help3("Strings should finish on the same line as they began.")
13889 ("I've deleted the partial string; you might want to")
13890 ("insert another by typing, e.g., `I\"new string\"'.");
13891 mp->deletions_allowed=false; mp_error(mp);
13892 mp->deletions_allowed=true;
13896 @ @<Get the integer part |n| of a numeric token...@>=
13898 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13899 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13902 if ( mp->buffer[loc]=='.' )
13903 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13906 goto FIN_NUMERIC_TOKEN;
13909 @ @<Get the fraction part |f| of a numeric token@>=
13912 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13913 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13916 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13917 f=mp_round_decimals(mp, k);
13922 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13924 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13925 } else if ( mp->scanner_status!=tex_flushing ) {
13926 print_err("Enormous number has been reduced");
13927 @.Enormous number...@>
13928 help2("I can\'t handle numbers bigger than 32767.99998;")
13929 ("so I've changed your constant to that maximum amount.");
13930 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13931 mp->cur_mod=el_gordo;
13933 mp->cur_cmd=numeric_token; return
13935 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13937 mp->cur_mod=n*unity+f;
13938 if ( mp->cur_mod>=fraction_one ) {
13939 if ( (mp->internal[mp_warning_check]>0) &&
13940 (mp->scanner_status!=tex_flushing) ) {
13941 print_err("Number is too large (");
13942 mp_print_scaled(mp, mp->cur_mod);
13943 mp_print_char(mp, ')');
13944 help3("It is at least 4096. Continue and I'll try to cope")
13945 ("with that big value; but it might be dangerous.")
13946 ("(Set warningcheck:=0 to suppress this message.)");
13952 @ Let's consider now what happens when |get_next| is looking at a token list.
13955 @<Input from token list;...@>=
13956 if ( loc>=mp->hi_mem_min ) { /* one-word token */
13957 mp->cur_sym=info(loc); loc=link(loc); /* move to next */
13958 if ( mp->cur_sym>=expr_base ) {
13959 if ( mp->cur_sym>=suffix_base ) {
13960 @<Insert a suffix or text parameter and |goto restart|@>;
13962 mp->cur_cmd=capsule_token;
13963 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
13964 mp->cur_sym=0; return;
13967 } else if ( loc>null ) {
13968 @<Get a stored numeric or string or capsule token and |return|@>
13969 } else { /* we are done with this token list */
13970 mp_end_token_list(mp); goto RESTART; /* resume previous level */
13973 @ @<Insert a suffix or text parameter...@>=
13975 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
13976 /* |param_size=text_base-suffix_base| */
13977 mp_begin_token_list(mp,
13978 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
13983 @ @<Get a stored numeric or string or capsule token...@>=
13985 if ( name_type(loc)==mp_token ) {
13986 mp->cur_mod=value(loc);
13987 if ( type(loc)==mp_known ) {
13988 mp->cur_cmd=numeric_token;
13990 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
13993 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
13995 loc=link(loc); return;
13998 @ All of the easy branches of |get_next| have now been taken care of.
13999 There is one more branch.
14001 @<Move to next line of file, or |goto restart|...@>=
14002 if ( name>max_spec_src ) {
14003 @<Read next line of file into |buffer|, or
14004 |goto restart| if the file has ended@>;
14006 if ( mp->input_ptr>0 ) {
14007 /* text was inserted during error recovery or by \&{scantokens} */
14008 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
14010 if ( mp->selector<log_only || mp->selector>=write_file) mp_open_log_file(mp);
14011 if ( mp->interaction>mp_nonstop_mode ) {
14012 if ( limit==start ) /* previous line was empty */
14013 mp_print_nl(mp, "(Please type a command or say `end')");
14015 mp_print_ln(mp); mp->first=start;
14016 prompt_input("*"); /* input on-line into |buffer| */
14018 limit=mp->last; mp->buffer[limit]='%';
14019 mp->first=limit+1; loc=start;
14021 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
14023 /* nonstop mode, which is intended for overnight batch processing,
14024 never waits for on-line input */
14028 @ The global variable |force_eof| is normally |false|; it is set |true|
14029 by an \&{endinput} command.
14032 boolean force_eof; /* should the next \&{input} be aborted early? */
14034 @ We must decrement |loc| in order to leave the buffer in a valid state
14035 when an error condition causes us to |goto restart| without calling
14036 |end_file_reading|.
14038 @<Read next line of file into |buffer|, or
14039 |goto restart| if the file has ended@>=
14041 incr(line); mp->first=start;
14042 if ( ! mp->force_eof ) {
14043 if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
14044 mp_firm_up_the_line(mp); /* this sets |limit| */
14046 mp->force_eof=true;
14048 if ( mp->force_eof ) {
14049 mp->force_eof=false;
14051 if ( mpx_reading ) {
14052 @<Complain that the \.{MPX} file ended unexpectly; then set
14053 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
14055 mp_print_char(mp, ')'); decr(mp->open_parens);
14056 update_terminal; /* show user that file has been read */
14057 mp_end_file_reading(mp); /* resume previous level */
14058 if ( mp_check_outer_validity(mp) ) goto RESTART;
14062 mp->buffer[limit]='%'; mp->first=limit+1; loc=start; /* ready to read */
14065 @ We should never actually come to the end of an \.{MPX} file because such
14066 files should have an \&{mpxbreak} after the translation of the last
14067 \&{btex}$\,\ldots\,$\&{etex} block.
14069 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
14071 mp->mpx_name[index]=finished;
14072 print_err("mpx file ended unexpectedly");
14073 help4("The file had too few picture expressions for btex...etex")
14074 ("blocks. Such files are normally generated automatically")
14075 ("but this one got messed up. You might want to insert a")
14076 ("picture expression now.");
14077 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
14078 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
14081 @ Sometimes we want to make it look as though we have just read a blank line
14082 without really doing so.
14084 @<Put an empty line in the input buffer@>=
14085 mp->last=mp->first; limit=mp->last; /* simulate |input_ln| and |firm_up_the_line| */
14086 mp->buffer[limit]='%'; mp->first=limit+1; loc=start
14088 @ If the user has set the |mp_pausing| parameter to some positive value,
14089 and if nonstop mode has not been selected, each line of input is displayed
14090 on the terminal and the transcript file, followed by `\.{=>}'.
14091 \MP\ waits for a response. If the response is null (i.e., if nothing is
14092 typed except perhaps a few blank spaces), the original
14093 line is accepted as it stands; otherwise the line typed is
14094 used instead of the line in the file.
14096 @c void mp_firm_up_the_line (MP mp) {
14097 size_t k; /* an index into |buffer| */
14099 if ( mp->internal[mp_pausing]>0) if ( mp->interaction>mp_nonstop_mode ) {
14100 wake_up_terminal; mp_print_ln(mp);
14101 if ( start<limit ) {
14102 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
14103 mp_print_str(mp, mp->buffer[k]);
14106 mp->first=limit; prompt_input("=>"); /* wait for user response */
14108 if ( mp->last>mp->first ) {
14109 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
14110 mp->buffer[k+start-mp->first]=mp->buffer[k];
14112 limit=start+mp->last-mp->first;
14117 @* \[30] Dealing with \TeX\ material.
14118 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
14119 features need to be implemented at a low level in the scanning process
14120 so that \MP\ can stay in synch with the a preprocessor that treats
14121 blocks of \TeX\ material as they occur in the input file without trying
14122 to expand \MP\ macros. Thus we need a special version of |get_next|
14123 that does not expand macros and such but does handle \&{btex},
14124 \&{verbatimtex}, etc.
14126 The special version of |get_next| is called |get_t_next|. It works by flushing
14127 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
14128 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
14129 \&{btex}, and switching back when it sees \&{mpxbreak}.
14135 mp_primitive(mp, "btex",start_tex,btex_code);
14136 @:btex_}{\&{btex} primitive@>
14137 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
14138 @:verbatimtex_}{\&{verbatimtex} primitive@>
14139 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
14140 @:etex_}{\&{etex} primitive@>
14141 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
14142 @:mpx_break_}{\&{mpxbreak} primitive@>
14144 @ @<Cases of |print_cmd...@>=
14145 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
14146 else mp_print(mp, "verbatimtex"); break;
14147 case etex_marker: mp_print(mp, "etex"); break;
14148 case mpx_break: mp_print(mp, "mpxbreak"); break;
14150 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
14151 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
14154 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
14157 void mp_start_mpx_input (MP mp);
14160 void mp_t_next (MP mp) {
14161 int old_status; /* saves the |scanner_status| */
14162 integer old_info; /* saves the |warning_info| */
14163 while ( mp->cur_cmd<=max_pre_command ) {
14164 if ( mp->cur_cmd==mpx_break ) {
14165 if ( ! file_state || (mp->mpx_name[index]==absent) ) {
14166 @<Complain about a misplaced \&{mpxbreak}@>;
14168 mp_end_mpx_reading(mp);
14171 } else if ( mp->cur_cmd==start_tex ) {
14172 if ( token_state || (name<=max_spec_src) ) {
14173 @<Complain that we are not reading a file@>;
14174 } else if ( mpx_reading ) {
14175 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
14176 } else if ( (mp->cur_mod!=verbatim_code)&&
14177 (mp->mpx_name[index]!=finished) ) {
14178 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
14183 @<Complain about a misplaced \&{etex}@>;
14185 goto COMMON_ENDING;
14187 @<Flush the \TeX\ material@>;
14193 @ We could be in the middle of an operation such as skipping false conditional
14194 text when \TeX\ material is encountered, so we must be careful to save the
14197 @<Flush the \TeX\ material@>=
14198 old_status=mp->scanner_status;
14199 old_info=mp->warning_info;
14200 mp->scanner_status=tex_flushing;
14201 mp->warning_info=line;
14202 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14203 mp->scanner_status=old_status;
14204 mp->warning_info=old_info
14206 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14207 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14208 help4("This file contains picture expressions for btex...etex")
14209 ("blocks. Such files are normally generated automatically")
14210 ("but this one seems to be messed up. I'll just keep going")
14211 ("and hope for the best.");
14215 @ @<Complain that we are not reading a file@>=
14216 { print_err("You can only use `btex' or `verbatimtex' in a file");
14217 help3("I'll have to ignore this preprocessor command because it")
14218 ("only works when there is a file to preprocess. You might")
14219 ("want to delete everything up to the next `etex`.");
14223 @ @<Complain about a misplaced \&{mpxbreak}@>=
14224 { print_err("Misplaced mpxbreak");
14225 help2("I'll ignore this preprocessor command because it")
14226 ("doesn't belong here");
14230 @ @<Complain about a misplaced \&{etex}@>=
14231 { print_err("Extra etex will be ignored");
14232 help1("There is no btex or verbatimtex for this to match");
14236 @* \[31] Scanning macro definitions.
14237 \MP\ has a variety of ways to tuck tokens away into token lists for later
14238 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14239 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14240 All such operations are handled by the routines in this part of the program.
14242 The modifier part of each command code is zero for the ``ending delimiters''
14243 like \&{enddef} and \&{endfor}.
14245 @d start_def 1 /* command modifier for \&{def} */
14246 @d var_def 2 /* command modifier for \&{vardef} */
14247 @d end_def 0 /* command modifier for \&{enddef} */
14248 @d start_forever 1 /* command modifier for \&{forever} */
14249 @d end_for 0 /* command modifier for \&{endfor} */
14252 mp_primitive(mp, "def",macro_def,start_def);
14253 @:def_}{\&{def} primitive@>
14254 mp_primitive(mp, "vardef",macro_def,var_def);
14255 @:var_def_}{\&{vardef} primitive@>
14256 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14257 @:primary_def_}{\&{primarydef} primitive@>
14258 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14259 @:secondary_def_}{\&{secondarydef} primitive@>
14260 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14261 @:tertiary_def_}{\&{tertiarydef} primitive@>
14262 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14263 @:end_def_}{\&{enddef} primitive@>
14265 mp_primitive(mp, "for",iteration,expr_base);
14266 @:for_}{\&{for} primitive@>
14267 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14268 @:for_suffixes_}{\&{forsuffixes} primitive@>
14269 mp_primitive(mp, "forever",iteration,start_forever);
14270 @:forever_}{\&{forever} primitive@>
14271 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14272 @:end_for_}{\&{endfor} primitive@>
14274 @ @<Cases of |print_cmd...@>=
14276 if ( m<=var_def ) {
14277 if ( m==start_def ) mp_print(mp, "def");
14278 else if ( m<start_def ) mp_print(mp, "enddef");
14279 else mp_print(mp, "vardef");
14280 } else if ( m==secondary_primary_macro ) {
14281 mp_print(mp, "primarydef");
14282 } else if ( m==tertiary_secondary_macro ) {
14283 mp_print(mp, "secondarydef");
14285 mp_print(mp, "tertiarydef");
14289 if ( m<=start_forever ) {
14290 if ( m==start_forever ) mp_print(mp, "forever");
14291 else mp_print(mp, "endfor");
14292 } else if ( m==expr_base ) {
14293 mp_print(mp, "for");
14295 mp_print(mp, "forsuffixes");
14299 @ Different macro-absorbing operations have different syntaxes, but they
14300 also have a lot in common. There is a list of special symbols that are to
14301 be replaced by parameter tokens; there is a special command code that
14302 ends the definition; the quotation conventions are identical. Therefore
14303 it makes sense to have most of the work done by a single subroutine. That
14304 subroutine is called |scan_toks|.
14306 The first parameter to |scan_toks| is the command code that will
14307 terminate scanning (either |macro_def| or |iteration|).
14309 The second parameter, |subst_list|, points to a (possibly empty) list
14310 of two-word nodes whose |info| and |value| fields specify symbol tokens
14311 before and after replacement. The list will be returned to free storage
14314 The third parameter is simply appended to the token list that is built.
14315 And the final parameter tells how many of the special operations
14316 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14317 When such parameters are present, they are called \.{(SUFFIX0)},
14318 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14320 @c pointer mp_scan_toks (MP mp,command_code terminator, pointer
14321 subst_list, pointer tail_end, small_number suffix_count) {
14322 pointer p; /* tail of the token list being built */
14323 pointer q; /* temporary for link management */
14324 integer balance; /* left delimiters minus right delimiters */
14325 p=hold_head; balance=1; link(hold_head)=null;
14328 if ( mp->cur_sym>0 ) {
14329 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14330 if ( mp->cur_cmd==terminator ) {
14331 @<Adjust the balance; |break| if it's zero@>;
14332 } else if ( mp->cur_cmd==macro_special ) {
14333 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14336 link(p)=mp_cur_tok(mp); p=link(p);
14338 link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14339 return link(hold_head);
14342 @ @<Substitute for |cur_sym|...@>=
14345 while ( q!=null ) {
14346 if ( info(q)==mp->cur_sym ) {
14347 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14353 @ @<Adjust the balance; |break| if it's zero@>=
14354 if ( mp->cur_mod>0 ) {
14362 @ Four commands are intended to be used only within macro texts: \&{quote},
14363 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14364 code called |macro_special|.
14366 @d quote 0 /* |macro_special| modifier for \&{quote} */
14367 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14368 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14369 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14372 mp_primitive(mp, "quote",macro_special,quote);
14373 @:quote_}{\&{quote} primitive@>
14374 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14375 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14376 mp_primitive(mp, "@@",macro_special,macro_at);
14377 @:]]]\AT!_}{\.{\AT!} primitive@>
14378 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14379 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14381 @ @<Cases of |print_cmd...@>=
14382 case macro_special:
14384 case macro_prefix: mp_print(mp, "#@@"); break;
14385 case macro_at: mp_print_char(mp, '@@'); break;
14386 case macro_suffix: mp_print(mp, "@@#"); break;
14387 default: mp_print(mp, "quote"); break;
14391 @ @<Handle quoted...@>=
14393 if ( mp->cur_mod==quote ) { get_t_next; }
14394 else if ( mp->cur_mod<=suffix_count )
14395 mp->cur_sym=suffix_base-1+mp->cur_mod;
14398 @ Here is a routine that's used whenever a token will be redefined. If
14399 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14400 substituted; the latter is redefinable but essentially impossible to use,
14401 hence \MP's tables won't get fouled up.
14403 @c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14406 if ( (mp->cur_sym==0)||(mp->cur_sym>frozen_inaccessible) ) {
14407 print_err("Missing symbolic token inserted");
14408 @.Missing symbolic token...@>
14409 help3("Sorry: You can\'t redefine a number, string, or expr.")
14410 ("I've inserted an inaccessible symbol so that your")
14411 ("definition will be completed without mixing me up too badly.");
14412 if ( mp->cur_sym>0 )
14413 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14414 else if ( mp->cur_cmd==string_token )
14415 delete_str_ref(mp->cur_mod);
14416 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14420 @ Before we actually redefine a symbolic token, we need to clear away its
14421 former value, if it was a variable. The following stronger version of
14422 |get_symbol| does that.
14424 @c void mp_get_clear_symbol (MP mp) {
14425 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14428 @ Here's another little subroutine; it checks that an equals sign
14429 or assignment sign comes along at the proper place in a macro definition.
14431 @c void mp_check_equals (MP mp) {
14432 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14433 mp_missing_err(mp, "=");
14435 help5("The next thing in this `def' should have been `=',")
14436 ("because I've already looked at the definition heading.")
14437 ("But don't worry; I'll pretend that an equals sign")
14438 ("was present. Everything from here to `enddef'")
14439 ("will be the replacement text of this macro.");
14444 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14445 handled now that we have |scan_toks|. In this case there are
14446 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14447 |expr_base| and |expr_base+1|).
14449 @c void mp_make_op_def (MP mp) {
14450 command_code m; /* the type of definition */
14451 pointer p,q,r; /* for list manipulation */
14453 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14454 info(q)=mp->cur_sym; value(q)=expr_base;
14455 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14456 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14457 info(p)=mp->cur_sym; value(p)=expr_base+1; link(p)=q;
14458 get_t_next; mp_check_equals(mp);
14459 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14460 r=mp_get_avail(mp); link(q)=r; info(r)=general_macro;
14461 link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14462 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14463 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14466 @ Parameters to macros are introduced by the keywords \&{expr},
14467 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14470 mp_primitive(mp, "expr",param_type,expr_base);
14471 @:expr_}{\&{expr} primitive@>
14472 mp_primitive(mp, "suffix",param_type,suffix_base);
14473 @:suffix_}{\&{suffix} primitive@>
14474 mp_primitive(mp, "text",param_type,text_base);
14475 @:text_}{\&{text} primitive@>
14476 mp_primitive(mp, "primary",param_type,primary_macro);
14477 @:primary_}{\&{primary} primitive@>
14478 mp_primitive(mp, "secondary",param_type,secondary_macro);
14479 @:secondary_}{\&{secondary} primitive@>
14480 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14481 @:tertiary_}{\&{tertiary} primitive@>
14483 @ @<Cases of |print_cmd...@>=
14485 if ( m>=expr_base ) {
14486 if ( m==expr_base ) mp_print(mp, "expr");
14487 else if ( m==suffix_base ) mp_print(mp, "suffix");
14488 else mp_print(mp, "text");
14489 } else if ( m<secondary_macro ) {
14490 mp_print(mp, "primary");
14491 } else if ( m==secondary_macro ) {
14492 mp_print(mp, "secondary");
14494 mp_print(mp, "tertiary");
14498 @ Let's turn next to the more complex processing associated with \&{def}
14499 and \&{vardef}. When the following procedure is called, |cur_mod|
14500 should be either |start_def| or |var_def|.
14502 @c @<Declare the procedure called |check_delimiter|@>
14503 @<Declare the function called |scan_declared_variable|@>
14504 void mp_scan_def (MP mp) {
14505 int m; /* the type of definition */
14506 int n; /* the number of special suffix parameters */
14507 int k; /* the total number of parameters */
14508 int c; /* the kind of macro we're defining */
14509 pointer r; /* parameter-substitution list */
14510 pointer q; /* tail of the macro token list */
14511 pointer p; /* temporary storage */
14512 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14513 pointer l_delim,r_delim; /* matching delimiters */
14514 m=mp->cur_mod; c=general_macro; link(hold_head)=null;
14515 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14516 @<Scan the token or variable to be defined;
14517 set |n|, |scanner_status|, and |warning_info|@>;
14519 if ( mp->cur_cmd==left_delimiter ) {
14520 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14522 if ( mp->cur_cmd==param_type ) {
14523 @<Absorb undelimited parameters, putting them into list |r|@>;
14525 mp_check_equals(mp);
14526 p=mp_get_avail(mp); info(p)=c; link(q)=p;
14527 @<Attach the replacement text to the tail of node |p|@>;
14528 mp->scanner_status=normal; mp_get_x_next(mp);
14531 @ We don't put `|frozen_end_group|' into the replacement text of
14532 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14534 @<Attach the replacement text to the tail of node |p|@>=
14535 if ( m==start_def ) {
14536 link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14538 q=mp_get_avail(mp); info(q)=mp->bg_loc; link(p)=q;
14539 p=mp_get_avail(mp); info(p)=mp->eg_loc;
14540 link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14542 if ( mp->warning_info==bad_vardef )
14543 mp_flush_token_list(mp, value(bad_vardef))
14547 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14549 @ @<Scan the token or variable to be defined;...@>=
14550 if ( m==start_def ) {
14551 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14552 mp->scanner_status=op_defining; n=0;
14553 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14555 p=mp_scan_declared_variable(mp);
14556 mp_flush_variable(mp, equiv(info(p)),link(p),true);
14557 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14558 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14559 mp->scanner_status=var_defining; n=2;
14560 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14563 type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14564 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14566 @ @<Change to `\.{a bad variable}'@>=
14568 print_err("This variable already starts with a macro");
14569 @.This variable already...@>
14570 help2("After `vardef a' you can\'t say `vardef a.b'.")
14571 ("So I'll have to discard this definition.");
14572 mp_error(mp); mp->warning_info=bad_vardef;
14575 @ @<Initialize table entries...@>=
14576 name_type(bad_vardef)=mp_root; link(bad_vardef)=frozen_bad_vardef;
14577 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14579 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14581 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14582 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14585 print_err("Missing parameter type; `expr' will be assumed");
14586 @.Missing parameter type@>
14587 help1("You should've had `expr' or `suffix' or `text' here.");
14588 mp_back_error(mp); base=expr_base;
14590 @<Absorb parameter tokens for type |base|@>;
14591 mp_check_delimiter(mp, l_delim,r_delim);
14593 } while (mp->cur_cmd==left_delimiter)
14595 @ @<Absorb parameter tokens for type |base|@>=
14597 link(q)=mp_get_avail(mp); q=link(q); info(q)=base+k;
14598 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14599 value(p)=base+k; info(p)=mp->cur_sym;
14600 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14601 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14602 incr(k); link(p)=r; r=p; get_t_next;
14603 } while (mp->cur_cmd==comma)
14605 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14607 p=mp_get_node(mp, token_node_size);
14608 if ( mp->cur_mod<expr_base ) {
14609 c=mp->cur_mod; value(p)=expr_base+k;
14611 value(p)=mp->cur_mod+k;
14612 if ( mp->cur_mod==expr_base ) c=expr_macro;
14613 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14616 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14617 incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; link(p)=r; r=p; get_t_next;
14618 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14619 c=of_macro; p=mp_get_node(mp, token_node_size);
14620 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14621 value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
14622 link(p)=r; r=p; get_t_next;
14626 @* \[32] Expanding the next token.
14627 Only a few command codes |<min_command| can possibly be returned by
14628 |get_t_next|; in increasing order, they are
14629 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14630 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14632 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14633 like |get_t_next| except that it keeps getting more tokens until
14634 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14635 macros and removes conditionals or iterations or input instructions that
14638 It follows that |get_x_next| might invoke itself recursively. In fact,
14639 there is massive recursion, since macro expansion can involve the
14640 scanning of arbitrarily complex expressions, which in turn involve
14641 macro expansion and conditionals, etc.
14644 Therefore it's necessary to declare a whole bunch of |forward|
14645 procedures at this point, and to insert some other procedures
14646 that will be invoked by |get_x_next|.
14649 void mp_scan_primary (MP mp);
14650 void mp_scan_secondary (MP mp);
14651 void mp_scan_tertiary (MP mp);
14652 void mp_scan_expression (MP mp);
14653 void mp_scan_suffix (MP mp);
14654 @<Declare the procedure called |macro_call|@>
14655 void mp_get_boolean (MP mp);
14656 void mp_pass_text (MP mp);
14657 void mp_conditional (MP mp);
14658 void mp_start_input (MP mp);
14659 void mp_begin_iteration (MP mp);
14660 void mp_resume_iteration (MP mp);
14661 void mp_stop_iteration (MP mp);
14663 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14664 when it has to do exotic expansion commands.
14666 @c void mp_expand (MP mp) {
14667 pointer p; /* for list manipulation */
14668 size_t k; /* something that we hope is |<=buf_size| */
14669 pool_pointer j; /* index into |str_pool| */
14670 if ( mp->internal[mp_tracing_commands]>unity )
14671 if ( mp->cur_cmd!=defined_macro )
14673 switch (mp->cur_cmd) {
14675 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14678 @<Terminate the current conditional and skip to \&{fi}@>;
14681 @<Initiate or terminate input from a file@>;
14684 if ( mp->cur_mod==end_for ) {
14685 @<Scold the user for having an extra \&{endfor}@>;
14687 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14694 @<Exit a loop if the proper time has come@>;
14699 @<Expand the token after the next token@>;
14702 @<Put a string into the input buffer@>;
14704 case defined_macro:
14705 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14707 }; /* there are no other cases */
14710 @ @<Scold the user...@>=
14712 print_err("Extra `endfor'");
14714 help2("I'm not currently working on a for loop,")
14715 ("so I had better not try to end anything.");
14719 @ The processing of \&{input} involves the |start_input| subroutine,
14720 which will be declared later; the processing of \&{endinput} is trivial.
14723 mp_primitive(mp, "input",input,0);
14724 @:input_}{\&{input} primitive@>
14725 mp_primitive(mp, "endinput",input,1);
14726 @:end_input_}{\&{endinput} primitive@>
14728 @ @<Cases of |print_cmd_mod|...@>=
14730 if ( m==0 ) mp_print(mp, "input");
14731 else mp_print(mp, "endinput");
14734 @ @<Initiate or terminate input...@>=
14735 if ( mp->cur_mod>0 ) mp->force_eof=true;
14736 else mp_start_input(mp)
14738 @ We'll discuss the complicated parts of loop operations later. For now
14739 it suffices to know that there's a global variable called |loop_ptr|
14740 that will be |null| if no loop is in progress.
14743 { while ( token_state &&(loc==null) )
14744 mp_end_token_list(mp); /* conserve stack space */
14745 if ( mp->loop_ptr==null ) {
14746 print_err("Lost loop");
14748 help2("I'm confused; after exiting from a loop, I still seem")
14749 ("to want to repeat it. I'll try to forget the problem.");
14752 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14756 @ @<Exit a loop if the proper time has come@>=
14757 { mp_get_boolean(mp);
14758 if ( mp->internal[mp_tracing_commands]>unity )
14759 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14760 if ( mp->cur_exp==true_code ) {
14761 if ( mp->loop_ptr==null ) {
14762 print_err("No loop is in progress");
14763 @.No loop is in progress@>
14764 help1("Why say `exitif' when there's nothing to exit from?");
14765 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14767 @<Exit prematurely from an iteration@>;
14769 } else if ( mp->cur_cmd!=semicolon ) {
14770 mp_missing_err(mp, ";");
14772 help2("After `exitif <boolean exp>' I expect to see a semicolon.")
14773 ("I shall pretend that one was there."); mp_back_error(mp);
14777 @ Here we use the fact that |forever_text| is the only |token_type| that
14778 is less than |loop_text|.
14780 @<Exit prematurely...@>=
14783 if ( file_state ) {
14784 mp_end_file_reading(mp);
14786 if ( token_type<=loop_text ) p=start;
14787 mp_end_token_list(mp);
14790 if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14792 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14795 @ @<Expand the token after the next token@>=
14797 p=mp_cur_tok(mp); get_t_next;
14798 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14799 else mp_back_input(mp);
14803 @ @<Put a string into the input buffer@>=
14804 { mp_get_x_next(mp); mp_scan_primary(mp);
14805 if ( mp->cur_type!=mp_string_type ) {
14806 mp_disp_err(mp, null,"Not a string");
14808 help2("I'm going to flush this expression, since")
14809 ("scantokens should be followed by a known string.");
14810 mp_put_get_flush_error(mp, 0);
14813 if ( length(mp->cur_exp)>0 )
14814 @<Pretend we're reading a new one-line file@>;
14818 @ @<Pretend we're reading a new one-line file@>=
14819 { mp_begin_file_reading(mp); name=is_scantok;
14820 k=mp->first+length(mp->cur_exp);
14821 if ( k>=mp->max_buf_stack ) {
14822 while ( k>=mp->buf_size ) {
14823 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
14825 mp->max_buf_stack=k+1;
14827 j=mp->str_start[mp->cur_exp]; limit=k;
14828 while ( mp->first<(size_t)limit ) {
14829 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14831 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
14832 mp_flush_cur_exp(mp, 0);
14835 @ Here finally is |get_x_next|.
14837 The expression scanning routines to be considered later
14838 communicate via the global quantities |cur_type| and |cur_exp|;
14839 we must be very careful to save and restore these quantities while
14840 macros are being expanded.
14844 void mp_get_x_next (MP mp);
14846 @ @c void mp_get_x_next (MP mp) {
14847 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14849 if ( mp->cur_cmd<min_command ) {
14850 save_exp=mp_stash_cur_exp(mp);
14852 if ( mp->cur_cmd==defined_macro )
14853 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14857 } while (mp->cur_cmd<min_command);
14858 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14862 @ Now let's consider the |macro_call| procedure, which is used to start up
14863 all user-defined macros. Since the arguments to a macro might be expressions,
14864 |macro_call| is recursive.
14867 The first parameter to |macro_call| points to the reference count of the
14868 token list that defines the macro. The second parameter contains any
14869 arguments that have already been parsed (see below). The third parameter
14870 points to the symbolic token that names the macro. If the third parameter
14871 is |null|, the macro was defined by \&{vardef}, so its name can be
14872 reconstructed from the prefix and ``at'' arguments found within the
14875 What is this second parameter? It's simply a linked list of one-word items,
14876 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14877 no arguments have been scanned yet; otherwise |info(arg_list)| points to
14878 the first scanned argument, and |link(arg_list)| points to the list of
14879 further arguments (if any).
14881 Arguments of type \&{expr} are so-called capsules, which we will
14882 discuss later when we concentrate on expressions; they can be
14883 recognized easily because their |link| field is |void|. Arguments of type
14884 \&{suffix} and \&{text} are token lists without reference counts.
14886 @ After argument scanning is complete, the arguments are moved to the
14887 |param_stack|. (They can't be put on that stack any sooner, because
14888 the stack is growing and shrinking in unpredictable ways as more arguments
14889 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14890 the replacement text of the macro is placed at the top of the \MP's
14891 input stack, so that |get_t_next| will proceed to read it next.
14893 @<Declare the procedure called |macro_call|@>=
14894 @<Declare the procedure called |print_macro_name|@>
14895 @<Declare the procedure called |print_arg|@>
14896 @<Declare the procedure called |scan_text_arg|@>
14897 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14898 pointer macro_name) ;
14901 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14902 pointer macro_name) {
14903 /* invokes a user-defined control sequence */
14904 pointer r; /* current node in the macro's token list */
14905 pointer p,q; /* for list manipulation */
14906 integer n; /* the number of arguments */
14907 pointer tail = 0; /* tail of the argument list */
14908 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14909 r=link(def_ref); add_mac_ref(def_ref);
14910 if ( arg_list==null ) {
14913 @<Determine the number |n| of arguments already supplied,
14914 and set |tail| to the tail of |arg_list|@>;
14916 if ( mp->internal[mp_tracing_macros]>0 ) {
14917 @<Show the text of the macro being expanded, and the existing arguments@>;
14919 @<Scan the remaining arguments, if any; set |r| to the first token
14920 of the replacement text@>;
14921 @<Feed the arguments and replacement text to the scanner@>;
14924 @ @<Show the text of the macro...@>=
14925 mp_begin_diagnostic(mp); mp_print_ln(mp);
14926 mp_print_macro_name(mp, arg_list,macro_name);
14927 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14928 mp_show_macro(mp, def_ref,null,100000);
14929 if ( arg_list!=null ) {
14933 mp_print_arg(mp, q,n,0);
14934 incr(n); p=link(p);
14937 mp_end_diagnostic(mp, false)
14940 @ @<Declare the procedure called |print_macro_name|@>=
14941 void mp_print_macro_name (MP mp,pointer a, pointer n);
14944 void mp_print_macro_name (MP mp,pointer a, pointer n) {
14945 pointer p,q; /* they traverse the first part of |a| */
14951 mp_print_text(info(info(link(a))));
14954 while ( link(q)!=null ) q=link(q);
14955 link(q)=info(link(a));
14956 mp_show_token_list(mp, p,null,1000,0);
14962 @ @<Declare the procedure called |print_arg|@>=
14963 void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
14966 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
14967 if ( link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
14968 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
14969 else mp_print_nl(mp, "(TEXT");
14970 mp_print_int(mp, n); mp_print(mp, ")<-");
14971 if ( link(q)==mp_void ) mp_print_exp(mp, q,1);
14972 else mp_show_token_list(mp, q,null,1000,0);
14975 @ @<Determine the number |n| of arguments already supplied...@>=
14977 n=1; tail=arg_list;
14978 while ( link(tail)!=null ) {
14979 incr(n); tail=link(tail);
14983 @ @<Scan the remaining arguments, if any; set |r|...@>=
14984 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
14985 while ( info(r)>=expr_base ) {
14986 @<Scan the delimited argument represented by |info(r)|@>;
14989 if ( mp->cur_cmd==comma ) {
14990 print_err("Too many arguments to ");
14991 @.Too many arguments...@>
14992 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, ';');
14993 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
14995 mp_print(mp, "' has been inserted");
14996 help3("I'm going to assume that the comma I just read was a")
14997 ("right delimiter, and then I'll begin expanding the macro.")
14998 ("You might want to delete some tokens before continuing.");
15001 if ( info(r)!=general_macro ) {
15002 @<Scan undelimited argument(s)@>;
15006 @ At this point, the reader will find it advisable to review the explanation
15007 of token list format that was presented earlier, paying special attention to
15008 the conventions that apply only at the beginning of a macro's token list.
15010 On the other hand, the reader will have to take the expression-parsing
15011 aspects of the following program on faith; we will explain |cur_type|
15012 and |cur_exp| later. (Several things in this program depend on each other,
15013 and it's necessary to jump into the circle somewhere.)
15015 @<Scan the delimited argument represented by |info(r)|@>=
15016 if ( mp->cur_cmd!=comma ) {
15018 if ( mp->cur_cmd!=left_delimiter ) {
15019 print_err("Missing argument to ");
15020 @.Missing argument...@>
15021 mp_print_macro_name(mp, arg_list,macro_name);
15022 help3("That macro has more parameters than you thought.")
15023 ("I'll continue by pretending that each missing argument")
15024 ("is either zero or null.");
15025 if ( info(r)>=suffix_base ) {
15026 mp->cur_exp=null; mp->cur_type=mp_token_list;
15028 mp->cur_exp=0; mp->cur_type=mp_known;
15030 mp_back_error(mp); mp->cur_cmd=right_delimiter;
15033 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
15035 @<Scan the argument represented by |info(r)|@>;
15036 if ( mp->cur_cmd!=comma )
15037 @<Check that the proper right delimiter was present@>;
15039 @<Append the current expression to |arg_list|@>
15041 @ @<Check that the proper right delim...@>=
15042 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15043 if ( info(link(r))>=expr_base ) {
15044 mp_missing_err(mp, ",");
15046 help3("I've finished reading a macro argument and am about to")
15047 ("read another; the arguments weren't delimited correctly.")
15048 ("You might want to delete some tokens before continuing.");
15049 mp_back_error(mp); mp->cur_cmd=comma;
15051 mp_missing_err(mp, str(text(r_delim)));
15053 help2("I've gotten to the end of the macro parameter list.")
15054 ("You might want to delete some tokens before continuing.");
15059 @ A \&{suffix} or \&{text} parameter will have been scanned as
15060 a token list pointed to by |cur_exp|, in which case we will have
15061 |cur_type=token_list|.
15063 @<Append the current expression to |arg_list|@>=
15065 p=mp_get_avail(mp);
15066 if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
15067 else info(p)=mp_stash_cur_exp(mp);
15068 if ( mp->internal[mp_tracing_macros]>0 ) {
15069 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
15070 mp_end_diagnostic(mp, false);
15072 if ( arg_list==null ) arg_list=p;
15077 @ @<Scan the argument represented by |info(r)|@>=
15078 if ( info(r)>=text_base ) {
15079 mp_scan_text_arg(mp, l_delim,r_delim);
15082 if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
15083 else mp_scan_expression(mp);
15086 @ The parameters to |scan_text_arg| are either a pair of delimiters
15087 or zero; the latter case is for undelimited text arguments, which
15088 end with the first semicolon or \&{endgroup} or \&{end} that is not
15089 contained in a group.
15091 @<Declare the procedure called |scan_text_arg|@>=
15092 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
15095 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
15096 integer balance; /* excess of |l_delim| over |r_delim| */
15097 pointer p; /* list tail */
15098 mp->warning_info=l_delim; mp->scanner_status=absorbing;
15099 p=hold_head; balance=1; link(hold_head)=null;
15102 if ( l_delim==0 ) {
15103 @<Adjust the balance for an undelimited argument; |break| if done@>;
15105 @<Adjust the balance for a delimited argument; |break| if done@>;
15107 link(p)=mp_cur_tok(mp); p=link(p);
15109 mp->cur_exp=link(hold_head); mp->cur_type=mp_token_list;
15110 mp->scanner_status=normal;
15113 @ @<Adjust the balance for a delimited argument...@>=
15114 if ( mp->cur_cmd==right_delimiter ) {
15115 if ( mp->cur_mod==l_delim ) {
15117 if ( balance==0 ) break;
15119 } else if ( mp->cur_cmd==left_delimiter ) {
15120 if ( mp->cur_mod==r_delim ) incr(balance);
15123 @ @<Adjust the balance for an undelimited...@>=
15124 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
15125 if ( balance==1 ) { break; }
15126 else { if ( mp->cur_cmd==end_group ) decr(balance); }
15127 } else if ( mp->cur_cmd==begin_group ) {
15131 @ @<Scan undelimited argument(s)@>=
15133 if ( info(r)<text_macro ) {
15135 if ( info(r)!=suffix_macro ) {
15136 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
15140 case primary_macro:mp_scan_primary(mp); break;
15141 case secondary_macro:mp_scan_secondary(mp); break;
15142 case tertiary_macro:mp_scan_tertiary(mp); break;
15143 case expr_macro:mp_scan_expression(mp); break;
15145 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
15148 @<Scan a suffix with optional delimiters@>;
15150 case text_macro:mp_scan_text_arg(mp, 0,0); break;
15151 } /* there are no other cases */
15153 @<Append the current expression to |arg_list|@>;
15156 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
15158 mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
15159 if ( mp->internal[mp_tracing_macros]>0 ) {
15160 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
15161 mp_end_diagnostic(mp, false);
15163 if ( arg_list==null ) arg_list=p; else link(tail)=p;
15165 if ( mp->cur_cmd!=of_token ) {
15166 mp_missing_err(mp, "of"); mp_print(mp, " for ");
15168 mp_print_macro_name(mp, arg_list,macro_name);
15169 help1("I've got the first argument; will look now for the other.");
15172 mp_get_x_next(mp); mp_scan_primary(mp);
15175 @ @<Scan a suffix with optional delimiters@>=
15177 if ( mp->cur_cmd!=left_delimiter ) {
15180 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
15182 mp_scan_suffix(mp);
15183 if ( l_delim!=null ) {
15184 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15185 mp_missing_err(mp, str(text(r_delim)));
15187 help2("I've gotten to the end of the macro parameter list.")
15188 ("You might want to delete some tokens before continuing.");
15195 @ Before we put a new token list on the input stack, it is wise to clean off
15196 all token lists that have recently been depleted. Then a user macro that ends
15197 with a call to itself will not require unbounded stack space.
15199 @<Feed the arguments and replacement text to the scanner@>=
15200 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15201 if ( mp->param_ptr+n>mp->max_param_stack ) {
15202 mp->max_param_stack=mp->param_ptr+n;
15203 if ( mp->max_param_stack>mp->param_size )
15204 mp_overflow(mp, "parameter stack size",mp->param_size);
15205 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15207 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15211 mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=link(p);
15213 mp_flush_list(mp, arg_list);
15216 @ It's sometimes necessary to put a single argument onto |param_stack|.
15217 The |stack_argument| subroutine does this.
15219 @c void mp_stack_argument (MP mp,pointer p) {
15220 if ( mp->param_ptr==mp->max_param_stack ) {
15221 incr(mp->max_param_stack);
15222 if ( mp->max_param_stack>mp->param_size )
15223 mp_overflow(mp, "parameter stack size",mp->param_size);
15224 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15226 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15229 @* \[33] Conditional processing.
15230 Let's consider now the way \&{if} commands are handled.
15232 Conditions can be inside conditions, and this nesting has a stack
15233 that is independent of other stacks.
15234 Four global variables represent the top of the condition stack:
15235 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15236 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15237 the largest code of a |fi_or_else| command that is syntactically legal;
15238 and |if_line| is the line number at which the current conditional began.
15240 If no conditions are currently in progress, the condition stack has the
15241 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15242 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15243 |link| fields of the first word contain |if_limit|, |cur_if|, and
15244 |cond_ptr| at the next level, and the second word contains the
15245 corresponding |if_line|.
15247 @d if_node_size 2 /* number of words in stack entry for conditionals */
15248 @d if_line_field(A) mp->mem[(A)+1].cint
15249 @d if_code 1 /* code for \&{if} being evaluated */
15250 @d fi_code 2 /* code for \&{fi} */
15251 @d else_code 3 /* code for \&{else} */
15252 @d else_if_code 4 /* code for \&{elseif} */
15255 pointer cond_ptr; /* top of the condition stack */
15256 integer if_limit; /* upper bound on |fi_or_else| codes */
15257 small_number cur_if; /* type of conditional being worked on */
15258 integer if_line; /* line where that conditional began */
15261 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15264 mp_primitive(mp, "if",if_test,if_code);
15265 @:if_}{\&{if} primitive@>
15266 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15267 @:fi_}{\&{fi} primitive@>
15268 mp_primitive(mp, "else",fi_or_else,else_code);
15269 @:else_}{\&{else} primitive@>
15270 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15271 @:else_if_}{\&{elseif} primitive@>
15273 @ @<Cases of |print_cmd_mod|...@>=
15277 case if_code:mp_print(mp, "if"); break;
15278 case fi_code:mp_print(mp, "fi"); break;
15279 case else_code:mp_print(mp, "else"); break;
15280 default: mp_print(mp, "elseif"); break;
15284 @ Here is a procedure that ignores text until coming to an \&{elseif},
15285 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15286 nesting. After it has acted, |cur_mod| will indicate the token that
15289 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15290 makes the skipping process a bit simpler.
15293 void mp_pass_text (MP mp) {
15295 mp->scanner_status=skipping;
15296 mp->warning_info=mp_true_line(mp);
15299 if ( mp->cur_cmd<=fi_or_else ) {
15300 if ( mp->cur_cmd<fi_or_else ) {
15304 if ( mp->cur_mod==fi_code ) decr(l);
15307 @<Decrease the string reference count,
15308 if the current token is a string@>;
15311 mp->scanner_status=normal;
15314 @ @<Decrease the string reference count...@>=
15315 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15317 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15318 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15319 condition has been evaluated, a colon will be inserted.
15320 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15322 @<Push the condition stack@>=
15323 { p=mp_get_node(mp, if_node_size); link(p)=mp->cond_ptr; type(p)=mp->if_limit;
15324 name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15325 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15326 mp->cur_if=if_code;
15329 @ @<Pop the condition stack@>=
15330 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15331 mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=link(p);
15332 mp_free_node(mp, p,if_node_size);
15335 @ Here's a procedure that changes the |if_limit| code corresponding to
15336 a given value of |cond_ptr|.
15338 @c void mp_change_if_limit (MP mp,small_number l, pointer p) {
15340 if ( p==mp->cond_ptr ) {
15341 mp->if_limit=l; /* that's the easy case */
15345 if ( q==null ) mp_confusion(mp, "if");
15346 @:this can't happen if}{\quad if@>
15347 if ( link(q)==p ) {
15355 @ The user is supposed to put colons into the proper parts of conditional
15356 statements. Therefore, \MP\ has to check for their presence.
15359 void mp_check_colon (MP mp) {
15360 if ( mp->cur_cmd!=colon ) {
15361 mp_missing_err(mp, ":");
15363 help2("There should've been a colon after the condition.")
15364 ("I shall pretend that one was there.");;
15369 @ A condition is started when the |get_x_next| procedure encounters
15370 an |if_test| command; in that case |get_x_next| calls |conditional|,
15371 which is a recursive procedure.
15374 @c void mp_conditional (MP mp) {
15375 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15376 int new_if_limit; /* future value of |if_limit| */
15377 pointer p; /* temporary register */
15378 @<Push the condition stack@>;
15379 save_cond_ptr=mp->cond_ptr;
15381 mp_get_boolean(mp); new_if_limit=else_if_code;
15382 if ( mp->internal[mp_tracing_commands]>unity ) {
15383 @<Display the boolean value of |cur_exp|@>;
15386 mp_check_colon(mp);
15387 if ( mp->cur_exp==true_code ) {
15388 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15389 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15391 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15393 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15394 if ( mp->cur_mod==fi_code ) {
15395 @<Pop the condition stack@>
15396 } else if ( mp->cur_mod==else_if_code ) {
15399 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15404 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15405 \&{else}: \\{bar} \&{fi}', the first \&{else}
15406 that we come to after learning that the \&{if} is false is not the
15407 \&{else} we're looking for. Hence the following curious logic is needed.
15409 @<Skip to \&{elseif}...@>=
15412 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15413 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15417 @ @<Display the boolean value...@>=
15418 { mp_begin_diagnostic(mp);
15419 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15420 else mp_print(mp, "{false}");
15421 mp_end_diagnostic(mp, false);
15424 @ The processing of conditionals is complete except for the following
15425 code, which is actually part of |get_x_next|. It comes into play when
15426 \&{elseif}, \&{else}, or \&{fi} is scanned.
15428 @<Terminate the current conditional and skip to \&{fi}@>=
15429 if ( mp->cur_mod>mp->if_limit ) {
15430 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15431 mp_missing_err(mp, ":");
15433 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15435 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15439 help1("I'm ignoring this; it doesn't match any if.");
15443 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15444 @<Pop the condition stack@>;
15447 @* \[34] Iterations.
15448 To bring our treatment of |get_x_next| to a close, we need to consider what
15449 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15451 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15452 that are currently active. If |loop_ptr=null|, no loops are in progress;
15453 otherwise |info(loop_ptr)| points to the iterative text of the current
15454 (innermost) loop, and |link(loop_ptr)| points to the data for any other
15455 loops that enclose the current one.
15457 A loop-control node also has two other fields, called |loop_type| and
15458 |loop_list|, whose contents depend on the type of loop:
15460 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15461 points to a list of one-word nodes whose |info| fields point to the
15462 remaining argument values of a suffix list and expression list.
15464 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15467 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15468 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15469 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15472 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15473 header and |loop_list(loop_ptr)| points into the graphical object list for
15476 \yskip\noindent In the case of a progression node, the first word is not used
15477 because the link field of words in the dynamic memory area cannot be arbitrary.
15479 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15480 @d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
15481 @d loop_list(A) link(loop_list_loc((A))) /* the remaining list elements */
15482 @d loop_node_size 2 /* the number of words in a loop control node */
15483 @d progression_node_size 4 /* the number of words in a progression node */
15484 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15485 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15486 @d progression_flag (null+2)
15487 /* |loop_type| value when |loop_list| points to a progression node */
15490 pointer loop_ptr; /* top of the loop-control-node stack */
15495 @ If the expressions that define an arithmetic progression in
15496 a \&{for} loop don't have known numeric values, the |bad_for|
15497 subroutine screams at the user.
15499 @c void mp_bad_for (MP mp, const char * s) {
15500 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15501 @.Improper...replaced by 0@>
15502 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15503 help4("When you say `for x=a step b until c',")
15504 ("the initial value `a' and the step size `b'")
15505 ("and the final value `c' must have known numeric values.")
15506 ("I'm zeroing this one. Proceed, with fingers crossed.");
15507 mp_put_get_flush_error(mp, 0);
15510 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15511 has just been scanned. (This code requires slight familiarity with
15512 expression-parsing routines that we have not yet discussed; but it seems
15513 to belong in the present part of the program, even though the original author
15514 didn't write it until later. The reader may wish to come back to it.)
15516 @c void mp_begin_iteration (MP mp) {
15517 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15518 halfword n; /* hash address of the current symbol */
15519 pointer s; /* the new loop-control node */
15520 pointer p; /* substitution list for |scan_toks| */
15521 pointer q; /* link manipulation register */
15522 pointer pp; /* a new progression node */
15523 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15524 if ( m==start_forever ){
15525 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15527 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15528 info(p)=mp->cur_sym; value(p)=m;
15530 if ( mp->cur_cmd==within_token ) {
15531 @<Set up a picture iteration@>;
15533 @<Check for the |"="| or |":="| in a loop header@>;
15534 @<Scan the values to be used in the loop@>;
15537 @<Check for the presence of a colon@>;
15538 @<Scan the loop text and put it on the loop control stack@>;
15539 mp_resume_iteration(mp);
15542 @ @<Check for the |"="| or |":="| in a loop header@>=
15543 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15544 mp_missing_err(mp, "=");
15546 help3("The next thing in this loop should have been `=' or `:='.")
15547 ("But don't worry; I'll pretend that an equals sign")
15548 ("was present, and I'll look for the values next.");
15552 @ @<Check for the presence of a colon@>=
15553 if ( mp->cur_cmd!=colon ) {
15554 mp_missing_err(mp, ":");
15556 help3("The next thing in this loop should have been a `:'.")
15557 ("So I'll pretend that a colon was present;")
15558 ("everything from here to `endfor' will be iterated.");
15562 @ We append a special |frozen_repeat_loop| token in place of the
15563 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15564 at the proper time to cause the loop to be repeated.
15566 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15567 he will be foiled by the |get_symbol| routine, which keeps frozen
15568 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15569 token, so it won't be lost accidentally.)
15571 @ @<Scan the loop text...@>=
15572 q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
15573 mp->scanner_status=loop_defining; mp->warning_info=n;
15574 info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15575 link(s)=mp->loop_ptr; mp->loop_ptr=s
15577 @ @<Initialize table...@>=
15578 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15579 text(frozen_repeat_loop)=intern(" ENDFOR");
15581 @ The loop text is inserted into \MP's scanning apparatus by the
15582 |resume_iteration| routine.
15584 @c void mp_resume_iteration (MP mp) {
15585 pointer p,q; /* link registers */
15586 p=loop_type(mp->loop_ptr);
15587 if ( p==progression_flag ) {
15588 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15589 mp->cur_exp=value(p);
15590 if ( @<The arithmetic progression has ended@> ) {
15591 mp_stop_iteration(mp);
15594 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15595 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15596 } else if ( p==null ) {
15597 p=loop_list(mp->loop_ptr);
15599 mp_stop_iteration(mp);
15602 loop_list(mp->loop_ptr)=link(p); q=info(p); free_avail(p);
15603 } else if ( p==mp_void ) {
15604 mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
15606 @<Make |q| a capsule containing the next picture component from
15607 |loop_list(loop_ptr)| or |goto not_found|@>;
15609 mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
15610 mp_stack_argument(mp, q);
15611 if ( mp->internal[mp_tracing_commands]>unity ) {
15612 @<Trace the start of a loop@>;
15616 mp_stop_iteration(mp);
15619 @ @<The arithmetic progression has ended@>=
15620 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15621 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15623 @ @<Trace the start of a loop@>=
15625 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15627 if ( (q!=null)&&(link(q)==mp_void) ) mp_print_exp(mp, q,1);
15628 else mp_show_token_list(mp, q,null,50,0);
15629 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
15632 @ @<Make |q| a capsule containing the next picture component from...@>=
15633 { q=loop_list(mp->loop_ptr);
15634 if ( q==null ) goto NOT_FOUND;
15635 skip_component(q) goto NOT_FOUND;
15636 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15637 mp_init_bbox(mp, mp->cur_exp);
15638 mp->cur_type=mp_picture_type;
15639 loop_list(mp->loop_ptr)=q;
15640 q=mp_stash_cur_exp(mp);
15643 @ A level of loop control disappears when |resume_iteration| has decided
15644 not to resume, or when an \&{exitif} construction has removed the loop text
15645 from the input stack.
15647 @c void mp_stop_iteration (MP mp) {
15648 pointer p,q; /* the usual */
15649 p=loop_type(mp->loop_ptr);
15650 if ( p==progression_flag ) {
15651 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15652 } else if ( p==null ){
15653 q=loop_list(mp->loop_ptr);
15654 while ( q!=null ) {
15657 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
15658 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15660 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15663 p=q; q=link(q); free_avail(p);
15665 } else if ( p>progression_flag ) {
15666 delete_edge_ref(p);
15668 p=mp->loop_ptr; mp->loop_ptr=link(p); mp_flush_token_list(mp, info(p));
15669 mp_free_node(mp, p,loop_node_size);
15672 @ Now that we know all about loop control, we can finish up
15673 the missing portion of |begin_iteration| and we'll be done.
15675 The following code is performed after the `\.=' has been scanned in
15676 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15677 (if |m=suffix_base|).
15679 @<Scan the values to be used in the loop@>=
15680 loop_type(s)=null; q=loop_list_loc(s); link(q)=null; /* |link(q)=loop_list(s)| */
15683 if ( m!=expr_base ) {
15684 mp_scan_suffix(mp);
15686 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15688 mp_scan_expression(mp);
15689 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15690 @<Prepare for step-until construction and |break|@>;
15692 mp->cur_exp=mp_stash_cur_exp(mp);
15694 link(q)=mp_get_avail(mp); q=link(q);
15695 info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15698 } while (mp->cur_cmd==comma)
15700 @ @<Prepare for step-until construction and |break|@>=
15702 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15703 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15704 mp_get_x_next(mp); mp_scan_expression(mp);
15705 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15706 step_size(pp)=mp->cur_exp;
15707 if ( mp->cur_cmd!=until_token ) {
15708 mp_missing_err(mp, "until");
15709 @.Missing `until'@>
15710 help2("I assume you meant to say `until' after `step'.")
15711 ("So I'll look for the final value and colon next.");
15714 mp_get_x_next(mp); mp_scan_expression(mp);
15715 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15716 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15717 loop_type(s)=progression_flag;
15721 @ The last case is when we have just seen ``\&{within}'', and we need to
15722 parse a picture expression and prepare to iterate over it.
15724 @<Set up a picture iteration@>=
15725 { mp_get_x_next(mp);
15726 mp_scan_expression(mp);
15727 @<Make sure the current expression is a known picture@>;
15728 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15729 q=link(dummy_loc(mp->cur_exp));
15731 if ( is_start_or_stop(q) )
15732 if ( mp_skip_1component(mp, q)==null ) q=link(q);
15736 @ @<Make sure the current expression is a known picture@>=
15737 if ( mp->cur_type!=mp_picture_type ) {
15738 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15739 help1("When you say `for x in p', p must be a known picture.");
15740 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15741 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15744 @* \[35] File names.
15745 It's time now to fret about file names. Besides the fact that different
15746 operating systems treat files in different ways, we must cope with the
15747 fact that completely different naming conventions are used by different
15748 groups of people. The following programs show what is required for one
15749 particular operating system; similar routines for other systems are not
15750 difficult to devise.
15751 @^system dependencies@>
15753 \MP\ assumes that a file name has three parts: the name proper; its
15754 ``extension''; and a ``file area'' where it is found in an external file
15755 system. The extension of an input file is assumed to be
15756 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15757 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15758 metric files that describe characters in any fonts created by \MP; it is
15759 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15760 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15761 The file area can be arbitrary on input files, but files are usually
15762 output to the user's current area. If an input file cannot be
15763 found on the specified area, \MP\ will look for it on a special system
15764 area; this special area is intended for commonly used input files.
15766 Simple uses of \MP\ refer only to file names that have no explicit
15767 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15768 instead of `\.{input} \.{cmr10.new}'. Simple file
15769 names are best, because they make the \MP\ source files portable;
15770 whenever a file name consists entirely of letters and digits, it should be
15771 treated in the same way by all implementations of \MP. However, users
15772 need the ability to refer to other files in their environment, especially
15773 when responding to error messages concerning unopenable files; therefore
15774 we want to let them use the syntax that appears in their favorite
15777 @ \MP\ uses the same conventions that have proved to be satisfactory for
15778 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15779 @^system dependencies@>
15780 the system-independent parts of \MP\ are expressed in terms
15781 of three system-dependent
15782 procedures called |begin_name|, |more_name|, and |end_name|. In
15783 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15784 the system-independent driver program does the operations
15785 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
15787 These three procedures communicate with each other via global variables.
15788 Afterwards the file name will appear in the string pool as three strings
15789 called |cur_name|\penalty10000\hskip-.05em,
15790 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15791 |""|), unless they were explicitly specified by the user.
15793 Actually the situation is slightly more complicated, because \MP\ needs
15794 to know when the file name ends. The |more_name| routine is a function
15795 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15796 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15797 returns |false|; or, it returns |true| and $c_n$ is the last character
15798 on the current input line. In other words,
15799 |more_name| is supposed to return |true| unless it is sure that the
15800 file name has been completely scanned; and |end_name| is supposed to be able
15801 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15802 whether $|more_name|(c_n)$ returned |true| or |false|.
15805 char * cur_name; /* name of file just scanned */
15806 char * cur_area; /* file area just scanned, or \.{""} */
15807 char * cur_ext; /* file extension just scanned, or \.{""} */
15809 @ It is easier to maintain reference counts if we assign initial values.
15812 mp->cur_name=xstrdup("");
15813 mp->cur_area=xstrdup("");
15814 mp->cur_ext=xstrdup("");
15816 @ @<Dealloc variables@>=
15817 xfree(mp->cur_area);
15818 xfree(mp->cur_name);
15819 xfree(mp->cur_ext);
15821 @ The file names we shall deal with for illustrative purposes have the
15822 following structure: If the name contains `\.>' or `\.:', the file area
15823 consists of all characters up to and including the final such character;
15824 otherwise the file area is null. If the remaining file name contains
15825 `\..', the file extension consists of all such characters from the first
15826 remaining `\..' to the end, otherwise the file extension is null.
15827 @^system dependencies@>
15829 We can scan such file names easily by using two global variables that keep track
15830 of the occurrences of area and extension delimiters. Note that these variables
15831 cannot be of type |pool_pointer| because a string pool compaction could occur
15832 while scanning a file name.
15835 integer area_delimiter;
15836 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15837 integer ext_delimiter; /* the relevant `\..', if any */
15839 @ Here now is the first of the system-dependent routines for file name scanning.
15840 @^system dependencies@>
15842 The file name length is limited to |file_name_size|. That is good, because
15843 in the current configuration we cannot call |mp_do_compaction| while a name
15844 is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct
15845 offsets into |mp->str_pool|. I am not in a great hurry to fix this, because
15846 calling |str_room()| just once is more efficient anyway. TODO.
15848 @<Declare subroutines for parsing file names@>=
15849 void mp_begin_name (MP mp) {
15850 xfree(mp->cur_name);
15851 xfree(mp->cur_area);
15852 xfree(mp->cur_ext);
15853 mp->area_delimiter=-1;
15854 mp->ext_delimiter=-1;
15855 str_room(file_name_size);
15858 @ And here's the second.
15859 @^system dependencies@>
15861 @<Declare subroutines for parsing file names@>=
15862 boolean mp_more_name (MP mp, ASCII_code c) {
15866 if ( (c=='>')||(c==':') ) {
15867 mp->area_delimiter=mp->pool_ptr;
15868 mp->ext_delimiter=-1;
15869 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15870 mp->ext_delimiter=mp->pool_ptr;
15872 append_char(c); /* contribute |c| to the current string */
15878 @^system dependencies@>
15880 @d copy_pool_segment(A,B,C) {
15881 A = xmalloc(C+1,sizeof(char));
15882 strncpy(A,(char *)(mp->str_pool+B),C);
15885 @<Declare subroutines for parsing file names@>=
15886 void mp_end_name (MP mp) {
15887 pool_pointer s; /* length of area, name, and extension */
15890 s = mp->str_start[mp->str_ptr];
15891 if ( mp->area_delimiter<0 ) {
15892 mp->cur_area=xstrdup("");
15894 len = mp->area_delimiter-s;
15895 copy_pool_segment(mp->cur_area,s,len);
15898 if ( mp->ext_delimiter<0 ) {
15899 mp->cur_ext=xstrdup("");
15900 len = mp->pool_ptr-s;
15902 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(mp->pool_ptr-mp->ext_delimiter));
15903 len = mp->ext_delimiter-s;
15905 copy_pool_segment(mp->cur_name,s,len);
15906 mp->pool_ptr=s; /* don't need this partial string */
15909 @ Conversely, here is a routine that takes three strings and prints a file
15910 name that might have produced them. (The routine is system dependent, because
15911 some operating systems put the file area last instead of first.)
15912 @^system dependencies@>
15914 @<Basic printing...@>=
15915 void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15916 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15919 @ Another system-dependent routine is needed to convert three internal
15921 to the |name_of_file| value that is used to open files. The present code
15922 allows both lowercase and uppercase letters in the file name.
15923 @^system dependencies@>
15925 @d append_to_name(A) { c=(A);
15926 if ( k<file_name_size ) {
15927 mp->name_of_file[k]=xchr(c);
15932 @<Declare subroutines for parsing file names@>=
15933 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
15934 integer k; /* number of positions filled in |name_of_file| */
15935 ASCII_code c; /* character being packed */
15936 const char *j; /* a character index */
15940 for (j=a;*j;j++) { append_to_name(*j); }
15942 for (j=n;*j;j++) { append_to_name(*j); }
15944 for (j=e;*j;j++) { append_to_name(*j); }
15946 mp->name_of_file[k]=0;
15950 @ @<Internal library declarations@>=
15951 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
15953 @ A messier routine is also needed, since mem file names must be scanned
15954 before \MP's string mechanism has been initialized. We shall use the
15955 global variable |MP_mem_default| to supply the text for default system areas
15956 and extensions related to mem files.
15957 @^system dependencies@>
15959 @d mem_default_length 9 /* length of the |MP_mem_default| string */
15960 @d mem_ext_length 4 /* length of its `\.{.mem}' part */
15961 @d mem_extension ".mem" /* the extension, as a \.{WEB} constant */
15964 char *MP_mem_default;
15966 @ @<Option variables@>=
15967 char *mem_name; /* for commandline */
15969 @ @<Allocate or initialize ...@>=
15970 mp->MP_mem_default = xstrdup("plain.mem");
15971 mp->mem_name = xstrdup(opt->mem_name);
15973 @^system dependencies@>
15975 @ @<Dealloc variables@>=
15976 xfree(mp->MP_mem_default);
15977 xfree(mp->mem_name);
15979 @ @<Check the ``constant'' values for consistency@>=
15980 if ( mem_default_length>file_name_size ) mp->bad=20;
15982 @ Here is the messy routine that was just mentioned. It sets |name_of_file|
15983 from the first |n| characters of |MP_mem_default|, followed by
15984 |buffer[a..b-1]|, followed by the last |mem_ext_length| characters of
15987 We dare not give error messages here, since \MP\ calls this routine before
15988 the |error| routine is ready to roll. Instead, we simply drop excess characters,
15989 since the error will be detected in another way when a strange file name
15991 @^system dependencies@>
15993 @c void mp_pack_buffered_name (MP mp,small_number n, integer a,
15995 integer k; /* number of positions filled in |name_of_file| */
15996 ASCII_code c; /* character being packed */
15997 integer j; /* index into |buffer| or |MP_mem_default| */
15998 if ( n+b-a+1+mem_ext_length>file_name_size )
15999 b=a+file_name_size-n-1-mem_ext_length;
16001 for (j=0;j<n;j++) {
16002 append_to_name(xord((int)mp->MP_mem_default[j]));
16004 for (j=a;j<b;j++) {
16005 append_to_name(mp->buffer[j]);
16007 for (j=mem_default_length-mem_ext_length;
16008 j<mem_default_length;j++) {
16009 append_to_name(xord((int)mp->MP_mem_default[j]));
16011 mp->name_of_file[k]=0;
16015 @ Here is the only place we use |pack_buffered_name|. This part of the program
16016 becomes active when a ``virgin'' \MP\ is trying to get going, just after
16017 the preliminary initialization, or when the user is substituting another
16018 mem file by typing `\.\&' after the initial `\.{**}' prompt. The buffer
16019 contains the first line of input in |buffer[loc..(last-1)]|, where
16020 |loc<last| and |buffer[loc]<>" "|.
16023 boolean mp_open_mem_file (MP mp) ;
16026 boolean mp_open_mem_file (MP mp) {
16027 int j; /* the first space after the file name */
16028 if (mp->mem_name!=NULL) {
16029 mp->mem_file = (mp->open_file)(mp,mp->mem_name, "r", mp_filetype_memfile);
16030 if ( mp->mem_file ) return true;
16033 if ( mp->buffer[loc]=='&' ) {
16034 incr(loc); j=loc; mp->buffer[mp->last]=' ';
16035 while ( mp->buffer[j]!=' ' ) incr(j);
16036 mp_pack_buffered_name(mp, 0,loc,j); /* try first without the system file area */
16037 if ( mp_w_open_in(mp, &mp->mem_file) ) goto FOUND;
16039 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
16040 @.Sorry, I can't find...@>
16043 /* now pull out all the stops: try for the system \.{plain} file */
16044 mp_pack_buffered_name(mp, mem_default_length-mem_ext_length,0,0);
16045 if ( ! mp_w_open_in(mp, &mp->mem_file) ) {
16047 wterm_ln("I can\'t find the PLAIN mem file!\n");
16048 @.I can't find PLAIN...@>
16053 loc=j; return true;
16056 @ Operating systems often make it possible to determine the exact name (and
16057 possible version number) of a file that has been opened. The following routine,
16058 which simply makes a \MP\ string from the value of |name_of_file|, should
16059 ideally be changed to deduce the full name of file~|f|, which is the file
16060 most recently opened, if it is possible to do this.
16061 @^system dependencies@>
16064 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
16065 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
16066 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
16069 str_number mp_make_name_string (MP mp) {
16070 int k; /* index into |name_of_file| */
16071 str_room(mp->name_length);
16072 for (k=0;k<mp->name_length;k++) {
16073 append_char(xord((int)mp->name_of_file[k]));
16075 return mp_make_string(mp);
16078 @ Now let's consider the ``driver''
16079 routines by which \MP\ deals with file names
16080 in a system-independent manner. First comes a procedure that looks for a
16081 file name in the input by taking the information from the input buffer.
16082 (We can't use |get_next|, because the conversion to tokens would
16083 destroy necessary information.)
16085 This procedure doesn't allow semicolons or percent signs to be part of
16086 file names, because of other conventions of \MP.
16087 {\sl The {\logos METAFONT\/}book} doesn't
16088 use semicolons or percents immediately after file names, but some users
16089 no doubt will find it natural to do so; therefore system-dependent
16090 changes to allow such characters in file names should probably
16091 be made with reluctance, and only when an entire file name that
16092 includes special characters is ``quoted'' somehow.
16093 @^system dependencies@>
16095 @c void mp_scan_file_name (MP mp) {
16097 while ( mp->buffer[loc]==' ' ) incr(loc);
16099 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
16100 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
16106 @ Here is another version that takes its input from a string.
16108 @<Declare subroutines for parsing file names@>=
16109 void mp_str_scan_file (MP mp, str_number s) {
16110 pool_pointer p,q; /* current position and stopping point */
16112 p=mp->str_start[s]; q=str_stop(s);
16114 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
16120 @ And one that reads from a |char*|.
16122 @<Declare subroutines for parsing file names@>=
16123 void mp_ptr_scan_file (MP mp, char *s) {
16124 char *p, *q; /* current position and stopping point */
16126 p=s; q=p+strlen(s);
16128 if ( ! mp_more_name(mp, *p)) break;
16135 @ The global variable |job_name| contains the file name that was first
16136 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
16137 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
16140 boolean log_opened; /* has the transcript file been opened? */
16141 char *log_name; /* full name of the log file */
16143 @ @<Option variables@>=
16144 char *job_name; /* principal file name */
16146 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
16147 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
16148 except of course for a short time just after |job_name| has become nonzero.
16150 @<Allocate or ...@>=
16151 mp->job_name=mp_xstrdup(mp, opt->job_name);
16152 mp->log_opened=false;
16154 @ @<Dealloc variables@>=
16155 xfree(mp->job_name);
16157 @ Here is a routine that manufactures the output file names, assuming that
16158 |job_name<>0|. It ignores and changes the current settings of |cur_area|
16161 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
16164 void mp_pack_job_name (MP mp, const char *s) ;
16167 void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
16168 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
16169 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16170 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
16174 @ If some trouble arises when \MP\ tries to open a file, the following
16175 routine calls upon the user to supply another file name. Parameter~|s|
16176 is used in the error message to identify the type of file; parameter~|e|
16177 is the default extension if none is given. Upon exit from the routine,
16178 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16179 ready for another attempt at file opening.
16182 void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
16184 @ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
16185 size_t k; /* index into |buffer| */
16186 char * saved_cur_name;
16187 if ( mp->interaction==mp_scroll_mode )
16189 if (strcmp(s,"input file name")==0) {
16190 print_err("I can\'t find file `");
16191 @.I can't find file x@>
16193 print_err("I can\'t write on file `");
16195 @.I can't write on file x@>
16196 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16197 mp_print(mp, "'.");
16198 if (strcmp(e,"")==0)
16199 mp_show_context(mp);
16200 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16202 if ( mp->interaction<mp_scroll_mode )
16203 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16204 @.job aborted, file error...@>
16205 saved_cur_name = xstrdup(mp->cur_name);
16206 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16207 if (strcmp(mp->cur_ext,"")==0)
16208 mp->cur_ext=xstrdup(e);
16209 if (strlen(mp->cur_name)==0) {
16210 mp->cur_name=saved_cur_name;
16212 xfree(saved_cur_name);
16217 @ @<Scan file name in the buffer@>=
16219 mp_begin_name(mp); k=mp->first;
16220 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16222 if ( k==mp->last ) break;
16223 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16229 @ The |open_log_file| routine is used to open the transcript file and to help
16230 it catch up to what has previously been printed on the terminal.
16232 @c void mp_open_log_file (MP mp) {
16233 int old_setting; /* previous |selector| setting */
16234 int k; /* index into |months| and |buffer| */
16235 int l; /* end of first input line */
16236 integer m; /* the current month */
16237 const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16238 /* abbreviations of month names */
16239 old_setting=mp->selector;
16240 if ( mp->job_name==NULL ) {
16241 mp->job_name=xstrdup("mpout");
16243 mp_pack_job_name(mp,".log");
16244 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16245 @<Try to get a different log file name@>;
16247 mp->log_name=xstrdup(mp->name_of_file);
16248 mp->selector=log_only; mp->log_opened=true;
16249 @<Print the banner line, including the date and time@>;
16250 mp->input_stack[mp->input_ptr]=mp->cur_input;
16251 /* make sure bottom level is in memory */
16253 if (!mp->noninteractive) {
16254 mp_print_nl(mp, "**");
16255 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16256 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16257 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16259 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16262 @ @<Dealloc variables@>=
16263 xfree(mp->log_name);
16265 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16266 unable to print error messages or even to |show_context|.
16267 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16268 routine will not be invoked because |log_opened| will be false.
16270 The normal idea of |mp_batch_mode| is that nothing at all should be written
16271 on the terminal. However, in the unusual case that
16272 no log file could be opened, we make an exception and allow
16273 an explanatory message to be seen.
16275 Incidentally, the program always refers to the log file as a `\.{transcript
16276 file}', because some systems cannot use the extension `\.{.log}' for
16279 @<Try to get a different log file name@>=
16281 mp->selector=term_only;
16282 mp_prompt_file_name(mp, "transcript file name",".log");
16285 @ @<Print the banner...@>=
16288 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16289 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16290 mp_print_char(mp, ' ');
16291 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16292 for (k=3*m-3;k<3*m;k++) { wlog_chr(months[k]); }
16293 mp_print_char(mp, ' ');
16294 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16295 mp_print_char(mp, ' ');
16296 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16297 mp_print_dd(mp, m / 60); mp_print_char(mp, ':'); mp_print_dd(mp, m % 60);
16300 @ The |try_extension| function tries to open an input file determined by
16301 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16302 can't find the file in |cur_area| or the appropriate system area.
16304 @c boolean mp_try_extension (MP mp, const char *ext) {
16305 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16306 in_name=xstrdup(mp->cur_name);
16307 in_area=xstrdup(mp->cur_area);
16308 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16311 mp_pack_file_name(mp, mp->cur_name,NULL,ext);
16312 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16316 @ Let's turn now to the procedure that is used to initiate file reading
16317 when an `\.{input}' command is being processed.
16319 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16320 char *fname = NULL;
16321 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16323 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16324 if ( strlen(mp->cur_ext)==0 ) {
16325 if ( mp_try_extension(mp, ".mp") ) break;
16326 else if ( mp_try_extension(mp, "") ) break;
16327 else if ( mp_try_extension(mp, ".mf") ) break;
16328 /* |else do_nothing; | */
16329 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16332 mp_end_file_reading(mp); /* remove the level that didn't work */
16333 mp_prompt_file_name(mp, "input file name","");
16335 name=mp_a_make_name_string(mp, cur_file);
16336 fname = xstrdup(mp->name_of_file);
16337 if ( mp->job_name==NULL ) {
16338 mp->job_name=xstrdup(mp->cur_name);
16339 mp_open_log_file(mp);
16340 } /* |open_log_file| doesn't |show_context|, so |limit|
16341 and |loc| needn't be set to meaningful values yet */
16342 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16343 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
16344 mp_print_char(mp, '('); incr(mp->open_parens); mp_print(mp, fname);
16347 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16348 @<Read the first line of the new file@>;
16351 @ This code should be omitted if |a_make_name_string| returns something other
16352 than just a copy of its argument and the full file name is needed for opening
16353 \.{MPX} files or implementing the switch-to-editor option.
16354 @^system dependencies@>
16356 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16357 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16359 @ If the file is empty, it is considered to contain a single blank line,
16360 so there is no need to test the return value.
16362 @<Read the first line...@>=
16365 (void)mp_input_ln(mp, cur_file );
16366 mp_firm_up_the_line(mp);
16367 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
16370 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16371 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16372 if ( token_state ) {
16373 print_err("File names can't appear within macros");
16374 @.File names can't...@>
16375 help3("Sorry...I've converted what follows to tokens,")
16376 ("possibly garbaging the name you gave.")
16377 ("Please delete the tokens and insert the name again.");
16380 if ( file_state ) {
16381 mp_scan_file_name(mp);
16383 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16384 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16385 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16388 @ The following simple routine starts reading the \.{MPX} file associated
16389 with the current input file.
16391 @c void mp_start_mpx_input (MP mp) {
16392 char *origname = NULL; /* a copy of nameoffile */
16393 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16394 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16395 |goto not_found| if there is a problem@>;
16396 mp_begin_file_reading(mp);
16397 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16398 mp_end_file_reading(mp);
16401 name=mp_a_make_name_string(mp, cur_file);
16402 mp->mpx_name[index]=name; add_str_ref(name);
16403 @<Read the first line of the new file@>;
16406 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16410 @ This should ideally be changed to do whatever is necessary to create the
16411 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16412 of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
16413 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16414 completely different typesetting program if suitable postprocessor is
16415 available to perform the function of \.{DVItoMP}.)
16416 @^system dependencies@>
16418 @ @<Exported types@>=
16419 typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
16421 @ @<Option variables@>=
16422 mp_run_make_mpx_command run_make_mpx;
16424 @ @<Allocate or initialize ...@>=
16425 set_callback_option(run_make_mpx);
16427 @ @<Internal library declarations@>=
16428 int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16430 @ The default does nothing.
16432 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16439 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16440 |goto not_found| if there is a problem@>=
16441 origname = mp_xstrdup(mp,mp->name_of_file);
16442 *(origname+strlen(origname)-1)=0; /* drop the x */
16443 if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
16446 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16447 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16448 mp_print_nl(mp, ">> ");
16449 mp_print(mp, origname);
16450 mp_print_nl(mp, ">> ");
16451 mp_print(mp, mp->name_of_file);
16452 mp_print_nl(mp, "! Unable to make mpx file");
16453 help4("The two files given above are one of your source files")
16454 ("and an auxiliary file I need to read to find out what your")
16455 ("btex..etex blocks mean. If you don't know why I had trouble,")
16456 ("try running it manually through MPtoTeX, TeX, and DVItoMP");
16459 @ The last file-opening commands are for files accessed via the \&{readfrom}
16460 @:read_from_}{\&{readfrom} primitive@>
16461 operator and the \&{write} command. Such files are stored in separate arrays.
16462 @:write_}{\&{write} primitive@>
16464 @<Types in the outer block@>=
16465 typedef unsigned int readf_index; /* |0..max_read_files| */
16466 typedef unsigned int write_index; /* |0..max_write_files| */
16469 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16470 void ** rd_file; /* \&{readfrom} files */
16471 char ** rd_fname; /* corresponding file name or 0 if file not open */
16472 readf_index read_files; /* number of valid entries in the above arrays */
16473 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16474 void ** wr_file; /* \&{write} files */
16475 char ** wr_fname; /* corresponding file name or 0 if file not open */
16476 write_index write_files; /* number of valid entries in the above arrays */
16478 @ @<Allocate or initialize ...@>=
16479 mp->max_read_files=8;
16480 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
16481 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16482 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16484 mp->max_write_files=8;
16485 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
16486 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16487 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16491 @ This routine starts reading the file named by string~|s| without setting
16492 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16493 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16495 @c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16496 mp_ptr_scan_file(mp, s);
16498 mp_begin_file_reading(mp);
16499 if ( ! mp_a_open_in(mp, &mp->rd_file[n], (mp_filetype_text+n)) )
16501 if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
16502 (mp->close_file)(mp,mp->rd_file[n]);
16505 mp->rd_fname[n]=xstrdup(mp->name_of_file);
16508 mp_end_file_reading(mp);
16512 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16515 void mp_open_write_file (MP mp, char *s, readf_index n) ;
16517 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16518 mp_ptr_scan_file(mp, s);
16520 while ( ! mp_a_open_out(mp, &mp->wr_file[n], (mp_filetype_text+n)) )
16521 mp_prompt_file_name(mp, "file name for write output","");
16522 mp->wr_fname[n]=xstrdup(mp->name_of_file);
16526 @* \[36] Introduction to the parsing routines.
16527 We come now to the central nervous system that sparks many of \MP's activities.
16528 By evaluating expressions, from their primary constituents to ever larger
16529 subexpressions, \MP\ builds the structures that ultimately define complete
16530 pictures or fonts of type.
16532 Four mutually recursive subroutines are involved in this process: We call them
16533 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16534 and |scan_expression|.}$$
16536 Each of them is parameterless and begins with the first token to be scanned
16537 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16538 the value of the primary or secondary or tertiary or expression that was
16539 found will appear in the global variables |cur_type| and |cur_exp|. The
16540 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16543 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16544 backup mechanisms have been added in order to provide reasonable error
16548 small_number cur_type; /* the type of the expression just found */
16549 integer cur_exp; /* the value of the expression just found */
16554 @ Many different kinds of expressions are possible, so it is wise to have
16555 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16558 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16559 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16560 construction in which there was no expression before the \&{endgroup}.
16561 In this case |cur_exp| has some irrelevant value.
16564 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16568 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16570 a ring of equivalent booleans whose value has not yet been defined.
16573 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16574 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16575 includes this particular reference.
16578 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16580 a ring of equivalent strings whose value has not yet been defined.
16583 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16584 else points to any of the nodes in this pen. The pen may be polygonal or
16588 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16590 a ring of equivalent pens whose value has not yet been defined.
16593 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16594 a path; nobody else points to this particular path. The control points of
16595 the path will have been chosen.
16598 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16600 a ring of equivalent paths whose value has not yet been defined.
16603 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16604 There may be other pointers to this particular set of edges. The header node
16605 contains a reference count that includes this particular reference.
16608 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16610 a ring of equivalent pictures whose value has not yet been defined.
16613 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16614 capsule node. The |value| part of this capsule
16615 points to a transform node that contains six numeric values,
16616 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16619 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16620 capsule node. The |value| part of this capsule
16621 points to a color node that contains three numeric values,
16622 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16625 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16626 capsule node. The |value| part of this capsule
16627 points to a color node that contains four numeric values,
16628 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16631 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16632 node whose type is |mp_pair_type|. The |value| part of this capsule
16633 points to a pair node that contains two numeric values,
16634 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16637 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16640 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16641 is |dependent|. The |dep_list| field in this capsule points to the associated
16645 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16646 capsule node. The |dep_list| field in this capsule
16647 points to the associated dependency list.
16650 |cur_type=independent| means that |cur_exp| points to a capsule node
16651 whose type is |independent|. This somewhat unusual case can arise, for
16652 example, in the expression
16653 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16656 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16659 \smallskip\noindent
16660 The possible settings of |cur_type| have been listed here in increasing
16661 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16662 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16663 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16666 @ Capsules are two-word nodes that have a similar meaning
16667 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
16668 and their |type| field is one of the possibilities for |cur_type| listed above.
16669 Also |link<=void| in capsules that aren't part of a token list.
16671 The |value| field of a capsule is, in most cases, the value that
16672 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16673 However, when |cur_exp| would point to a capsule,
16674 no extra layer of indirection is present; the |value|
16675 field is what would have been called |value(cur_exp)| if it had not been
16676 encapsulated. Furthermore, if the type is |dependent| or
16677 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16678 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16679 always part of the general |dep_list| structure.
16681 The |get_x_next| routine is careful not to change the values of |cur_type|
16682 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16683 call a macro, which might parse an expression, which might execute lots of
16684 commands in a group; hence it's possible that |cur_type| might change
16685 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16686 |known| or |independent|, during the time |get_x_next| is called. The
16687 programs below are careful to stash sensitive intermediate results in
16688 capsules, so that \MP's generality doesn't cause trouble.
16690 Here's a procedure that illustrates these conventions. It takes
16691 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16692 and stashes them away in a
16693 capsule. It is not used when |cur_type=mp_token_list|.
16694 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16695 copy path lists or to update reference counts, etc.
16697 The special link |mp_void| is put on the capsule returned by
16698 |stash_cur_exp|, because this procedure is used to store macro parameters
16699 that must be easily distinguishable from token lists.
16701 @<Declare the stashing/unstashing routines@>=
16702 pointer mp_stash_cur_exp (MP mp) {
16703 pointer p; /* the capsule that will be returned */
16704 switch (mp->cur_type) {
16705 case unknown_types:
16706 case mp_transform_type:
16707 case mp_color_type:
16710 case mp_proto_dependent:
16711 case mp_independent:
16712 case mp_cmykcolor_type:
16716 p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
16717 type(p)=mp->cur_type; value(p)=mp->cur_exp;
16720 mp->cur_type=mp_vacuous; link(p)=mp_void;
16724 @ The inverse of |stash_cur_exp| is the following procedure, which
16725 deletes an unnecessary capsule and puts its contents into |cur_type|
16728 The program steps of \MP\ can be divided into two categories: those in
16729 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16730 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16731 information or not. It's important not to ignore them when they're alive,
16732 and it's important not to pay attention to them when they're dead.
16734 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16735 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16736 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16737 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16738 only when they are alive or dormant.
16740 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16741 are alive or dormant. The \\{unstash} procedure assumes that they are
16742 dead or dormant; it resuscitates them.
16744 @<Declare the stashing/unstashing...@>=
16745 void mp_unstash_cur_exp (MP mp,pointer p) ;
16748 void mp_unstash_cur_exp (MP mp,pointer p) {
16749 mp->cur_type=type(p);
16750 switch (mp->cur_type) {
16751 case unknown_types:
16752 case mp_transform_type:
16753 case mp_color_type:
16756 case mp_proto_dependent:
16757 case mp_independent:
16758 case mp_cmykcolor_type:
16762 mp->cur_exp=value(p);
16763 mp_free_node(mp, p,value_node_size);
16768 @ The following procedure prints the values of expressions in an
16769 abbreviated format. If its first parameter |p| is null, the value of
16770 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16771 containing the desired value. The second parameter controls the amount of
16772 output. If it is~0, dependency lists will be abbreviated to
16773 `\.{linearform}' unless they consist of a single term. If it is greater
16774 than~1, complicated structures (pens, pictures, and paths) will be displayed
16778 @<Declare subroutines for printing expressions@>=
16779 @<Declare the procedure called |print_dp|@>
16780 @<Declare the stashing/unstashing routines@>
16781 void mp_print_exp (MP mp,pointer p, small_number verbosity) {
16782 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16783 small_number t; /* the type of the expression */
16784 pointer q; /* a big node being displayed */
16785 integer v=0; /* the value of the expression */
16787 restore_cur_exp=false;
16789 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16792 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16793 @<Print an abbreviated value of |v| with format depending on |t|@>;
16794 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16797 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16799 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16800 case mp_boolean_type:
16801 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16803 case unknown_types: case mp_numeric_type:
16804 @<Display a variable that's been declared but not defined@>;
16806 case mp_string_type:
16807 mp_print_char(mp, '"'); mp_print_str(mp, v); mp_print_char(mp, '"');
16809 case mp_pen_type: case mp_path_type: case mp_picture_type:
16810 @<Display a complex type@>;
16812 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16813 if ( v==null ) mp_print_type(mp, t);
16814 else @<Display a big node@>;
16816 case mp_known:mp_print_scaled(mp, v); break;
16817 case mp_dependent: case mp_proto_dependent:
16818 mp_print_dp(mp, t,v,verbosity);
16820 case mp_independent:mp_print_variable_name(mp, p); break;
16821 default: mp_confusion(mp, "exp"); break;
16822 @:this can't happen exp}{\quad exp@>
16825 @ @<Display a big node@>=
16827 mp_print_char(mp, '('); q=v+mp->big_node_size[t];
16829 if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
16830 else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
16831 else mp_print_dp(mp, type(v),dep_list(v),verbosity);
16833 if ( v!=q ) mp_print_char(mp, ',');
16835 mp_print_char(mp, ')');
16838 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16839 in the log file only, unless the user has given a positive value to
16842 @<Display a complex type@>=
16843 if ( verbosity<=1 ) {
16844 mp_print_type(mp, t);
16846 if ( mp->selector==term_and_log )
16847 if ( mp->internal[mp_tracing_online]<=0 ) {
16848 mp->selector=term_only;
16849 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16850 mp->selector=term_and_log;
16853 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16854 case mp_path_type:mp_print_path(mp, v,"",false); break;
16855 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16856 } /* there are no other cases */
16859 @ @<Declare the procedure called |print_dp|@>=
16860 void mp_print_dp (MP mp,small_number t, pointer p,
16861 small_number verbosity) {
16862 pointer q; /* the node following |p| */
16864 if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16865 else mp_print(mp, "linearform");
16868 @ The displayed name of a variable in a ring will not be a capsule unless
16869 the ring consists entirely of capsules.
16871 @<Display a variable that's been declared but not defined@>=
16872 { mp_print_type(mp, t);
16874 { mp_print_char(mp, ' ');
16875 while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16876 mp_print_variable_name(mp, v);
16880 @ When errors are detected during parsing, it is often helpful to
16881 display an expression just above the error message, using |exp_err|
16882 or |disp_err| instead of |print_err|.
16884 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16886 @<Declare subroutines for printing expressions@>=
16887 void mp_disp_err (MP mp,pointer p, const char *s) {
16888 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16889 mp_print_nl(mp, ">> ");
16891 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16893 mp_print_nl(mp, "! "); mp_print(mp, s);
16898 @ If |cur_type| and |cur_exp| contain relevant information that should
16899 be recycled, we will use the following procedure, which changes |cur_type|
16900 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16901 and |cur_exp| as either alive or dormant after this has been done,
16902 because |cur_exp| will not contain a pointer value.
16904 @ @c void mp_flush_cur_exp (MP mp,scaled v) {
16905 switch (mp->cur_type) {
16906 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16907 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16908 mp_recycle_value(mp, mp->cur_exp);
16909 mp_free_node(mp, mp->cur_exp,value_node_size);
16911 case mp_string_type:
16912 delete_str_ref(mp->cur_exp); break;
16913 case mp_pen_type: case mp_path_type:
16914 mp_toss_knot_list(mp, mp->cur_exp); break;
16915 case mp_picture_type:
16916 delete_edge_ref(mp->cur_exp); break;
16920 mp->cur_type=mp_known; mp->cur_exp=v;
16923 @ There's a much more general procedure that is capable of releasing
16924 the storage associated with any two-word value packet.
16926 @<Declare the recycling subroutines@>=
16927 void mp_recycle_value (MP mp,pointer p) ;
16929 @ @c void mp_recycle_value (MP mp,pointer p) {
16930 small_number t; /* a type code */
16931 integer vv; /* another value */
16932 pointer q,r,s,pp; /* link manipulation registers */
16933 integer v=0; /* a value */
16935 if ( t<mp_dependent ) v=value(p);
16937 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
16938 case mp_numeric_type:
16940 case unknown_types:
16941 mp_ring_delete(mp, p); break;
16942 case mp_string_type:
16943 delete_str_ref(v); break;
16944 case mp_path_type: case mp_pen_type:
16945 mp_toss_knot_list(mp, v); break;
16946 case mp_picture_type:
16947 delete_edge_ref(v); break;
16948 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
16949 case mp_transform_type:
16950 @<Recycle a big node@>; break;
16951 case mp_dependent: case mp_proto_dependent:
16952 @<Recycle a dependency list@>; break;
16953 case mp_independent:
16954 @<Recycle an independent variable@>; break;
16955 case mp_token_list: case mp_structured:
16956 mp_confusion(mp, "recycle"); break;
16957 @:this can't happen recycle}{\quad recycle@>
16958 case mp_unsuffixed_macro: case mp_suffixed_macro:
16959 mp_delete_mac_ref(mp, value(p)); break;
16960 } /* there are no other cases */
16964 @ @<Recycle a big node@>=
16966 q=v+mp->big_node_size[t];
16968 q=q-2; mp_recycle_value(mp, q);
16970 mp_free_node(mp, v,mp->big_node_size[t]);
16973 @ @<Recycle a dependency list@>=
16976 while ( info(q)!=null ) q=link(q);
16977 link(prev_dep(p))=link(q);
16978 prev_dep(link(q))=prev_dep(p);
16979 link(q)=null; mp_flush_node_list(mp, dep_list(p));
16982 @ When an independent variable disappears, it simply fades away, unless
16983 something depends on it. In the latter case, a dependent variable whose
16984 coefficient of dependence is maximal will take its place.
16985 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
16986 as part of his Ph.D. thesis (Stanford University, December 1982).
16987 @^Zabala Salelles, Ignacio Andr\'es@>
16989 For example, suppose that variable $x$ is being recycled, and that the
16990 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
16991 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
16992 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
16993 we will print `\.{\#\#\# -2x=-y+a}'.
16995 There's a slight complication, however: An independent variable $x$
16996 can occur both in dependency lists and in proto-dependency lists.
16997 This makes it necessary to be careful when deciding which coefficient
17000 Furthermore, this complication is not so slight when
17001 a proto-dependent variable is chosen to become independent. For example,
17002 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
17003 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
17004 large coefficient `50'.
17006 In order to deal with these complications without wasting too much time,
17007 we shall link together the occurrences of~$x$ among all the linear
17008 dependencies, maintaining separate lists for the dependent and
17009 proto-dependent cases.
17011 @<Recycle an independent variable@>=
17013 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
17014 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
17016 while ( q!=dep_head ) {
17017 s=value_loc(q); /* now |link(s)=dep_list(q)| */
17020 if ( info(r)==null ) break;
17021 if ( info(r)!=p ) {
17024 t=type(q); link(s)=link(r); info(r)=q;
17025 if ( abs(value(r))>mp->max_c[t] ) {
17026 @<Record a new maximum coefficient of type |t|@>;
17028 link(r)=mp->max_link[t]; mp->max_link[t]=r;
17034 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
17035 @<Choose a dependent variable to take the place of the disappearing
17036 independent variable, and change all remaining dependencies
17041 @ The code for independency removal makes use of three two-word arrays.
17044 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
17045 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
17046 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
17048 @ @<Record a new maximum coefficient...@>=
17050 if ( mp->max_c[t]>0 ) {
17051 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17053 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
17056 @ @<Choose a dependent...@>=
17058 if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
17061 t=mp_proto_dependent;
17062 @<Determine the dependency list |s| to substitute for the independent
17064 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
17065 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
17066 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17068 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
17069 else { @<Substitute new proto-dependencies in place of |p|@>;}
17070 mp_flush_node_list(mp, s);
17071 if ( mp->fix_needed ) mp_fix_dependencies(mp);
17075 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
17076 and |info(s)| points to the dependent variable~|pp| of type~|t| from
17077 whose dependency list we have removed node~|s|. We must reinsert
17078 node~|s| into the dependency list, with coefficient $-1.0$, and with
17079 |pp| as the new independent variable. Since |pp| will have a larger serial
17080 number than any other variable, we can put node |s| at the head of the
17083 @<Determine the dep...@>=
17084 s=mp->max_ptr[t]; pp=info(s); v=value(s);
17085 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
17086 r=dep_list(pp); link(s)=r;
17087 while ( info(r)!=null ) r=link(r);
17088 q=link(r); link(r)=null;
17089 prev_dep(q)=prev_dep(pp); link(prev_dep(pp))=q;
17091 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
17092 if ( mp->internal[mp_tracing_equations]>0 ) {
17093 @<Show the transformed dependency@>;
17096 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
17097 by the dependency list~|s|.
17099 @<Show the transformed...@>=
17100 if ( mp_interesting(mp, p) ) {
17101 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
17102 @:]]]\#\#\#_}{\.{\#\#\#}@>
17103 if ( v>0 ) mp_print_char(mp, '-');
17104 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
17105 else vv=mp->max_c[mp_proto_dependent];
17106 if ( vv!=unity ) mp_print_scaled(mp, vv);
17107 mp_print_variable_name(mp, p);
17108 while ( value(p) % s_scale>0 ) {
17109 mp_print(mp, "*4"); value(p)=value(p)-2;
17111 if ( t==mp_dependent ) mp_print_char(mp, '='); else mp_print(mp, " = ");
17112 mp_print_dependency(mp, s,t);
17113 mp_end_diagnostic(mp, false);
17116 @ Finally, there are dependent and proto-dependent variables whose
17117 dependency lists must be brought up to date.
17119 @<Substitute new dependencies...@>=
17120 for (t=mp_dependent;t<=mp_proto_dependent;t++){
17122 while ( r!=null ) {
17124 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17125 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
17126 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
17127 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17131 @ @<Substitute new proto...@>=
17132 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
17134 while ( r!=null ) {
17136 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
17137 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
17138 mp->cur_type=mp_proto_dependent;
17139 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
17140 mp_dependent,mp_proto_dependent);
17141 type(q)=mp_proto_dependent;
17142 value(r)=mp_round_fraction(mp, value(r));
17144 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17145 mp_make_scaled(mp, value(r),-v),s,
17146 mp_proto_dependent,mp_proto_dependent);
17147 if ( dep_list(q)==mp->dep_final )
17148 mp_make_known(mp, q,mp->dep_final);
17149 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17153 @ Here are some routines that provide handy combinations of actions
17154 that are often needed during error recovery. For example,
17155 `|flush_error|' flushes the current expression, replaces it by
17156 a given value, and calls |error|.
17158 Errors often are detected after an extra token has already been scanned.
17159 The `\\{put\_get}' routines put that token back before calling |error|;
17160 then they get it back again. (Or perhaps they get another token, if
17161 the user has changed things.)
17164 void mp_flush_error (MP mp,scaled v);
17165 void mp_put_get_error (MP mp);
17166 void mp_put_get_flush_error (MP mp,scaled v) ;
17169 void mp_flush_error (MP mp,scaled v) {
17170 mp_error(mp); mp_flush_cur_exp(mp, v);
17172 void mp_put_get_error (MP mp) {
17173 mp_back_error(mp); mp_get_x_next(mp);
17175 void mp_put_get_flush_error (MP mp,scaled v) {
17176 mp_put_get_error(mp);
17177 mp_flush_cur_exp(mp, v);
17180 @ A global variable |var_flag| is set to a special command code
17181 just before \MP\ calls |scan_expression|, if the expression should be
17182 treated as a variable when this command code immediately follows. For
17183 example, |var_flag| is set to |assignment| at the beginning of a
17184 statement, because we want to know the {\sl location\/} of a variable at
17185 the left of `\.{:=}', not the {\sl value\/} of that variable.
17187 The |scan_expression| subroutine calls |scan_tertiary|,
17188 which calls |scan_secondary|, which calls |scan_primary|, which sets
17189 |var_flag:=0|. In this way each of the scanning routines ``knows''
17190 when it has been called with a special |var_flag|, but |var_flag| is
17193 A variable preceding a command that equals |var_flag| is converted to a
17194 token list rather than a value. Furthermore, an `\.{=}' sign following an
17195 expression with |var_flag=assignment| is not considered to be a relation
17196 that produces boolean expressions.
17200 int var_flag; /* command that wants a variable */
17205 @* \[37] Parsing primary expressions.
17206 The first parsing routine, |scan_primary|, is also the most complicated one,
17207 since it involves so many different cases. But each case---with one
17208 exception---is fairly simple by itself.
17210 When |scan_primary| begins, the first token of the primary to be scanned
17211 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17212 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17213 earlier. If |cur_cmd| is not between |min_primary_command| and
17214 |max_primary_command|, inclusive, a syntax error will be signaled.
17216 @<Declare the basic parsing subroutines@>=
17217 void mp_scan_primary (MP mp) {
17218 pointer p,q,r; /* for list manipulation */
17219 quarterword c; /* a primitive operation code */
17220 int my_var_flag; /* initial value of |my_var_flag| */
17221 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17222 @<Other local variables for |scan_primary|@>;
17223 my_var_flag=mp->var_flag; mp->var_flag=0;
17226 @<Supply diagnostic information, if requested@>;
17227 switch (mp->cur_cmd) {
17228 case left_delimiter:
17229 @<Scan a delimited primary@>; break;
17231 @<Scan a grouped primary@>; break;
17233 @<Scan a string constant@>; break;
17234 case numeric_token:
17235 @<Scan a primary that starts with a numeric token@>; break;
17237 @<Scan a nullary operation@>; break;
17238 case unary: case type_name: case cycle: case plus_or_minus:
17239 @<Scan a unary operation@>; break;
17240 case primary_binary:
17241 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17243 @<Convert a suffix to a string@>; break;
17244 case internal_quantity:
17245 @<Scan an internal numeric quantity@>; break;
17246 case capsule_token:
17247 mp_make_exp_copy(mp, mp->cur_mod); break;
17249 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17251 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17252 @.A primary expression...@>
17254 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17256 if ( mp->cur_cmd==left_bracket ) {
17257 if ( mp->cur_type>=mp_known ) {
17258 @<Scan a mediation construction@>;
17265 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17267 @c void mp_bad_exp (MP mp, const char * s) {
17269 print_err(s); mp_print(mp, " expression can't begin with `");
17270 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17271 mp_print_char(mp, '\'');
17272 help4("I'm afraid I need some sort of value in order to continue,")
17273 ("so I've tentatively inserted `0'. You may want to")
17274 ("delete this zero and insert something else;")
17275 ("see Chapter 27 of The METAFONTbook for an example.");
17276 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17277 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17278 mp->cur_mod=0; mp_ins_error(mp);
17279 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17280 mp->var_flag=save_flag;
17283 @ @<Supply diagnostic information, if requested@>=
17285 if ( mp->panicking ) mp_check_mem(mp, false);
17287 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17288 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17291 @ @<Scan a delimited primary@>=
17293 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17294 mp_get_x_next(mp); mp_scan_expression(mp);
17295 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17296 @<Scan the rest of a delimited set of numerics@>;
17298 mp_check_delimiter(mp, l_delim,r_delim);
17302 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17303 within a ``big node.''
17305 @c void mp_stash_in (MP mp,pointer p) {
17306 pointer q; /* temporary register */
17307 type(p)=mp->cur_type;
17308 if ( mp->cur_type==mp_known ) {
17309 value(p)=mp->cur_exp;
17311 if ( mp->cur_type==mp_independent ) {
17312 @<Stash an independent |cur_exp| into a big node@>;
17314 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17315 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17316 link(prev_dep(p))=p;
17318 mp_free_node(mp, mp->cur_exp,value_node_size);
17320 mp->cur_type=mp_vacuous;
17323 @ In rare cases the current expression can become |independent|. There
17324 may be many dependency lists pointing to such an independent capsule,
17325 so we can't simply move it into place within a big node. Instead,
17326 we copy it, then recycle it.
17328 @ @<Stash an independent |cur_exp|...@>=
17330 q=mp_single_dependency(mp, mp->cur_exp);
17331 if ( q==mp->dep_final ){
17332 type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17334 type(p)=mp_dependent; mp_new_dep(mp, p,q);
17336 mp_recycle_value(mp, mp->cur_exp);
17339 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17340 are synonymous with |x_part_loc| and |y_part_loc|.
17342 @<Scan the rest of a delimited set of numerics@>=
17344 p=mp_stash_cur_exp(mp);
17345 mp_get_x_next(mp); mp_scan_expression(mp);
17346 @<Make sure the second part of a pair or color has a numeric type@>;
17347 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
17348 if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
17349 else type(q)=mp_pair_type;
17350 mp_init_big_node(mp, q); r=value(q);
17351 mp_stash_in(mp, y_part_loc(r));
17352 mp_unstash_cur_exp(mp, p);
17353 mp_stash_in(mp, x_part_loc(r));
17354 if ( mp->cur_cmd==comma ) {
17355 @<Scan the last of a triplet of numerics@>;
17357 if ( mp->cur_cmd==comma ) {
17358 type(q)=mp_cmykcolor_type;
17359 mp_init_big_node(mp, q); t=value(q);
17360 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17361 value(cyan_part_loc(t))=value(red_part_loc(r));
17362 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17363 value(magenta_part_loc(t))=value(green_part_loc(r));
17364 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17365 value(yellow_part_loc(t))=value(blue_part_loc(r));
17366 mp_recycle_value(mp, r);
17368 @<Scan the last of a quartet of numerics@>;
17370 mp_check_delimiter(mp, l_delim,r_delim);
17371 mp->cur_type=type(q);
17375 @ @<Make sure the second part of a pair or color has a numeric type@>=
17376 if ( mp->cur_type<mp_known ) {
17377 exp_err("Nonnumeric ypart has been replaced by 0");
17378 @.Nonnumeric...replaced by 0@>
17379 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';")
17380 ("but after finding a nice `a' I found a `b' that isn't")
17381 ("of numeric type. So I've changed that part to zero.")
17382 ("(The b that I didn't like appears above the error message.)");
17383 mp_put_get_flush_error(mp, 0);
17386 @ @<Scan the last of a triplet of numerics@>=
17388 mp_get_x_next(mp); mp_scan_expression(mp);
17389 if ( mp->cur_type<mp_known ) {
17390 exp_err("Nonnumeric third part has been replaced by 0");
17391 @.Nonnumeric...replaced by 0@>
17392 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'")
17393 ("isn't of numeric type. So I've changed that part to zero.")
17394 ("(The c that I didn't like appears above the error message.)");
17395 mp_put_get_flush_error(mp, 0);
17397 mp_stash_in(mp, blue_part_loc(r));
17400 @ @<Scan the last of a quartet of numerics@>=
17402 mp_get_x_next(mp); mp_scan_expression(mp);
17403 if ( mp->cur_type<mp_known ) {
17404 exp_err("Nonnumeric blackpart has been replaced by 0");
17405 @.Nonnumeric...replaced by 0@>
17406 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")
17407 ("of numeric type. So I've changed that part to zero.")
17408 ("(The k that I didn't like appears above the error message.)");
17409 mp_put_get_flush_error(mp, 0);
17411 mp_stash_in(mp, black_part_loc(r));
17414 @ The local variable |group_line| keeps track of the line
17415 where a \&{begingroup} command occurred; this will be useful
17416 in an error message if the group doesn't actually end.
17418 @<Other local variables for |scan_primary|@>=
17419 integer group_line; /* where a group began */
17421 @ @<Scan a grouped primary@>=
17423 group_line=mp_true_line(mp);
17424 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17425 save_boundary_item(p);
17427 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17428 } while (mp->cur_cmd==semicolon);
17429 if ( mp->cur_cmd!=end_group ) {
17430 print_err("A group begun on line ");
17431 @.A group...never ended@>
17432 mp_print_int(mp, group_line);
17433 mp_print(mp, " never ended");
17434 help2("I saw a `begingroup' back there that hasn't been matched")
17435 ("by `endgroup'. So I've inserted `endgroup' now.");
17436 mp_back_error(mp); mp->cur_cmd=end_group;
17439 /* this might change |cur_type|, if independent variables are recycled */
17440 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17443 @ @<Scan a string constant@>=
17445 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17448 @ Later we'll come to procedures that perform actual operations like
17449 addition, square root, and so on; our purpose now is to do the parsing.
17450 But we might as well mention those future procedures now, so that the
17451 suspense won't be too bad:
17454 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17455 `\&{true}' or `\&{pencircle}');
17458 |do_unary(c)| applies a primitive operation to the current expression;
17461 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17462 and the current expression.
17464 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17466 @ @<Scan a unary operation@>=
17468 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17469 mp_do_unary(mp, c); goto DONE;
17472 @ A numeric token might be a primary by itself, or it might be the
17473 numerator of a fraction composed solely of numeric tokens, or it might
17474 multiply the primary that follows (provided that the primary doesn't begin
17475 with a plus sign or a minus sign). The code here uses the facts that
17476 |max_primary_command=plus_or_minus| and
17477 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17478 than unity, we try to retain higher precision when we use it in scalar
17481 @<Other local variables for |scan_primary|@>=
17482 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17484 @ @<Scan a primary that starts with a numeric token@>=
17486 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17487 if ( mp->cur_cmd!=slash ) {
17491 if ( mp->cur_cmd!=numeric_token ) {
17493 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17496 num=mp->cur_exp; denom=mp->cur_mod;
17497 if ( denom==0 ) { @<Protest division by zero@>; }
17498 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17499 check_arith; mp_get_x_next(mp);
17501 if ( mp->cur_cmd>=min_primary_command ) {
17502 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17503 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17504 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17505 mp_do_binary(mp, p,times);
17507 mp_frac_mult(mp, num,denom);
17508 mp_free_node(mp, p,value_node_size);
17515 @ @<Protest division...@>=
17517 print_err("Division by zero");
17518 @.Division by zero@>
17519 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17522 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17524 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17525 if ( mp->cur_cmd!=of_token ) {
17526 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17527 mp_print_cmd_mod(mp, primary_binary,c);
17529 help1("I've got the first argument; will look now for the other.");
17532 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17533 mp_do_binary(mp, p,c); goto DONE;
17536 @ @<Convert a suffix to a string@>=
17538 mp_get_x_next(mp); mp_scan_suffix(mp);
17539 mp->old_setting=mp->selector; mp->selector=new_string;
17540 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17541 mp_flush_token_list(mp, mp->cur_exp);
17542 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17543 mp->cur_type=mp_string_type;
17547 @ If an internal quantity appears all by itself on the left of an
17548 assignment, we return a token list of length one, containing the address
17549 of the internal quantity plus |hash_end|. (This accords with the conventions
17550 of the save stack, as described earlier.)
17552 @<Scan an internal...@>=
17555 if ( my_var_flag==assignment ) {
17557 if ( mp->cur_cmd==assignment ) {
17558 mp->cur_exp=mp_get_avail(mp);
17559 info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17564 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17567 @ The most difficult part of |scan_primary| has been saved for last, since
17568 it was necessary to build up some confidence first. We can now face the task
17569 of scanning a variable.
17571 As we scan a variable, we build a token list containing the relevant
17572 names and subscript values, simultaneously following along in the
17573 ``collective'' structure to see if we are actually dealing with a macro
17574 instead of a value.
17576 The local variables |pre_head| and |post_head| will point to the beginning
17577 of the prefix and suffix lists; |tail| will point to the end of the list
17578 that is currently growing.
17580 Another local variable, |tt|, contains partial information about the
17581 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17582 relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
17583 doesn't bother to update its information about type. And if
17584 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17586 @ @<Other local variables for |scan_primary|@>=
17587 pointer pre_head,post_head,tail;
17588 /* prefix and suffix list variables */
17589 small_number tt; /* approximation to the type of the variable-so-far */
17590 pointer t; /* a token */
17591 pointer macro_ref = 0; /* reference count for a suffixed macro */
17593 @ @<Scan a variable primary...@>=
17595 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17597 t=mp_cur_tok(mp); link(tail)=t;
17598 if ( tt!=undefined ) {
17599 @<Find the approximate type |tt| and corresponding~|q|@>;
17600 if ( tt>=mp_unsuffixed_macro ) {
17601 @<Either begin an unsuffixed macro call or
17602 prepare for a suffixed one@>;
17605 mp_get_x_next(mp); tail=t;
17606 if ( mp->cur_cmd==left_bracket ) {
17607 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17609 if ( mp->cur_cmd>max_suffix_token ) break;
17610 if ( mp->cur_cmd<min_suffix_token ) break;
17611 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17612 @<Handle unusual cases that masquerade as variables, and |goto restart|
17613 or |goto done| if appropriate;
17614 otherwise make a copy of the variable and |goto done|@>;
17617 @ @<Either begin an unsuffixed macro call or...@>=
17620 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17621 post_head=mp_get_avail(mp); tail=post_head; link(tail)=t;
17622 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17624 @<Set up unsuffixed macro call and |goto restart|@>;
17628 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17630 mp_get_x_next(mp); mp_scan_expression(mp);
17631 if ( mp->cur_cmd!=right_bracket ) {
17632 @<Put the left bracket and the expression back to be rescanned@>;
17634 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17635 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17639 @ The left bracket that we thought was introducing a subscript might have
17640 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17641 So we don't issue an error message at this point; but we do want to back up
17642 so as to avoid any embarrassment about our incorrect assumption.
17644 @<Put the left bracket and the expression back to be rescanned@>=
17646 mp_back_input(mp); /* that was the token following the current expression */
17647 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17648 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17651 @ Here's a routine that puts the current expression back to be read again.
17653 @c void mp_back_expr (MP mp) {
17654 pointer p; /* capsule token */
17655 p=mp_stash_cur_exp(mp); link(p)=null; back_list(p);
17658 @ Unknown subscripts lead to the following error message.
17660 @c void mp_bad_subscript (MP mp) {
17661 exp_err("Improper subscript has been replaced by zero");
17662 @.Improper subscript...@>
17663 help3("A bracketed subscript must have a known numeric value;")
17664 ("unfortunately, what I found was the value that appears just")
17665 ("above this error message. So I'll try a zero subscript.");
17666 mp_flush_error(mp, 0);
17669 @ Every time we call |get_x_next|, there's a chance that the variable we've
17670 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17671 into the variable structure; we need to start searching from the root each time.
17673 @<Find the approximate type |tt| and corresponding~|q|@>=
17676 p=link(pre_head); q=info(p); tt=undefined;
17677 if ( eq_type(q) % outer_tag==tag_token ) {
17679 if ( q==null ) goto DONE2;
17683 tt=type(q); goto DONE2;
17685 if ( type(q)!=mp_structured ) goto DONE2;
17686 q=link(attr_head(q)); /* the |collective_subscript| attribute */
17687 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17688 do { q=link(q); } while (! (attr_loc(q)>=info(p)));
17689 if ( attr_loc(q)>info(p) ) goto DONE2;
17697 @ How do things stand now? Well, we have scanned an entire variable name,
17698 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17699 |cur_sym| represent the token that follows. If |post_head=null|, a
17700 token list for this variable name starts at |link(pre_head)|, with all
17701 subscripts evaluated. But if |post_head<>null|, the variable turned out
17702 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17703 |post_head| is the head of a token list containing both `\.{\AT!}' and
17706 Our immediate problem is to see if this variable still exists. (Variable
17707 structures can change drastically whenever we call |get_x_next|; users
17708 aren't supposed to do this, but the fact that it is possible means that
17709 we must be cautious.)
17711 The following procedure prints an error message when a variable
17712 unexpectedly disappears. Its help message isn't quite right for
17713 our present purposes, but we'll be able to fix that up.
17716 void mp_obliterated (MP mp,pointer q) {
17717 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17718 mp_print(mp, " has been obliterated");
17719 @.Variable...obliterated@>
17720 help5("It seems you did a nasty thing---probably by accident,")
17721 ("but nevertheless you nearly hornswoggled me...")
17722 ("While I was evaluating the right-hand side of this")
17723 ("command, something happened, and the left-hand side")
17724 ("is no longer a variable! So I won't change anything.");
17727 @ If the variable does exist, we also need to check
17728 for a few other special cases before deciding that a plain old ordinary
17729 variable has, indeed, been scanned.
17731 @<Handle unusual cases that masquerade as variables...@>=
17732 if ( post_head!=null ) {
17733 @<Set up suffixed macro call and |goto restart|@>;
17735 q=link(pre_head); free_avail(pre_head);
17736 if ( mp->cur_cmd==my_var_flag ) {
17737 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17739 p=mp_find_variable(mp, q);
17741 mp_make_exp_copy(mp, p);
17743 mp_obliterated(mp, q);
17744 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17745 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17746 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17747 mp_put_get_flush_error(mp, 0);
17749 mp_flush_node_list(mp, q);
17752 @ The only complication associated with macro calling is that the prefix
17753 and ``at'' parameters must be packaged in an appropriate list of lists.
17755 @<Set up unsuffixed macro call and |goto restart|@>=
17757 p=mp_get_avail(mp); info(pre_head)=link(pre_head); link(pre_head)=p;
17758 info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17763 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17764 we don't care, because we have reserved a pointer (|macro_ref|) to its
17767 @<Set up suffixed macro call and |goto restart|@>=
17769 mp_back_input(mp); p=mp_get_avail(mp); q=link(post_head);
17770 info(pre_head)=link(pre_head); link(pre_head)=post_head;
17771 info(post_head)=q; link(post_head)=p; info(p)=link(q); link(q)=null;
17772 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17773 mp_get_x_next(mp); goto RESTART;
17776 @ Our remaining job is simply to make a copy of the value that has been
17777 found. Some cases are harder than others, but complexity arises solely
17778 because of the multiplicity of possible cases.
17780 @<Declare the procedure called |make_exp_copy|@>=
17781 @<Declare subroutines needed by |make_exp_copy|@>
17782 void mp_make_exp_copy (MP mp,pointer p) {
17783 pointer q,r,t; /* registers for list manipulation */
17785 mp->cur_type=type(p);
17786 switch (mp->cur_type) {
17787 case mp_vacuous: case mp_boolean_type: case mp_known:
17788 mp->cur_exp=value(p); break;
17789 case unknown_types:
17790 mp->cur_exp=mp_new_ring_entry(mp, p);
17792 case mp_string_type:
17793 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17795 case mp_picture_type:
17796 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17799 mp->cur_exp=copy_pen(value(p));
17802 mp->cur_exp=mp_copy_path(mp, value(p));
17804 case mp_transform_type: case mp_color_type:
17805 case mp_cmykcolor_type: case mp_pair_type:
17806 @<Copy the big node |p|@>;
17808 case mp_dependent: case mp_proto_dependent:
17809 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17811 case mp_numeric_type:
17812 new_indep(p); goto RESTART;
17814 case mp_independent:
17815 q=mp_single_dependency(mp, p);
17816 if ( q==mp->dep_final ){
17817 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
17819 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17823 mp_confusion(mp, "copy");
17824 @:this can't happen copy}{\quad copy@>
17829 @ The |encapsulate| subroutine assumes that |dep_final| is the
17830 tail of dependency list~|p|.
17832 @<Declare subroutines needed by |make_exp_copy|@>=
17833 void mp_encapsulate (MP mp,pointer p) {
17834 mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
17835 name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17838 @ The most tedious case arises when the user refers to a
17839 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17840 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17843 @<Copy the big node |p|@>=
17845 if ( value(p)==null )
17846 mp_init_big_node(mp, p);
17847 t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
17848 mp_init_big_node(mp, t);
17849 q=value(p)+mp->big_node_size[mp->cur_type];
17850 r=value(t)+mp->big_node_size[mp->cur_type];
17852 q=q-2; r=r-2; mp_install(mp, r,q);
17853 } while (q!=value(p));
17857 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17858 a big node that will be part of a capsule.
17860 @<Declare subroutines needed by |make_exp_copy|@>=
17861 void mp_install (MP mp,pointer r, pointer q) {
17862 pointer p; /* temporary register */
17863 if ( type(q)==mp_known ){
17864 value(r)=value(q); type(r)=mp_known;
17865 } else if ( type(q)==mp_independent ) {
17866 p=mp_single_dependency(mp, q);
17867 if ( p==mp->dep_final ) {
17868 type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
17870 type(r)=mp_dependent; mp_new_dep(mp, r,p);
17873 type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17877 @ Expressions of the form `\.{a[b,c]}' are converted into
17878 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17879 provided that \.a is numeric.
17881 @<Scan a mediation...@>=
17883 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17884 if ( mp->cur_cmd!=comma ) {
17885 @<Put the left bracket and the expression back...@>;
17886 mp_unstash_cur_exp(mp, p);
17888 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17889 if ( mp->cur_cmd!=right_bracket ) {
17890 mp_missing_err(mp, "]");
17892 help3("I've scanned an expression of the form `a[b,c',")
17893 ("so a right bracket should have come next.")
17894 ("I shall pretend that one was there.");
17897 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17898 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17899 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17903 @ Here is a comparatively simple routine that is used to scan the
17904 \&{suffix} parameters of a macro.
17906 @<Declare the basic parsing subroutines@>=
17907 void mp_scan_suffix (MP mp) {
17908 pointer h,t; /* head and tail of the list being built */
17909 pointer p; /* temporary register */
17910 h=mp_get_avail(mp); t=h;
17912 if ( mp->cur_cmd==left_bracket ) {
17913 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17915 if ( mp->cur_cmd==numeric_token ) {
17916 p=mp_new_num_tok(mp, mp->cur_mod);
17917 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17918 p=mp_get_avail(mp); info(p)=mp->cur_sym;
17922 link(t)=p; t=p; mp_get_x_next(mp);
17924 mp->cur_exp=link(h); free_avail(h); mp->cur_type=mp_token_list;
17927 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17929 mp_get_x_next(mp); mp_scan_expression(mp);
17930 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17931 if ( mp->cur_cmd!=right_bracket ) {
17932 mp_missing_err(mp, "]");
17934 help3("I've seen a `[' and a subscript value, in a suffix,")
17935 ("so a right bracket should have come next.")
17936 ("I shall pretend that one was there.");
17939 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
17942 @* \[38] Parsing secondary and higher expressions.
17944 After the intricacies of |scan_primary|\kern-1pt,
17945 the |scan_secondary| routine is
17946 refreshingly simple. It's not trivial, but the operations are relatively
17947 straightforward; the main difficulty is, again, that expressions and data
17948 structures might change drastically every time we call |get_x_next|, so a
17949 cautious approach is mandatory. For example, a macro defined by
17950 \&{primarydef} might have disappeared by the time its second argument has
17951 been scanned; we solve this by increasing the reference count of its token
17952 list, so that the macro can be called even after it has been clobbered.
17954 @<Declare the basic parsing subroutines@>=
17955 void mp_scan_secondary (MP mp) {
17956 pointer p; /* for list manipulation */
17957 halfword c,d; /* operation codes or modifiers */
17958 pointer mac_name; /* token defined with \&{primarydef} */
17960 if ((mp->cur_cmd<min_primary_command)||
17961 (mp->cur_cmd>max_primary_command) )
17962 mp_bad_exp(mp, "A secondary");
17963 @.A secondary expression...@>
17964 mp_scan_primary(mp);
17966 if ( mp->cur_cmd<=max_secondary_command &&
17967 mp->cur_cmd>=min_secondary_command ) {
17968 p=mp_stash_cur_exp(mp);
17969 c=mp->cur_mod; d=mp->cur_cmd;
17970 if ( d==secondary_primary_macro ) {
17971 mac_name=mp->cur_sym;
17975 mp_scan_primary(mp);
17976 if ( d!=secondary_primary_macro ) {
17977 mp_do_binary(mp, p,c);
17980 mp_binary_mac(mp, p,c,mac_name);
17981 decr(ref_count(c));
17989 @ The following procedure calls a macro that has two parameters,
17992 @c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
17993 pointer q,r; /* nodes in the parameter list */
17994 q=mp_get_avail(mp); r=mp_get_avail(mp); link(q)=r;
17995 info(q)=p; info(r)=mp_stash_cur_exp(mp);
17996 mp_macro_call(mp, c,q,n);
17999 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
18001 @<Declare the basic parsing subroutines@>=
18002 void mp_scan_tertiary (MP mp) {
18003 pointer p; /* for list manipulation */
18004 halfword c,d; /* operation codes or modifiers */
18005 pointer mac_name; /* token defined with \&{secondarydef} */
18007 if ((mp->cur_cmd<min_primary_command)||
18008 (mp->cur_cmd>max_primary_command) )
18009 mp_bad_exp(mp, "A tertiary");
18010 @.A tertiary expression...@>
18011 mp_scan_secondary(mp);
18013 if ( mp->cur_cmd<=max_tertiary_command ) {
18014 if ( mp->cur_cmd>=min_tertiary_command ) {
18015 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18016 if ( d==tertiary_secondary_macro ) {
18017 mac_name=mp->cur_sym; add_mac_ref(c);
18019 mp_get_x_next(mp); mp_scan_secondary(mp);
18020 if ( d!=tertiary_secondary_macro ) {
18021 mp_do_binary(mp, p,c);
18023 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18024 decr(ref_count(c)); mp_get_x_next(mp);
18032 @ Finally we reach the deepest level in our quartet of parsing routines.
18033 This one is much like the others; but it has an extra complication from
18034 paths, which materialize here.
18036 @d continue_path 25 /* a label inside of |scan_expression| */
18037 @d finish_path 26 /* another */
18039 @<Declare the basic parsing subroutines@>=
18040 void mp_scan_expression (MP mp) {
18041 pointer p,q,r,pp,qq; /* for list manipulation */
18042 halfword c,d; /* operation codes or modifiers */
18043 int my_var_flag; /* initial value of |var_flag| */
18044 pointer mac_name; /* token defined with \&{tertiarydef} */
18045 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
18046 scaled x,y; /* explicit coordinates or tension at a path join */
18047 int t; /* knot type following a path join */
18049 my_var_flag=mp->var_flag; mac_name=null;
18051 if ((mp->cur_cmd<min_primary_command)||
18052 (mp->cur_cmd>max_primary_command) )
18053 mp_bad_exp(mp, "An");
18054 @.An expression...@>
18055 mp_scan_tertiary(mp);
18057 if ( mp->cur_cmd<=max_expression_command )
18058 if ( mp->cur_cmd>=min_expression_command ) {
18059 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
18060 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18061 if ( d==expression_tertiary_macro ) {
18062 mac_name=mp->cur_sym; add_mac_ref(c);
18064 if ( (d<ampersand)||((d==ampersand)&&
18065 ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
18066 @<Scan a path construction operation;
18067 but |return| if |p| has the wrong type@>;
18069 mp_get_x_next(mp); mp_scan_tertiary(mp);
18070 if ( d!=expression_tertiary_macro ) {
18071 mp_do_binary(mp, p,c);
18073 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18074 decr(ref_count(c)); mp_get_x_next(mp);
18083 @ The reader should review the data structure conventions for paths before
18084 hoping to understand the next part of this code.
18086 @<Scan a path construction operation...@>=
18089 @<Convert the left operand, |p|, into a partial path ending at~|q|;
18090 but |return| if |p| doesn't have a suitable type@>;
18092 @<Determine the path join parameters;
18093 but |goto finish_path| if there's only a direction specifier@>;
18094 if ( mp->cur_cmd==cycle ) {
18095 @<Get ready to close a cycle@>;
18097 mp_scan_tertiary(mp);
18098 @<Convert the right operand, |cur_exp|,
18099 into a partial path from |pp| to~|qq|@>;
18101 @<Join the partial paths and reset |p| and |q| to the head and tail
18103 if ( mp->cur_cmd>=min_expression_command )
18104 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
18106 @<Choose control points for the path and put the result into |cur_exp|@>;
18109 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
18111 mp_unstash_cur_exp(mp, p);
18112 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
18113 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
18116 while ( link(q)!=p ) q=link(q);
18117 if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
18118 r=mp_copy_knot(mp, p); link(q)=r; q=r;
18120 left_type(p)=mp_open; right_type(q)=mp_open;
18123 @ A pair of numeric values is changed into a knot node for a one-point path
18124 when \MP\ discovers that the pair is part of a path.
18126 @c @<Declare the procedure called |known_pair|@>
18127 pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
18128 pointer q; /* the new node */
18129 q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
18130 right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; link(q)=q;
18131 mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
18135 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
18136 of the current expression, assuming that the current expression is a
18137 pair of known numerics. Unknown components are zeroed, and the
18138 current expression is flushed.
18140 @<Declare the procedure called |known_pair|@>=
18141 void mp_known_pair (MP mp) {
18142 pointer p; /* the pair node */
18143 if ( mp->cur_type!=mp_pair_type ) {
18144 exp_err("Undefined coordinates have been replaced by (0,0)");
18145 @.Undefined coordinates...@>
18146 help5("I need x and y numbers for this part of the path.")
18147 ("The value I found (see above) was no good;")
18148 ("so I'll try to keep going by using zero instead.")
18149 ("(Chapter 27 of The METAFONTbook explains that")
18150 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18151 ("you might want to type `I ??" "?' now.)");
18152 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
18154 p=value(mp->cur_exp);
18155 @<Make sure that both |x| and |y| parts of |p| are known;
18156 copy them into |cur_x| and |cur_y|@>;
18157 mp_flush_cur_exp(mp, 0);
18161 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
18162 if ( type(x_part_loc(p))==mp_known ) {
18163 mp->cur_x=value(x_part_loc(p));
18165 mp_disp_err(mp, x_part_loc(p),
18166 "Undefined x coordinate has been replaced by 0");
18167 @.Undefined coordinates...@>
18168 help5("I need a `known' x value for this part of the path.")
18169 ("The value I found (see above) was no good;")
18170 ("so I'll try to keep going by using zero instead.")
18171 ("(Chapter 27 of The METAFONTbook explains that")
18172 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18173 ("you might want to type `I ??" "?' now.)");
18174 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18176 if ( type(y_part_loc(p))==mp_known ) {
18177 mp->cur_y=value(y_part_loc(p));
18179 mp_disp_err(mp, y_part_loc(p),
18180 "Undefined y coordinate has been replaced by 0");
18181 help5("I need a `known' y value for this part of the path.")
18182 ("The value I found (see above) was no good;")
18183 ("so I'll try to keep going by using zero instead.")
18184 ("(Chapter 27 of The METAFONTbook explains that")
18185 ("you might want to type `I ??" "?' now.)");
18186 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18189 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18191 @<Determine the path join parameters...@>=
18192 if ( mp->cur_cmd==left_brace ) {
18193 @<Put the pre-join direction information into node |q|@>;
18196 if ( d==path_join ) {
18197 @<Determine the tension and/or control points@>;
18198 } else if ( d!=ampersand ) {
18202 if ( mp->cur_cmd==left_brace ) {
18203 @<Put the post-join direction information into |x| and |t|@>;
18204 } else if ( right_type(q)!=mp_explicit ) {
18208 @ The |scan_direction| subroutine looks at the directional information
18209 that is enclosed in braces, and also scans ahead to the following character.
18210 A type code is returned, either |open| (if the direction was $(0,0)$),
18211 or |curl| (if the direction was a curl of known value |cur_exp|), or
18212 |given| (if the direction is given by the |angle| value that now
18213 appears in |cur_exp|).
18215 There's nothing difficult about this subroutine, but the program is rather
18216 lengthy because a variety of potential errors need to be nipped in the bud.
18218 @c small_number mp_scan_direction (MP mp) {
18219 int t; /* the type of information found */
18220 scaled x; /* an |x| coordinate */
18222 if ( mp->cur_cmd==curl_command ) {
18223 @<Scan a curl specification@>;
18225 @<Scan a given direction@>;
18227 if ( mp->cur_cmd!=right_brace ) {
18228 mp_missing_err(mp, "}");
18229 @.Missing `\char`\}'@>
18230 help3("I've scanned a direction spec for part of a path,")
18231 ("so a right brace should have come next.")
18232 ("I shall pretend that one was there.");
18239 @ @<Scan a curl specification@>=
18240 { mp_get_x_next(mp); mp_scan_expression(mp);
18241 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18242 exp_err("Improper curl has been replaced by 1");
18244 help1("A curl must be a known, nonnegative number.");
18245 mp_put_get_flush_error(mp, unity);
18250 @ @<Scan a given direction@>=
18251 { mp_scan_expression(mp);
18252 if ( mp->cur_type>mp_pair_type ) {
18253 @<Get given directions separated by commas@>;
18257 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18258 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18261 @ @<Get given directions separated by commas@>=
18263 if ( mp->cur_type!=mp_known ) {
18264 exp_err("Undefined x coordinate has been replaced by 0");
18265 @.Undefined coordinates...@>
18266 help5("I need a `known' x value for this part of the path.")
18267 ("The value I found (see above) was no good;")
18268 ("so I'll try to keep going by using zero instead.")
18269 ("(Chapter 27 of The METAFONTbook explains that")
18270 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18271 ("you might want to type `I ??" "?' now.)");
18272 mp_put_get_flush_error(mp, 0);
18275 if ( mp->cur_cmd!=comma ) {
18276 mp_missing_err(mp, ",");
18278 help2("I've got the x coordinate of a path direction;")
18279 ("will look for the y coordinate next.");
18282 mp_get_x_next(mp); mp_scan_expression(mp);
18283 if ( mp->cur_type!=mp_known ) {
18284 exp_err("Undefined y coordinate has been replaced by 0");
18285 help5("I need a `known' y value for this part of the path.")
18286 ("The value I found (see above) was no good;")
18287 ("so I'll try to keep going by using zero instead.")
18288 ("(Chapter 27 of The METAFONTbook explains that")
18289 ("you might want to type `I ??" "?' now.)");
18290 mp_put_get_flush_error(mp, 0);
18292 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18295 @ At this point |right_type(q)| is usually |open|, but it may have been
18296 set to some other value by a previous operation. We must maintain
18297 the value of |right_type(q)| in cases such as
18298 `\.{..\{curl2\}z\{0,0\}..}'.
18300 @<Put the pre-join...@>=
18302 t=mp_scan_direction(mp);
18303 if ( t!=mp_open ) {
18304 right_type(q)=t; right_given(q)=mp->cur_exp;
18305 if ( left_type(q)==mp_open ) {
18306 left_type(q)=t; left_given(q)=mp->cur_exp;
18307 } /* note that |left_given(q)=left_curl(q)| */
18311 @ Since |left_tension| and |left_y| share the same position in knot nodes,
18312 and since |left_given| is similarly equivalent to |left_x|, we use
18313 |x| and |y| to hold the given direction and tension information when
18314 there are no explicit control points.
18316 @<Put the post-join...@>=
18318 t=mp_scan_direction(mp);
18319 if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
18320 else t=mp_explicit; /* the direction information is superfluous */
18323 @ @<Determine the tension and/or...@>=
18326 if ( mp->cur_cmd==tension ) {
18327 @<Set explicit tensions@>;
18328 } else if ( mp->cur_cmd==controls ) {
18329 @<Set explicit control points@>;
18331 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18334 if ( mp->cur_cmd!=path_join ) {
18335 mp_missing_err(mp, "..");
18337 help1("A path join command should end with two dots.");
18344 @ @<Set explicit tensions@>=
18346 mp_get_x_next(mp); y=mp->cur_cmd;
18347 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18348 mp_scan_primary(mp);
18349 @<Make sure that the current expression is a valid tension setting@>;
18350 if ( y==at_least ) negate(mp->cur_exp);
18351 right_tension(q)=mp->cur_exp;
18352 if ( mp->cur_cmd==and_command ) {
18353 mp_get_x_next(mp); y=mp->cur_cmd;
18354 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18355 mp_scan_primary(mp);
18356 @<Make sure that the current expression is a valid tension setting@>;
18357 if ( y==at_least ) negate(mp->cur_exp);
18362 @ @d min_tension three_quarter_unit
18364 @<Make sure that the current expression is a valid tension setting@>=
18365 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18366 exp_err("Improper tension has been set to 1");
18367 @.Improper tension@>
18368 help1("The expression above should have been a number >=3/4.");
18369 mp_put_get_flush_error(mp, unity);
18372 @ @<Set explicit control points@>=
18374 right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18375 mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
18376 if ( mp->cur_cmd!=and_command ) {
18377 x=right_x(q); y=right_y(q);
18379 mp_get_x_next(mp); mp_scan_primary(mp);
18380 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18384 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18386 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18387 else pp=mp->cur_exp;
18389 while ( link(qq)!=pp ) qq=link(qq);
18390 if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18391 r=mp_copy_knot(mp, pp); link(qq)=r; qq=r;
18393 left_type(pp)=mp_open; right_type(qq)=mp_open;
18396 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18397 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18398 shouldn't have length zero.
18400 @<Get ready to close a cycle@>=
18402 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18403 if ( d==ampersand ) if ( p==q ) {
18404 d=path_join; right_tension(q)=unity; y=unity;
18408 @ @<Join the partial paths and reset |p| and |q|...@>=
18410 if ( d==ampersand ) {
18411 if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
18412 print_err("Paths don't touch; `&' will be changed to `..'");
18413 @.Paths don't touch@>
18414 help3("When you join paths `p&q', the ending point of p")
18415 ("must be exactly equal to the starting point of q.")
18416 ("So I'm going to pretend that you said `p..q' instead.");
18417 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18420 @<Plug an opening in |right_type(pp)|, if possible@>;
18421 if ( d==ampersand ) {
18422 @<Splice independent paths together@>;
18424 @<Plug an opening in |right_type(q)|, if possible@>;
18425 link(q)=pp; left_y(pp)=y;
18426 if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
18431 @ @<Plug an opening in |right_type(q)|...@>=
18432 if ( right_type(q)==mp_open ) {
18433 if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
18434 right_type(q)=left_type(q); right_given(q)=left_given(q);
18438 @ @<Plug an opening in |right_type(pp)|...@>=
18439 if ( right_type(pp)==mp_open ) {
18440 if ( (t==mp_curl)||(t==mp_given) ) {
18441 right_type(pp)=t; right_given(pp)=x;
18445 @ @<Splice independent paths together@>=
18447 if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
18448 left_type(q)=mp_curl; left_curl(q)=unity;
18450 if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
18451 right_type(pp)=mp_curl; right_curl(pp)=unity;
18453 right_type(q)=right_type(pp); link(q)=link(pp);
18454 right_x(q)=right_x(pp); right_y(q)=right_y(pp);
18455 mp_free_node(mp, pp,knot_node_size);
18456 if ( qq==pp ) qq=q;
18459 @ @<Choose control points for the path...@>=
18461 if ( d==ampersand ) p=q;
18463 left_type(p)=mp_endpoint;
18464 if ( right_type(p)==mp_open ) {
18465 right_type(p)=mp_curl; right_curl(p)=unity;
18467 right_type(q)=mp_endpoint;
18468 if ( left_type(q)==mp_open ) {
18469 left_type(q)=mp_curl; left_curl(q)=unity;
18473 mp_make_choices(mp, p);
18474 mp->cur_type=mp_path_type; mp->cur_exp=p
18476 @ Finally, we sometimes need to scan an expression whose value is
18477 supposed to be either |true_code| or |false_code|.
18479 @<Declare the basic parsing subroutines@>=
18480 void mp_get_boolean (MP mp) {
18481 mp_get_x_next(mp); mp_scan_expression(mp);
18482 if ( mp->cur_type!=mp_boolean_type ) {
18483 exp_err("Undefined condition will be treated as `false'");
18484 @.Undefined condition...@>
18485 help2("The expression shown above should have had a definite")
18486 ("true-or-false value. I'm changing it to `false'.");
18487 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18491 @* \[39] Doing the operations.
18492 The purpose of parsing is primarily to permit people to avoid piles of
18493 parentheses. But the real work is done after the structure of an expression
18494 has been recognized; that's when new expressions are generated. We
18495 turn now to the guts of \MP, which handles individual operators that
18496 have come through the parsing mechanism.
18498 We'll start with the easy ones that take no operands, then work our way
18499 up to operators with one and ultimately two arguments. In other words,
18500 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18501 that are invoked periodically by the expression scanners.
18503 First let's make sure that all of the primitive operators are in the
18504 hash table. Although |scan_primary| and its relatives made use of the
18505 \\{cmd} code for these operators, the \\{do} routines base everything
18506 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18507 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18510 mp_primitive(mp, "true",nullary,true_code);
18511 @:true_}{\&{true} primitive@>
18512 mp_primitive(mp, "false",nullary,false_code);
18513 @:false_}{\&{false} primitive@>
18514 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18515 @:null_picture_}{\&{nullpicture} primitive@>
18516 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18517 @:null_pen_}{\&{nullpen} primitive@>
18518 mp_primitive(mp, "jobname",nullary,job_name_op);
18519 @:job_name_}{\&{jobname} primitive@>
18520 mp_primitive(mp, "readstring",nullary,read_string_op);
18521 @:read_string_}{\&{readstring} primitive@>
18522 mp_primitive(mp, "pencircle",nullary,pen_circle);
18523 @:pen_circle_}{\&{pencircle} primitive@>
18524 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18525 @:normal_deviate_}{\&{normaldeviate} primitive@>
18526 mp_primitive(mp, "readfrom",unary,read_from_op);
18527 @:read_from_}{\&{readfrom} primitive@>
18528 mp_primitive(mp, "closefrom",unary,close_from_op);
18529 @:close_from_}{\&{closefrom} primitive@>
18530 mp_primitive(mp, "odd",unary,odd_op);
18531 @:odd_}{\&{odd} primitive@>
18532 mp_primitive(mp, "known",unary,known_op);
18533 @:known_}{\&{known} primitive@>
18534 mp_primitive(mp, "unknown",unary,unknown_op);
18535 @:unknown_}{\&{unknown} primitive@>
18536 mp_primitive(mp, "not",unary,not_op);
18537 @:not_}{\&{not} primitive@>
18538 mp_primitive(mp, "decimal",unary,decimal);
18539 @:decimal_}{\&{decimal} primitive@>
18540 mp_primitive(mp, "reverse",unary,reverse);
18541 @:reverse_}{\&{reverse} primitive@>
18542 mp_primitive(mp, "makepath",unary,make_path_op);
18543 @:make_path_}{\&{makepath} primitive@>
18544 mp_primitive(mp, "makepen",unary,make_pen_op);
18545 @:make_pen_}{\&{makepen} primitive@>
18546 mp_primitive(mp, "oct",unary,oct_op);
18547 @:oct_}{\&{oct} primitive@>
18548 mp_primitive(mp, "hex",unary,hex_op);
18549 @:hex_}{\&{hex} primitive@>
18550 mp_primitive(mp, "ASCII",unary,ASCII_op);
18551 @:ASCII_}{\&{ASCII} primitive@>
18552 mp_primitive(mp, "char",unary,char_op);
18553 @:char_}{\&{char} primitive@>
18554 mp_primitive(mp, "length",unary,length_op);
18555 @:length_}{\&{length} primitive@>
18556 mp_primitive(mp, "turningnumber",unary,turning_op);
18557 @:turning_number_}{\&{turningnumber} primitive@>
18558 mp_primitive(mp, "xpart",unary,x_part);
18559 @:x_part_}{\&{xpart} primitive@>
18560 mp_primitive(mp, "ypart",unary,y_part);
18561 @:y_part_}{\&{ypart} primitive@>
18562 mp_primitive(mp, "xxpart",unary,xx_part);
18563 @:xx_part_}{\&{xxpart} primitive@>
18564 mp_primitive(mp, "xypart",unary,xy_part);
18565 @:xy_part_}{\&{xypart} primitive@>
18566 mp_primitive(mp, "yxpart",unary,yx_part);
18567 @:yx_part_}{\&{yxpart} primitive@>
18568 mp_primitive(mp, "yypart",unary,yy_part);
18569 @:yy_part_}{\&{yypart} primitive@>
18570 mp_primitive(mp, "redpart",unary,red_part);
18571 @:red_part_}{\&{redpart} primitive@>
18572 mp_primitive(mp, "greenpart",unary,green_part);
18573 @:green_part_}{\&{greenpart} primitive@>
18574 mp_primitive(mp, "bluepart",unary,blue_part);
18575 @:blue_part_}{\&{bluepart} primitive@>
18576 mp_primitive(mp, "cyanpart",unary,cyan_part);
18577 @:cyan_part_}{\&{cyanpart} primitive@>
18578 mp_primitive(mp, "magentapart",unary,magenta_part);
18579 @:magenta_part_}{\&{magentapart} primitive@>
18580 mp_primitive(mp, "yellowpart",unary,yellow_part);
18581 @:yellow_part_}{\&{yellowpart} primitive@>
18582 mp_primitive(mp, "blackpart",unary,black_part);
18583 @:black_part_}{\&{blackpart} primitive@>
18584 mp_primitive(mp, "greypart",unary,grey_part);
18585 @:grey_part_}{\&{greypart} primitive@>
18586 mp_primitive(mp, "colormodel",unary,color_model_part);
18587 @:color_model_part_}{\&{colormodel} primitive@>
18588 mp_primitive(mp, "fontpart",unary,font_part);
18589 @:font_part_}{\&{fontpart} primitive@>
18590 mp_primitive(mp, "textpart",unary,text_part);
18591 @:text_part_}{\&{textpart} primitive@>
18592 mp_primitive(mp, "pathpart",unary,path_part);
18593 @:path_part_}{\&{pathpart} primitive@>
18594 mp_primitive(mp, "penpart",unary,pen_part);
18595 @:pen_part_}{\&{penpart} primitive@>
18596 mp_primitive(mp, "dashpart",unary,dash_part);
18597 @:dash_part_}{\&{dashpart} primitive@>
18598 mp_primitive(mp, "sqrt",unary,sqrt_op);
18599 @:sqrt_}{\&{sqrt} primitive@>
18600 mp_primitive(mp, "mexp",unary,m_exp_op);
18601 @:m_exp_}{\&{mexp} primitive@>
18602 mp_primitive(mp, "mlog",unary,m_log_op);
18603 @:m_log_}{\&{mlog} primitive@>
18604 mp_primitive(mp, "sind",unary,sin_d_op);
18605 @:sin_d_}{\&{sind} primitive@>
18606 mp_primitive(mp, "cosd",unary,cos_d_op);
18607 @:cos_d_}{\&{cosd} primitive@>
18608 mp_primitive(mp, "floor",unary,floor_op);
18609 @:floor_}{\&{floor} primitive@>
18610 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18611 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18612 mp_primitive(mp, "charexists",unary,char_exists_op);
18613 @:char_exists_}{\&{charexists} primitive@>
18614 mp_primitive(mp, "fontsize",unary,font_size);
18615 @:font_size_}{\&{fontsize} primitive@>
18616 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18617 @:ll_corner_}{\&{llcorner} primitive@>
18618 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18619 @:lr_corner_}{\&{lrcorner} primitive@>
18620 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18621 @:ul_corner_}{\&{ulcorner} primitive@>
18622 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18623 @:ur_corner_}{\&{urcorner} primitive@>
18624 mp_primitive(mp, "arclength",unary,arc_length);
18625 @:arc_length_}{\&{arclength} primitive@>
18626 mp_primitive(mp, "angle",unary,angle_op);
18627 @:angle_}{\&{angle} primitive@>
18628 mp_primitive(mp, "cycle",cycle,cycle_op);
18629 @:cycle_}{\&{cycle} primitive@>
18630 mp_primitive(mp, "stroked",unary,stroked_op);
18631 @:stroked_}{\&{stroked} primitive@>
18632 mp_primitive(mp, "filled",unary,filled_op);
18633 @:filled_}{\&{filled} primitive@>
18634 mp_primitive(mp, "textual",unary,textual_op);
18635 @:textual_}{\&{textual} primitive@>
18636 mp_primitive(mp, "clipped",unary,clipped_op);
18637 @:clipped_}{\&{clipped} primitive@>
18638 mp_primitive(mp, "bounded",unary,bounded_op);
18639 @:bounded_}{\&{bounded} primitive@>
18640 mp_primitive(mp, "+",plus_or_minus,plus);
18641 @:+ }{\.{+} primitive@>
18642 mp_primitive(mp, "-",plus_or_minus,minus);
18643 @:- }{\.{-} primitive@>
18644 mp_primitive(mp, "*",secondary_binary,times);
18645 @:* }{\.{*} primitive@>
18646 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18647 @:/ }{\.{/} primitive@>
18648 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18649 @:++_}{\.{++} primitive@>
18650 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18651 @:+-+_}{\.{+-+} primitive@>
18652 mp_primitive(mp, "or",tertiary_binary,or_op);
18653 @:or_}{\&{or} primitive@>
18654 mp_primitive(mp, "and",and_command,and_op);
18655 @:and_}{\&{and} primitive@>
18656 mp_primitive(mp, "<",expression_binary,less_than);
18657 @:< }{\.{<} primitive@>
18658 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18659 @:<=_}{\.{<=} primitive@>
18660 mp_primitive(mp, ">",expression_binary,greater_than);
18661 @:> }{\.{>} primitive@>
18662 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18663 @:>=_}{\.{>=} primitive@>
18664 mp_primitive(mp, "=",equals,equal_to);
18665 @:= }{\.{=} primitive@>
18666 mp_primitive(mp, "<>",expression_binary,unequal_to);
18667 @:<>_}{\.{<>} primitive@>
18668 mp_primitive(mp, "substring",primary_binary,substring_of);
18669 @:substring_}{\&{substring} primitive@>
18670 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18671 @:subpath_}{\&{subpath} primitive@>
18672 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18673 @:direction_time_}{\&{directiontime} primitive@>
18674 mp_primitive(mp, "point",primary_binary,point_of);
18675 @:point_}{\&{point} primitive@>
18676 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18677 @:precontrol_}{\&{precontrol} primitive@>
18678 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18679 @:postcontrol_}{\&{postcontrol} primitive@>
18680 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18681 @:pen_offset_}{\&{penoffset} primitive@>
18682 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18683 @:arc_time_of_}{\&{arctime} primitive@>
18684 mp_primitive(mp, "mpversion",nullary,mp_version);
18685 @:mp_verison_}{\&{mpversion} primitive@>
18686 mp_primitive(mp, "&",ampersand,concatenate);
18687 @:!!!}{\.{\&} primitive@>
18688 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18689 @:rotated_}{\&{rotated} primitive@>
18690 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18691 @:slanted_}{\&{slanted} primitive@>
18692 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18693 @:scaled_}{\&{scaled} primitive@>
18694 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18695 @:shifted_}{\&{shifted} primitive@>
18696 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18697 @:transformed_}{\&{transformed} primitive@>
18698 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18699 @:x_scaled_}{\&{xscaled} primitive@>
18700 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18701 @:y_scaled_}{\&{yscaled} primitive@>
18702 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18703 @:z_scaled_}{\&{zscaled} primitive@>
18704 mp_primitive(mp, "infont",secondary_binary,in_font);
18705 @:in_font_}{\&{infont} primitive@>
18706 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18707 @:intersection_times_}{\&{intersectiontimes} primitive@>
18708 mp_primitive(mp, "envelope",primary_binary,envelope_of);
18709 @:envelope_}{\&{envelope} primitive@>
18711 @ @<Cases of |print_cmd...@>=
18714 case primary_binary:
18715 case secondary_binary:
18716 case tertiary_binary:
18717 case expression_binary:
18719 case plus_or_minus:
18724 mp_print_op(mp, m);
18727 @ OK, let's look at the simplest \\{do} procedure first.
18729 @c @<Declare nullary action procedure@>
18730 void mp_do_nullary (MP mp,quarterword c) {
18732 if ( mp->internal[mp_tracing_commands]>two )
18733 mp_show_cmd_mod(mp, nullary,c);
18735 case true_code: case false_code:
18736 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18738 case null_picture_code:
18739 mp->cur_type=mp_picture_type;
18740 mp->cur_exp=mp_get_node(mp, edge_header_size);
18741 mp_init_edges(mp, mp->cur_exp);
18743 case null_pen_code:
18744 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18746 case normal_deviate:
18747 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18750 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18753 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18754 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18757 mp->cur_type=mp_string_type;
18758 mp->cur_exp=intern(metapost_version) ;
18760 case read_string_op:
18761 @<Read a string from the terminal@>;
18763 } /* there are no other cases */
18767 @ @<Read a string...@>=
18769 if ( mp->interaction<=mp_nonstop_mode )
18770 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18771 mp_begin_file_reading(mp); name=is_read;
18772 limit=start; prompt_input("");
18773 mp_finish_read(mp);
18776 @ @<Declare nullary action procedure@>=
18777 void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18779 str_room((int)mp->last-start);
18780 for (k=start;k<=mp->last-1;k++) {
18781 append_char(mp->buffer[k]);
18783 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18784 mp->cur_exp=mp_make_string(mp);
18787 @ Things get a bit more interesting when there's an operand. The
18788 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18790 @c @<Declare unary action procedures@>
18791 void mp_do_unary (MP mp,quarterword c) {
18792 pointer p,q,r; /* for list manipulation */
18793 integer x; /* a temporary register */
18795 if ( mp->internal[mp_tracing_commands]>two )
18796 @<Trace the current unary operation@>;
18799 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18802 @<Negate the current expression@>;
18804 @<Additional cases of unary operators@>;
18805 } /* there are no other cases */
18809 @ The |nice_pair| function returns |true| if both components of a pair
18812 @<Declare unary action procedures@>=
18813 boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18814 if ( t==mp_pair_type ) {
18816 if ( type(x_part_loc(p))==mp_known )
18817 if ( type(y_part_loc(p))==mp_known )
18823 @ The |nice_color_or_pair| function is analogous except that it also accepts
18824 fully known colors.
18826 @<Declare unary action procedures@>=
18827 boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18828 pointer q,r; /* for scanning the big node */
18829 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18833 r=q+mp->big_node_size[type(p)];
18836 if ( type(r)!=mp_known )
18843 @ @<Declare unary action...@>=
18844 void mp_print_known_or_unknown_type (MP mp,small_number t, integer v) {
18845 mp_print_char(mp, '(');
18846 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18847 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18848 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18849 mp_print_type(mp, t);
18851 mp_print_char(mp, ')');
18854 @ @<Declare unary action...@>=
18855 void mp_bad_unary (MP mp,quarterword c) {
18856 exp_err("Not implemented: "); mp_print_op(mp, c);
18857 @.Not implemented...@>
18858 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18859 help3("I'm afraid I don't know how to apply that operation to that")
18860 ("particular type. Continue, and I'll simply return the")
18861 ("argument (shown above) as the result of the operation.");
18862 mp_put_get_error(mp);
18865 @ @<Trace the current unary operation@>=
18867 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18868 mp_print_op(mp, c); mp_print_char(mp, '(');
18869 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18870 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18873 @ Negation is easy except when the current expression
18874 is of type |independent|, or when it is a pair with one or more
18875 |independent| components.
18877 It is tempting to argue that the negative of an independent variable
18878 is an independent variable, hence we don't have to do anything when
18879 negating it. The fallacy is that other dependent variables pointing
18880 to the current expression must change the sign of their
18881 coefficients if we make no change to the current expression.
18883 Instead, we work around the problem by copying the current expression
18884 and recycling it afterwards (cf.~the |stash_in| routine).
18886 @<Negate the current expression@>=
18887 switch (mp->cur_type) {
18888 case mp_color_type:
18889 case mp_cmykcolor_type:
18891 case mp_independent:
18892 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18893 if ( mp->cur_type==mp_dependent ) {
18894 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18895 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18896 p=value(mp->cur_exp);
18897 r=p+mp->big_node_size[mp->cur_type];
18900 if ( type(r)==mp_known ) negate(value(r));
18901 else mp_negate_dep_list(mp, dep_list(r));
18903 } /* if |cur_type=mp_known| then |cur_exp=0| */
18904 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18907 case mp_proto_dependent:
18908 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18911 negate(mp->cur_exp);
18914 mp_bad_unary(mp, minus);
18918 @ @<Declare unary action...@>=
18919 void mp_negate_dep_list (MP mp,pointer p) {
18922 if ( info(p)==null ) return;
18927 @ @<Additional cases of unary operators@>=
18929 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
18930 else mp->cur_exp=true_code+false_code-mp->cur_exp;
18933 @ @d three_sixty_units 23592960 /* that's |360*unity| */
18934 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
18936 @<Additional cases of unary operators@>=
18943 case uniform_deviate:
18945 case char_exists_op:
18946 if ( mp->cur_type!=mp_known ) {
18947 mp_bad_unary(mp, c);
18950 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
18951 case m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
18952 case m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
18955 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
18956 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
18957 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
18959 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
18960 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
18962 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
18963 mp->cur_type=mp_boolean_type;
18965 case char_exists_op:
18966 @<Determine if a character has been shipped out@>;
18968 } /* there are no other cases */
18972 @ @<Additional cases of unary operators@>=
18974 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
18975 p=value(mp->cur_exp);
18976 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
18977 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
18978 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
18980 mp_bad_unary(mp, angle_op);
18984 @ If the current expression is a pair, but the context wants it to
18985 be a path, we call |pair_to_path|.
18987 @<Declare unary action...@>=
18988 void mp_pair_to_path (MP mp) {
18989 mp->cur_exp=mp_new_knot(mp);
18990 mp->cur_type=mp_path_type;
18994 @d pict_color_type(A) ((link(dummy_loc(mp->cur_exp))!=null) &&
18995 (has_color(link(dummy_loc(mp->cur_exp)))) &&
18996 ((color_model(link(dummy_loc(mp->cur_exp)))==A)
18998 ((color_model(link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) &&
18999 (mp->internal[mp_default_color_model]/unity)==(A))))
19001 @<Additional cases of unary operators@>=
19004 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
19005 mp_take_part(mp, c);
19006 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19007 else mp_bad_unary(mp, c);
19013 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
19014 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19015 else mp_bad_unary(mp, c);
19020 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
19021 else if ( mp->cur_type==mp_picture_type ) {
19022 if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
19023 else mp_bad_color_part(mp, c);
19025 else mp_bad_unary(mp, c);
19031 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
19032 else if ( mp->cur_type==mp_picture_type ) {
19033 if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
19034 else mp_bad_color_part(mp, c);
19036 else mp_bad_unary(mp, c);
19039 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
19040 else if ( mp->cur_type==mp_picture_type ) {
19041 if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
19042 else mp_bad_color_part(mp, c);
19044 else mp_bad_unary(mp, c);
19046 case color_model_part:
19047 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19048 else mp_bad_unary(mp, c);
19051 @ @<Declarations@>=
19052 void mp_bad_color_part(MP mp, quarterword c);
19055 void mp_bad_color_part(MP mp, quarterword c) {
19056 pointer p; /* the big node */
19057 p=link(dummy_loc(mp->cur_exp));
19058 exp_err("Wrong picture color model: "); mp_print_op(mp, c);
19059 @.Wrong picture color model...@>
19060 if (color_model(p)==mp_grey_model)
19061 mp_print(mp, " of grey object");
19062 else if (color_model(p)==mp_cmyk_model)
19063 mp_print(mp, " of cmyk object");
19064 else if (color_model(p)==mp_rgb_model)
19065 mp_print(mp, " of rgb object");
19066 else if (color_model(p)==mp_no_model)
19067 mp_print(mp, " of marking object");
19069 mp_print(mp," of defaulted object");
19070 help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,")
19071 ("the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ")
19072 ("or the greypart of a grey object. No mixing and matching, please.");
19075 mp_flush_cur_exp(mp,unity);
19077 mp_flush_cur_exp(mp,0);
19080 @ In the following procedure, |cur_exp| points to a capsule, which points to
19081 a big node. We want to delete all but one part of the big node.
19083 @<Declare unary action...@>=
19084 void mp_take_part (MP mp,quarterword c) {
19085 pointer p; /* the big node */
19086 p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
19087 link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
19088 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
19089 mp_recycle_value(mp, temp_val);
19092 @ @<Initialize table entries...@>=
19093 name_type(temp_val)=mp_capsule;
19095 @ @<Additional cases of unary operators@>=
19101 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19102 else mp_bad_unary(mp, c);
19105 @ @<Declarations@>=
19106 void mp_scale_edges (MP mp);
19108 @ @<Declare unary action...@>=
19109 void mp_take_pict_part (MP mp,quarterword c) {
19110 pointer p; /* first graphical object in |cur_exp| */
19111 p=link(dummy_loc(mp->cur_exp));
19114 case x_part: case y_part: case xx_part:
19115 case xy_part: case yx_part: case yy_part:
19116 if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
19117 else goto NOT_FOUND;
19119 case red_part: case green_part: case blue_part:
19120 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
19121 else goto NOT_FOUND;
19123 case cyan_part: case magenta_part: case yellow_part:
19125 if ( has_color(p) ) {
19126 if ( color_model(p)==mp_uninitialized_model && c==black_part)
19127 mp_flush_cur_exp(mp, unity);
19129 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
19130 } else goto NOT_FOUND;
19133 if ( has_color(p) )
19134 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
19135 else goto NOT_FOUND;
19137 case color_model_part:
19138 if ( has_color(p) ) {
19139 if ( color_model(p)==mp_uninitialized_model )
19140 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
19142 mp_flush_cur_exp(mp, color_model(p)*unity);
19143 } else goto NOT_FOUND;
19145 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
19146 } /* all cases have been enumerated */
19150 @<Convert the current expression to a null value appropriate
19154 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
19156 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19158 mp_flush_cur_exp(mp, text_p(p));
19159 add_str_ref(mp->cur_exp);
19160 mp->cur_type=mp_string_type;
19164 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19166 mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
19167 add_str_ref(mp->cur_exp);
19168 mp->cur_type=mp_string_type;
19172 if ( type(p)==mp_text_code ) goto NOT_FOUND;
19173 else if ( is_stop(p) ) mp_confusion(mp, "pict");
19174 @:this can't happen pict}{\quad pict@>
19176 mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
19177 mp->cur_type=mp_path_type;
19181 if ( ! has_pen(p) ) goto NOT_FOUND;
19183 if ( pen_p(p)==null ) goto NOT_FOUND;
19184 else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
19185 mp->cur_type=mp_pen_type;
19190 if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
19191 else { if ( dash_p(p)==null ) goto NOT_FOUND;
19192 else { add_edge_ref(dash_p(p));
19193 mp->se_sf=dash_scale(p);
19194 mp->se_pic=dash_p(p);
19195 mp_scale_edges(mp);
19196 mp_flush_cur_exp(mp, mp->se_pic);
19197 mp->cur_type=mp_picture_type;
19202 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
19203 parameterless procedure even though it really takes two arguments and updates
19204 one of them. Hence the following globals are needed.
19207 pointer se_pic; /* edge header used and updated by |scale_edges| */
19208 scaled se_sf; /* the scale factor argument to |scale_edges| */
19210 @ @<Convert the current expression to a null value appropriate...@>=
19212 case text_part: case font_part:
19213 mp_flush_cur_exp(mp, rts(""));
19214 mp->cur_type=mp_string_type;
19217 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19218 left_type(mp->cur_exp)=mp_endpoint;
19219 right_type(mp->cur_exp)=mp_endpoint;
19220 link(mp->cur_exp)=mp->cur_exp;
19221 x_coord(mp->cur_exp)=0;
19222 y_coord(mp->cur_exp)=0;
19223 originator(mp->cur_exp)=mp_metapost_user;
19224 mp->cur_type=mp_path_type;
19227 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19228 mp->cur_type=mp_pen_type;
19231 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19232 mp_init_edges(mp, mp->cur_exp);
19233 mp->cur_type=mp_picture_type;
19236 mp_flush_cur_exp(mp, 0);
19240 @ @<Additional cases of unary...@>=
19242 if ( mp->cur_type!=mp_known ) {
19243 mp_bad_unary(mp, char_op);
19245 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19246 mp->cur_type=mp_string_type;
19247 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19251 if ( mp->cur_type!=mp_known ) {
19252 mp_bad_unary(mp, decimal);
19254 mp->old_setting=mp->selector; mp->selector=new_string;
19255 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19256 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19262 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19263 else mp_str_to_num(mp, c);
19266 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19267 else @<Find the design size of the font whose name is |cur_exp|@>;
19270 @ @<Declare unary action...@>=
19271 void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19272 integer n; /* accumulator */
19273 ASCII_code m; /* current character */
19274 pool_pointer k; /* index into |str_pool| */
19275 int b; /* radix of conversion */
19276 boolean bad_char; /* did the string contain an invalid digit? */
19277 if ( c==ASCII_op ) {
19278 if ( length(mp->cur_exp)==0 ) n=-1;
19279 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19281 if ( c==oct_op ) b=8; else b=16;
19282 n=0; bad_char=false;
19283 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19285 if ( (m>='0')&&(m<='9') ) m=m-'0';
19286 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19287 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19288 else { bad_char=true; m=0; };
19289 if ( m>=b ) { bad_char=true; m=0; };
19290 if ( n<32768 / b ) n=n*b+m; else n=32767;
19292 @<Give error messages if |bad_char| or |n>=4096|@>;
19294 mp_flush_cur_exp(mp, n*unity);
19297 @ @<Give error messages if |bad_char|...@>=
19299 exp_err("String contains illegal digits");
19300 @.String contains illegal digits@>
19302 help1("I zeroed out characters that weren't in the range 0..7.");
19304 help1("I zeroed out characters that weren't hex digits.");
19306 mp_put_get_error(mp);
19309 if ( mp->internal[mp_warning_check]>0 ) {
19310 print_err("Number too large (");
19311 mp_print_int(mp, n); mp_print_char(mp, ')');
19312 @.Number too large@>
19313 help2("I have trouble with numbers greater than 4095; watch out.")
19314 ("(Set warningcheck:=0 to suppress this message.)");
19315 mp_put_get_error(mp);
19319 @ The length operation is somewhat unusual in that it applies to a variety
19320 of different types of operands.
19322 @<Additional cases of unary...@>=
19324 switch (mp->cur_type) {
19325 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19326 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19327 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19328 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19330 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19331 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19332 value(x_part_loc(value(mp->cur_exp))),
19333 value(y_part_loc(value(mp->cur_exp)))));
19334 else mp_bad_unary(mp, c);
19339 @ @<Declare unary action...@>=
19340 scaled mp_path_length (MP mp) { /* computes the length of the current path */
19341 scaled n; /* the path length so far */
19342 pointer p; /* traverser */
19344 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
19345 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
19349 @ @<Declare unary action...@>=
19350 scaled mp_pict_length (MP mp) {
19351 /* counts interior components in picture |cur_exp| */
19352 scaled n; /* the count so far */
19353 pointer p; /* traverser */
19355 p=link(dummy_loc(mp->cur_exp));
19357 if ( is_start_or_stop(p) )
19358 if ( mp_skip_1component(mp, p)==null ) p=link(p);
19359 while ( p!=null ) {
19360 skip_component(p) return n;
19367 @ Implement |turningnumber|
19369 @<Additional cases of unary...@>=
19371 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19372 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19373 else if ( left_type(mp->cur_exp)==mp_endpoint )
19374 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19376 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19379 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19380 argument is |origin|.
19382 @<Declare unary action...@>=
19383 angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19384 if ( (! ((xpar==0) && (ypar==0))) )
19385 return mp_n_arg(mp, xpar,ypar);
19390 @ The actual turning number is (for the moment) computed in a C function
19391 that receives eight integers corresponding to the four controlling points,
19392 and returns a single angle. Besides those, we have to account for discrete
19393 moves at the actual points.
19395 @d floor(a) (a>=0 ? a : -(int)(-a))
19396 @d bezier_error (720<<20)+1
19397 @d sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19399 @d out ((double)(xo>>20))
19400 @d mid ((double)(xm>>20))
19401 @d in ((double)(xi>>20))
19402 @d divisor (256*256)
19403 @d double2angle(a) (int)floor(a*256.0*256.0*16.0)
19405 @<Declare unary action...@>=
19406 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19407 integer CX,integer CY,integer DX,integer DY);
19410 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19411 integer CX,integer CY,integer DX,integer DY) {
19413 integer deltax,deltay;
19414 double ax,ay,bx,by,cx,cy,dx,dy;
19415 angle xi = 0, xo = 0, xm = 0;
19417 ax=AX/divisor; ay=AY/divisor;
19418 bx=BX/divisor; by=BY/divisor;
19419 cx=CX/divisor; cy=CY/divisor;
19420 dx=DX/divisor; dy=DY/divisor;
19422 deltax = (BX-AX); deltay = (BY-AY);
19423 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19424 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19425 xi = mp_an_angle(mp,deltax,deltay);
19427 deltax = (CX-BX); deltay = (CY-BY);
19428 xm = mp_an_angle(mp,deltax,deltay);
19430 deltax = (DX-CX); deltay = (DY-CY);
19431 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19432 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19433 xo = mp_an_angle(mp,deltax,deltay);
19435 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19436 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19437 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19439 if ((a==0)&&(c==0)) {
19440 res = (b==0 ? 0 : (out-in));
19441 print_roots("no roots (a)");
19442 } else if ((a==0)||(c==0)) {
19443 if ((sign(b) == sign(a)) || (sign(b) == sign(c))) {
19444 res = out-in; /* ? */
19447 else if (res>180.0)
19449 print_roots("no roots (b)");
19451 res = out-in; /* ? */
19452 print_roots("one root (a)");
19454 } else if ((sign(a)*sign(c))<0) {
19455 res = out-in; /* ? */
19458 else if (res>180.0)
19460 print_roots("one root (b)");
19462 if (sign(a) == sign(b)) {
19463 res = out-in; /* ? */
19466 else if (res>180.0)
19468 print_roots("no roots (d)");
19470 if ((b*b) == (4*a*c)) {
19471 res = bezier_error;
19472 print_roots("double root"); /* cusp */
19473 } else if ((b*b) < (4*a*c)) {
19474 res = out-in; /* ? */
19475 if (res<=0.0 &&res>-180.0)
19477 else if (res>=0.0 && res<180.0)
19479 print_roots("no roots (e)");
19484 else if (res>180.0)
19486 print_roots("two roots"); /* two inflections */
19490 return double2angle(res);
19494 @d p_nextnext link(link(p))
19496 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19498 @<Declare unary action...@>=
19499 scaled mp_new_turn_cycles (MP mp,pointer c) {
19500 angle res,ang; /* the angles of intermediate results */
19501 scaled turns; /* the turn counter */
19502 pointer p; /* for running around the path */
19503 integer xp,yp; /* coordinates of next point */
19504 integer x,y; /* helper coordinates */
19505 angle in_angle,out_angle; /* helper angles */
19506 int old_setting; /* saved |selector| setting */
19510 old_setting = mp->selector; mp->selector=term_only;
19511 if ( mp->internal[mp_tracing_commands]>unity ) {
19512 mp_begin_diagnostic(mp);
19513 mp_print_nl(mp, "");
19514 mp_end_diagnostic(mp, false);
19517 xp = x_coord(p_next); yp = y_coord(p_next);
19518 ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
19519 left_x(p_next), left_y(p_next), xp, yp);
19520 if ( ang>seven_twenty_deg ) {
19521 print_err("Strange path");
19523 mp->selector=old_setting;
19527 if ( res > one_eighty_deg ) {
19528 res = res - three_sixty_deg;
19529 turns = turns + unity;
19531 if ( res <= -one_eighty_deg ) {
19532 res = res + three_sixty_deg;
19533 turns = turns - unity;
19535 /* incoming angle at next point */
19536 x = left_x(p_next); y = left_y(p_next);
19537 if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
19538 if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
19539 in_angle = mp_an_angle(mp, xp - x, yp - y);
19540 /* outgoing angle at next point */
19541 x = right_x(p_next); y = right_y(p_next);
19542 if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
19543 if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
19544 out_angle = mp_an_angle(mp, x - xp, y- yp);
19545 ang = (out_angle - in_angle);
19549 if ( res >= one_eighty_deg ) {
19550 res = res - three_sixty_deg;
19551 turns = turns + unity;
19553 if ( res <= -one_eighty_deg ) {
19554 res = res + three_sixty_deg;
19555 turns = turns - unity;
19560 mp->selector=old_setting;
19565 @ This code is based on Bogus\l{}av Jackowski's
19566 |emergency_turningnumber| macro, with some minor changes by Taco
19567 Hoekwater. The macro code looked more like this:
19569 vardef turning\_number primary p =
19570 ~~save res, ang, turns;
19572 ~~if length p <= 2:
19573 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19575 ~~~~for t = 0 upto length p-1 :
19576 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19577 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19578 ~~~~~~if angc > 180: angc := angc - 360; fi;
19579 ~~~~~~if angc < -180: angc := angc + 360; fi;
19580 ~~~~~~res := res + angc;
19585 The general idea is to calculate only the sum of the angles of
19586 straight lines between the points, of a path, not worrying about cusps
19587 or self-intersections in the segments at all. If the segment is not
19588 well-behaved, the result is not necesarily correct. But the old code
19589 was not always correct either, and worse, it sometimes failed for
19590 well-behaved paths as well. All known bugs that were triggered by the
19591 original code no longer occur with this code, and it runs roughly 3
19592 times as fast because the algorithm is much simpler.
19594 @ It is possible to overflow the return value of the |turn_cycles|
19595 function when the path is sufficiently long and winding, but I am not
19596 going to bother testing for that. In any case, it would only return
19597 the looped result value, which is not a big problem.
19599 The macro code for the repeat loop was a bit nicer to look
19600 at than the pascal code, because it could use |point -1 of p|. In
19601 pascal, the fastest way to loop around the path is not to look
19602 backward once, but forward twice. These defines help hide the trick.
19604 @d p_to link(link(p))
19608 @<Declare unary action...@>=
19609 scaled mp_turn_cycles (MP mp,pointer c) {
19610 angle res,ang; /* the angles of intermediate results */
19611 scaled turns; /* the turn counter */
19612 pointer p; /* for running around the path */
19613 res=0; turns= 0; p=c;
19615 ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
19616 y_coord(p_to) - y_coord(p_here))
19617 - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
19618 y_coord(p_here) - y_coord(p_from));
19621 if ( res >= three_sixty_deg ) {
19622 res = res - three_sixty_deg;
19623 turns = turns + unity;
19625 if ( res <= -three_sixty_deg ) {
19626 res = res + three_sixty_deg;
19627 turns = turns - unity;
19634 @ @<Declare unary action...@>=
19635 scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19637 scaled saved_t_o; /* tracing\_online saved */
19638 if ( (link(c)==c)||(link(link(c))==c) ) {
19639 if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
19644 nval = mp_new_turn_cycles(mp, c);
19645 oval = mp_turn_cycles(mp, c);
19646 if ( nval!=oval ) {
19647 saved_t_o=mp->internal[mp_tracing_online];
19648 mp->internal[mp_tracing_online]=unity;
19649 mp_begin_diagnostic(mp);
19650 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19651 " The current computed value is ");
19652 mp_print_scaled(mp, nval);
19653 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19654 mp_print_scaled(mp, oval);
19655 mp_end_diagnostic(mp, false);
19656 mp->internal[mp_tracing_online]=saved_t_o;
19662 @ @<Declare unary action...@>=
19663 scaled mp_count_turns (MP mp,pointer c) {
19664 pointer p; /* a knot in envelope spec |c| */
19665 integer t; /* total pen offset changes counted */
19668 t=t+info(p)-zero_off;
19671 return ((t / 3)*unity);
19674 @ @d type_range(A,B) {
19675 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19676 mp_flush_cur_exp(mp, true_code);
19677 else mp_flush_cur_exp(mp, false_code);
19678 mp->cur_type=mp_boolean_type;
19681 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19682 else mp_flush_cur_exp(mp, false_code);
19683 mp->cur_type=mp_boolean_type;
19686 @<Additional cases of unary operators@>=
19687 case mp_boolean_type:
19688 type_range(mp_boolean_type,mp_unknown_boolean); break;
19689 case mp_string_type:
19690 type_range(mp_string_type,mp_unknown_string); break;
19692 type_range(mp_pen_type,mp_unknown_pen); break;
19694 type_range(mp_path_type,mp_unknown_path); break;
19695 case mp_picture_type:
19696 type_range(mp_picture_type,mp_unknown_picture); break;
19697 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19699 type_test(c); break;
19700 case mp_numeric_type:
19701 type_range(mp_known,mp_independent); break;
19702 case known_op: case unknown_op:
19703 mp_test_known(mp, c); break;
19705 @ @<Declare unary action procedures@>=
19706 void mp_test_known (MP mp,quarterword c) {
19707 int b; /* is the current expression known? */
19708 pointer p,q; /* locations in a big node */
19710 switch (mp->cur_type) {
19711 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19712 case mp_pen_type: case mp_path_type: case mp_picture_type:
19716 case mp_transform_type:
19717 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19718 p=value(mp->cur_exp);
19719 q=p+mp->big_node_size[mp->cur_type];
19722 if ( type(q)!=mp_known )
19731 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19732 else mp_flush_cur_exp(mp, true_code+false_code-b);
19733 mp->cur_type=mp_boolean_type;
19736 @ @<Additional cases of unary operators@>=
19738 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19739 else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19740 else mp_flush_cur_exp(mp, false_code);
19741 mp->cur_type=mp_boolean_type;
19744 @ @<Additional cases of unary operators@>=
19746 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19747 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19748 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19751 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19753 @^data structure assumptions@>
19755 @<Additional cases of unary operators@>=
19761 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19762 else if ( link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19763 else if ( type(link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19764 mp_flush_cur_exp(mp, true_code);
19765 else mp_flush_cur_exp(mp, false_code);
19766 mp->cur_type=mp_boolean_type;
19769 @ @<Additional cases of unary operators@>=
19771 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19772 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19774 mp->cur_type=mp_pen_type;
19775 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19779 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19781 mp->cur_type=mp_path_type;
19782 mp_make_path(mp, mp->cur_exp);
19786 if ( mp->cur_type==mp_path_type ) {
19787 p=mp_htap_ypoc(mp, mp->cur_exp);
19788 if ( right_type(p)==mp_endpoint ) p=link(p);
19789 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19790 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19791 else mp_bad_unary(mp, reverse);
19794 @ The |pair_value| routine changes the current expression to a
19795 given ordered pair of values.
19797 @<Declare unary action procedures@>=
19798 void mp_pair_value (MP mp,scaled x, scaled y) {
19799 pointer p; /* a pair node */
19800 p=mp_get_node(mp, value_node_size);
19801 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19802 type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19804 type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19805 type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19808 @ @<Additional cases of unary operators@>=
19810 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19811 else mp_pair_value(mp, minx,miny);
19814 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19815 else mp_pair_value(mp, maxx,miny);
19818 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19819 else mp_pair_value(mp, minx,maxy);
19822 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19823 else mp_pair_value(mp, maxx,maxy);
19826 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19827 box of the current expression. The boolean result is |false| if the expression
19828 has the wrong type.
19830 @<Declare unary action procedures@>=
19831 boolean mp_get_cur_bbox (MP mp) {
19832 switch (mp->cur_type) {
19833 case mp_picture_type:
19834 mp_set_bbox(mp, mp->cur_exp,true);
19835 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19836 minx=0; maxx=0; miny=0; maxy=0;
19838 minx=minx_val(mp->cur_exp);
19839 maxx=maxx_val(mp->cur_exp);
19840 miny=miny_val(mp->cur_exp);
19841 maxy=maxy_val(mp->cur_exp);
19845 mp_path_bbox(mp, mp->cur_exp);
19848 mp_pen_bbox(mp, mp->cur_exp);
19856 @ @<Additional cases of unary operators@>=
19858 case close_from_op:
19859 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19860 else mp_do_read_or_close(mp,c);
19863 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19864 a line from the file or to close the file.
19866 @<Declare unary action procedures@>=
19867 void mp_do_read_or_close (MP mp,quarterword c) {
19868 readf_index n,n0; /* indices for searching |rd_fname| */
19869 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19870 call |start_read_input| and |goto found| or |not_found|@>;
19871 mp_begin_file_reading(mp);
19873 if ( mp_input_ln(mp, mp->rd_file[n] ) )
19875 mp_end_file_reading(mp);
19877 @<Record the end of file and set |cur_exp| to a dummy value@>;
19880 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19883 mp_flush_cur_exp(mp, 0);
19884 mp_finish_read(mp);
19887 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19890 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19895 fn = str(mp->cur_exp);
19896 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19899 } else if ( c==close_from_op ) {
19902 if ( n0==mp->read_files ) {
19903 if ( mp->read_files<mp->max_read_files ) {
19904 incr(mp->read_files);
19909 l = mp->max_read_files + (mp->max_read_files>>2);
19910 rd_file = xmalloc((l+1), sizeof(void *));
19911 rd_fname = xmalloc((l+1), sizeof(char *));
19912 for (k=0;k<=l;k++) {
19913 if (k<=mp->max_read_files) {
19914 rd_file[k]=mp->rd_file[k];
19915 rd_fname[k]=mp->rd_fname[k];
19921 xfree(mp->rd_file); xfree(mp->rd_fname);
19922 mp->max_read_files = l;
19923 mp->rd_file = rd_file;
19924 mp->rd_fname = rd_fname;
19928 if ( mp_start_read_input(mp,fn,n) )
19933 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19935 if ( c==close_from_op ) {
19936 (mp->close_file)(mp,mp->rd_file[n]);
19941 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19942 xfree(mp->rd_fname[n]);
19943 mp->rd_fname[n]=NULL;
19944 if ( n==mp->read_files-1 ) mp->read_files=n;
19945 if ( c==close_from_op )
19947 mp_flush_cur_exp(mp, mp->eof_line);
19948 mp->cur_type=mp_string_type
19950 @ The string denoting end-of-file is a one-byte string at position zero, by definition
19953 str_number eof_line;
19958 @ Finally, we have the operations that combine a capsule~|p|
19959 with the current expression.
19961 @d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
19963 @c @<Declare binary action procedures@>
19964 void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
19966 @<Recycle any sidestepped |independent| capsules@>;
19968 void mp_do_binary (MP mp,pointer p, quarterword c) {
19969 pointer q,r,rr; /* for list manipulation */
19970 pointer old_p,old_exp; /* capsules to recycle */
19971 integer v; /* for numeric manipulation */
19973 if ( mp->internal[mp_tracing_commands]>two ) {
19974 @<Trace the current binary operation@>;
19976 @<Sidestep |independent| cases in capsule |p|@>;
19977 @<Sidestep |independent| cases in the current expression@>;
19979 case plus: case minus:
19980 @<Add or subtract the current expression from |p|@>;
19982 @<Additional cases of binary operators@>;
19983 }; /* there are no other cases */
19984 mp_recycle_value(mp, p);
19985 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
19986 mp_finish_binary(mp, old_p, old_exp);
19989 @ @<Declare binary action...@>=
19990 void mp_bad_binary (MP mp,pointer p, quarterword c) {
19991 mp_disp_err(mp, p,"");
19992 exp_err("Not implemented: ");
19993 @.Not implemented...@>
19994 if ( c>=min_of ) mp_print_op(mp, c);
19995 mp_print_known_or_unknown_type(mp, type(p),p);
19996 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
19997 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
19998 help3("I'm afraid I don't know how to apply that operation to that")
19999 ("combination of types. Continue, and I'll return the second")
20000 ("argument (see above) as the result of the operation.");
20001 mp_put_get_error(mp);
20003 void mp_bad_envelope_pen (MP mp) {
20004 mp_disp_err(mp, null,"");
20005 exp_err("Not implemented: envelope(elliptical pen)of(path)");
20006 @.Not implemented...@>
20007 help3("I'm afraid I don't know how to apply that operation to that")
20008 ("combination of types. Continue, and I'll return the second")
20009 ("argument (see above) as the result of the operation.");
20010 mp_put_get_error(mp);
20013 @ @<Trace the current binary operation@>=
20015 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
20016 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
20017 mp_print_char(mp,')'); mp_print_op(mp,c); mp_print_char(mp,'(');
20018 mp_print_exp(mp,null,0); mp_print(mp,")}");
20019 mp_end_diagnostic(mp, false);
20022 @ Several of the binary operations are potentially complicated by the
20023 fact that |independent| values can sneak into capsules. For example,
20024 we've seen an instance of this difficulty in the unary operation
20025 of negation. In order to reduce the number of cases that need to be
20026 handled, we first change the two operands (if necessary)
20027 to rid them of |independent| components. The original operands are
20028 put into capsules called |old_p| and |old_exp|, which will be
20029 recycled after the binary operation has been safely carried out.
20031 @<Recycle any sidestepped |independent| capsules@>=
20032 if ( old_p!=null ) {
20033 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
20035 if ( old_exp!=null ) {
20036 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
20039 @ A big node is considered to be ``tarnished'' if it contains at least one
20040 independent component. We will define a simple function called `|tarnished|'
20041 that returns |null| if and only if its argument is not tarnished.
20043 @<Sidestep |independent| cases in capsule |p|@>=
20045 case mp_transform_type:
20046 case mp_color_type:
20047 case mp_cmykcolor_type:
20049 old_p=mp_tarnished(mp, p);
20051 case mp_independent: old_p=mp_void; break;
20052 default: old_p=null; break;
20054 if ( old_p!=null ) {
20055 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
20056 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
20059 @ @<Sidestep |independent| cases in the current expression@>=
20060 switch (mp->cur_type) {
20061 case mp_transform_type:
20062 case mp_color_type:
20063 case mp_cmykcolor_type:
20065 old_exp=mp_tarnished(mp, mp->cur_exp);
20067 case mp_independent:old_exp=mp_void; break;
20068 default: old_exp=null; break;
20070 if ( old_exp!=null ) {
20071 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20074 @ @<Declare binary action...@>=
20075 pointer mp_tarnished (MP mp,pointer p) {
20076 pointer q; /* beginning of the big node */
20077 pointer r; /* current position in the big node */
20078 q=value(p); r=q+mp->big_node_size[type(p)];
20081 if ( type(r)==mp_independent ) return mp_void;
20086 @ @<Add or subtract the current expression from |p|@>=
20087 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20088 mp_bad_binary(mp, p,c);
20090 if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20091 mp_add_or_subtract(mp, p,null,c);
20093 if ( mp->cur_type!=type(p) ) {
20094 mp_bad_binary(mp, p,c);
20096 q=value(p); r=value(mp->cur_exp);
20097 rr=r+mp->big_node_size[mp->cur_type];
20099 mp_add_or_subtract(mp, q,r,c);
20106 @ The first argument to |add_or_subtract| is the location of a value node
20107 in a capsule or pair node that will soon be recycled. The second argument
20108 is either a location within a pair or transform node of |cur_exp|,
20109 or it is null (which means that |cur_exp| itself should be the second
20110 argument). The third argument is either |plus| or |minus|.
20112 The sum or difference of the numeric quantities will replace the second
20113 operand. Arithmetic overflow may go undetected; users aren't supposed to
20114 be monkeying around with really big values.
20115 @^overflow in arithmetic@>
20117 @<Declare binary action...@>=
20118 @<Declare the procedure called |dep_finish|@>
20119 void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
20120 small_number s,t; /* operand types */
20121 pointer r; /* list traverser */
20122 integer v; /* second operand value */
20125 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
20128 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
20130 if ( t==mp_known ) {
20131 if ( c==minus ) negate(v);
20132 if ( type(p)==mp_known ) {
20133 v=mp_slow_add(mp, value(p),v);
20134 if ( q==null ) mp->cur_exp=v; else value(q)=v;
20137 @<Add a known value to the constant term of |dep_list(p)|@>;
20139 if ( c==minus ) mp_negate_dep_list(mp, v);
20140 @<Add operand |p| to the dependency list |v|@>;
20144 @ @<Add a known value to the constant term of |dep_list(p)|@>=
20146 while ( info(r)!=null ) r=link(r);
20147 value(r)=mp_slow_add(mp, value(r),v);
20149 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
20150 name_type(q)=mp_capsule;
20152 dep_list(q)=dep_list(p); type(q)=type(p);
20153 prev_dep(q)=prev_dep(p); link(prev_dep(p))=q;
20154 type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
20156 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
20157 nice to retain the extra accuracy of |fraction| coefficients.
20158 But we have to handle both kinds, and mixtures too.
20160 @<Add operand |p| to the dependency list |v|@>=
20161 if ( type(p)==mp_known ) {
20162 @<Add the known |value(p)| to the constant term of |v|@>;
20164 s=type(p); r=dep_list(p);
20165 if ( t==mp_dependent ) {
20166 if ( s==mp_dependent ) {
20167 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
20168 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
20169 } /* |fix_needed| will necessarily be false */
20170 t=mp_proto_dependent;
20171 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
20173 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
20174 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
20176 @<Output the answer, |v| (which might have become |known|)@>;
20179 @ @<Add the known |value(p)| to the constant term of |v|@>=
20181 while ( info(v)!=null ) v=link(v);
20182 value(v)=mp_slow_add(mp, value(p),value(v));
20185 @ @<Output the answer, |v| (which might have become |known|)@>=
20186 if ( q!=null ) mp_dep_finish(mp, v,q,t);
20187 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
20189 @ Here's the current situation: The dependency list |v| of type |t|
20190 should either be put into the current expression (if |q=null|) or
20191 into location |q| within a pair node (otherwise). The destination (|cur_exp|
20192 or |q|) formerly held a dependency list with the same
20193 final pointer as the list |v|.
20195 @<Declare the procedure called |dep_finish|@>=
20196 void mp_dep_finish (MP mp, pointer v, pointer q, small_number t) {
20197 pointer p; /* the destination */
20198 scaled vv; /* the value, if it is |known| */
20199 if ( q==null ) p=mp->cur_exp; else p=q;
20200 dep_list(p)=v; type(p)=t;
20201 if ( info(v)==null ) {
20204 mp_flush_cur_exp(mp, vv);
20206 mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
20208 } else if ( q==null ) {
20211 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20214 @ Let's turn now to the six basic relations of comparison.
20216 @<Additional cases of binary operators@>=
20217 case less_than: case less_or_equal: case greater_than:
20218 case greater_or_equal: case equal_to: case unequal_to:
20219 check_arith; /* at this point |arith_error| should be |false|? */
20220 if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20221 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20222 } else if ( mp->cur_type!=type(p) ) {
20223 mp_bad_binary(mp, p,c); goto DONE;
20224 } else if ( mp->cur_type==mp_string_type ) {
20225 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20226 } else if ((mp->cur_type==mp_unknown_string)||
20227 (mp->cur_type==mp_unknown_boolean) ) {
20228 @<Check if unknowns have been equated@>;
20229 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20230 @<Reduce comparison of big nodes to comparison of scalars@>;
20231 } else if ( mp->cur_type==mp_boolean_type ) {
20232 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20234 mp_bad_binary(mp, p,c); goto DONE;
20236 @<Compare the current expression with zero@>;
20238 mp->arith_error=false; /* ignore overflow in comparisons */
20241 @ @<Compare the current expression with zero@>=
20242 if ( mp->cur_type!=mp_known ) {
20243 if ( mp->cur_type<mp_known ) {
20244 mp_disp_err(mp, p,"");
20245 help1("The quantities shown above have not been equated.")
20247 help2("Oh dear. I can\'t decide if the expression above is positive,")
20248 ("negative, or zero. So this comparison test won't be `true'.");
20250 exp_err("Unknown relation will be considered false");
20251 @.Unknown relation...@>
20252 mp_put_get_flush_error(mp, false_code);
20255 case less_than: boolean_reset(mp->cur_exp<0); break;
20256 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20257 case greater_than: boolean_reset(mp->cur_exp>0); break;
20258 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20259 case equal_to: boolean_reset(mp->cur_exp==0); break;
20260 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20261 }; /* there are no other cases */
20263 mp->cur_type=mp_boolean_type
20265 @ When two unknown strings are in the same ring, we know that they are
20266 equal. Otherwise, we don't know whether they are equal or not, so we
20269 @<Check if unknowns have been equated@>=
20271 q=value(mp->cur_exp);
20272 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20273 if ( q==p ) mp_flush_cur_exp(mp, 0);
20276 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20278 q=value(p); r=value(mp->cur_exp);
20279 rr=r+mp->big_node_size[mp->cur_type]-2;
20280 while (1) { mp_add_or_subtract(mp, q,r,minus);
20281 if ( type(r)!=mp_known ) break;
20282 if ( value(r)!=0 ) break;
20283 if ( r==rr ) break;
20286 mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
20289 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20291 @<Additional cases of binary operators@>=
20294 if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20295 mp_bad_binary(mp, p,c);
20296 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20299 @ @<Additional cases of binary operators@>=
20301 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20302 mp_bad_binary(mp, p,times);
20303 } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
20304 @<Multiply when at least one operand is known@>;
20305 } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
20306 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20307 (type(p)>mp_pair_type)) ) {
20308 mp_hard_times(mp, p);
20311 mp_bad_binary(mp, p,times);
20315 @ @<Multiply when at least one operand is known@>=
20317 if ( type(p)==mp_known ) {
20318 v=value(p); mp_free_node(mp, p,value_node_size);
20320 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20322 if ( mp->cur_type==mp_known ) {
20323 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20324 } else if ( (mp->cur_type==mp_pair_type)||
20325 (mp->cur_type==mp_color_type)||
20326 (mp->cur_type==mp_cmykcolor_type) ) {
20327 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20329 p=p-2; mp_dep_mult(mp, p,v,true);
20330 } while (p!=value(mp->cur_exp));
20332 mp_dep_mult(mp, null,v,true);
20337 @ @<Declare binary action...@>=
20338 void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20339 pointer q; /* the dependency list being multiplied by |v| */
20340 small_number s,t; /* its type, before and after */
20343 } else if ( type(p)!=mp_known ) {
20346 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20347 else value(p)=mp_take_fraction(mp, value(p),v);
20350 t=type(q); q=dep_list(q); s=t;
20351 if ( t==mp_dependent ) if ( v_is_scaled )
20352 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20353 t=mp_proto_dependent;
20354 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20355 mp_dep_finish(mp, q,p,t);
20358 @ Here is a routine that is similar to |times|; but it is invoked only
20359 internally, when |v| is a |fraction| whose magnitude is at most~1,
20360 and when |cur_type>=mp_color_type|.
20362 @c void mp_frac_mult (MP mp,scaled n, scaled d) {
20363 /* multiplies |cur_exp| by |n/d| */
20364 pointer p; /* a pair node */
20365 pointer old_exp; /* a capsule to recycle */
20366 fraction v; /* |n/d| */
20367 if ( mp->internal[mp_tracing_commands]>two ) {
20368 @<Trace the fraction multiplication@>;
20370 switch (mp->cur_type) {
20371 case mp_transform_type:
20372 case mp_color_type:
20373 case mp_cmykcolor_type:
20375 old_exp=mp_tarnished(mp, mp->cur_exp);
20377 case mp_independent: old_exp=mp_void; break;
20378 default: old_exp=null; break;
20380 if ( old_exp!=null ) {
20381 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20383 v=mp_make_fraction(mp, n,d);
20384 if ( mp->cur_type==mp_known ) {
20385 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20386 } else if ( mp->cur_type<=mp_pair_type ) {
20387 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20390 mp_dep_mult(mp, p,v,false);
20391 } while (p!=value(mp->cur_exp));
20393 mp_dep_mult(mp, null,v,false);
20395 if ( old_exp!=null ) {
20396 mp_recycle_value(mp, old_exp);
20397 mp_free_node(mp, old_exp,value_node_size);
20401 @ @<Trace the fraction multiplication@>=
20403 mp_begin_diagnostic(mp);
20404 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,'/');
20405 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20407 mp_end_diagnostic(mp, false);
20410 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20412 @<Declare binary action procedures@>=
20413 void mp_hard_times (MP mp,pointer p) {
20414 pointer q; /* a copy of the dependent variable |p| */
20415 pointer r; /* a component of the big node for the nice color or pair */
20416 scaled v; /* the known value for |r| */
20417 if ( type(p)<=mp_pair_type ) {
20418 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20419 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20420 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20425 if ( r==value(mp->cur_exp) )
20427 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20428 mp_dep_mult(mp, r,v,true);
20430 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20431 link(prev_dep(p))=r;
20432 mp_free_node(mp, p,value_node_size);
20433 mp_dep_mult(mp, r,v,true);
20436 @ @<Additional cases of binary operators@>=
20438 if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
20439 mp_bad_binary(mp, p,over);
20441 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20443 @<Squeal about division by zero@>;
20445 if ( mp->cur_type==mp_known ) {
20446 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20447 } else if ( mp->cur_type<=mp_pair_type ) {
20448 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20450 p=p-2; mp_dep_div(mp, p,v);
20451 } while (p!=value(mp->cur_exp));
20453 mp_dep_div(mp, null,v);
20460 @ @<Declare binary action...@>=
20461 void mp_dep_div (MP mp,pointer p, scaled v) {
20462 pointer q; /* the dependency list being divided by |v| */
20463 small_number s,t; /* its type, before and after */
20464 if ( p==null ) q=mp->cur_exp;
20465 else if ( type(p)!=mp_known ) q=p;
20466 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20467 t=type(q); q=dep_list(q); s=t;
20468 if ( t==mp_dependent )
20469 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20470 t=mp_proto_dependent;
20471 q=mp_p_over_v(mp, q,v,s,t);
20472 mp_dep_finish(mp, q,p,t);
20475 @ @<Squeal about division by zero@>=
20477 exp_err("Division by zero");
20478 @.Division by zero@>
20479 help2("You're trying to divide the quantity shown above the error")
20480 ("message by zero. I'm going to divide it by one instead.");
20481 mp_put_get_error(mp);
20484 @ @<Additional cases of binary operators@>=
20487 if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
20488 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20489 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20490 } else mp_bad_binary(mp, p,c);
20493 @ The next few sections of the program deal with affine transformations
20494 of coordinate data.
20496 @<Additional cases of binary operators@>=
20497 case rotated_by: case slanted_by:
20498 case scaled_by: case shifted_by: case transformed_by:
20499 case x_scaled: case y_scaled: case z_scaled:
20500 if ( type(p)==mp_path_type ) {
20501 path_trans(c,p); binary_return;
20502 } else if ( type(p)==mp_pen_type ) {
20504 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20505 /* rounding error could destroy convexity */
20507 } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
20508 mp_big_trans(mp, p,c);
20509 } else if ( type(p)==mp_picture_type ) {
20510 mp_do_edges_trans(mp, p,c); binary_return;
20512 mp_bad_binary(mp, p,c);
20516 @ Let |c| be one of the eight transform operators. The procedure call
20517 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20518 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20519 change at all if |c=transformed_by|.)
20521 Then, if all components of the resulting transform are |known|, they are
20522 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20523 and |cur_exp| is changed to the known value zero.
20525 @<Declare binary action...@>=
20526 void mp_set_up_trans (MP mp,quarterword c) {
20527 pointer p,q,r; /* list manipulation registers */
20528 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20529 @<Put the current transform into |cur_exp|@>;
20531 @<If the current transform is entirely known, stash it in global variables;
20532 otherwise |return|@>;
20541 scaled ty; /* current transform coefficients */
20543 @ @<Put the current transform...@>=
20545 p=mp_stash_cur_exp(mp);
20546 mp->cur_exp=mp_id_transform(mp);
20547 mp->cur_type=mp_transform_type;
20548 q=value(mp->cur_exp);
20550 @<For each of the eight cases, change the relevant fields of |cur_exp|
20552 but do nothing if capsule |p| doesn't have the appropriate type@>;
20553 }; /* there are no other cases */
20554 mp_disp_err(mp, p,"Improper transformation argument");
20555 @.Improper transformation argument@>
20556 help3("The expression shown above has the wrong type,")
20557 ("so I can\'t transform anything using it.")
20558 ("Proceed, and I'll omit the transformation.");
20559 mp_put_get_error(mp);
20561 mp_recycle_value(mp, p);
20562 mp_free_node(mp, p,value_node_size);
20565 @ @<If the current transform is entirely known, ...@>=
20566 q=value(mp->cur_exp); r=q+transform_node_size;
20569 if ( type(r)!=mp_known ) return;
20571 mp->txx=value(xx_part_loc(q));
20572 mp->txy=value(xy_part_loc(q));
20573 mp->tyx=value(yx_part_loc(q));
20574 mp->tyy=value(yy_part_loc(q));
20575 mp->tx=value(x_part_loc(q));
20576 mp->ty=value(y_part_loc(q));
20577 mp_flush_cur_exp(mp, 0)
20579 @ @<For each of the eight cases...@>=
20581 if ( type(p)==mp_known )
20582 @<Install sines and cosines, then |goto done|@>;
20585 if ( type(p)>mp_pair_type ) {
20586 mp_install(mp, xy_part_loc(q),p); goto DONE;
20590 if ( type(p)>mp_pair_type ) {
20591 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20596 if ( type(p)==mp_pair_type ) {
20597 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20598 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20602 if ( type(p)>mp_pair_type ) {
20603 mp_install(mp, xx_part_loc(q),p); goto DONE;
20607 if ( type(p)>mp_pair_type ) {
20608 mp_install(mp, yy_part_loc(q),p); goto DONE;
20612 if ( type(p)==mp_pair_type )
20613 @<Install a complex multiplier, then |goto done|@>;
20615 case transformed_by:
20619 @ @<Install sines and cosines, then |goto done|@>=
20620 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20621 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20622 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20623 value(xy_part_loc(q))=-value(yx_part_loc(q));
20624 value(yy_part_loc(q))=value(xx_part_loc(q));
20628 @ @<Install a complex multiplier, then |goto done|@>=
20631 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20632 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20633 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20634 if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20635 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20636 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20640 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20641 insists that the transformation be entirely known.
20643 @<Declare binary action...@>=
20644 void mp_set_up_known_trans (MP mp,quarterword c) {
20645 mp_set_up_trans(mp, c);
20646 if ( mp->cur_type!=mp_known ) {
20647 exp_err("Transform components aren't all known");
20648 @.Transform components...@>
20649 help3("I'm unable to apply a partially specified transformation")
20650 ("except to a fully known pair or transform.")
20651 ("Proceed, and I'll omit the transformation.");
20652 mp_put_get_flush_error(mp, 0);
20653 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20654 mp->tx=0; mp->ty=0;
20658 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20659 coordinates in locations |p| and~|q|.
20661 @<Declare binary action...@>=
20662 void mp_trans (MP mp,pointer p, pointer q) {
20663 scaled v; /* the new |x| value */
20664 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20665 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20666 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20667 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20671 @ The simplest transformation procedure applies a transform to all
20672 coordinates of a path. The |path_trans(c)(p)| macro applies
20673 a transformation defined by |cur_exp| and the transform operator |c|
20676 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20677 mp_unstash_cur_exp(mp, (B));
20678 mp_do_path_trans(mp, mp->cur_exp); }
20680 @<Declare binary action...@>=
20681 void mp_do_path_trans (MP mp,pointer p) {
20682 pointer q; /* list traverser */
20685 if ( left_type(q)!=mp_endpoint )
20686 mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
20687 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20688 if ( right_type(q)!=mp_endpoint )
20689 mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
20690 @^data structure assumptions@>
20695 @ Transforming a pen is very similar, except that there are no |left_type|
20696 and |right_type| fields.
20698 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20699 mp_unstash_cur_exp(mp, (B));
20700 mp_do_pen_trans(mp, mp->cur_exp); }
20702 @<Declare binary action...@>=
20703 void mp_do_pen_trans (MP mp,pointer p) {
20704 pointer q; /* list traverser */
20705 if ( pen_is_elliptical(p) ) {
20706 mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
20707 mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
20711 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20712 @^data structure assumptions@>
20717 @ The next transformation procedure applies to edge structures. It will do
20718 any transformation, but the results may be substandard if the picture contains
20719 text that uses downloaded bitmap fonts. The binary action procedure is
20720 |do_edges_trans|, but we also need a function that just scales a picture.
20721 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20722 should be thought of as procedures that update an edge structure |h|, except
20723 that they have to return a (possibly new) structure because of the need to call
20726 @<Declare binary action...@>=
20727 pointer mp_edges_trans (MP mp, pointer h) {
20728 pointer q; /* the object being transformed */
20729 pointer r,s; /* for list manipulation */
20730 scaled sx,sy; /* saved transformation parameters */
20731 scaled sqdet; /* square root of determinant for |dash_scale| */
20732 integer sgndet; /* sign of the determinant */
20733 scaled v; /* a temporary value */
20734 h=mp_private_edges(mp, h);
20735 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20736 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20737 if ( dash_list(h)!=null_dash ) {
20738 @<Try to transform the dash list of |h|@>;
20740 @<Make the bounding box of |h| unknown if it can't be updated properly
20741 without scanning the whole structure@>;
20742 q=link(dummy_loc(h));
20743 while ( q!=null ) {
20744 @<Transform graphical object |q|@>;
20749 void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20750 mp_set_up_known_trans(mp, c);
20751 value(p)=mp_edges_trans(mp, value(p));
20752 mp_unstash_cur_exp(mp, p);
20754 void mp_scale_edges (MP mp) {
20755 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20756 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20757 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20760 @ @<Try to transform the dash list of |h|@>=
20761 if ( (mp->txy!=0)||(mp->tyx!=0)||
20762 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20763 mp_flush_dash_list(mp, h);
20765 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20766 @<Scale the dash list by |txx| and shift it by |tx|@>;
20767 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20770 @ @<Reverse the dash list of |h|@>=
20773 dash_list(h)=null_dash;
20774 while ( r!=null_dash ) {
20776 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20777 link(s)=dash_list(h);
20782 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20784 while ( r!=null_dash ) {
20785 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20786 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20790 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20791 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20792 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20793 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20794 mp_init_bbox(mp, h);
20797 if ( minx_val(h)<=maxx_val(h) ) {
20798 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20805 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20807 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20808 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20811 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20814 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20816 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20817 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20818 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20819 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20820 if ( mp->txx+mp->txy<0 ) {
20821 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20823 if ( mp->tyx+mp->tyy<0 ) {
20824 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20828 @ Now we ready for the main task of transforming the graphical objects in edge
20831 @<Transform graphical object |q|@>=
20833 case mp_fill_code: case mp_stroked_code:
20834 mp_do_path_trans(mp, path_p(q));
20835 @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20837 case mp_start_clip_code: case mp_start_bounds_code:
20838 mp_do_path_trans(mp, path_p(q));
20842 @<Transform the compact transformation starting at |r|@>;
20844 case mp_stop_clip_code: case mp_stop_bounds_code:
20846 } /* there are no other cases */
20848 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20849 The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
20850 since the \ps\ output procedures will try to compensate for the transformation
20851 we are applying to |pen_p(q)|. Since this compensation is based on the square
20852 root of the determinant, |sqdet| is the appropriate factor.
20854 @<Transform |pen_p(q)|, making sure...@>=
20855 if ( pen_p(q)!=null ) {
20856 sx=mp->tx; sy=mp->ty;
20857 mp->tx=0; mp->ty=0;
20858 mp_do_pen_trans(mp, pen_p(q));
20859 if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
20860 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20861 if ( ! pen_is_elliptical(pen_p(q)) )
20863 pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
20864 /* this unreverses the pen */
20865 mp->tx=sx; mp->ty=sy;
20868 @ This uses the fact that transformations are stored in the order
20869 |(tx,ty,txx,txy,tyx,tyy)|.
20870 @^data structure assumptions@>
20872 @<Transform the compact transformation starting at |r|@>=
20873 mp_trans(mp, r,r+1);
20874 sx=mp->tx; sy=mp->ty;
20875 mp->tx=0; mp->ty=0;
20876 mp_trans(mp, r+2,r+4);
20877 mp_trans(mp, r+3,r+5);
20878 mp->tx=sx; mp->ty=sy
20880 @ The hard cases of transformation occur when big nodes are involved,
20881 and when some of their components are unknown.
20883 @<Declare binary action...@>=
20884 @<Declare subroutines needed by |big_trans|@>
20885 void mp_big_trans (MP mp,pointer p, quarterword c) {
20886 pointer q,r,pp,qq; /* list manipulation registers */
20887 small_number s; /* size of a big node */
20888 s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
20891 if ( type(r)!=mp_known ) {
20892 @<Transform an unknown big node and |return|@>;
20895 @<Transform a known big node@>;
20896 } /* node |p| will now be recycled by |do_binary| */
20898 @ @<Transform an unknown big node and |return|@>=
20900 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20901 r=value(mp->cur_exp);
20902 if ( mp->cur_type==mp_transform_type ) {
20903 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20904 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20905 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20906 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20908 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20909 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20913 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20914 and let |q| point to a another value field. The |bilin1| procedure
20915 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20917 @<Declare subroutines needed by |big_trans|@>=
20918 void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20919 scaled u, scaled delta) {
20920 pointer r; /* list traverser */
20921 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20923 if ( type(q)==mp_known ) {
20924 delta+=mp_take_scaled(mp, value(q),u);
20926 @<Ensure that |type(p)=mp_proto_dependent|@>;
20927 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20928 mp_proto_dependent,type(q));
20931 if ( type(p)==mp_known ) {
20935 while ( info(r)!=null ) r=link(r);
20937 if ( r!=dep_list(p) ) value(r)=delta;
20938 else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
20940 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20943 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
20944 if ( type(p)!=mp_proto_dependent ) {
20945 if ( type(p)==mp_known )
20946 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
20948 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
20949 mp_proto_dependent,true);
20950 type(p)=mp_proto_dependent;
20953 @ @<Transform a known big node@>=
20954 mp_set_up_trans(mp, c);
20955 if ( mp->cur_type==mp_known ) {
20956 @<Transform known by known@>;
20958 pp=mp_stash_cur_exp(mp); qq=value(pp);
20959 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20960 if ( mp->cur_type==mp_transform_type ) {
20961 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
20962 value(xy_part_loc(q)),yx_part_loc(qq),null);
20963 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
20964 value(xx_part_loc(q)),yx_part_loc(qq),null);
20965 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
20966 value(yy_part_loc(q)),xy_part_loc(qq),null);
20967 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
20968 value(yx_part_loc(q)),xy_part_loc(qq),null);
20970 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
20971 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
20972 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
20973 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
20974 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
20977 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
20978 at |dep_final|. The following procedure adds |v| times another
20979 numeric quantity to~|p|.
20981 @<Declare subroutines needed by |big_trans|@>=
20982 void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
20983 if ( type(r)==mp_known ) {
20984 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
20986 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
20987 mp_proto_dependent,type(r));
20988 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20992 @ The |bilin2| procedure is something like |bilin1|, but with known
20993 and unknown quantities reversed. Parameter |p| points to a value field
20994 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
20995 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
20996 unless it is |null| (which stands for zero). Location~|p| will be
20997 replaced by $p\cdot t+v\cdot u+q$.
20999 @<Declare subroutines needed by |big_trans|@>=
21000 void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
21001 pointer u, pointer q) {
21002 scaled vv; /* temporary storage for |value(p)| */
21003 vv=value(p); type(p)=mp_proto_dependent;
21004 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
21006 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
21007 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
21008 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
21009 if ( dep_list(p)==mp->dep_final ) {
21010 vv=value(mp->dep_final); mp_recycle_value(mp, p);
21011 type(p)=mp_known; value(p)=vv;
21015 @ @<Transform known by known@>=
21017 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
21018 if ( mp->cur_type==mp_transform_type ) {
21019 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
21020 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
21021 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
21022 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
21024 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
21025 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
21028 @ Finally, in |bilin3| everything is |known|.
21030 @<Declare subroutines needed by |big_trans|@>=
21031 void mp_bilin3 (MP mp,pointer p, scaled t,
21032 scaled v, scaled u, scaled delta) {
21034 delta+=mp_take_scaled(mp, value(p),t);
21037 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
21038 else value(p)=delta;
21041 @ @<Additional cases of binary operators@>=
21043 if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
21044 else mp_bad_binary(mp, p,concatenate);
21047 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
21048 mp_chop_string(mp, value(p));
21049 else mp_bad_binary(mp, p,substring_of);
21052 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21053 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
21054 mp_chop_path(mp, value(p));
21055 else mp_bad_binary(mp, p,subpath_of);
21058 @ @<Declare binary action...@>=
21059 void mp_cat (MP mp,pointer p) {
21060 str_number a,b; /* the strings being concatenated */
21061 pool_pointer k; /* index into |str_pool| */
21062 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
21063 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
21064 append_char(mp->str_pool[k]);
21066 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
21067 append_char(mp->str_pool[k]);
21069 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
21072 @ @<Declare binary action...@>=
21073 void mp_chop_string (MP mp,pointer p) {
21074 integer a, b; /* start and stop points */
21075 integer l; /* length of the original string */
21076 integer k; /* runs from |a| to |b| */
21077 str_number s; /* the original string */
21078 boolean reversed; /* was |a>b|? */
21079 a=mp_round_unscaled(mp, value(x_part_loc(p)));
21080 b=mp_round_unscaled(mp, value(y_part_loc(p)));
21081 if ( a<=b ) reversed=false;
21082 else { reversed=true; k=a; a=b; b=k; };
21083 s=mp->cur_exp; l=length(s);
21094 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
21095 append_char(mp->str_pool[k]);
21098 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
21099 append_char(mp->str_pool[k]);
21102 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
21105 @ @<Declare binary action...@>=
21106 void mp_chop_path (MP mp,pointer p) {
21107 pointer q; /* a knot in the original path */
21108 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
21109 scaled a,b,k,l; /* indices for chopping */
21110 boolean reversed; /* was |a>b|? */
21111 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
21112 if ( a<=b ) reversed=false;
21113 else { reversed=true; k=a; a=b; b=k; };
21114 @<Dispense with the cases |a<0| and/or |b>l|@>;
21116 while ( a>=unity ) {
21117 q=link(q); a=a-unity; b=b-unity;
21120 @<Construct a path from |pp| to |qq| of length zero@>;
21122 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
21124 left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; link(qq)=pp;
21125 mp_toss_knot_list(mp, mp->cur_exp);
21127 mp->cur_exp=link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
21133 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
21135 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21136 a=0; if ( b<0 ) b=0;
21138 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
21142 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21143 b=l; if ( a>l ) a=l;
21151 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
21153 pp=mp_copy_knot(mp, q); qq=pp;
21155 q=link(q); rr=qq; qq=mp_copy_knot(mp, q); link(rr)=qq; b=b-unity;
21158 ss=pp; pp=link(pp);
21159 mp_split_cubic(mp, ss,a*010000); pp=link(ss);
21160 mp_free_node(mp, ss,knot_node_size);
21162 b=mp_make_scaled(mp, b,unity-a); rr=pp;
21166 mp_split_cubic(mp, rr,(b+unity)*010000);
21167 mp_free_node(mp, qq,knot_node_size);
21172 @ @<Construct a path from |pp| to |qq| of length zero@>=
21174 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=link(q); };
21175 pp=mp_copy_knot(mp, q); qq=pp;
21178 @ @<Additional cases of binary operators@>=
21179 case point_of: case precontrol_of: case postcontrol_of:
21180 if ( mp->cur_type==mp_pair_type )
21181 mp_pair_to_path(mp);
21182 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21183 mp_find_point(mp, value(p),c);
21185 mp_bad_binary(mp, p,c);
21187 case pen_offset_of:
21188 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
21189 mp_set_up_offset(mp, value(p));
21191 mp_bad_binary(mp, p,pen_offset_of);
21193 case direction_time_of:
21194 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21195 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
21196 mp_set_up_direction_time(mp, value(p));
21198 mp_bad_binary(mp, p,direction_time_of);
21201 if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
21202 mp_bad_binary(mp, p,envelope_of);
21204 mp_set_up_envelope(mp, p);
21207 @ @<Declare binary action...@>=
21208 void mp_set_up_offset (MP mp,pointer p) {
21209 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
21210 mp_pair_value(mp, mp->cur_x,mp->cur_y);
21212 void mp_set_up_direction_time (MP mp,pointer p) {
21213 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
21214 value(y_part_loc(p)),mp->cur_exp));
21216 void mp_set_up_envelope (MP mp,pointer p) {
21217 small_number ljoin, lcap;
21219 pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
21220 /* TODO: accept elliptical pens for straight paths */
21221 if (pen_is_elliptical(value(p))) {
21222 mp_bad_envelope_pen(mp);
21224 mp->cur_type = mp_path_type;
21227 if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
21228 else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
21230 if ( mp->internal[mp_linecap]>unity ) lcap=2;
21231 else if ( mp->internal[mp_linecap]>0 ) lcap=1;
21233 if ( mp->internal[mp_miterlimit]<unity )
21236 miterlim=mp->internal[mp_miterlimit];
21237 mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
21238 mp->cur_type = mp_path_type;
21241 @ @<Declare binary action...@>=
21242 void mp_find_point (MP mp,scaled v, quarterword c) {
21243 pointer p; /* the path */
21244 scaled n; /* its length */
21246 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
21247 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
21250 } else if ( v<0 ) {
21251 if ( left_type(p)==mp_endpoint ) v=0;
21252 else v=n-1-((-v-1) % n);
21253 } else if ( v>n ) {
21254 if ( left_type(p)==mp_endpoint ) v=n;
21258 while ( v>=unity ) { p=link(p); v=v-unity; };
21260 @<Insert a fractional node by splitting the cubic@>;
21262 @<Set the current expression to the desired path coordinates@>;
21265 @ @<Insert a fractional node...@>=
21266 { mp_split_cubic(mp, p,v*010000); p=link(p); }
21268 @ @<Set the current expression to the desired path coordinates...@>=
21271 mp_pair_value(mp, x_coord(p),y_coord(p));
21273 case precontrol_of:
21274 if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21275 else mp_pair_value(mp, left_x(p),left_y(p));
21277 case postcontrol_of:
21278 if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21279 else mp_pair_value(mp, right_x(p),right_y(p));
21281 } /* there are no other cases */
21283 @ @<Additional cases of binary operators@>=
21285 if ( mp->cur_type==mp_pair_type )
21286 mp_pair_to_path(mp);
21287 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21288 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21290 mp_bad_binary(mp, p,c);
21293 @ @<Additional cases of bin...@>=
21295 if ( type(p)==mp_pair_type ) {
21296 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21297 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21299 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21300 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
21301 mp_path_intersection(mp, value(p),mp->cur_exp);
21302 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21304 mp_bad_binary(mp, p,intersect);
21308 @ @<Additional cases of bin...@>=
21310 if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
21311 mp_bad_binary(mp, p,in_font);
21312 else { mp_do_infont(mp, p); binary_return; }
21315 @ Function |new_text_node| owns the reference count for its second argument
21316 (the text string) but not its first (the font name).
21318 @<Declare binary action...@>=
21319 void mp_do_infont (MP mp,pointer p) {
21321 q=mp_get_node(mp, edge_header_size);
21322 mp_init_edges(mp, q);
21323 link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
21324 obj_tail(q)=link(obj_tail(q));
21325 mp_free_node(mp, p,value_node_size);
21326 mp_flush_cur_exp(mp, q);
21327 mp->cur_type=mp_picture_type;
21330 @* \[40] Statements and commands.
21331 The chief executive of \MP\ is the |do_statement| routine, which
21332 contains the master switch that causes all the various pieces of \MP\
21333 to do their things, in the right order.
21335 In a sense, this is the grand climax of the program: It applies all the
21336 tools that we have worked so hard to construct. In another sense, this is
21337 the messiest part of the program: It necessarily refers to other pieces
21338 of code all over the place, so that a person can't fully understand what is
21339 going on without paging back and forth to be reminded of conventions that
21340 are defined elsewhere. We are now at the hub of the web.
21342 The structure of |do_statement| itself is quite simple. The first token
21343 of the statement is fetched using |get_x_next|. If it can be the first
21344 token of an expression, we look for an equation, an assignment, or a
21345 title. Otherwise we use a \&{case} construction to branch at high speed to
21346 the appropriate routine for various and sundry other types of commands,
21347 each of which has an ``action procedure'' that does the necessary work.
21349 The program uses the fact that
21350 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21351 to interpret a statement that starts with, e.g., `\&{string}',
21352 as a type declaration rather than a boolean expression.
21354 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21355 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21356 if ( mp->cur_cmd>max_primary_command ) {
21357 @<Worry about bad statement@>;
21358 } else if ( mp->cur_cmd>max_statement_command ) {
21359 @<Do an equation, assignment, title, or
21360 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21362 @<Do a statement that doesn't begin with an expression@>;
21364 if ( mp->cur_cmd<semicolon )
21365 @<Flush unparsable junk that was found after the statement@>;
21369 @ @<Declarations@>=
21370 @<Declare action procedures for use by |do_statement|@>
21372 @ The only command codes |>max_primary_command| that can be present
21373 at the beginning of a statement are |semicolon| and higher; these
21374 occur when the statement is null.
21376 @<Worry about bad statement@>=
21378 if ( mp->cur_cmd<semicolon ) {
21379 print_err("A statement can't begin with `");
21380 @.A statement can't begin with x@>
21381 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, '\'');
21382 help5("I was looking for the beginning of a new statement.")
21383 ("If you just proceed without changing anything, I'll ignore")
21384 ("everything up to the next `;'. Please insert a semicolon")
21385 ("now in front of anything that you don't want me to delete.")
21386 ("(See Chapter 27 of The METAFONTbook for an example.)");
21387 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21388 mp_back_error(mp); mp_get_x_next(mp);
21392 @ The help message printed here says that everything is flushed up to
21393 a semicolon, but actually the commands |end_group| and |stop| will
21394 also terminate a statement.
21396 @<Flush unparsable junk that was found after the statement@>=
21398 print_err("Extra tokens will be flushed");
21399 @.Extra tokens will be flushed@>
21400 help6("I've just read as much of that statement as I could fathom,")
21401 ("so a semicolon should have been next. It's very puzzling...")
21402 ("but I'll try to get myself back together, by ignoring")
21403 ("everything up to the next `;'. Please insert a semicolon")
21404 ("now in front of anything that you don't want me to delete.")
21405 ("(See Chapter 27 of The METAFONTbook for an example.)");
21406 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21407 mp_back_error(mp); mp->scanner_status=flushing;
21410 @<Decrease the string reference count...@>;
21411 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21412 mp->scanner_status=normal;
21415 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21416 |cur_type=mp_vacuous| unless the statement was simply an expression;
21417 in the latter case, |cur_type| and |cur_exp| should represent that
21420 @<Do a statement that doesn't...@>=
21422 if ( mp->internal[mp_tracing_commands]>0 )
21424 switch (mp->cur_cmd ) {
21425 case type_name:mp_do_type_declaration(mp); break;
21427 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21428 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21430 @<Cases of |do_statement| that invoke particular commands@>;
21431 } /* there are no other cases */
21432 mp->cur_type=mp_vacuous;
21435 @ The most important statements begin with expressions.
21437 @<Do an equation, assignment, title, or...@>=
21439 mp->var_flag=assignment; mp_scan_expression(mp);
21440 if ( mp->cur_cmd<end_group ) {
21441 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21442 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21443 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21444 else if ( mp->cur_type!=mp_vacuous ){
21445 exp_err("Isolated expression");
21446 @.Isolated expression@>
21447 help3("I couldn't find an `=' or `:=' after the")
21448 ("expression that is shown above this error message,")
21449 ("so I guess I'll just ignore it and carry on.");
21450 mp_put_get_error(mp);
21452 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21458 if ( mp->internal[mp_tracing_titles]>0 ) {
21459 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21463 @ Equations and assignments are performed by the pair of mutually recursive
21465 routines |do_equation| and |do_assignment|. These routines are called when
21466 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21467 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21468 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21469 will be equal to the right-hand side (which will normally be equal
21470 to the left-hand side).
21472 @<Declare action procedures for use by |do_statement|@>=
21473 @<Declare the procedure called |try_eq|@>
21474 @<Declare the procedure called |make_eq|@>
21475 void mp_do_equation (MP mp) ;
21478 void mp_do_equation (MP mp) {
21479 pointer lhs; /* capsule for the left-hand side */
21480 pointer p; /* temporary register */
21481 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21482 mp->var_flag=assignment; mp_scan_expression(mp);
21483 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21484 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21485 if ( mp->internal[mp_tracing_commands]>two )
21486 @<Trace the current equation@>;
21487 if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
21488 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21489 }; /* in this case |make_eq| will change the pair to a path */
21490 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21493 @ And |do_assignment| is similar to |do_equation|:
21496 void mp_do_assignment (MP mp);
21498 @ @<Declare action procedures for use by |do_statement|@>=
21499 void mp_do_assignment (MP mp) ;
21502 void mp_do_assignment (MP mp) {
21503 pointer lhs; /* token list for the left-hand side */
21504 pointer p; /* where the left-hand value is stored */
21505 pointer q; /* temporary capsule for the right-hand value */
21506 if ( mp->cur_type!=mp_token_list ) {
21507 exp_err("Improper `:=' will be changed to `='");
21509 help2("I didn't find a variable name at the left of the `:=',")
21510 ("so I'm going to pretend that you said `=' instead.");
21511 mp_error(mp); mp_do_equation(mp);
21513 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21514 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21515 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21516 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21517 if ( mp->internal[mp_tracing_commands]>two )
21518 @<Trace the current assignment@>;
21519 if ( info(lhs)>hash_end ) {
21520 @<Assign the current expression to an internal variable@>;
21522 @<Assign the current expression to the variable |lhs|@>;
21524 mp_flush_node_list(mp, lhs);
21528 @ @<Trace the current equation@>=
21530 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21531 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21532 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21535 @ @<Trace the current assignment@>=
21537 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21538 if ( info(lhs)>hash_end )
21539 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21541 mp_show_token_list(mp, lhs,null,1000,0);
21542 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21543 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
21546 @ @<Assign the current expression to an internal variable@>=
21547 if ( mp->cur_type==mp_known ) {
21548 mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
21550 exp_err("Internal quantity `");
21551 @.Internal quantity...@>
21552 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21553 mp_print(mp, "' must receive a known value");
21554 help2("I can\'t set an internal quantity to anything but a known")
21555 ("numeric value, so I'll have to ignore this assignment.");
21556 mp_put_get_error(mp);
21559 @ @<Assign the current expression to the variable |lhs|@>=
21561 p=mp_find_variable(mp, lhs);
21563 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21564 mp_recycle_value(mp, p);
21565 type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21566 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21568 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21573 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21574 a pointer to a capsule that is to be equated to the current expression.
21576 @<Declare the procedure called |make_eq|@>=
21577 void mp_make_eq (MP mp,pointer lhs) ;
21581 @c void mp_make_eq (MP mp,pointer lhs) {
21582 small_number t; /* type of the left-hand side */
21583 pointer p,q; /* pointers inside of big nodes */
21584 integer v=0; /* value of the left-hand side */
21587 if ( t<=mp_pair_type ) v=value(lhs);
21589 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21590 is incompatible with~|t|@>;
21591 } /* all cases have been listed */
21592 @<Announce that the equation cannot be performed@>;
21594 check_arith; mp_recycle_value(mp, lhs);
21595 mp_free_node(mp, lhs,value_node_size);
21598 @ @<Announce that the equation cannot be performed@>=
21599 mp_disp_err(mp, lhs,"");
21600 exp_err("Equation cannot be performed (");
21601 @.Equation cannot be performed@>
21602 if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
21603 else mp_print(mp, "numeric");
21604 mp_print_char(mp, '=');
21605 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21606 else mp_print(mp, "numeric");
21607 mp_print_char(mp, ')');
21608 help2("I'm sorry, but I don't know how to make such things equal.")
21609 ("(See the two expressions just above the error message.)");
21610 mp_put_get_error(mp)
21612 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21613 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21614 case mp_path_type: case mp_picture_type:
21615 if ( mp->cur_type==t+unknown_tag ) {
21616 mp_nonlinear_eq(mp, v,mp->cur_exp,false);
21617 mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
21618 } else if ( mp->cur_type==t ) {
21619 @<Report redundant or inconsistent equation and |goto done|@>;
21622 case unknown_types:
21623 if ( mp->cur_type==t-unknown_tag ) {
21624 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21625 } else if ( mp->cur_type==t ) {
21626 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21627 } else if ( mp->cur_type==mp_pair_type ) {
21628 if ( t==mp_unknown_path ) {
21629 mp_pair_to_path(mp); goto RESTART;
21633 case mp_transform_type: case mp_color_type:
21634 case mp_cmykcolor_type: case mp_pair_type:
21635 if ( mp->cur_type==t ) {
21636 @<Do multiple equations and |goto done|@>;
21639 case mp_known: case mp_dependent:
21640 case mp_proto_dependent: case mp_independent:
21641 if ( mp->cur_type>=mp_known ) {
21642 mp_try_eq(mp, lhs,null); goto DONE;
21648 @ @<Report redundant or inconsistent equation and |goto done|@>=
21650 if ( mp->cur_type<=mp_string_type ) {
21651 if ( mp->cur_type==mp_string_type ) {
21652 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21655 } else if ( v!=mp->cur_exp ) {
21658 @<Exclaim about a redundant equation@>; goto DONE;
21660 print_err("Redundant or inconsistent equation");
21661 @.Redundant or inconsistent equation@>
21662 help2("An equation between already-known quantities can't help.")
21663 ("But don't worry; continue and I'll just ignore it.");
21664 mp_put_get_error(mp); goto DONE;
21666 print_err("Inconsistent equation");
21667 @.Inconsistent equation@>
21668 help2("The equation I just read contradicts what was said before.")
21669 ("But don't worry; continue and I'll just ignore it.");
21670 mp_put_get_error(mp); goto DONE;
21673 @ @<Do multiple equations and |goto done|@>=
21675 p=v+mp->big_node_size[t];
21676 q=value(mp->cur_exp)+mp->big_node_size[t];
21678 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21683 @ The first argument to |try_eq| is the location of a value node
21684 in a capsule that will soon be recycled. The second argument is
21685 either a location within a pair or transform node pointed to by
21686 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21687 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21688 but to equate the two operands.
21690 @<Declare the procedure called |try_eq|@>=
21691 void mp_try_eq (MP mp,pointer l, pointer r) ;
21694 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21695 pointer p; /* dependency list for right operand minus left operand */
21696 int t; /* the type of list |p| */
21697 pointer q; /* the constant term of |p| is here */
21698 pointer pp; /* dependency list for right operand */
21699 int tt; /* the type of list |pp| */
21700 boolean copied; /* have we copied a list that ought to be recycled? */
21701 @<Remove the left operand from its container, negate it, and
21702 put it into dependency list~|p| with constant term~|q|@>;
21703 @<Add the right operand to list |p|@>;
21704 if ( info(p)==null ) {
21705 @<Deal with redundant or inconsistent equation@>;
21707 mp_linear_eq(mp, p,t);
21708 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21709 if ( type(mp->cur_exp)==mp_known ) {
21710 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21711 mp_free_node(mp, pp,value_node_size);
21717 @ @<Remove the left operand from its container, negate it, and...@>=
21719 if ( t==mp_known ) {
21720 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21721 } else if ( t==mp_independent ) {
21722 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21725 p=dep_list(l); q=p;
21728 if ( info(q)==null ) break;
21731 link(prev_dep(l))=link(q); prev_dep(link(q))=prev_dep(l);
21735 @ @<Deal with redundant or inconsistent equation@>=
21737 if ( abs(value(p))>64 ) { /* off by .001 or more */
21738 print_err("Inconsistent equation");
21739 @.Inconsistent equation@>
21740 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21741 mp_print_char(mp, ')');
21742 help2("The equation I just read contradicts what was said before.")
21743 ("But don't worry; continue and I'll just ignore it.");
21744 mp_put_get_error(mp);
21745 } else if ( r==null ) {
21746 @<Exclaim about a redundant equation@>;
21748 mp_free_node(mp, p,dep_node_size);
21751 @ @<Add the right operand to list |p|@>=
21753 if ( mp->cur_type==mp_known ) {
21754 value(q)=value(q)+mp->cur_exp; goto DONE1;
21757 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21758 else pp=dep_list(mp->cur_exp);
21761 if ( type(r)==mp_known ) {
21762 value(q)=value(q)+value(r); goto DONE1;
21765 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21766 else pp=dep_list(r);
21769 if ( tt!=mp_independent ) copied=false;
21770 else { copied=true; tt=mp_dependent; };
21771 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21772 if ( copied ) mp_flush_node_list(mp, pp);
21775 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21776 mp->watch_coefs=false;
21778 p=mp_p_plus_q(mp, p,pp,t);
21779 } else if ( t==mp_proto_dependent ) {
21780 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21783 while ( info(q)!=null ) {
21784 value(q)=mp_round_fraction(mp, value(q)); q=link(q);
21786 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21788 mp->watch_coefs=true;
21790 @ Our next goal is to process type declarations. For this purpose it's
21791 convenient to have a procedure that scans a $\langle\,$declared
21792 variable$\,\rangle$ and returns the corresponding token list. After the
21793 following procedure has acted, the token after the declared variable
21794 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21797 @<Declare the function called |scan_declared_variable|@>=
21798 pointer mp_scan_declared_variable (MP mp) {
21799 pointer x; /* hash address of the variable's root */
21800 pointer h,t; /* head and tail of the token list to be returned */
21801 pointer l; /* hash address of left bracket */
21802 mp_get_symbol(mp); x=mp->cur_sym;
21803 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21804 h=mp_get_avail(mp); info(h)=x; t=h;
21807 if ( mp->cur_sym==0 ) break;
21808 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21809 if ( mp->cur_cmd==left_bracket ) {
21810 @<Descend past a collective subscript@>;
21815 link(t)=mp_get_avail(mp); t=link(t); info(t)=mp->cur_sym;
21817 if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
21818 if ( equiv(x)==null ) mp_new_root(mp, x);
21822 @ If the subscript isn't collective, we don't accept it as part of the
21825 @<Descend past a collective subscript@>=
21827 l=mp->cur_sym; mp_get_x_next(mp);
21828 if ( mp->cur_cmd!=right_bracket ) {
21829 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21831 mp->cur_sym=collective_subscript;
21835 @ Type declarations are introduced by the following primitive operations.
21838 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21839 @:numeric_}{\&{numeric} primitive@>
21840 mp_primitive(mp, "string",type_name,mp_string_type);
21841 @:string_}{\&{string} primitive@>
21842 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21843 @:boolean_}{\&{boolean} primitive@>
21844 mp_primitive(mp, "path",type_name,mp_path_type);
21845 @:path_}{\&{path} primitive@>
21846 mp_primitive(mp, "pen",type_name,mp_pen_type);
21847 @:pen_}{\&{pen} primitive@>
21848 mp_primitive(mp, "picture",type_name,mp_picture_type);
21849 @:picture_}{\&{picture} primitive@>
21850 mp_primitive(mp, "transform",type_name,mp_transform_type);
21851 @:transform_}{\&{transform} primitive@>
21852 mp_primitive(mp, "color",type_name,mp_color_type);
21853 @:color_}{\&{color} primitive@>
21854 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21855 @:color_}{\&{rgbcolor} primitive@>
21856 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21857 @:color_}{\&{cmykcolor} primitive@>
21858 mp_primitive(mp, "pair",type_name,mp_pair_type);
21859 @:pair_}{\&{pair} primitive@>
21861 @ @<Cases of |print_cmd...@>=
21862 case type_name: mp_print_type(mp, m); break;
21864 @ Now we are ready to handle type declarations, assuming that a
21865 |type_name| has just been scanned.
21867 @<Declare action procedures for use by |do_statement|@>=
21868 void mp_do_type_declaration (MP mp) ;
21871 void mp_do_type_declaration (MP mp) {
21872 small_number t; /* the type being declared */
21873 pointer p; /* token list for a declared variable */
21874 pointer q; /* value node for the variable */
21875 if ( mp->cur_mod>=mp_transform_type )
21878 t=mp->cur_mod+unknown_tag;
21880 p=mp_scan_declared_variable(mp);
21881 mp_flush_variable(mp, equiv(info(p)),link(p),false);
21882 q=mp_find_variable(mp, p);
21884 type(q)=t; value(q)=null;
21886 print_err("Declared variable conflicts with previous vardef");
21887 @.Declared variable conflicts...@>
21888 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")
21889 ("Proceed, and I'll ignore the illegal redeclaration.");
21890 mp_put_get_error(mp);
21892 mp_flush_list(mp, p);
21893 if ( mp->cur_cmd<comma ) {
21894 @<Flush spurious symbols after the declared variable@>;
21896 } while (! end_of_statement);
21899 @ @<Flush spurious symbols after the declared variable@>=
21901 print_err("Illegal suffix of declared variable will be flushed");
21902 @.Illegal suffix...flushed@>
21903 help5("Variables in declarations must consist entirely of")
21904 ("names and collective subscripts, e.g., `x[]a'.")
21905 ("Are you trying to use a reserved word in a variable name?")
21906 ("I'm going to discard the junk I found here,")
21907 ("up to the next comma or the end of the declaration.");
21908 if ( mp->cur_cmd==numeric_token )
21909 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21910 mp_put_get_error(mp); mp->scanner_status=flushing;
21913 @<Decrease the string reference count...@>;
21914 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21915 mp->scanner_status=normal;
21918 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21919 until coming to the end of the user's program.
21920 Each execution of |do_statement| concludes with
21921 |cur_cmd=semicolon|, |end_group|, or |stop|.
21923 @c void mp_main_control (MP mp) {
21925 mp_do_statement(mp);
21926 if ( mp->cur_cmd==end_group ) {
21927 print_err("Extra `endgroup'");
21928 @.Extra `endgroup'@>
21929 help2("I'm not currently working on a `begingroup',")
21930 ("so I had better not try to end anything.");
21931 mp_flush_error(mp, 0);
21933 } while (mp->cur_cmd!=stop);
21935 int __attribute__((noinline))
21937 if (mp->history < mp_fatal_error_stop ) {
21938 @<Install and test the non-local jump buffer@>;
21939 mp_main_control(mp); /* come to life */
21940 mp_final_cleanup(mp); /* prepare for death */
21941 mp_close_files_and_terminate(mp);
21943 return mp->history;
21945 int __attribute__((noinline))
21946 mp_execute (MP mp) {
21947 if (mp->history < mp_fatal_error_stop ) {
21948 mp->history = mp_spotless;
21949 mp->file_offset = 0;
21950 mp->term_offset = 0;
21952 @<Install and test the non-local jump buffer@>;
21953 if (mp->run_state==0) {
21956 mp_input_ln(mp,mp->term_in);
21957 mp_firm_up_the_line(mp);
21958 mp->buffer[limit]='%';
21963 mp_do_statement(mp);
21964 } while (mp->cur_cmd!=stop);
21966 return mp->history;
21968 int __attribute__((noinline))
21969 mp_finish (MP mp) {
21970 if (mp->history < mp_fatal_error_stop ) {
21971 @<Install and test the non-local jump buffer@>;
21972 mp_final_cleanup(mp); /* prepare for death */
21973 mp_close_files_and_terminate(mp);
21975 return mp->history;
21977 const char * mp_mplib_version (MP mp) {
21979 return mplib_version;
21981 const char * mp_metapost_version (MP mp) {
21983 return metapost_version;
21986 @ @<Exported function headers@>=
21987 int mp_run (MP mp);
21988 int mp_execute (MP mp);
21989 int mp_finish (MP mp);
21990 const char * mp_mplib_version (MP mp);
21991 const char * mp_metapost_version (MP mp);
21994 mp_primitive(mp, "end",stop,0);
21995 @:end_}{\&{end} primitive@>
21996 mp_primitive(mp, "dump",stop,1);
21997 @:dump_}{\&{dump} primitive@>
21999 @ @<Cases of |print_cmd...@>=
22001 if ( m==0 ) mp_print(mp, "end");
22002 else mp_print(mp, "dump");
22006 Let's turn now to statements that are classified as ``commands'' because
22007 of their imperative nature. We'll begin with simple ones, so that it
22008 will be clear how to hook command processing into the |do_statement| routine;
22009 then we'll tackle the tougher commands.
22011 Here's one of the simplest:
22013 @<Cases of |do_statement|...@>=
22014 case mp_random_seed: mp_do_random_seed(mp); break;
22016 @ @<Declare action procedures for use by |do_statement|@>=
22017 void mp_do_random_seed (MP mp) ;
22019 @ @c void mp_do_random_seed (MP mp) {
22021 if ( mp->cur_cmd!=assignment ) {
22022 mp_missing_err(mp, ":=");
22024 help1("Always say `randomseed:=<numeric expression>'.");
22027 mp_get_x_next(mp); mp_scan_expression(mp);
22028 if ( mp->cur_type!=mp_known ) {
22029 exp_err("Unknown value will be ignored");
22030 @.Unknown value...ignored@>
22031 help2("Your expression was too random for me to handle,")
22032 ("so I won't change the random seed just now.");
22033 mp_put_get_flush_error(mp, 0);
22035 @<Initialize the random seed to |cur_exp|@>;
22039 @ @<Initialize the random seed to |cur_exp|@>=
22041 mp_init_randoms(mp, mp->cur_exp);
22042 if ( mp->selector>=log_only && mp->selector<write_file) {
22043 mp->old_setting=mp->selector; mp->selector=log_only;
22044 mp_print_nl(mp, "{randomseed:=");
22045 mp_print_scaled(mp, mp->cur_exp);
22046 mp_print_char(mp, '}');
22047 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
22051 @ And here's another simple one (somewhat different in flavor):
22053 @<Cases of |do_statement|...@>=
22055 mp_print_ln(mp); mp->interaction=mp->cur_mod;
22056 @<Initialize the print |selector| based on |interaction|@>;
22057 if ( mp->log_opened ) mp->selector=mp->selector+2;
22062 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
22063 @:mp_batch_mode_}{\&{batchmode} primitive@>
22064 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
22065 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
22066 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
22067 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
22068 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
22069 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
22071 @ @<Cases of |print_cmd_mod|...@>=
22074 case mp_batch_mode: mp_print(mp, "batchmode"); break;
22075 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
22076 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
22077 default: mp_print(mp, "errorstopmode"); break;
22081 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
22083 @<Cases of |do_statement|...@>=
22084 case protection_command: mp_do_protection(mp); break;
22087 mp_primitive(mp, "inner",protection_command,0);
22088 @:inner_}{\&{inner} primitive@>
22089 mp_primitive(mp, "outer",protection_command,1);
22090 @:outer_}{\&{outer} primitive@>
22092 @ @<Cases of |print_cmd...@>=
22093 case protection_command:
22094 if ( m==0 ) mp_print(mp, "inner");
22095 else mp_print(mp, "outer");
22098 @ @<Declare action procedures for use by |do_statement|@>=
22099 void mp_do_protection (MP mp) ;
22101 @ @c void mp_do_protection (MP mp) {
22102 int m; /* 0 to unprotect, 1 to protect */
22103 halfword t; /* the |eq_type| before we change it */
22106 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
22108 if ( t>=outer_tag )
22109 eq_type(mp->cur_sym)=t-outer_tag;
22110 } else if ( t<outer_tag ) {
22111 eq_type(mp->cur_sym)=t+outer_tag;
22114 } while (mp->cur_cmd==comma);
22117 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
22118 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
22119 declaration assigns the command code |left_delimiter| to `\.{(}' and
22120 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
22121 hash address of its mate.
22123 @<Cases of |do_statement|...@>=
22124 case delimiters: mp_def_delims(mp); break;
22126 @ @<Declare action procedures for use by |do_statement|@>=
22127 void mp_def_delims (MP mp) ;
22129 @ @c void mp_def_delims (MP mp) {
22130 pointer l_delim,r_delim; /* the new delimiter pair */
22131 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
22132 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
22133 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
22134 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
22138 @ Here is a procedure that is called when \MP\ has reached a point
22139 where some right delimiter is mandatory.
22141 @<Declare the procedure called |check_delimiter|@>=
22142 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
22143 if ( mp->cur_cmd==right_delimiter )
22144 if ( mp->cur_mod==l_delim )
22146 if ( mp->cur_sym!=r_delim ) {
22147 mp_missing_err(mp, str(text(r_delim)));
22149 help2("I found no right delimiter to match a left one. So I've")
22150 ("put one in, behind the scenes; this may fix the problem.");
22153 print_err("The token `"); mp_print_text(r_delim);
22154 @.The token...delimiter@>
22155 mp_print(mp, "' is no longer a right delimiter");
22156 help3("Strange: This token has lost its former meaning!")
22157 ("I'll read it as a right delimiter this time;")
22158 ("but watch out, I'll probably miss it later.");
22163 @ The next four commands save or change the values associated with tokens.
22165 @<Cases of |do_statement|...@>=
22168 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
22169 } while (mp->cur_cmd==comma);
22171 case interim_command: mp_do_interim(mp); break;
22172 case let_command: mp_do_let(mp); break;
22173 case new_internal: mp_do_new_internal(mp); break;
22175 @ @<Declare action procedures for use by |do_statement|@>=
22176 void mp_do_statement (MP mp);
22177 void mp_do_interim (MP mp);
22179 @ @c void mp_do_interim (MP mp) {
22181 if ( mp->cur_cmd!=internal_quantity ) {
22182 print_err("The token `");
22183 @.The token...quantity@>
22184 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
22185 else mp_print_text(mp->cur_sym);
22186 mp_print(mp, "' isn't an internal quantity");
22187 help1("Something like `tracingonline' should follow `interim'.");
22190 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
22192 mp_do_statement(mp);
22195 @ The following procedure is careful not to undefine the left-hand symbol
22196 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
22198 @<Declare action procedures for use by |do_statement|@>=
22199 void mp_do_let (MP mp) ;
22201 @ @c void mp_do_let (MP mp) {
22202 pointer l; /* hash location of the left-hand symbol */
22203 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
22204 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
22205 mp_missing_err(mp, "=");
22207 help3("You should have said `let symbol = something'.")
22208 ("But don't worry; I'll pretend that an equals sign")
22209 ("was present. The next token I read will be `something'.");
22213 switch (mp->cur_cmd) {
22214 case defined_macro: case secondary_primary_macro:
22215 case tertiary_secondary_macro: case expression_tertiary_macro:
22216 add_mac_ref(mp->cur_mod);
22221 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
22222 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
22223 else equiv(l)=mp->cur_mod;
22227 @ @<Declarations@>=
22228 void mp_grow_internals (MP mp, int l);
22229 void mp_do_new_internal (MP mp) ;
22232 void mp_grow_internals (MP mp, int l) {
22236 if ( hash_end+l>max_halfword ) {
22237 mp_confusion(mp, "out of memory space"); /* can't be reached */
22239 int_name = xmalloc ((l+1),sizeof(char *));
22240 internal = xmalloc ((l+1),sizeof(scaled));
22241 for (k=0;k<=l; k++ ) {
22242 if (k<=mp->max_internal) {
22243 internal[k]=mp->internal[k];
22244 int_name[k]=mp->int_name[k];
22250 xfree(mp->internal); xfree(mp->int_name);
22251 mp->int_name = int_name;
22252 mp->internal = internal;
22253 mp->max_internal = l;
22257 void mp_do_new_internal (MP mp) {
22259 if ( mp->int_ptr==mp->max_internal ) {
22260 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal>>2)));
22262 mp_get_clear_symbol(mp); incr(mp->int_ptr);
22263 eq_type(mp->cur_sym)=internal_quantity;
22264 equiv(mp->cur_sym)=mp->int_ptr;
22265 if(mp->int_name[mp->int_ptr]!=NULL)
22266 xfree(mp->int_name[mp->int_ptr]);
22267 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
22268 mp->internal[mp->int_ptr]=0;
22270 } while (mp->cur_cmd==comma);
22273 @ @<Dealloc variables@>=
22274 for (k=0;k<=mp->max_internal;k++) {
22275 xfree(mp->int_name[k]);
22277 xfree(mp->internal);
22278 xfree(mp->int_name);
22281 @ The various `\&{show}' commands are distinguished by modifier fields
22284 @d show_token_code 0 /* show the meaning of a single token */
22285 @d show_stats_code 1 /* show current memory and string usage */
22286 @d show_code 2 /* show a list of expressions */
22287 @d show_var_code 3 /* show a variable and its descendents */
22288 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22291 mp_primitive(mp, "showtoken",show_command,show_token_code);
22292 @:show_token_}{\&{showtoken} primitive@>
22293 mp_primitive(mp, "showstats",show_command,show_stats_code);
22294 @:show_stats_}{\&{showstats} primitive@>
22295 mp_primitive(mp, "show",show_command,show_code);
22296 @:show_}{\&{show} primitive@>
22297 mp_primitive(mp, "showvariable",show_command,show_var_code);
22298 @:show_var_}{\&{showvariable} primitive@>
22299 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22300 @:show_dependencies_}{\&{showdependencies} primitive@>
22302 @ @<Cases of |print_cmd...@>=
22305 case show_token_code:mp_print(mp, "showtoken"); break;
22306 case show_stats_code:mp_print(mp, "showstats"); break;
22307 case show_code:mp_print(mp, "show"); break;
22308 case show_var_code:mp_print(mp, "showvariable"); break;
22309 default: mp_print(mp, "showdependencies"); break;
22313 @ @<Cases of |do_statement|...@>=
22314 case show_command:mp_do_show_whatever(mp); break;
22316 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22317 if it's |show_code|, complicated structures are abbreviated, otherwise
22320 @<Declare action procedures for use by |do_statement|@>=
22321 void mp_do_show (MP mp) ;
22323 @ @c void mp_do_show (MP mp) {
22325 mp_get_x_next(mp); mp_scan_expression(mp);
22326 mp_print_nl(mp, ">> ");
22328 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22329 } while (mp->cur_cmd==comma);
22332 @ @<Declare action procedures for use by |do_statement|@>=
22333 void mp_disp_token (MP mp) ;
22335 @ @c void mp_disp_token (MP mp) {
22336 mp_print_nl(mp, "> ");
22338 if ( mp->cur_sym==0 ) {
22339 @<Show a numeric or string or capsule token@>;
22341 mp_print_text(mp->cur_sym); mp_print_char(mp, '=');
22342 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22343 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22344 if ( mp->cur_cmd==defined_macro ) {
22345 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22346 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22351 @ @<Show a numeric or string or capsule token@>=
22353 if ( mp->cur_cmd==numeric_token ) {
22354 mp_print_scaled(mp, mp->cur_mod);
22355 } else if ( mp->cur_cmd==capsule_token ) {
22356 mp_print_capsule(mp,mp->cur_mod);
22358 mp_print_char(mp, '"');
22359 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, '"');
22360 delete_str_ref(mp->cur_mod);
22364 @ The following cases of |print_cmd_mod| might arise in connection
22365 with |disp_token|, although they don't necessarily correspond to
22368 @<Cases of |print_cmd_...@>=
22369 case left_delimiter:
22370 case right_delimiter:
22371 if ( c==left_delimiter ) mp_print(mp, "left");
22372 else mp_print(mp, "right");
22373 mp_print(mp, " delimiter that matches ");
22377 if ( m==null ) mp_print(mp, "tag");
22378 else mp_print(mp, "variable");
22380 case defined_macro:
22381 mp_print(mp, "macro:");
22383 case secondary_primary_macro:
22384 case tertiary_secondary_macro:
22385 case expression_tertiary_macro:
22386 mp_print_cmd_mod(mp, macro_def,c);
22387 mp_print(mp, "'d macro:");
22388 mp_print_ln(mp); mp_show_token_list(mp, link(link(m)),null,1000,0);
22391 mp_print(mp, "[repeat the loop]");
22393 case internal_quantity:
22394 mp_print(mp, mp->int_name[m]);
22397 @ @<Declare action procedures for use by |do_statement|@>=
22398 void mp_do_show_token (MP mp) ;
22400 @ @c void mp_do_show_token (MP mp) {
22402 get_t_next; mp_disp_token(mp);
22404 } while (mp->cur_cmd==comma);
22407 @ @<Declare action procedures for use by |do_statement|@>=
22408 void mp_do_show_stats (MP mp) ;
22410 @ @c void mp_do_show_stats (MP mp) {
22411 mp_print_nl(mp, "Memory usage ");
22412 @.Memory usage...@>
22413 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used);
22414 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22415 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22416 mp_print_nl(mp, "String usage ");
22417 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22418 mp_print_char(mp, '&'); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22419 mp_print(mp, " (");
22420 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, '&');
22421 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22422 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22426 @ Here's a recursive procedure that gives an abbreviated account
22427 of a variable, for use by |do_show_var|.
22429 @<Declare action procedures for use by |do_statement|@>=
22430 void mp_disp_var (MP mp,pointer p) ;
22432 @ @c void mp_disp_var (MP mp,pointer p) {
22433 pointer q; /* traverses attributes and subscripts */
22434 int n; /* amount of macro text to show */
22435 if ( type(p)==mp_structured ) {
22436 @<Descend the structure@>;
22437 } else if ( type(p)>=mp_unsuffixed_macro ) {
22438 @<Display a variable macro@>;
22439 } else if ( type(p)!=undefined ){
22440 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22441 mp_print_char(mp, '=');
22442 mp_print_exp(mp, p,0);
22446 @ @<Descend the structure@>=
22449 do { mp_disp_var(mp, q); q=link(q); } while (q!=end_attr);
22451 while ( name_type(q)==mp_subscr ) {
22452 mp_disp_var(mp, q); q=link(q);
22456 @ @<Display a variable macro@>=
22458 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22459 if ( type(p)>mp_unsuffixed_macro )
22460 mp_print(mp, "@@#"); /* |suffixed_macro| */
22461 mp_print(mp, "=macro:");
22462 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22463 else n=mp->max_print_line-mp->file_offset-15;
22464 mp_show_macro(mp, value(p),null,n);
22467 @ @<Declare action procedures for use by |do_statement|@>=
22468 void mp_do_show_var (MP mp) ;
22470 @ @c void mp_do_show_var (MP mp) {
22473 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22474 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22475 mp_disp_var(mp, mp->cur_mod); goto DONE;
22480 } while (mp->cur_cmd==comma);
22483 @ @<Declare action procedures for use by |do_statement|@>=
22484 void mp_do_show_dependencies (MP mp) ;
22486 @ @c void mp_do_show_dependencies (MP mp) {
22487 pointer p; /* link that runs through all dependencies */
22489 while ( p!=dep_head ) {
22490 if ( mp_interesting(mp, p) ) {
22491 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22492 if ( type(p)==mp_dependent ) mp_print_char(mp, '=');
22493 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22494 mp_print_dependency(mp, dep_list(p),type(p));
22497 while ( info(p)!=null ) p=link(p);
22503 @ Finally we are ready for the procedure that governs all of the
22506 @<Declare action procedures for use by |do_statement|@>=
22507 void mp_do_show_whatever (MP mp) ;
22509 @ @c void mp_do_show_whatever (MP mp) {
22510 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
22511 switch (mp->cur_mod) {
22512 case show_token_code:mp_do_show_token(mp); break;
22513 case show_stats_code:mp_do_show_stats(mp); break;
22514 case show_code:mp_do_show(mp); break;
22515 case show_var_code:mp_do_show_var(mp); break;
22516 case show_dependencies_code:mp_do_show_dependencies(mp); break;
22517 } /* there are no other cases */
22518 if ( mp->internal[mp_showstopping]>0 ){
22521 if ( mp->interaction<mp_error_stop_mode ) {
22522 help0; decr(mp->error_count);
22524 help1("This isn't an error message; I'm just showing something.");
22526 if ( mp->cur_cmd==semicolon ) mp_error(mp);
22527 else mp_put_get_error(mp);
22531 @ The `\&{addto}' command needs the following additional primitives:
22533 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
22534 @d contour_code 1 /* command modifier for `\&{contour}' */
22535 @d also_code 2 /* command modifier for `\&{also}' */
22537 @ Pre and postscripts need two new identifiers:
22539 @d with_pre_script 11
22540 @d with_post_script 13
22543 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
22544 @:double_path_}{\&{doublepath} primitive@>
22545 mp_primitive(mp, "contour",thing_to_add,contour_code);
22546 @:contour_}{\&{contour} primitive@>
22547 mp_primitive(mp, "also",thing_to_add,also_code);
22548 @:also_}{\&{also} primitive@>
22549 mp_primitive(mp, "withpen",with_option,mp_pen_type);
22550 @:with_pen_}{\&{withpen} primitive@>
22551 mp_primitive(mp, "dashed",with_option,mp_picture_type);
22552 @:dashed_}{\&{dashed} primitive@>
22553 mp_primitive(mp, "withprescript",with_option,with_pre_script);
22554 @:with_pre_script_}{\&{withprescript} primitive@>
22555 mp_primitive(mp, "withpostscript",with_option,with_post_script);
22556 @:with_post_script_}{\&{withpostscript} primitive@>
22557 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
22558 @:with_color_}{\&{withoutcolor} primitive@>
22559 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
22560 @:with_color_}{\&{withgreyscale} primitive@>
22561 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
22562 @:with_color_}{\&{withcolor} primitive@>
22563 /* \&{withrgbcolor} is an alias for \&{withcolor} */
22564 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
22565 @:with_color_}{\&{withrgbcolor} primitive@>
22566 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
22567 @:with_color_}{\&{withcmykcolor} primitive@>
22569 @ @<Cases of |print_cmd...@>=
22571 if ( m==contour_code ) mp_print(mp, "contour");
22572 else if ( m==double_path_code ) mp_print(mp, "doublepath");
22573 else mp_print(mp, "also");
22576 if ( m==mp_pen_type ) mp_print(mp, "withpen");
22577 else if ( m==with_pre_script ) mp_print(mp, "withprescript");
22578 else if ( m==with_post_script ) mp_print(mp, "withpostscript");
22579 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
22580 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
22581 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
22582 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
22583 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
22584 else mp_print(mp, "dashed");
22587 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
22588 updates the list of graphical objects starting at |p|. Each $\langle$with
22589 clause$\rangle$ updates all graphical objects whose |type| is compatible.
22590 Other objects are ignored.
22592 @<Declare action procedures for use by |do_statement|@>=
22593 void mp_scan_with_list (MP mp,pointer p) ;
22595 @ @c void mp_scan_with_list (MP mp,pointer p) {
22596 small_number t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
22597 pointer q; /* for list manipulation */
22598 int old_setting; /* saved |selector| setting */
22599 pointer k; /* for finding the near-last item in a list */
22600 str_number s; /* for string cleanup after combining */
22601 pointer cp,pp,dp,ap,bp;
22602 /* objects being updated; |void| initially; |null| to suppress update */
22603 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
22605 while ( mp->cur_cmd==with_option ){
22608 if ( t!=mp_no_model ) mp_scan_expression(mp);
22609 if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
22610 ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
22611 ((t==mp_uninitialized_model)&&
22612 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
22613 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
22614 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
22615 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
22616 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
22617 ((t==mp_pen_type)&&(mp->cur_type!=t))||
22618 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
22619 @<Complain about improper type@>;
22620 } else if ( t==mp_uninitialized_model ) {
22621 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22623 @<Transfer a color from the current expression to object~|cp|@>;
22624 mp_flush_cur_exp(mp, 0);
22625 } else if ( t==mp_rgb_model ) {
22626 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22628 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
22629 mp_flush_cur_exp(mp, 0);
22630 } else if ( t==mp_cmyk_model ) {
22631 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22633 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
22634 mp_flush_cur_exp(mp, 0);
22635 } else if ( t==mp_grey_model ) {
22636 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22638 @<Transfer a greyscale from the current expression to object~|cp|@>;
22639 mp_flush_cur_exp(mp, 0);
22640 } else if ( t==mp_no_model ) {
22641 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22643 @<Transfer a noncolor from the current expression to object~|cp|@>;
22644 } else if ( t==mp_pen_type ) {
22645 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
22647 if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
22648 pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
22650 } else if ( t==with_pre_script ) {
22653 while ( (ap!=null)&&(! has_color(ap)) )
22656 if ( pre_script(ap)!=null ) { /* build a new,combined string */
22658 old_setting=mp->selector;
22659 mp->selector=new_string;
22660 str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
22661 mp_print_str(mp, mp->cur_exp);
22662 append_char(13); /* a forced \ps\ newline */
22663 mp_print_str(mp, pre_script(ap));
22664 pre_script(ap)=mp_make_string(mp);
22666 mp->selector=old_setting;
22668 pre_script(ap)=mp->cur_exp;
22670 mp->cur_type=mp_vacuous;
22672 } else if ( t==with_post_script ) {
22676 while ( link(k)!=null ) {
22678 if ( has_color(k) ) bp=k;
22681 if ( post_script(bp)!=null ) {
22683 old_setting=mp->selector;
22684 mp->selector=new_string;
22685 str_room(length(post_script(bp))+length(mp->cur_exp)+2);
22686 mp_print_str(mp, post_script(bp));
22687 append_char(13); /* a forced \ps\ newline */
22688 mp_print_str(mp, mp->cur_exp);
22689 post_script(bp)=mp_make_string(mp);
22691 mp->selector=old_setting;
22693 post_script(bp)=mp->cur_exp;
22695 mp->cur_type=mp_vacuous;
22698 if ( dp==mp_void ) {
22699 @<Make |dp| a stroked node in list~|p|@>;
22702 if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
22703 dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
22704 dash_scale(dp)=unity;
22705 mp->cur_type=mp_vacuous;
22709 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
22713 @ @<Complain about improper type@>=
22714 { exp_err("Improper type");
22716 help2("Next time say `withpen <known pen expression>';")
22717 ("I'll ignore the bad `with' clause and look for another.");
22718 if ( t==with_pre_script )
22719 mp->help_line[1]="Next time say `withprescript <known string expression>';";
22720 else if ( t==with_post_script )
22721 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
22722 else if ( t==mp_picture_type )
22723 mp->help_line[1]="Next time say `dashed <known picture expression>';";
22724 else if ( t==mp_uninitialized_model )
22725 mp->help_line[1]="Next time say `withcolor <known color expression>';";
22726 else if ( t==mp_rgb_model )
22727 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
22728 else if ( t==mp_cmyk_model )
22729 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
22730 else if ( t==mp_grey_model )
22731 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
22732 mp_put_get_flush_error(mp, 0);
22735 @ Forcing the color to be between |0| and |unity| here guarantees that no
22736 picture will ever contain a color outside the legal range for \ps\ graphics.
22738 @<Transfer a color from the current expression to object~|cp|@>=
22739 { if ( mp->cur_type==mp_color_type )
22740 @<Transfer a rgbcolor from the current expression to object~|cp|@>
22741 else if ( mp->cur_type==mp_cmykcolor_type )
22742 @<Transfer a cmykcolor from the current expression to object~|cp|@>
22743 else if ( mp->cur_type==mp_known )
22744 @<Transfer a greyscale from the current expression to object~|cp|@>
22745 else if ( mp->cur_exp==false_code )
22746 @<Transfer a noncolor from the current expression to object~|cp|@>;
22749 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
22750 { q=value(mp->cur_exp);
22755 red_val(cp)=value(red_part_loc(q));
22756 green_val(cp)=value(green_part_loc(q));
22757 blue_val(cp)=value(blue_part_loc(q));
22758 color_model(cp)=mp_rgb_model;
22759 if ( red_val(cp)<0 ) red_val(cp)=0;
22760 if ( green_val(cp)<0 ) green_val(cp)=0;
22761 if ( blue_val(cp)<0 ) blue_val(cp)=0;
22762 if ( red_val(cp)>unity ) red_val(cp)=unity;
22763 if ( green_val(cp)>unity ) green_val(cp)=unity;
22764 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
22767 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
22768 { q=value(mp->cur_exp);
22769 cyan_val(cp)=value(cyan_part_loc(q));
22770 magenta_val(cp)=value(magenta_part_loc(q));
22771 yellow_val(cp)=value(yellow_part_loc(q));
22772 black_val(cp)=value(black_part_loc(q));
22773 color_model(cp)=mp_cmyk_model;
22774 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
22775 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
22776 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
22777 if ( black_val(cp)<0 ) black_val(cp)=0;
22778 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
22779 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
22780 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
22781 if ( black_val(cp)>unity ) black_val(cp)=unity;
22784 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
22791 color_model(cp)=mp_grey_model;
22792 if ( grey_val(cp)<0 ) grey_val(cp)=0;
22793 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
22796 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
22803 color_model(cp)=mp_no_model;
22806 @ @<Make |cp| a colored object in object list~|p|@>=
22808 while ( cp!=null ){
22809 if ( has_color(cp) ) break;
22814 @ @<Make |pp| an object in list~|p| that needs a pen@>=
22816 while ( pp!=null ) {
22817 if ( has_pen(pp) ) break;
22822 @ @<Make |dp| a stroked node in list~|p|@>=
22824 while ( dp!=null ) {
22825 if ( type(dp)==mp_stroked_code ) break;
22830 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
22831 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
22832 if ( pp>mp_void ) {
22833 @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
22835 if ( dp>mp_void ) {
22836 @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
22840 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
22842 while ( q!=null ) {
22843 if ( has_color(q) ) {
22844 red_val(q)=red_val(cp);
22845 green_val(q)=green_val(cp);
22846 blue_val(q)=blue_val(cp);
22847 black_val(q)=black_val(cp);
22848 color_model(q)=color_model(cp);
22854 @ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
22856 while ( q!=null ) {
22857 if ( has_pen(q) ) {
22858 if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
22859 pen_p(q)=copy_pen(pen_p(pp));
22865 @ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
22867 while ( q!=null ) {
22868 if ( type(q)==mp_stroked_code ) {
22869 if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
22870 dash_p(q)=dash_p(dp);
22871 dash_scale(q)=unity;
22872 if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
22878 @ One of the things we need to do when we've parsed an \&{addto} or
22879 similar command is find the header of a supposed \&{picture} variable, given
22880 a token list for that variable. Since the edge structure is about to be
22881 updated, we use |private_edges| to make sure that this is possible.
22883 @<Declare action procedures for use by |do_statement|@>=
22884 pointer mp_find_edges_var (MP mp, pointer t) ;
22886 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
22888 pointer cur_edges; /* the return value */
22889 p=mp_find_variable(mp, t); cur_edges=null;
22891 mp_obliterated(mp, t); mp_put_get_error(mp);
22892 } else if ( type(p)!=mp_picture_type ) {
22893 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
22894 @.Variable x is the wrong type@>
22895 mp_print(mp, " is the wrong type (");
22896 mp_print_type(mp, type(p)); mp_print_char(mp, ')');
22897 help2("I was looking for a \"known\" picture variable.")
22898 ("So I'll not change anything just now.");
22899 mp_put_get_error(mp);
22901 value(p)=mp_private_edges(mp, value(p));
22902 cur_edges=value(p);
22904 mp_flush_node_list(mp, t);
22908 @ @<Cases of |do_statement|...@>=
22909 case add_to_command: mp_do_add_to(mp); break;
22910 case bounds_command:mp_do_bounds(mp); break;
22913 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
22914 @:clip_}{\&{clip} primitive@>
22915 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
22916 @:set_bounds_}{\&{setbounds} primitive@>
22918 @ @<Cases of |print_cmd...@>=
22919 case bounds_command:
22920 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
22921 else mp_print(mp, "setbounds");
22924 @ The following function parses the beginning of an \&{addto} or \&{clip}
22925 command: it expects a variable name followed by a token with |cur_cmd=sep|
22926 and then an expression. The function returns the token list for the variable
22927 and stores the command modifier for the separator token in the global variable
22928 |last_add_type|. We must be careful because this variable might get overwritten
22929 any time we call |get_x_next|.
22932 quarterword last_add_type;
22933 /* command modifier that identifies the last \&{addto} command */
22935 @ @<Declare action procedures for use by |do_statement|@>=
22936 pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
22938 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
22939 pointer lhv; /* variable to add to left */
22940 quarterword add_type=0; /* value to be returned in |last_add_type| */
22942 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
22943 if ( mp->cur_type!=mp_token_list ) {
22944 @<Abandon edges command because there's no variable@>;
22946 lhv=mp->cur_exp; add_type=mp->cur_mod;
22947 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
22949 mp->last_add_type=add_type;
22953 @ @<Abandon edges command because there's no variable@>=
22954 { exp_err("Not a suitable variable");
22955 @.Not a suitable variable@>
22956 help4("At this point I needed to see the name of a picture variable.")
22957 ("(Or perhaps you have indeed presented me with one; I might")
22958 ("have missed it, if it wasn't followed by the proper token.)")
22959 ("So I'll not change anything just now.");
22960 mp_put_get_flush_error(mp, 0);
22963 @ Here is an example of how to use |start_draw_cmd|.
22965 @<Declare action procedures for use by |do_statement|@>=
22966 void mp_do_bounds (MP mp) ;
22968 @ @c void mp_do_bounds (MP mp) {
22969 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
22970 pointer p; /* for list manipulation */
22971 integer m; /* initial value of |cur_mod| */
22973 lhv=mp_start_draw_cmd(mp, to_token);
22975 lhe=mp_find_edges_var(mp, lhv);
22977 mp_flush_cur_exp(mp, 0);
22978 } else if ( mp->cur_type!=mp_path_type ) {
22979 exp_err("Improper `clip'");
22980 @.Improper `addto'@>
22981 help2("This expression should have specified a known path.")
22982 ("So I'll not change anything just now.");
22983 mp_put_get_flush_error(mp, 0);
22984 } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
22985 @<Complain about a non-cycle@>;
22987 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
22992 @ @<Complain about a non-cycle@>=
22993 { print_err("Not a cycle");
22995 help2("That contour should have ended with `..cycle' or `&cycle'.")
22996 ("So I'll not change anything just now."); mp_put_get_error(mp);
22999 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
23000 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
23001 link(p)=link(dummy_loc(lhe));
23002 link(dummy_loc(lhe))=p;
23003 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
23004 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
23005 type(p)=stop_type(m);
23006 link(obj_tail(lhe))=p;
23008 mp_init_bbox(mp, lhe);
23011 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
23012 cases to deal with.
23014 @<Declare action procedures for use by |do_statement|@>=
23015 void mp_do_add_to (MP mp) ;
23017 @ @c void mp_do_add_to (MP mp) {
23018 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23019 pointer p; /* the graphical object or list for |scan_with_list| to update */
23020 pointer e; /* an edge structure to be merged */
23021 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
23022 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
23024 if ( add_type==also_code ) {
23025 @<Make sure the current expression is a suitable picture and set |e| and |p|
23028 @<Create a graphical object |p| based on |add_type| and the current
23031 mp_scan_with_list(mp, p);
23032 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
23036 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
23037 setting |e:=null| prevents anything from being added to |lhe|.
23039 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
23042 if ( mp->cur_type!=mp_picture_type ) {
23043 exp_err("Improper `addto'");
23044 @.Improper `addto'@>
23045 help2("This expression should have specified a known picture.")
23046 ("So I'll not change anything just now."); mp_put_get_flush_error(mp, 0);
23048 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
23049 p=link(dummy_loc(e));
23053 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
23054 attempts to add to the edge structure.
23056 @<Create a graphical object |p| based on |add_type| and the current...@>=
23058 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
23059 if ( mp->cur_type!=mp_path_type ) {
23060 exp_err("Improper `addto'");
23061 @.Improper `addto'@>
23062 help2("This expression should have specified a known path.")
23063 ("So I'll not change anything just now.");
23064 mp_put_get_flush_error(mp, 0);
23065 } else if ( add_type==contour_code ) {
23066 if ( left_type(mp->cur_exp)==mp_endpoint ) {
23067 @<Complain about a non-cycle@>;
23069 p=mp_new_fill_node(mp, mp->cur_exp);
23070 mp->cur_type=mp_vacuous;
23073 p=mp_new_stroked_node(mp, mp->cur_exp);
23074 mp->cur_type=mp_vacuous;
23078 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
23079 lhe=mp_find_edges_var(mp, lhv);
23081 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
23082 if ( e!=null ) delete_edge_ref(e);
23083 } else if ( add_type==also_code ) {
23085 @<Merge |e| into |lhe| and delete |e|@>;
23089 } else if ( p!=null ) {
23090 link(obj_tail(lhe))=p;
23092 if ( add_type==double_path_code )
23093 if ( pen_p(p)==null )
23094 pen_p(p)=mp_get_pen_circle(mp, 0);
23097 @ @<Merge |e| into |lhe| and delete |e|@>=
23098 { if ( link(dummy_loc(e))!=null ) {
23099 link(obj_tail(lhe))=link(dummy_loc(e));
23100 obj_tail(lhe)=obj_tail(e);
23101 obj_tail(e)=dummy_loc(e);
23102 link(dummy_loc(e))=null;
23103 mp_flush_dash_list(mp, lhe);
23105 mp_toss_edges(mp, e);
23108 @ @<Cases of |do_statement|...@>=
23109 case ship_out_command: mp_do_ship_out(mp); break;
23111 @ @<Declare action procedures for use by |do_statement|@>=
23112 @<Declare the function called |tfm_check|@>
23113 @<Declare the \ps\ output procedures@>
23114 void mp_do_ship_out (MP mp) ;
23116 @ @c void mp_do_ship_out (MP mp) {
23117 integer c; /* the character code */
23118 mp_get_x_next(mp); mp_scan_expression(mp);
23119 if ( mp->cur_type!=mp_picture_type ) {
23120 @<Complain that it's not a known picture@>;
23122 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
23123 if ( c<0 ) c=c+256;
23124 @<Store the width information for character code~|c|@>;
23125 mp_ship_out(mp, mp->cur_exp);
23126 mp_flush_cur_exp(mp, 0);
23130 @ @<Complain that it's not a known picture@>=
23132 exp_err("Not a known picture");
23133 help1("I can only output known pictures.");
23134 mp_put_get_flush_error(mp, 0);
23137 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
23140 @<Cases of |do_statement|...@>=
23141 case every_job_command:
23142 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
23146 halfword start_sym; /* a symbolic token to insert at beginning of job */
23151 @ Finally, we have only the ``message'' commands remaining.
23154 @d err_message_code 1
23156 @d filename_template_code 3
23157 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
23158 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
23160 mp->pool_ptr = mp->pool_ptr - g;
23162 mp_print_char(mp, '0');
23165 mp_print_int(mp, (A));
23170 mp_primitive(mp, "message",message_command,message_code);
23171 @:message_}{\&{message} primitive@>
23172 mp_primitive(mp, "errmessage",message_command,err_message_code);
23173 @:err_message_}{\&{errmessage} primitive@>
23174 mp_primitive(mp, "errhelp",message_command,err_help_code);
23175 @:err_help_}{\&{errhelp} primitive@>
23176 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
23177 @:filename_template_}{\&{filenametemplate} primitive@>
23179 @ @<Cases of |print_cmd...@>=
23180 case message_command:
23181 if ( m<err_message_code ) mp_print(mp, "message");
23182 else if ( m==err_message_code ) mp_print(mp, "errmessage");
23183 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
23184 else mp_print(mp, "errhelp");
23187 @ @<Cases of |do_statement|...@>=
23188 case message_command: mp_do_message(mp); break;
23190 @ @<Declare action procedures for use by |do_statement|@>=
23191 @<Declare a procedure called |no_string_err|@>
23192 void mp_do_message (MP mp) ;
23195 @c void mp_do_message (MP mp) {
23196 int m; /* the type of message */
23197 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
23198 if ( mp->cur_type!=mp_string_type )
23199 mp_no_string_err(mp, "A message should be a known string expression.");
23203 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
23205 case err_message_code:
23206 @<Print string |cur_exp| as an error message@>;
23208 case err_help_code:
23209 @<Save string |cur_exp| as the |err_help|@>;
23211 case filename_template_code:
23212 @<Save the filename template@>;
23214 } /* there are no other cases */
23216 mp_flush_cur_exp(mp, 0);
23219 @ @<Declare a procedure called |no_string_err|@>=
23220 void mp_no_string_err (MP mp, const char *s) {
23221 exp_err("Not a string");
23224 mp_put_get_error(mp);
23227 @ The global variable |err_help| is zero when the user has most recently
23228 given an empty help string, or if none has ever been given.
23230 @<Save string |cur_exp| as the |err_help|@>=
23232 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
23233 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
23234 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
23237 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
23238 \&{errhelp}, we don't want to give a long help message each time. So we
23239 give a verbose explanation only once.
23242 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
23244 @ @<Set init...@>=mp->long_help_seen=false;
23246 @ @<Print string |cur_exp| as an error message@>=
23248 print_err(""); mp_print_str(mp, mp->cur_exp);
23249 if ( mp->err_help!=0 ) {
23250 mp->use_err_help=true;
23251 } else if ( mp->long_help_seen ) {
23252 help1("(That was another `errmessage'.)") ;
23254 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
23255 help4("This error message was generated by an `errmessage'")
23256 ("command, so I can\'t give any explicit help.")
23257 ("Pretend that you're Miss Marple: Examine all clues,")
23259 ("and deduce the truth by inspired guesses.");
23261 mp_put_get_error(mp); mp->use_err_help=false;
23264 @ @<Cases of |do_statement|...@>=
23265 case write_command: mp_do_write(mp); break;
23267 @ @<Declare action procedures for use by |do_statement|@>=
23268 void mp_do_write (MP mp) ;
23270 @ @c void mp_do_write (MP mp) {
23271 str_number t; /* the line of text to be written */
23272 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
23273 int old_setting; /* for saving |selector| during output */
23275 mp_scan_expression(mp);
23276 if ( mp->cur_type!=mp_string_type ) {
23277 mp_no_string_err(mp, "The text to be written should be a known string expression");
23278 } else if ( mp->cur_cmd!=to_token ) {
23279 print_err("Missing `to' clause");
23280 help1("A write command should end with `to <filename>'");
23281 mp_put_get_error(mp);
23283 t=mp->cur_exp; mp->cur_type=mp_vacuous;
23285 mp_scan_expression(mp);
23286 if ( mp->cur_type!=mp_string_type )
23287 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23289 @<Write |t| to the file named by |cur_exp|@>;
23293 mp_flush_cur_exp(mp, 0);
23296 @ @<Write |t| to the file named by |cur_exp|@>=
23298 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23299 |cur_exp| must be inserted@>;
23300 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23301 @<Record the end of file on |wr_file[n]|@>;
23303 old_setting=mp->selector;
23304 mp->selector=n+write_file;
23305 mp_print_str(mp, t); mp_print_ln(mp);
23306 mp->selector = old_setting;
23310 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23312 char *fn = str(mp->cur_exp);
23314 n0=mp->write_files;
23315 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23316 if ( n==0 ) { /* bottom reached */
23317 if ( n0==mp->write_files ) {
23318 if ( mp->write_files<mp->max_write_files ) {
23319 incr(mp->write_files);
23324 l = mp->max_write_files + (mp->max_write_files>>2);
23325 wr_file = xmalloc((l+1),sizeof(void *));
23326 wr_fname = xmalloc((l+1),sizeof(char *));
23327 for (k=0;k<=l;k++) {
23328 if (k<=mp->max_write_files) {
23329 wr_file[k]=mp->wr_file[k];
23330 wr_fname[k]=mp->wr_fname[k];
23336 xfree(mp->wr_file); xfree(mp->wr_fname);
23337 mp->max_write_files = l;
23338 mp->wr_file = wr_file;
23339 mp->wr_fname = wr_fname;
23343 mp_open_write_file(mp, fn ,n);
23346 if ( mp->wr_fname[n]==NULL ) n0=n;
23351 @ @<Record the end of file on |wr_file[n]|@>=
23352 { (mp->close_file)(mp,mp->wr_file[n]);
23353 xfree(mp->wr_fname[n]);
23354 if ( n==mp->write_files-1 ) mp->write_files=n;
23358 @* \[42] Writing font metric data.
23359 \TeX\ gets its knowledge about fonts from font metric files, also called
23360 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23361 but other programs know about them too. One of \MP's duties is to
23362 write \.{TFM} files so that the user's fonts can readily be
23363 applied to typesetting.
23364 @:TFM files}{\.{TFM} files@>
23365 @^font metric files@>
23367 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23368 Since the number of bytes is always a multiple of~4, we could
23369 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23370 byte interpretation. The format of \.{TFM} files was designed by
23371 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23372 @^Ramshaw, Lyle Harold@>
23373 of information in a compact but useful form.
23376 void * tfm_file; /* the font metric output goes here */
23377 char * metric_file_name; /* full name of the font metric file */
23379 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23380 integers that give the lengths of the various subsequent portions
23381 of the file. These twelve integers are, in order:
23382 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23383 |lf|&length of the entire file, in words;\cr
23384 |lh|&length of the header data, in words;\cr
23385 |bc|&smallest character code in the font;\cr
23386 |ec|&largest character code in the font;\cr
23387 |nw|&number of words in the width table;\cr
23388 |nh|&number of words in the height table;\cr
23389 |nd|&number of words in the depth table;\cr
23390 |ni|&number of words in the italic correction table;\cr
23391 |nl|&number of words in the lig/kern table;\cr
23392 |nk|&number of words in the kern table;\cr
23393 |ne|&number of words in the extensible character table;\cr
23394 |np|&number of font parameter words.\cr}}$$
23395 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23397 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23398 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23399 and as few as 0 characters (if |bc=ec+1|).
23401 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23402 16 or more bits, the most significant bytes appear first in the file.
23403 This is called BigEndian order.
23404 @^BigEndian order@>
23406 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23409 The most important data type used here is a |fix_word|, which is
23410 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23411 quantity, with the two's complement of the entire word used to represent
23412 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23413 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23414 the smallest is $-2048$. We will see below, however, that all but two of
23415 the |fix_word| values must lie between $-16$ and $+16$.
23417 @ The first data array is a block of header information, which contains
23418 general facts about the font. The header must contain at least two words,
23419 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23420 header information of use to other software routines might also be
23421 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23422 For example, 16 more words of header information are in use at the Xerox
23423 Palo Alto Research Center; the first ten specify the character coding
23424 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23425 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23426 last gives the ``face byte.''
23428 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23429 the \.{GF} output file. This helps ensure consistency between files,
23430 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23431 should match the check sums on actual fonts that are used. The actual
23432 relation between this check sum and the rest of the \.{TFM} file is not
23433 important; the check sum is simply an identification number with the
23434 property that incompatible fonts almost always have distinct check sums.
23437 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23438 font, in units of \TeX\ points. This number must be at least 1.0; it is
23439 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23440 font, i.e., a font that was designed to look best at a 10-point size,
23441 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23442 $\delta$ \.{pt}', the effect is to override the design size and replace it
23443 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23444 the font image by a factor of $\delta$ divided by the design size. {\sl
23445 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23446 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23447 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23448 since many fonts have a design size equal to one em. The other dimensions
23449 must be less than 16 design-size units in absolute value; thus,
23450 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23451 \.{TFM} file whose first byte might be something besides 0 or 255.
23454 @ Next comes the |char_info| array, which contains one |char_info_word|
23455 per character. Each word in this part of the file contains six fields
23456 packed into four bytes as follows.
23458 \yskip\hang first byte: |width_index| (8 bits)\par
23459 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23461 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23463 \hang fourth byte: |remainder| (8 bits)\par
23465 The actual width of a character is \\{width}|[width_index]|, in design-size
23466 units; this is a device for compressing information, since many characters
23467 have the same width. Since it is quite common for many characters
23468 to have the same height, depth, or italic correction, the \.{TFM} format
23469 imposes a limit of 16 different heights, 16 different depths, and
23470 64 different italic corrections.
23472 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23473 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23474 value of zero. The |width_index| should never be zero unless the
23475 character does not exist in the font, since a character is valid if and
23476 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23478 @ The |tag| field in a |char_info_word| has four values that explain how to
23479 interpret the |remainder| field.
23481 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23482 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23483 program starting at location |remainder| in the |lig_kern| array.\par
23484 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23485 characters of ascending sizes, and not the largest in the chain. The
23486 |remainder| field gives the character code of the next larger character.\par
23487 \hang|tag=3| (|ext_tag|) means that this character code represents an
23488 extensible character, i.e., a character that is built up of smaller pieces
23489 so that it can be made arbitrarily large. The pieces are specified in
23490 |exten[remainder]|.\par
23492 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23493 unless they are used in special circumstances in math formulas. For example,
23494 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23495 operation looks for both |list_tag| and |ext_tag|.
23497 @d no_tag 0 /* vanilla character */
23498 @d lig_tag 1 /* character has a ligature/kerning program */
23499 @d list_tag 2 /* character has a successor in a charlist */
23500 @d ext_tag 3 /* character is extensible */
23502 @ The |lig_kern| array contains instructions in a simple programming language
23503 that explains what to do for special letter pairs. Each word in this array is a
23504 |lig_kern_command| of four bytes.
23506 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23507 step if the byte is 128 or more, otherwise the next step is obtained by
23508 skipping this number of intervening steps.\par
23509 \hang second byte: |next_char|, ``if |next_char| follows the current character,
23510 then perform the operation and stop, otherwise continue.''\par
23511 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
23512 a kern step otherwise.\par
23513 \hang fourth byte: |remainder|.\par
23516 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
23517 between the current character and |next_char|. This amount is
23518 often negative, so that the characters are brought closer together
23519 by kerning; but it might be positive.
23521 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
23522 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
23523 |remainder| is inserted between the current character and |next_char|;
23524 then the current character is deleted if $b=0$, and |next_char| is
23525 deleted if $c=0$; then we pass over $a$~characters to reach the next
23526 current character (which may have a ligature/kerning program of its own).
23528 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
23529 the |next_char| byte is the so-called right boundary character of this font;
23530 the value of |next_char| need not lie between |bc| and~|ec|.
23531 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
23532 there is a special ligature/kerning program for a left boundary character,
23533 beginning at location |256*op_byte+remainder|.
23534 The interpretation is that \TeX\ puts implicit boundary characters
23535 before and after each consecutive string of characters from the same font.
23536 These implicit characters do not appear in the output, but they can affect
23537 ligatures and kerning.
23539 If the very first instruction of a character's |lig_kern| program has
23540 |skip_byte>128|, the program actually begins in location
23541 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
23542 arrays, because the first instruction must otherwise
23543 appear in a location |<=255|.
23545 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
23547 $$\hbox{|256*op_byte+remainder<nl|.}$$
23548 If such an instruction is encountered during
23549 normal program execution, it denotes an unconditional halt; no ligature
23550 command is performed.
23553 /* value indicating `\.{STOP}' in a lig/kern program */
23554 @d kern_flag (128) /* op code for a kern step */
23555 @d skip_byte(A) mp->lig_kern[(A)].b0
23556 @d next_char(A) mp->lig_kern[(A)].b1
23557 @d op_byte(A) mp->lig_kern[(A)].b2
23558 @d rem_byte(A) mp->lig_kern[(A)].b3
23560 @ Extensible characters are specified by an |extensible_recipe|, which
23561 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
23562 order). These bytes are the character codes of individual pieces used to
23563 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
23564 present in the built-up result. For example, an extensible vertical line is
23565 like an extensible bracket, except that the top and bottom pieces are missing.
23567 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
23568 if the piece isn't present. Then the extensible characters have the form
23569 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
23570 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
23571 The width of the extensible character is the width of $R$; and the
23572 height-plus-depth is the sum of the individual height-plus-depths of the
23573 components used, since the pieces are butted together in a vertical list.
23575 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
23576 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
23577 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
23578 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
23580 @ The final portion of a \.{TFM} file is the |param| array, which is another
23581 sequence of |fix_word| values.
23583 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
23584 to help position accents. For example, |slant=.25| means that when you go
23585 up one unit, you also go .25 units to the right. The |slant| is a pure
23586 number; it is the only |fix_word| other than the design size itself that is
23587 not scaled by the design size.
23590 \hang|param[2]=space| is the normal spacing between words in text.
23591 Note that character 040 in the font need not have anything to do with
23594 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
23596 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
23598 \hang|param[5]=x_height| is the size of one ex in the font; it is also
23599 the height of letters for which accents don't have to be raised or lowered.
23601 \hang|param[6]=quad| is the size of one em in the font.
23603 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
23607 If fewer than seven parameters are present, \TeX\ sets the missing parameters
23612 @d space_stretch_code 3
23613 @d space_shrink_code 4
23616 @d extra_space_code 7
23618 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
23619 information, and it does this all at once at the end of a job.
23620 In order to prepare for such frenetic activity, it squirrels away the
23621 necessary facts in various arrays as information becomes available.
23623 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
23624 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
23625 |tfm_ital_corr|. Other information about a character (e.g., about
23626 its ligatures or successors) is accessible via the |char_tag| and
23627 |char_remainder| arrays. Other information about the font as a whole
23628 is kept in additional arrays called |header_byte|, |lig_kern|,
23629 |kern|, |exten|, and |param|.
23631 @d max_tfm_int 32510
23632 @d undefined_label max_tfm_int /* an undefined local label */
23635 #define TFM_ITEMS 257
23637 eight_bits ec; /* smallest and largest character codes shipped out */
23638 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
23639 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
23640 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
23641 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
23642 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
23643 int char_tag[TFM_ITEMS]; /* |remainder| category */
23644 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
23645 char *header_byte; /* bytes of the \.{TFM} header */
23646 int header_last; /* last initialized \.{TFM} header byte */
23647 int header_size; /* size of the \.{TFM} header */
23648 four_quarters *lig_kern; /* the ligature/kern table */
23649 short nl; /* the number of ligature/kern steps so far */
23650 scaled *kern; /* distinct kerning amounts */
23651 short nk; /* the number of distinct kerns so far */
23652 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
23653 short ne; /* the number of extensible characters so far */
23654 scaled *param; /* \&{fontinfo} parameters */
23655 short np; /* the largest \&{fontinfo} parameter specified so far */
23656 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
23657 short skip_table[TFM_ITEMS]; /* local label status */
23658 boolean lk_started; /* has there been a lig/kern step in this command yet? */
23659 integer bchar; /* right boundary character */
23660 short bch_label; /* left boundary starting location */
23661 short ll;short lll; /* registers used for lig/kern processing */
23662 short label_loc[257]; /* lig/kern starting addresses */
23663 eight_bits label_char[257]; /* characters for |label_loc| */
23664 short label_ptr; /* highest position occupied in |label_loc| */
23666 @ @<Allocate or initialize ...@>=
23667 mp->header_last = 0; mp->header_size = 128; /* just for init */
23668 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
23669 mp->lig_kern = NULL; /* allocated when needed */
23670 mp->kern = NULL; /* allocated when needed */
23671 mp->param = NULL; /* allocated when needed */
23673 @ @<Dealloc variables@>=
23674 xfree(mp->header_byte);
23675 xfree(mp->lig_kern);
23680 for (k=0;k<= 255;k++ ) {
23681 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
23682 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
23683 mp->skip_table[k]=undefined_label;
23685 memset(mp->header_byte,0,mp->header_size);
23686 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
23687 mp->internal[mp_boundary_char]=-unity;
23688 mp->bch_label=undefined_label;
23689 mp->label_loc[0]=-1; mp->label_ptr=0;
23691 @ @<Declarations@>=
23692 scaled mp_tfm_check (MP mp,small_number m) ;
23694 @ @<Declare the function called |tfm_check|@>=
23695 scaled mp_tfm_check (MP mp,small_number m) {
23696 if ( abs(mp->internal[m])>=fraction_half ) {
23697 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
23698 @.Enormous charwd...@>
23699 @.Enormous chardp...@>
23700 @.Enormous charht...@>
23701 @.Enormous charic...@>
23702 @.Enormous designsize...@>
23703 mp_print(mp, " has been reduced");
23704 help1("Font metric dimensions must be less than 2048pt.");
23705 mp_put_get_error(mp);
23706 if ( mp->internal[m]>0 ) return (fraction_half-1);
23707 else return (1-fraction_half);
23709 return mp->internal[m];
23713 @ @<Store the width information for character code~|c|@>=
23714 if ( c<mp->bc ) mp->bc=c;
23715 if ( c>mp->ec ) mp->ec=c;
23716 mp->char_exists[c]=true;
23717 mp->tfm_width[c]=mp_tfm_check(mp, mp_char_wd);
23718 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
23719 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
23720 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
23722 @ Now let's consider \MP's special \.{TFM}-oriented commands.
23724 @<Cases of |do_statement|...@>=
23725 case tfm_command: mp_do_tfm_command(mp); break;
23727 @ @d char_list_code 0
23728 @d lig_table_code 1
23729 @d extensible_code 2
23730 @d header_byte_code 3
23731 @d font_dimen_code 4
23734 mp_primitive(mp, "charlist",tfm_command,char_list_code);
23735 @:char_list_}{\&{charlist} primitive@>
23736 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
23737 @:lig_table_}{\&{ligtable} primitive@>
23738 mp_primitive(mp, "extensible",tfm_command,extensible_code);
23739 @:extensible_}{\&{extensible} primitive@>
23740 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
23741 @:header_byte_}{\&{headerbyte} primitive@>
23742 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
23743 @:font_dimen_}{\&{fontdimen} primitive@>
23745 @ @<Cases of |print_cmd...@>=
23748 case char_list_code:mp_print(mp, "charlist"); break;
23749 case lig_table_code:mp_print(mp, "ligtable"); break;
23750 case extensible_code:mp_print(mp, "extensible"); break;
23751 case header_byte_code:mp_print(mp, "headerbyte"); break;
23752 default: mp_print(mp, "fontdimen"); break;
23756 @ @<Declare action procedures for use by |do_statement|@>=
23757 eight_bits mp_get_code (MP mp) ;
23759 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
23760 integer c; /* the code value found */
23761 mp_get_x_next(mp); mp_scan_expression(mp);
23762 if ( mp->cur_type==mp_known ) {
23763 c=mp_round_unscaled(mp, mp->cur_exp);
23764 if ( c>=0 ) if ( c<256 ) return c;
23765 } else if ( mp->cur_type==mp_string_type ) {
23766 if ( length(mp->cur_exp)==1 ) {
23767 c=mp->str_pool[mp->str_start[mp->cur_exp]];
23771 exp_err("Invalid code has been replaced by 0");
23772 @.Invalid code...@>
23773 help2("I was looking for a number between 0 and 255, or for a")
23774 ("string of length 1. Didn't find it; will use 0 instead.");
23775 mp_put_get_flush_error(mp, 0); c=0;
23779 @ @<Declare action procedures for use by |do_statement|@>=
23780 void mp_set_tag (MP mp,halfword c, small_number t, halfword r) ;
23782 @ @c void mp_set_tag (MP mp,halfword c, small_number t, halfword r) {
23783 if ( mp->char_tag[c]==no_tag ) {
23784 mp->char_tag[c]=t; mp->char_remainder[c]=r;
23786 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
23787 mp->label_char[mp->label_ptr]=c;
23790 @<Complain about a character tag conflict@>;
23794 @ @<Complain about a character tag conflict@>=
23796 print_err("Character ");
23797 if ( (c>' ')&&(c<127) ) mp_print_char(mp,c);
23798 else if ( c==256 ) mp_print(mp, "||");
23799 else { mp_print(mp, "code "); mp_print_int(mp, c); };
23800 mp_print(mp, " is already ");
23801 @.Character c is already...@>
23802 switch (mp->char_tag[c]) {
23803 case lig_tag: mp_print(mp, "in a ligtable"); break;
23804 case list_tag: mp_print(mp, "in a charlist"); break;
23805 case ext_tag: mp_print(mp, "extensible"); break;
23806 } /* there are no other cases */
23807 help2("It's not legal to label a character more than once.")
23808 ("So I'll not change anything just now.");
23809 mp_put_get_error(mp);
23812 @ @<Declare action procedures for use by |do_statement|@>=
23813 void mp_do_tfm_command (MP mp) ;
23815 @ @c void mp_do_tfm_command (MP mp) {
23816 int c,cc; /* character codes */
23817 int k; /* index into the |kern| array */
23818 int j; /* index into |header_byte| or |param| */
23819 switch (mp->cur_mod) {
23820 case char_list_code:
23822 /* we will store a list of character successors */
23823 while ( mp->cur_cmd==colon ) {
23824 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
23827 case lig_table_code:
23828 if (mp->lig_kern==NULL)
23829 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
23830 if (mp->kern==NULL)
23831 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
23832 @<Store a list of ligature/kern steps@>;
23834 case extensible_code:
23835 @<Define an extensible recipe@>;
23837 case header_byte_code:
23838 case font_dimen_code:
23839 c=mp->cur_mod; mp_get_x_next(mp);
23840 mp_scan_expression(mp);
23841 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
23842 exp_err("Improper location");
23843 @.Improper location@>
23844 help2("I was looking for a known, positive number.")
23845 ("For safety's sake I'll ignore the present command.");
23846 mp_put_get_error(mp);
23848 j=mp_round_unscaled(mp, mp->cur_exp);
23849 if ( mp->cur_cmd!=colon ) {
23850 mp_missing_err(mp, ":");
23852 help1("A colon should follow a headerbyte or fontinfo location.");
23855 if ( c==header_byte_code ) {
23856 @<Store a list of header bytes@>;
23858 if (mp->param==NULL)
23859 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
23860 @<Store a list of font dimensions@>;
23864 } /* there are no other cases */
23867 @ @<Store a list of ligature/kern steps@>=
23869 mp->lk_started=false;
23872 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
23873 @<Process a |skip_to| command and |goto done|@>;
23874 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
23875 else { mp_back_input(mp); c=mp_get_code(mp); };
23876 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
23877 @<Record a label in a lig/kern subprogram and |goto continue|@>;
23879 if ( mp->cur_cmd==lig_kern_token ) {
23880 @<Compile a ligature/kern command@>;
23882 print_err("Illegal ligtable step");
23883 @.Illegal ligtable step@>
23884 help1("I was looking for `=:' or `kern' here.");
23885 mp_back_error(mp); next_char(mp->nl)=qi(0);
23886 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
23887 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
23889 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
23891 if ( mp->cur_cmd==comma ) goto CONTINUE;
23892 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
23897 mp_primitive(mp, "=:",lig_kern_token,0);
23898 @:=:_}{\.{=:} primitive@>
23899 mp_primitive(mp, "=:|",lig_kern_token,1);
23900 @:=:/_}{\.{=:\char'174} primitive@>
23901 mp_primitive(mp, "=:|>",lig_kern_token,5);
23902 @:=:/>_}{\.{=:\char'174>} primitive@>
23903 mp_primitive(mp, "|=:",lig_kern_token,2);
23904 @:=:/_}{\.{\char'174=:} primitive@>
23905 mp_primitive(mp, "|=:>",lig_kern_token,6);
23906 @:=:/>_}{\.{\char'174=:>} primitive@>
23907 mp_primitive(mp, "|=:|",lig_kern_token,3);
23908 @:=:/_}{\.{\char'174=:\char'174} primitive@>
23909 mp_primitive(mp, "|=:|>",lig_kern_token,7);
23910 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
23911 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
23912 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
23913 mp_primitive(mp, "kern",lig_kern_token,128);
23914 @:kern_}{\&{kern} primitive@>
23916 @ @<Cases of |print_cmd...@>=
23917 case lig_kern_token:
23919 case 0:mp_print(mp, "=:"); break;
23920 case 1:mp_print(mp, "=:|"); break;
23921 case 2:mp_print(mp, "|=:"); break;
23922 case 3:mp_print(mp, "|=:|"); break;
23923 case 5:mp_print(mp, "=:|>"); break;
23924 case 6:mp_print(mp, "|=:>"); break;
23925 case 7:mp_print(mp, "|=:|>"); break;
23926 case 11:mp_print(mp, "|=:|>>"); break;
23927 default: mp_print(mp, "kern"); break;
23931 @ Local labels are implemented by maintaining the |skip_table| array,
23932 where |skip_table[c]| is either |undefined_label| or the address of the
23933 most recent lig/kern instruction that skips to local label~|c|. In the
23934 latter case, the |skip_byte| in that instruction will (temporarily)
23935 be zero if there were no prior skips to this label, or it will be the
23936 distance to the prior skip.
23938 We may need to cancel skips that span more than 127 lig/kern steps.
23940 @d cancel_skips(A) mp->ll=(A);
23942 mp->lll=qo(skip_byte(mp->ll));
23943 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
23944 } while (mp->lll!=0)
23945 @d skip_error(A) { print_err("Too far to skip");
23946 @.Too far to skip@>
23947 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
23948 mp_error(mp); cancel_skips((A));
23951 @<Process a |skip_to| command and |goto done|@>=
23954 if ( mp->nl-mp->skip_table[c]>128 ) {
23955 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
23957 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
23958 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
23959 mp->skip_table[c]=mp->nl-1; goto DONE;
23962 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
23964 if ( mp->cur_cmd==colon ) {
23965 if ( c==256 ) mp->bch_label=mp->nl;
23966 else mp_set_tag(mp, c,lig_tag,mp->nl);
23967 } else if ( mp->skip_table[c]<undefined_label ) {
23968 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
23970 mp->lll=qo(skip_byte(mp->ll));
23971 if ( mp->nl-mp->ll>128 ) {
23972 skip_error(mp->ll); goto CONTINUE;
23974 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
23975 } while (mp->lll!=0);
23980 @ @<Compile a ligature/kern...@>=
23982 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
23983 if ( mp->cur_mod<128 ) { /* ligature op */
23984 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
23986 mp_get_x_next(mp); mp_scan_expression(mp);
23987 if ( mp->cur_type!=mp_known ) {
23988 exp_err("Improper kern");
23990 help2("The amount of kern should be a known numeric value.")
23991 ("I'm zeroing this one. Proceed, with fingers crossed.");
23992 mp_put_get_flush_error(mp, 0);
23994 mp->kern[mp->nk]=mp->cur_exp;
23996 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
23998 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
24001 op_byte(mp->nl)=kern_flag+(k / 256);
24002 rem_byte(mp->nl)=qi((k % 256));
24004 mp->lk_started=true;
24007 @ @d missing_extensible_punctuation(A)
24008 { mp_missing_err(mp, (A));
24009 @.Missing `\char`\#'@>
24010 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
24013 @<Define an extensible recipe@>=
24015 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
24016 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
24017 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
24018 ext_top(mp->ne)=qi(mp_get_code(mp));
24019 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24020 ext_mid(mp->ne)=qi(mp_get_code(mp));
24021 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24022 ext_bot(mp->ne)=qi(mp_get_code(mp));
24023 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24024 ext_rep(mp->ne)=qi(mp_get_code(mp));
24028 @ The header could contain ASCII zeroes, so can't use |strdup|.
24030 @<Store a list of header bytes@>=
24032 if ( j>=mp->header_size ) {
24033 int l = mp->header_size + (mp->header_size >> 2);
24034 char *t = xmalloc(l,sizeof(char));
24036 memcpy(t,mp->header_byte,mp->header_size);
24037 xfree (mp->header_byte);
24038 mp->header_byte = t;
24039 mp->header_size = l;
24041 mp->header_byte[j]=mp_get_code(mp);
24042 incr(j); incr(mp->header_last);
24043 } while (mp->cur_cmd==comma)
24045 @ @<Store a list of font dimensions@>=
24047 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
24048 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
24049 mp_get_x_next(mp); mp_scan_expression(mp);
24050 if ( mp->cur_type!=mp_known ){
24051 exp_err("Improper font parameter");
24052 @.Improper font parameter@>
24053 help1("I'm zeroing this one. Proceed, with fingers crossed.");
24054 mp_put_get_flush_error(mp, 0);
24056 mp->param[j]=mp->cur_exp; incr(j);
24057 } while (mp->cur_cmd==comma)
24059 @ OK: We've stored all the data that is needed for the \.{TFM} file.
24060 All that remains is to output it in the correct format.
24062 An interesting problem needs to be solved in this connection, because
24063 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
24064 and 64~italic corrections. If the data has more distinct values than
24065 this, we want to meet the necessary restrictions by perturbing the
24066 given values as little as possible.
24068 \MP\ solves this problem in two steps. First the values of a given
24069 kind (widths, heights, depths, or italic corrections) are sorted;
24070 then the list of sorted values is perturbed, if necessary.
24072 The sorting operation is facilitated by having a special node of
24073 essentially infinite |value| at the end of the current list.
24075 @<Initialize table entries...@>=
24076 value(inf_val)=fraction_four;
24078 @ Straight linear insertion is good enough for sorting, since the lists
24079 are usually not terribly long. As we work on the data, the current list
24080 will start at |link(temp_head)| and end at |inf_val|; the nodes in this
24081 list will be in increasing order of their |value| fields.
24083 Given such a list, the |sort_in| function takes a value and returns a pointer
24084 to where that value can be found in the list. The value is inserted in
24085 the proper place, if necessary.
24087 At the time we need to do these operations, most of \MP's work has been
24088 completed, so we will have plenty of memory to play with. The value nodes
24089 that are allocated for sorting will never be returned to free storage.
24091 @d clear_the_list link(temp_head)=inf_val
24093 @c pointer mp_sort_in (MP mp,scaled v) {
24094 pointer p,q,r; /* list manipulation registers */
24098 if ( v<=value(q) ) break;
24101 if ( v<value(q) ) {
24102 r=mp_get_node(mp, value_node_size); value(r)=v; link(r)=q; link(p)=r;
24107 @ Now we come to the interesting part, where we reduce the list if necessary
24108 until it has the required size. The |min_cover| routine is basic to this
24109 process; it computes the minimum number~|m| such that the values of the
24110 current sorted list can be covered by |m|~intervals of width~|d|. It
24111 also sets the global value |perturbation| to the smallest value $d'>d$
24112 such that the covering found by this algorithm would be different.
24114 In particular, |min_cover(0)| returns the number of distinct values in the
24115 current list and sets |perturbation| to the minimum distance between
24118 @c integer mp_min_cover (MP mp,scaled d) {
24119 pointer p; /* runs through the current list */
24120 scaled l; /* the least element covered by the current interval */
24121 integer m; /* lower bound on the size of the minimum cover */
24122 m=0; p=link(temp_head); mp->perturbation=el_gordo;
24123 while ( p!=inf_val ){
24124 incr(m); l=value(p);
24125 do { p=link(p); } while (value(p)<=l+d);
24126 if ( value(p)-l<mp->perturbation )
24127 mp->perturbation=value(p)-l;
24133 scaled perturbation; /* quantity related to \.{TFM} rounding */
24134 integer excess; /* the list is this much too long */
24136 @ The smallest |d| such that a given list can be covered with |m| intervals
24137 is determined by the |threshold| routine, which is sort of an inverse
24138 to |min_cover|. The idea is to increase the interval size rapidly until
24139 finding the range, then to go sequentially until the exact borderline has
24142 @c scaled mp_threshold (MP mp,integer m) {
24143 scaled d; /* lower bound on the smallest interval size */
24144 mp->excess=mp_min_cover(mp, 0)-m;
24145 if ( mp->excess<=0 ) {
24149 d=mp->perturbation;
24150 } while (mp_min_cover(mp, d+d)>m);
24151 while ( mp_min_cover(mp, d)>m )
24152 d=mp->perturbation;
24157 @ The |skimp| procedure reduces the current list to at most |m| entries,
24158 by changing values if necessary. It also sets |info(p):=k| if |value(p)|
24159 is the |k|th distinct value on the resulting list, and it sets
24160 |perturbation| to the maximum amount by which a |value| field has
24161 been changed. The size of the resulting list is returned as the
24164 @c integer mp_skimp (MP mp,integer m) {
24165 scaled d; /* the size of intervals being coalesced */
24166 pointer p,q,r; /* list manipulation registers */
24167 scaled l; /* the least value in the current interval */
24168 scaled v; /* a compromise value */
24169 d=mp_threshold(mp, m); mp->perturbation=0;
24170 q=temp_head; m=0; p=link(temp_head);
24171 while ( p!=inf_val ) {
24172 incr(m); l=value(p); info(p)=m;
24173 if ( value(link(p))<=l+d ) {
24174 @<Replace an interval of values by its midpoint@>;
24181 @ @<Replace an interval...@>=
24184 p=link(p); info(p)=m;
24185 decr(mp->excess); if ( mp->excess==0 ) d=0;
24186 } while (value(link(p))<=l+d);
24187 v=l+halfp(value(p)-l);
24188 if ( value(p)-v>mp->perturbation )
24189 mp->perturbation=value(p)-v;
24192 r=link(r); value(r)=v;
24194 link(q)=p; /* remove duplicate values from the current list */
24197 @ A warning message is issued whenever something is perturbed by
24198 more than 1/16\thinspace pt.
24200 @c void mp_tfm_warning (MP mp,small_number m) {
24201 mp_print_nl(mp, "(some ");
24202 mp_print(mp, mp->int_name[m]);
24203 @.some charwds...@>
24204 @.some chardps...@>
24205 @.some charhts...@>
24206 @.some charics...@>
24207 mp_print(mp, " values had to be adjusted by as much as ");
24208 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
24211 @ Here's an example of how we use these routines.
24212 The width data needs to be perturbed only if there are 256 distinct
24213 widths, but \MP\ must check for this case even though it is
24216 An integer variable |k| will be defined when we use this code.
24217 The |dimen_head| array will contain pointers to the sorted
24218 lists of dimensions.
24220 @<Massage the \.{TFM} widths@>=
24222 for (k=mp->bc;k<=mp->ec;k++) {
24223 if ( mp->char_exists[k] )
24224 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
24226 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=link(temp_head);
24227 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
24230 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
24232 @ Heights, depths, and italic corrections are different from widths
24233 not only because their list length is more severely restricted, but
24234 also because zero values do not need to be put into the lists.
24236 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
24238 for (k=mp->bc;k<=mp->ec;k++) {
24239 if ( mp->char_exists[k] ) {
24240 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
24241 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
24244 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=link(temp_head);
24245 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
24247 for (k=mp->bc;k<=mp->ec;k++) {
24248 if ( mp->char_exists[k] ) {
24249 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
24250 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
24253 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=link(temp_head);
24254 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
24256 for (k=mp->bc;k<=mp->ec;k++) {
24257 if ( mp->char_exists[k] ) {
24258 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
24259 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
24262 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=link(temp_head);
24263 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
24265 @ @<Initialize table entries...@>=
24266 value(zero_val)=0; info(zero_val)=0;
24268 @ Bytes 5--8 of the header are set to the design size, unless the user has
24269 some crazy reason for specifying them differently.
24272 Error messages are not allowed at the time this procedure is called,
24273 so a warning is printed instead.
24275 The value of |max_tfm_dimen| is calculated so that
24276 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
24277 < \\{three\_bytes}.$$
24279 @d three_bytes 0100000000 /* $2^{24}$ */
24282 void mp_fix_design_size (MP mp) {
24283 scaled d; /* the design size */
24284 d=mp->internal[mp_design_size];
24285 if ( (d<unity)||(d>=fraction_half) ) {
24287 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24288 @.illegal design size...@>
24289 d=040000000; mp->internal[mp_design_size]=d;
24291 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24292 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24293 mp->header_byte[4]=d / 04000000;
24294 mp->header_byte[5]=(d / 4096) % 256;
24295 mp->header_byte[6]=(d / 16) % 256;
24296 mp->header_byte[7]=(d % 16)*16;
24298 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
24299 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24302 @ The |dimen_out| procedure computes a |fix_word| relative to the
24303 design size. If the data was out of range, it is corrected and the
24304 global variable |tfm_changed| is increased by~one.
24306 @c integer mp_dimen_out (MP mp,scaled x) {
24307 if ( abs(x)>mp->max_tfm_dimen ) {
24308 incr(mp->tfm_changed);
24309 if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
24311 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24316 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24317 integer tfm_changed; /* the number of data entries that were out of bounds */
24319 @ If the user has not specified any of the first four header bytes,
24320 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24321 from the |tfm_width| data relative to the design size.
24324 @c void mp_fix_check_sum (MP mp) {
24325 eight_bits k; /* runs through character codes */
24326 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24327 integer x; /* hash value used in check sum computation */
24328 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24329 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24330 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24331 mp->header_byte[0]=B1; mp->header_byte[1]=B2;
24332 mp->header_byte[2]=B3; mp->header_byte[3]=B4;
24337 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24338 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24339 for (k=mp->bc;k<=mp->ec;k++) {
24340 if ( mp->char_exists[k] ) {
24341 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24342 B1=(B1+B1+x) % 255;
24343 B2=(B2+B2+x) % 253;
24344 B3=(B3+B3+x) % 251;
24345 B4=(B4+B4+x) % 247;
24349 @ Finally we're ready to actually write the \.{TFM} information.
24350 Here are some utility routines for this purpose.
24352 @d tfm_out(A) do { /* output one byte to |tfm_file| */
24353 unsigned char s=(A);
24354 (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
24357 @c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24358 tfm_out(x / 256); tfm_out(x % 256);
24360 void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24361 if ( x>=0 ) tfm_out(x / three_bytes);
24363 x=x+010000000000; /* use two's complement for negative values */
24365 tfm_out((x / three_bytes) + 128);
24367 x=x % three_bytes; tfm_out(x / unity);
24368 x=x % unity; tfm_out(x / 0400);
24371 void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24372 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24373 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24376 @ @<Finish the \.{TFM} file@>=
24377 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24378 mp_pack_job_name(mp, ".tfm");
24379 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24380 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24381 mp->metric_file_name=xstrdup(mp->name_of_file);
24382 @<Output the subfile sizes and header bytes@>;
24383 @<Output the character information bytes, then
24384 output the dimensions themselves@>;
24385 @<Output the ligature/kern program@>;
24386 @<Output the extensible character recipes and the font metric parameters@>;
24387 if ( mp->internal[mp_tracing_stats]>0 )
24388 @<Log the subfile sizes of the \.{TFM} file@>;
24389 mp_print_nl(mp, "Font metrics written on ");
24390 mp_print(mp, mp->metric_file_name); mp_print_char(mp, '.');
24391 @.Font metrics written...@>
24392 (mp->close_file)(mp,mp->tfm_file)
24394 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24397 @<Output the subfile sizes and header bytes@>=
24399 LH=(k+3) / 4; /* this is the number of header words */
24400 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24401 @<Compute the ligature/kern program offset and implant the
24402 left boundary label@>;
24403 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24404 +lk_offset+mp->nk+mp->ne+mp->np);
24405 /* this is the total number of file words that will be output */
24406 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24407 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24408 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24409 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24410 mp_tfm_two(mp, mp->np);
24411 for (k=0;k< 4*LH;k++) {
24412 tfm_out(mp->header_byte[k]);
24415 @ @<Output the character information bytes...@>=
24416 for (k=mp->bc;k<=mp->ec;k++) {
24417 if ( ! mp->char_exists[k] ) {
24418 mp_tfm_four(mp, 0);
24420 tfm_out(info(mp->tfm_width[k])); /* the width index */
24421 tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
24422 tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24423 tfm_out(mp->char_remainder[k]);
24427 for (k=1;k<=4;k++) {
24428 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24429 while ( p!=inf_val ) {
24430 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=link(p);
24435 @ We need to output special instructions at the beginning of the
24436 |lig_kern| array in order to specify the right boundary character
24437 and/or to handle starting addresses that exceed 255. The |label_loc|
24438 and |label_char| arrays have been set up to record all the
24439 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24440 \le|label_loc|[|label_ptr]|$.
24442 @<Compute the ligature/kern program offset...@>=
24443 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24444 if ((mp->bchar<0)||(mp->bchar>255))
24445 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24446 else { mp->lk_started=true; lk_offset=1; };
24447 @<Find the minimum |lk_offset| and adjust all remainders@>;
24448 if ( mp->bch_label<undefined_label )
24449 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24450 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24451 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24452 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24455 @ @<Find the minimum |lk_offset|...@>=
24456 k=mp->label_ptr; /* pointer to the largest unallocated label */
24457 if ( mp->label_loc[k]+lk_offset>255 ) {
24458 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24460 mp->char_remainder[mp->label_char[k]]=lk_offset;
24461 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24462 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24464 incr(lk_offset); decr(k);
24465 } while (! (lk_offset+mp->label_loc[k]<256));
24466 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24468 if ( lk_offset>0 ) {
24470 mp->char_remainder[mp->label_char[k]]
24471 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24476 @ @<Output the ligature/kern program@>=
24477 for (k=0;k<= 255;k++ ) {
24478 if ( mp->skip_table[k]<undefined_label ) {
24479 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24480 @.local label l:: was missing@>
24481 cancel_skips(mp->skip_table[k]);
24484 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24485 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24487 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24488 mp->ll=mp->label_loc[mp->label_ptr];
24489 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24490 else { tfm_out(255); tfm_out(mp->bchar); };
24491 mp_tfm_two(mp, mp->ll+lk_offset);
24493 decr(mp->label_ptr);
24494 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24497 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24498 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24500 @ @<Output the extensible character recipes...@>=
24501 for (k=0;k<=mp->ne-1;k++)
24502 mp_tfm_qqqq(mp, mp->exten[k]);
24503 for (k=1;k<=mp->np;k++) {
24505 if ( abs(mp->param[1])<fraction_half ) {
24506 mp_tfm_four(mp, mp->param[1]*16);
24508 incr(mp->tfm_changed);
24509 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
24510 else mp_tfm_four(mp, -el_gordo);
24513 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
24516 if ( mp->tfm_changed>0 ) {
24517 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
24518 @.a font metric dimension...@>
24520 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
24521 @.font metric dimensions...@>
24522 mp_print(mp, " font metric dimensions");
24524 mp_print(mp, " had to be decreased)");
24527 @ @<Log the subfile sizes of the \.{TFM} file@>=
24531 if ( mp->bch_label<undefined_label ) decr(mp->nl);
24532 mp_snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
24533 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
24537 @* \[43] Reading font metric data.
24539 \MP\ isn't a typesetting program but it does need to find the bounding box
24540 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
24541 well as write them.
24546 @ All the width, height, and depth information is stored in an array called
24547 |font_info|. This array is allocated sequentially and each font is stored
24548 as a series of |char_info| words followed by the width, height, and depth
24549 tables. Since |font_name| entries are permanent, their |str_ref| values are
24550 set to |max_str_ref|.
24553 typedef unsigned int font_number; /* |0..font_max| */
24555 @ The |font_info| array is indexed via a group directory arrays.
24556 For example, the |char_info| data for character~|c| in font~|f| will be
24557 in |font_info[char_base[f]+c].qqqq|.
24560 font_number font_max; /* maximum font number for included text fonts */
24561 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
24562 memory_word *font_info; /* height, width, and depth data */
24563 char **font_enc_name; /* encoding names, if any */
24564 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
24565 int next_fmem; /* next unused entry in |font_info| */
24566 font_number last_fnum; /* last font number used so far */
24567 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
24568 char **font_name; /* name as specified in the \&{infont} command */
24569 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
24570 font_number last_ps_fnum; /* last valid |font_ps_name| index */
24571 eight_bits *font_bc;
24572 eight_bits *font_ec; /* first and last character code */
24573 int *char_base; /* base address for |char_info| */
24574 int *width_base; /* index for zeroth character width */
24575 int *height_base; /* index for zeroth character height */
24576 int *depth_base; /* index for zeroth character depth */
24577 pointer *font_sizes;
24579 @ @<Allocate or initialize ...@>=
24580 mp->font_mem_size = 10000;
24581 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
24582 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
24583 mp->font_enc_name = NULL;
24584 mp->font_ps_name_fixed = NULL;
24585 mp->font_dsize = NULL;
24586 mp->font_name = NULL;
24587 mp->font_ps_name = NULL;
24588 mp->font_bc = NULL;
24589 mp->font_ec = NULL;
24590 mp->last_fnum = null_font;
24591 mp->char_base = NULL;
24592 mp->width_base = NULL;
24593 mp->height_base = NULL;
24594 mp->depth_base = NULL;
24595 mp->font_sizes = null;
24597 @ @<Dealloc variables@>=
24598 for (k=1;k<=(int)mp->last_fnum;k++) {
24599 xfree(mp->font_enc_name[k]);
24600 xfree(mp->font_name[k]);
24601 xfree(mp->font_ps_name[k]);
24603 xfree(mp->font_info);
24604 xfree(mp->font_enc_name);
24605 xfree(mp->font_ps_name_fixed);
24606 xfree(mp->font_dsize);
24607 xfree(mp->font_name);
24608 xfree(mp->font_ps_name);
24609 xfree(mp->font_bc);
24610 xfree(mp->font_ec);
24611 xfree(mp->char_base);
24612 xfree(mp->width_base);
24613 xfree(mp->height_base);
24614 xfree(mp->depth_base);
24615 xfree(mp->font_sizes);
24619 void mp_reallocate_fonts (MP mp, font_number l) {
24621 XREALLOC(mp->font_enc_name, l, char *);
24622 XREALLOC(mp->font_ps_name_fixed, l, boolean);
24623 XREALLOC(mp->font_dsize, l, scaled);
24624 XREALLOC(mp->font_name, l, char *);
24625 XREALLOC(mp->font_ps_name, l, char *);
24626 XREALLOC(mp->font_bc, l, eight_bits);
24627 XREALLOC(mp->font_ec, l, eight_bits);
24628 XREALLOC(mp->char_base, l, int);
24629 XREALLOC(mp->width_base, l, int);
24630 XREALLOC(mp->height_base, l, int);
24631 XREALLOC(mp->depth_base, l, int);
24632 XREALLOC(mp->font_sizes, l, pointer);
24633 for (f=(mp->last_fnum+1);f<=l;f++) {
24634 mp->font_enc_name[f]=NULL;
24635 mp->font_ps_name_fixed[f] = false;
24636 mp->font_name[f]=NULL;
24637 mp->font_ps_name[f]=NULL;
24638 mp->font_sizes[f]=null;
24643 @ @<Declare |mp_reallocate| functions@>=
24644 void mp_reallocate_fonts (MP mp, font_number l);
24647 @ A |null_font| containing no characters is useful for error recovery. Its
24648 |font_name| entry starts out empty but is reset each time an erroneous font is
24649 found. This helps to cut down on the number of duplicate error messages without
24650 wasting a lot of space.
24652 @d null_font 0 /* the |font_number| for an empty font */
24654 @<Set initial...@>=
24655 mp->font_dsize[null_font]=0;
24656 mp->font_bc[null_font]=1;
24657 mp->font_ec[null_font]=0;
24658 mp->char_base[null_font]=0;
24659 mp->width_base[null_font]=0;
24660 mp->height_base[null_font]=0;
24661 mp->depth_base[null_font]=0;
24663 mp->last_fnum=null_font;
24664 mp->last_ps_fnum=null_font;
24665 mp->font_name[null_font]=(char *)"nullfont";
24666 mp->font_ps_name[null_font]=(char *)"";
24667 mp->font_ps_name_fixed[null_font] = false;
24668 mp->font_enc_name[null_font]=NULL;
24669 mp->font_sizes[null_font]=null;
24671 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
24672 the |width index|; the |b1| field contains the height
24673 index; the |b2| fields contains the depth index, and the |b3| field used only
24674 for temporary storage. (It is used to keep track of which characters occur in
24675 an edge structure that is being shipped out.)
24676 The corresponding words in the width, height, and depth tables are stored as
24677 |scaled| values in units of \ps\ points.
24679 With the macros below, the |char_info| word for character~|c| in font~|f| is
24680 |char_info(f)(c)| and the width is
24681 $$\hbox{|char_width(f)(char_info(f)(c)).sc|.}$$
24683 @d char_info_end(A) (A)].qqqq
24684 @d char_info(A) mp->font_info[mp->char_base[(A)]+char_info_end
24685 @d char_width_end(A) (A).b0].sc
24686 @d char_width(A) mp->font_info[mp->width_base[(A)]+char_width_end
24687 @d char_height_end(A) (A).b1].sc
24688 @d char_height(A) mp->font_info[mp->height_base[(A)]+char_height_end
24689 @d char_depth_end(A) (A).b2].sc
24690 @d char_depth(A) mp->font_info[mp->depth_base[(A)]+char_depth_end
24691 @d ichar_exists(A) ((A).b0>0)
24693 @ The |font_ps_name| for a built-in font should be what PostScript expects.
24694 A preliminary name is obtained here from the \.{TFM} name as given in the
24695 |fname| argument. This gets updated later from an external table if necessary.
24697 @<Declare text measuring subroutines@>=
24698 @<Declare subroutines for parsing file names@>
24699 font_number mp_read_font_info (MP mp, char *fname) {
24700 boolean file_opened; /* has |tfm_infile| been opened? */
24701 font_number n; /* the number to return */
24702 halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
24703 size_t whd_size; /* words needed for heights, widths, and depths */
24704 int i,ii; /* |font_info| indices */
24705 int jj; /* counts bytes to be ignored */
24706 scaled z; /* used to compute the design size */
24708 /* height, width, or depth as a fraction of design size times $2^{-8}$ */
24709 eight_bits h_and_d; /* height and depth indices being unpacked */
24710 unsigned char tfbyte; /* a byte read from the file */
24712 @<Open |tfm_infile| for input@>;
24713 @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
24714 otherwise |goto bad_tfm| or |goto done| as appropriate@>;
24716 @<Complain that the \.{TFM} file is bad@>;
24718 if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
24719 if ( n!=null_font ) {
24720 mp->font_ps_name[n]=mp_xstrdup(mp,fname);
24721 mp->font_name[n]=mp_xstrdup(mp,fname);
24726 @ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
24727 precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
24728 @.TFtoPL@> @.PLtoTF@>
24729 and \.{PLtoTF} can be used to debug \.{TFM} files.
24731 @<Complain that the \.{TFM} file is bad@>=
24732 print_err("Font ");
24733 mp_print(mp, fname);
24734 if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
24735 else mp_print(mp, " not usable: TFM file not found");
24736 help3("I wasn't able to read the size data for this font so this")
24737 ("`infont' operation won't produce anything. If the font name")
24738 ("is right, you might ask an expert to make a TFM file");
24740 mp->help_line[0]="is right, try asking an expert to fix the TFM file";
24743 @ @<Read data from |tfm_infile|; if there is no room, say so...@>=
24744 @<Read the \.{TFM} size fields@>;
24745 @<Use the size fields to allocate space in |font_info|@>;
24746 @<Read the \.{TFM} header@>;
24747 @<Read the character data and the width, height, and depth tables and
24750 @ A bad \.{TFM} file can be shorter than it claims to be. The code given here
24751 might try to read past the end of the file if this happens. Changes will be
24752 needed if it causes a system error to refer to |tfm_infile^| or call
24753 |get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
24754 @^system dependencies@>
24755 of |tfget| could be changed to
24756 ``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
24760 void *tfbyte_ptr = &tfbyte;
24761 (mp->read_binary_file)(mp,mp->tfm_infile,&tfbyte_ptr,&wanted);
24762 if (wanted==0) goto BAD_TFM;
24764 @d read_two(A) { (A)=tfbyte;
24765 if ( (A)>127 ) goto BAD_TFM;
24766 tfget; (A)=(A)*0400+tfbyte;
24768 @d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
24770 @<Read the \.{TFM} size fields@>=
24771 tfget; read_two(lf);
24772 tfget; read_two(tfm_lh);
24773 tfget; read_two(bc);
24774 tfget; read_two(ec);
24775 if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
24776 tfget; read_two(nw);
24777 tfget; read_two(nh);
24778 tfget; read_two(nd);
24779 whd_size=(ec+1-bc)+nw+nh+nd;
24780 if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
24783 @ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
24784 necessary to apply the |so| and |qo| macros when looking up the width of a
24785 character in the string pool. In order to ensure nonnegative |char_base|
24786 values when |bc>0|, it may be necessary to reserve a few unused |font_info|
24789 @<Use the size fields to allocate space in |font_info|@>=
24790 if ( mp->next_fmem<bc) mp->next_fmem=bc; /* ensure nonnegative |char_base| */
24791 if (mp->last_fnum==mp->font_max)
24792 mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max>>2)));
24793 while (mp->next_fmem+whd_size>=mp->font_mem_size) {
24794 size_t l = mp->font_mem_size+(mp->font_mem_size>>2);
24795 memory_word *font_info;
24796 font_info = xmalloc ((l+1),sizeof(memory_word));
24797 memset (font_info,0,sizeof(memory_word)*(l+1));
24798 memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
24799 xfree(mp->font_info);
24800 mp->font_info = font_info;
24801 mp->font_mem_size = l;
24803 incr(mp->last_fnum);
24807 mp->char_base[n]=mp->next_fmem-bc;
24808 mp->width_base[n]=mp->next_fmem+ec-bc+1;
24809 mp->height_base[n]=mp->width_base[n]+nw;
24810 mp->depth_base[n]=mp->height_base[n]+nh;
24811 mp->next_fmem=mp->next_fmem+whd_size;
24814 @ @<Read the \.{TFM} header@>=
24815 if ( tfm_lh<2 ) goto BAD_TFM;
24817 tfget; read_two(z);
24818 tfget; z=z*0400+tfbyte;
24819 tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
24820 mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
24821 /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
24822 tf_ignore(4*(tfm_lh-2))
24824 @ @<Read the character data and the width, height, and depth tables...@>=
24825 ii=mp->width_base[n];
24826 i=mp->char_base[n]+bc;
24828 tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
24829 tfget; h_and_d=tfbyte;
24830 mp->font_info[i].qqqq.b1=h_and_d / 16;
24831 mp->font_info[i].qqqq.b2=h_and_d % 16;
24835 while ( i<mp->next_fmem ) {
24836 @<Read a four byte dimension, scale it by the design size, store it in
24837 |font_info[i]|, and increment |i|@>;
24841 @ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
24842 interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
24843 we can multiply it by sixteen and think of it as a |fraction| that has been
24844 divided by sixteen. This cancels the extra scale factor contained in
24847 @<Read a four byte dimension, scale it by the design size, store it in...@>=
24850 if ( d>=0200 ) d=d-0400;
24851 tfget; d=d*0400+tfbyte;
24852 tfget; d=d*0400+tfbyte;
24853 tfget; d=d*0400+tfbyte;
24854 mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
24858 @ This function does no longer use the file name parser, because |fname| is
24859 a C string already.
24860 @<Open |tfm_infile| for input@>=
24862 mp_ptr_scan_file(mp, fname);
24863 if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); }
24864 if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
24866 mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
24867 if ( !mp->tfm_infile ) goto BAD_TFM;
24870 @ When we have a font name and we don't know whether it has been loaded yet,
24871 we scan the |font_name| array before calling |read_font_info|.
24873 @<Declare text measuring subroutines@>=
24874 font_number mp_find_font (MP mp, char *f) {
24876 for (n=0;n<=mp->last_fnum;n++) {
24877 if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
24882 n = mp_read_font_info(mp, f);
24887 @ One simple application of |find_font| is the implementation of the |font_size|
24888 operator that gets the design size for a given font name.
24890 @<Find the design size of the font whose name is |cur_exp|@>=
24891 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
24893 @ If we discover that the font doesn't have a requested character, we omit it
24894 from the bounding box computation and expect the \ps\ interpreter to drop it.
24895 This routine issues a warning message if the user has asked for it.
24897 @<Declare text measuring subroutines@>=
24898 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
24899 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
24900 mp_begin_diagnostic(mp);
24901 if ( mp->selector==log_only ) incr(mp->selector);
24902 mp_print_nl(mp, "Missing character: There is no ");
24903 @.Missing character@>
24904 mp_print_str(mp, mp->str_pool[k]);
24905 mp_print(mp, " in font ");
24906 mp_print(mp, mp->font_name[f]); mp_print_char(mp, '!');
24907 mp_end_diagnostic(mp, false);
24911 @ The whole purpose of saving the height, width, and depth information is to be
24912 able to find the bounding box of an item of text in an edge structure. The
24913 |set_text_box| procedure takes a text node and adds this information.
24915 @<Declare text measuring subroutines@>=
24916 void mp_set_text_box (MP mp,pointer p) {
24917 font_number f; /* |font_n(p)| */
24918 ASCII_code bc,ec; /* range of valid characters for font |f| */
24919 pool_pointer k,kk; /* current character and character to stop at */
24920 four_quarters cc; /* the |char_info| for the current character */
24921 scaled h,d; /* dimensions of the current character */
24923 height_val(p)=-el_gordo;
24924 depth_val(p)=-el_gordo;
24928 kk=str_stop(text_p(p));
24929 k=mp->str_start[text_p(p)];
24931 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
24933 @<Set the height and depth to zero if the bounding box is empty@>;
24936 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
24938 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
24939 mp_lost_warning(mp, f,k);
24941 cc=char_info(f)(mp->str_pool[k]);
24942 if ( ! ichar_exists(cc) ) {
24943 mp_lost_warning(mp, f,k);
24945 width_val(p)=width_val(p)+char_width(f)(cc);
24946 h=char_height(f)(cc);
24947 d=char_depth(f)(cc);
24948 if ( h>height_val(p) ) height_val(p)=h;
24949 if ( d>depth_val(p) ) depth_val(p)=d;
24955 @ Let's hope modern compilers do comparisons correctly when the difference would
24958 @<Set the height and depth to zero if the bounding box is empty@>=
24959 if ( height_val(p)<-depth_val(p) ) {
24964 @ The new primitives fontmapfile and fontmapline.
24966 @<Declare action procedures for use by |do_statement|@>=
24967 void mp_do_mapfile (MP mp) ;
24968 void mp_do_mapline (MP mp) ;
24970 @ @c void mp_do_mapfile (MP mp) {
24971 mp_get_x_next(mp); mp_scan_expression(mp);
24972 if ( mp->cur_type!=mp_string_type ) {
24973 @<Complain about improper map operation@>;
24975 mp_map_file(mp,mp->cur_exp);
24978 void mp_do_mapline (MP mp) {
24979 mp_get_x_next(mp); mp_scan_expression(mp);
24980 if ( mp->cur_type!=mp_string_type ) {
24981 @<Complain about improper map operation@>;
24983 mp_map_line(mp,mp->cur_exp);
24987 @ @<Complain about improper map operation@>=
24989 exp_err("Unsuitable expression");
24990 help1("Only known strings can be map files or map lines.");
24991 mp_put_get_error(mp);
24994 @ To print |scaled| value to PDF output we need some subroutines to ensure
24997 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
25000 scaled one_bp; /* scaled value corresponds to 1bp */
25001 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
25002 scaled one_hundred_inch; /* scaled value corresponds to 100in */
25003 integer ten_pow[10]; /* $10^0..10^9$ */
25004 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
25007 mp->one_bp = 65782; /* 65781.76 */
25008 mp->one_hundred_bp = 6578176;
25009 mp->one_hundred_inch = 473628672;
25010 mp->ten_pow[0] = 1;
25011 for (i = 1;i<= 9; i++ ) {
25012 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
25015 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
25017 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
25021 if ( s < 0 ) { sign = -sign; s = -s; }
25022 if ( m < 0 ) { sign = -sign; m = -m; }
25024 mp_confusion(mp, "arithmetic: divided by zero");
25025 else if ( m >= (max_integer / 10) )
25026 mp_confusion(mp, "arithmetic: number too big");
25029 for (i = 1;i<=dd;i++) {
25030 q = 10*q + (10*r) / m;
25033 if ( 2*r >= m ) { incr(q); r = r - m; }
25034 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
25038 @* \[44] Shipping pictures out.
25039 The |ship_out| procedure, to be described below, is given a pointer to
25040 an edge structure. Its mission is to output a file containing the \ps\
25041 description of an edge structure.
25043 @ Each time an edge structure is shipped out we write a new \ps\ output
25044 file named according to the current \&{charcode}.
25045 @:char_code_}{\&{charcode} primitive@>
25047 This is the only backend function that remains in the main |mpost.w| file.
25048 There are just too many variable accesses needed for status reporting
25049 etcetera to make it worthwile to move the code to |psout.w|.
25051 @<Internal library declarations@>=
25052 void mp_open_output_file (MP mp) ;
25055 char *mp_set_output_file_name (MP mp, integer c) {
25056 char *ss = NULL; /* filename extension proposal */
25057 int old_setting; /* previous |selector| setting */
25058 pool_pointer i; /* indexes into |filename_template| */
25059 integer cc; /* a temporary integer for template building */
25060 integer f,g=0; /* field widths */
25061 if ( mp->job_name==NULL ) mp_open_log_file(mp);
25062 if ( mp->filename_template==0 ) {
25063 char *s; /* a file extension derived from |c| */
25067 @<Use |c| to compute the file extension |s|@>;
25068 mp_pack_job_name(mp, s);
25070 } else { /* initializations */
25071 str_number s, n; /* a file extension derived from |c| */
25072 old_setting=mp->selector;
25073 mp->selector=new_string;
25075 i = mp->str_start[mp->filename_template];
25076 n = rts(""); /* initialize */
25077 while ( i<str_stop(mp->filename_template) ) {
25078 if ( mp->str_pool[i]=='%' ) {
25081 if ( i<str_stop(mp->filename_template) ) {
25082 if ( mp->str_pool[i]=='j' ) {
25083 mp_print(mp, mp->job_name);
25084 } else if ( mp->str_pool[i]=='d' ) {
25085 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
25086 print_with_leading_zeroes(cc);
25087 } else if ( mp->str_pool[i]=='m' ) {
25088 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
25089 print_with_leading_zeroes(cc);
25090 } else if ( mp->str_pool[i]=='y' ) {
25091 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
25092 print_with_leading_zeroes(cc);
25093 } else if ( mp->str_pool[i]=='H' ) {
25094 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
25095 print_with_leading_zeroes(cc);
25096 } else if ( mp->str_pool[i]=='M' ) {
25097 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
25098 print_with_leading_zeroes(cc);
25099 } else if ( mp->str_pool[i]=='c' ) {
25100 if ( c<0 ) mp_print(mp, "ps");
25101 else print_with_leading_zeroes(c);
25102 } else if ( (mp->str_pool[i]>='0') &&
25103 (mp->str_pool[i]<='9') ) {
25105 f = (f*10) + mp->str_pool[i]-'0';
25108 mp_print_str(mp, mp->str_pool[i]);
25112 if ( mp->str_pool[i]=='.' )
25114 n = mp_make_string(mp);
25115 mp_print_str(mp, mp->str_pool[i]);
25119 s = mp_make_string(mp);
25120 mp->selector= old_setting;
25121 if (length(n)==0) {
25125 mp_pack_file_name(mp, str(n),"",str(s));
25133 char * mp_get_output_file_name (MP mp) {
25134 char *fname; /* return value */
25135 char *saved_name; /* saved |name_of_file| */
25136 saved_name = mp_xstrdup(mp, mp->name_of_file);
25137 (void)mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code]));
25138 fname = mp_xstrdup(mp, mp->name_of_file);
25139 mp_pack_file_name(mp, saved_name,NULL,NULL);
25143 void mp_open_output_file (MP mp) {
25144 char *ss; /* filename extension proposal */
25145 integer c; /* \&{charcode} rounded to the nearest integer */
25146 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25147 ss = mp_set_output_file_name(mp, c);
25148 while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
25149 mp_prompt_file_name(mp, "file name for output",ss);
25151 @<Store the true output file name if appropriate@>;
25154 @ The file extension created here could be up to five characters long in
25155 extreme cases so it may have to be shortened on some systems.
25156 @^system dependencies@>
25158 @<Use |c| to compute the file extension |s|@>=
25161 mp_snprintf(s,7,".%i",(int)c);
25164 @ The user won't want to see all the output file names so we only save the
25165 first and last ones and a count of how many there were. For this purpose
25166 files are ordered primarily by \&{charcode} and secondarily by order of
25168 @:char_code_}{\&{charcode} primitive@>
25170 @<Store the true output file name if appropriate@>=
25171 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
25172 mp->first_output_code=c;
25173 xfree(mp->first_file_name);
25174 mp->first_file_name=xstrdup(mp->name_of_file);
25176 if ( c>=mp->last_output_code ) {
25177 mp->last_output_code=c;
25178 xfree(mp->last_file_name);
25179 mp->last_file_name=xstrdup(mp->name_of_file);
25183 char * first_file_name;
25184 char * last_file_name; /* full file names */
25185 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
25186 @:char_code_}{\&{charcode} primitive@>
25187 integer total_shipped; /* total number of |ship_out| operations completed */
25190 mp->first_file_name=xstrdup("");
25191 mp->last_file_name=xstrdup("");
25192 mp->first_output_code=32768;
25193 mp->last_output_code=-32768;
25194 mp->total_shipped=0;
25196 @ @<Dealloc variables@>=
25197 xfree(mp->first_file_name);
25198 xfree(mp->last_file_name);
25200 @ @<Begin the progress report for the output of picture~|c|@>=
25201 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
25202 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
25203 mp_print_char(mp, '[');
25204 if ( c>=0 ) mp_print_int(mp, c)
25206 @ @<End progress report@>=
25207 mp_print_char(mp, ']');
25209 incr(mp->total_shipped)
25211 @ @<Explain what output files were written@>=
25212 if ( mp->total_shipped>0 ) {
25213 mp_print_nl(mp, "");
25214 mp_print_int(mp, mp->total_shipped);
25215 mp_print(mp, " output file");
25216 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
25217 mp_print(mp, " written: ");
25218 mp_print(mp, mp->first_file_name);
25219 if ( mp->total_shipped>1 ) {
25220 if ( 31+strlen(mp->first_file_name)+
25221 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
25223 mp_print(mp, " .. ");
25224 mp_print(mp, mp->last_file_name);
25228 @ @<Internal library declarations@>=
25229 boolean mp_has_font_size(MP mp, font_number f );
25232 boolean mp_has_font_size(MP mp, font_number f ) {
25233 return (mp->font_sizes[f]!=null);
25236 @ The \&{special} command saves up lines of text to be printed during the next
25237 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25240 pointer last_pending; /* the last token in a list of pending specials */
25243 mp->last_pending=spec_head;
25245 @ @<Cases of |do_statement|...@>=
25246 case special_command:
25247 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25248 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25252 @ @<Declare action procedures for use by |do_statement|@>=
25253 void mp_do_special (MP mp) ;
25255 @ @c void mp_do_special (MP mp) {
25256 mp_get_x_next(mp); mp_scan_expression(mp);
25257 if ( mp->cur_type!=mp_string_type ) {
25258 @<Complain about improper special operation@>;
25260 link(mp->last_pending)=mp_stash_cur_exp(mp);
25261 mp->last_pending=link(mp->last_pending);
25262 link(mp->last_pending)=null;
25266 @ @<Complain about improper special operation@>=
25268 exp_err("Unsuitable expression");
25269 help1("Only known strings are allowed for output as specials.");
25270 mp_put_get_error(mp);
25273 @ On the export side, we need an extra object type for special strings.
25275 @<Graphical object codes@>=
25278 @ @<Export pending specials@>=
25280 while ( p!=null ) {
25281 mp_special_object *tp;
25282 tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
25283 gr_pre_script(tp) = str(value(p));
25284 if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
25285 else gr_link(hp) = (mp_graphic_object *)tp;
25286 hp = (mp_graphic_object *)tp;
25289 mp_flush_token_list(mp, link(spec_head));
25290 link(spec_head)=null;
25291 mp->last_pending=spec_head
25293 @ We are now ready for the main output procedure. Note that the |selector|
25294 setting is saved in a global variable so that |begin_diagnostic| can access it.
25296 @<Declare the \ps\ output procedures@>=
25297 void mp_ship_out (MP mp, pointer h) ;
25299 @ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
25301 @d export_color(q,p)
25302 if ( color_model(p)==mp_uninitialized_model ) {
25303 gr_color_model(q) = (mp->internal[mp_default_color_model]>>16);
25304 gr_cyan_val(q) = 0;
25305 gr_magenta_val(q) = 0;
25306 gr_yellow_val(q) = 0;
25307 gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
25309 gr_color_model(q) = color_model(p);
25310 gr_cyan_val(q) = cyan_val(p);
25311 gr_magenta_val(q) = magenta_val(p);
25312 gr_yellow_val(q) = yellow_val(p);
25313 gr_black_val(q) = black_val(p);
25316 @d export_scripts(q,p)
25317 if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
25318 if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
25321 struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
25322 pointer p; /* the current graphical object */
25323 integer t; /* a temporary value */
25324 scaled d_width; /* the current pen width */
25325 mp_edge_object *hh; /* the first graphical object */
25326 struct mp_graphic_object *hq; /* something |hp| points to */
25327 struct mp_text_object *tt;
25328 struct mp_fill_object *tf;
25329 struct mp_stroked_object *ts;
25330 struct mp_clip_object *tc;
25331 struct mp_bounds_object *tb;
25332 struct mp_graphic_object *hp = NULL; /* the current graphical object */
25333 mp_set_bbox(mp, h, true);
25334 hh = mp_xmalloc(mp,1,sizeof(mp_edge_object));
25338 hh->_minx = minx_val(h);
25339 hh->_miny = miny_val(h);
25340 hh->_maxx = maxx_val(h);
25341 hh->_maxy = maxy_val(h);
25342 hh->_filename = mp_get_output_file_name(mp);
25343 @<Export pending specials@>;
25344 p=link(dummy_loc(h));
25345 while ( p!=null ) {
25346 hq = mp_new_graphic_object(mp,type(p));
25349 tf = (mp_fill_object *)hq;
25350 gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
25351 d_width = mp_get_pen_scale(mp, pen_p(p));
25352 if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
25353 gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
25356 pc = mp_copy_path(mp, path_p(p));
25357 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25358 gr_path_p(tf) = mp_export_knot_list(mp,pp);
25359 mp_toss_knot_list(mp, pp);
25360 pc = mp_htap_ypoc(mp, path_p(p));
25361 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25362 gr_htap_p(tf) = mp_export_knot_list(mp,pp);
25363 mp_toss_knot_list(mp, pp);
25365 export_color(tf,p) ;
25366 export_scripts(tf,p);
25367 gr_ljoin_val(tf) = ljoin_val(p);
25368 gr_miterlim_val(tf) = miterlim_val(p);
25370 case mp_stroked_code:
25371 ts = (mp_stroked_object *)hq;
25372 gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
25373 d_width = mp_get_pen_scale(mp, pen_p(p));
25374 if (pen_is_elliptical(pen_p(p))) {
25375 gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
25378 pc=mp_copy_path(mp, path_p(p));
25380 if ( left_type(pc)!=mp_endpoint ) {
25381 left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
25382 right_type(pc)=mp_endpoint;
25386 pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
25387 gr_path_p(ts) = mp_export_knot_list(mp,pc);
25388 mp_toss_knot_list(mp, pc);
25390 export_color(ts,p) ;
25391 export_scripts(ts,p);
25392 gr_ljoin_val(ts) = ljoin_val(p);
25393 gr_miterlim_val(ts) = miterlim_val(p);
25394 gr_lcap_val(ts) = lcap_val(p);
25395 gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
25398 tt = (mp_text_object *)hq;
25399 gr_text_p(tt) = str(text_p(p));
25400 gr_font_n(tt) = font_n(p);
25401 gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
25402 gr_font_dsize(tt) = mp->font_dsize[font_n(p)];
25403 export_color(tt,p) ;
25404 export_scripts(tt,p);
25405 gr_width_val(tt) = width_val(p);
25406 gr_height_val(tt) = height_val(p);
25407 gr_depth_val(tt) = depth_val(p);
25408 gr_tx_val(tt) = tx_val(p);
25409 gr_ty_val(tt) = ty_val(p);
25410 gr_txx_val(tt) = txx_val(p);
25411 gr_txy_val(tt) = txy_val(p);
25412 gr_tyx_val(tt) = tyx_val(p);
25413 gr_tyy_val(tt) = tyy_val(p);
25415 case mp_start_clip_code:
25416 tc = (mp_clip_object *)hq;
25417 gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
25419 case mp_start_bounds_code:
25420 tb = (mp_bounds_object *)hq;
25421 gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
25423 case mp_stop_clip_code:
25424 case mp_stop_bounds_code:
25425 /* nothing to do here */
25428 if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
25435 @ @<Exported function ...@>=
25436 struct mp_edge_object *mp_gr_export(MP mp, int h);
25438 @ This function is now nearly trivial.
25441 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25442 integer c; /* \&{charcode} rounded to the nearest integer */
25443 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25444 @<Begin the progress report for the output of picture~|c|@>;
25445 (mp->shipout_backend) (mp, h);
25446 @<End progress report@>;
25447 if ( mp->internal[mp_tracing_output]>0 )
25448 mp_print_edges(mp, h," (just shipped out)",true);
25451 @ @<Declarations@>=
25452 void mp_shipout_backend (MP mp, pointer h);
25455 void mp_shipout_backend (MP mp, pointer h) {
25456 mp_edge_object *hh; /* the first graphical object */
25457 hh = mp_gr_export(mp,h);
25458 mp_gr_ship_out (hh,
25459 (mp->internal[mp_prologues]>>16),
25460 (mp->internal[mp_procset]>>16));
25461 mp_gr_toss_objects(hh);
25464 @ @<Exported types@>=
25465 typedef void (*mp_backend_writer)(MP, int);
25467 @ @<Option variables@>=
25468 mp_backend_writer shipout_backend;
25470 @ @<Allocate or initialize ...@>=
25471 set_callback_option(shipout_backend);
25473 @ Now that we've finished |ship_out|, let's look at the other commands
25474 by which a user can send things to the \.{GF} file.
25476 @ @<Determine if a character has been shipped out@>=
25478 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
25479 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
25480 boolean_reset(mp->char_exists[mp->cur_exp]);
25481 mp->cur_type=mp_boolean_type;
25487 @ @<Allocate or initialize ...@>=
25488 mp_backend_initialize(mp);
25491 mp_backend_free(mp);
25494 @* \[45] Dumping and undumping the tables.
25495 After \.{INIMP} has seen a collection of macros, it
25496 can write all the necessary information on an auxiliary file so
25497 that production versions of \MP\ are able to initialize their
25498 memory at high speed. The present section of the program takes
25499 care of such output and input. We shall consider simultaneously
25500 the processes of storing and restoring,
25501 so that the inverse relation between them is clear.
25504 The global variable |mem_ident| is a string that is printed right
25505 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
25506 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
25507 for example, `\.{(mem=plain 1990.4.14)}', showing the year,
25508 month, and day that the mem file was created. We have |mem_ident=0|
25509 before \MP's tables are loaded.
25515 mp->mem_ident=NULL;
25517 @ @<Initialize table entries...@>=
25518 mp->mem_ident=xstrdup(" (INIMP)");
25520 @ @<Declare act...@>=
25521 void mp_store_mem_file (MP mp) ;
25523 @ @c void mp_store_mem_file (MP mp) {
25524 integer k; /* all-purpose index */
25525 pointer p,q; /* all-purpose pointers */
25526 integer x; /* something to dump */
25527 four_quarters w; /* four ASCII codes */
25529 @<Create the |mem_ident|, open the mem file,
25530 and inform the user that dumping has begun@>;
25531 @<Dump constants for consistency check@>;
25532 @<Dump the string pool@>;
25533 @<Dump the dynamic memory@>;
25534 @<Dump the table of equivalents and the hash table@>;
25535 @<Dump a few more things and the closing check word@>;
25536 @<Close the mem file@>;
25539 @ Corresponding to the procedure that dumps a mem file, we also have a function
25540 that reads~one~in. The function returns |false| if the dumped mem is
25541 incompatible with the present \MP\ table sizes, etc.
25543 @d off_base 6666 /* go here if the mem file is unacceptable */
25544 @d too_small(A) { wake_up_terminal;
25545 wterm_ln("---! Must increase the "); wterm((A));
25546 @.Must increase the x@>
25551 boolean mp_load_mem_file (MP mp) {
25552 integer k; /* all-purpose index */
25553 pointer p,q; /* all-purpose pointers */
25554 integer x; /* something undumped */
25555 str_number s; /* some temporary string */
25556 four_quarters w; /* four ASCII codes */
25558 @<Undump constants for consistency check@>;
25559 @<Undump the string pool@>;
25560 @<Undump the dynamic memory@>;
25561 @<Undump the table of equivalents and the hash table@>;
25562 @<Undump a few more things and the closing check word@>;
25563 return true; /* it worked! */
25566 wterm_ln("(Fatal mem file error; I'm stymied)\n");
25567 @.Fatal mem file error@>
25571 @ @<Declarations@>=
25572 boolean mp_load_mem_file (MP mp) ;
25574 @ Mem files consist of |memory_word| items, and we use the following
25575 macros to dump words of different types:
25577 @d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25578 @d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
25579 @d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25580 @d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25581 @d dump_string(A) { dump_int(strlen(A)+1);
25582 (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
25585 void * mem_file; /* for input or output of mem information */
25587 @ The inverse macros are slightly more complicated, since we need to check
25588 the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
25589 read an integer value |x| that is supposed to be in the range |a<=x<=b|.
25592 size_t wanted = sizeof(A);
25594 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25595 if (wanted!=sizeof(A)) goto OFF_BASE;
25599 size_t wanted = sizeof(A);
25601 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25602 if (wanted!=sizeof(A)) goto OFF_BASE;
25605 @d undump_wd(A) { mgetw(WW); A=WW; }
25606 @d undump_int(A) { int cint; mgeti(cint); A=cint; }
25607 @d undump_hh(A) { mgetw(WW); A=WW.hh; }
25608 @d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
25609 @d undump_strings(A,B,C) {
25610 undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
25611 @d undump(A,B,C) { undump_int(x); if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
25612 @d undump_size(A,B,C,D) { undump_int(x);
25613 if (x<(A)) goto OFF_BASE;
25614 if (x>(B)) { too_small((C)); } else { D=x;} }
25615 @d undump_string(A) do {
25621 the_string = xmalloc(XX,sizeof(char));
25622 (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
25623 A = (char *)the_string;
25624 if (the_wanted!=(size_t)XX) goto OFF_BASE;
25627 @ The next few sections of the program should make it clear how we use the
25628 dump/undump macros.
25630 @<Dump constants for consistency check@>=
25631 dump_int(mp->mem_top);
25632 dump_int(mp->hash_size);
25633 dump_int(mp->hash_prime)
25634 dump_int(mp->param_size);
25635 dump_int(mp->max_in_open);
25637 @ Sections of a \.{WEB} program that are ``commented out'' still contribute
25638 strings to the string pool; therefore \.{INIMP} and \MP\ will have
25639 the same strings. (And it is, of course, a good thing that they do.)
25643 @<Undump constants for consistency check@>=
25644 undump_int(x); mp->mem_top = x;
25645 undump_int(x); if (mp->hash_size != x) goto OFF_BASE;
25646 undump_int(x); if (mp->hash_prime != x) goto OFF_BASE;
25647 undump_int(x); if (mp->param_size != x) goto OFF_BASE;
25648 undump_int(x); if (mp->max_in_open != x) goto OFF_BASE
25650 @ We do string pool compaction to avoid dumping unused strings.
25653 w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
25654 w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
25657 @<Dump the string pool@>=
25658 mp_do_compaction(mp, mp->pool_size);
25659 dump_int(mp->pool_ptr);
25660 dump_int(mp->max_str_ptr);
25661 dump_int(mp->str_ptr);
25663 while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
25666 while ( k<=mp->max_str_ptr ) {
25667 dump_int(mp->next_str[k]); incr(k);
25671 dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
25672 if ( k==mp->str_ptr ) {
25679 while (k+4<mp->pool_ptr ) {
25680 dump_four_ASCII; k=k+4;
25682 k=mp->pool_ptr-4; dump_four_ASCII;
25683 mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
25684 mp_print(mp, " strings of total length ");
25685 mp_print_int(mp, mp->pool_ptr)
25687 @ @d undump_four_ASCII
25689 mp->str_pool[k]=qo(w.b0); mp->str_pool[k+1]=qo(w.b1);
25690 mp->str_pool[k+2]=qo(w.b2); mp->str_pool[k+3]=qo(w.b3)
25692 @<Undump the string pool@>=
25693 undump_int(mp->pool_ptr);
25694 mp_reallocate_pool(mp, mp->pool_ptr) ;
25695 undump_int(mp->max_str_ptr);
25696 mp_reallocate_strings (mp,mp->max_str_ptr) ;
25697 undump(0,mp->max_str_ptr,mp->str_ptr);
25698 undump(0,mp->max_str_ptr+1,s);
25699 for (k=0;k<=s-1;k++)
25700 mp->next_str[k]=k+1;
25701 for (k=s;k<=mp->max_str_ptr;k++)
25702 undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
25703 mp->fixed_str_use=0;
25706 undump(0,mp->pool_ptr,mp->str_start[k]);
25707 if ( k==mp->str_ptr ) break;
25708 mp->str_ref[k]=max_str_ref;
25709 incr(mp->fixed_str_use);
25710 mp->last_fixed_str=k; k=mp->next_str[k];
25713 while ( k+4<mp->pool_ptr ) {
25714 undump_four_ASCII; k=k+4;
25716 k=mp->pool_ptr-4; undump_four_ASCII;
25717 mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
25718 mp->max_pool_ptr=mp->pool_ptr;
25719 mp->strs_used_up=mp->fixed_str_use;
25720 mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
25721 mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
25722 mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
25724 @ By sorting the list of available spaces in the variable-size portion of
25725 |mem|, we are usually able to get by without having to dump very much
25726 of the dynamic memory.
25728 We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
25729 information even when it has not been gathering statistics.
25731 @<Dump the dynamic memory@>=
25732 mp_sort_avail(mp); mp->var_used=0;
25733 dump_int(mp->lo_mem_max); dump_int(mp->rover);
25734 p=0; q=mp->rover; x=0;
25736 for (k=p;k<= q+1;k++)
25737 dump_wd(mp->mem[k]);
25738 x=x+q+2-p; mp->var_used=mp->var_used+q-p;
25739 p=q+node_size(q); q=rlink(q);
25740 } while (q!=mp->rover);
25741 mp->var_used=mp->var_used+mp->lo_mem_max-p;
25742 mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
25743 for (k=p;k<= mp->lo_mem_max;k++ )
25744 dump_wd(mp->mem[k]);
25745 x=x+mp->lo_mem_max+1-p;
25746 dump_int(mp->hi_mem_min); dump_int(mp->avail);
25747 for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
25748 dump_wd(mp->mem[k]);
25749 x=x+mp->mem_end+1-mp->hi_mem_min;
25751 while ( p!=null ) {
25752 decr(mp->dyn_used); p=link(p);
25754 dump_int(mp->var_used); dump_int(mp->dyn_used);
25755 mp_print_ln(mp); mp_print_int(mp, x);
25756 mp_print(mp, " memory locations dumped; current usage is ");
25757 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used)
25759 @ @<Undump the dynamic memory@>=
25760 undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
25761 undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
25764 for (k=p;k<= q+1; k++)
25765 undump_wd(mp->mem[k]);
25767 if ( (p>mp->lo_mem_max)||((q>=rlink(q))&&(rlink(q)!=mp->rover)) )
25770 } while (q!=mp->rover);
25771 for (k=p;k<=mp->lo_mem_max;k++ )
25772 undump_wd(mp->mem[k]);
25773 undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
25774 undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
25775 mp->last_pending=spec_head;
25776 for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
25777 undump_wd(mp->mem[k]);
25778 undump_int(mp->var_used); undump_int(mp->dyn_used)
25780 @ A different scheme is used to compress the hash table, since its lower region
25781 is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
25782 words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
25783 packed for |p>=hash_used|, so the remaining entries are output in~a~block.
25785 @<Dump the table of equivalents and the hash table@>=
25786 dump_int(mp->hash_used);
25787 mp->st_count=frozen_inaccessible-1-mp->hash_used;
25788 for (p=1;p<=mp->hash_used;p++) {
25789 if ( text(p)!=0 ) {
25790 dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
25793 for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
25794 dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
25796 dump_int(mp->st_count);
25797 mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
25799 @ @<Undump the table of equivalents and the hash table@>=
25800 undump(1,frozen_inaccessible,mp->hash_used);
25803 undump(p+1,mp->hash_used,p);
25804 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
25805 } while (p!=mp->hash_used);
25806 for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
25807 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
25809 undump_int(mp->st_count)
25811 @ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
25812 to prevent them appearing again.
25814 @<Dump a few more things and the closing check word@>=
25815 dump_int(mp->max_internal);
25816 dump_int(mp->int_ptr);
25817 for (k=1;k<= mp->int_ptr;k++ ) {
25818 dump_int(mp->internal[k]);
25819 dump_string(mp->int_name[k]);
25821 dump_int(mp->start_sym);
25822 dump_int(mp->interaction);
25823 dump_string(mp->mem_ident);
25824 dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
25825 mp->internal[mp_tracing_stats]=0
25827 @ @<Undump a few more things and the closing check word@>=
25829 if (x>mp->max_internal) mp_grow_internals(mp,x);
25830 undump_int(mp->int_ptr);
25831 for (k=1;k<= mp->int_ptr;k++) {
25832 undump_int(mp->internal[k]);
25833 undump_string(mp->int_name[k]);
25835 undump(0,frozen_inaccessible,mp->start_sym);
25836 if (mp->interaction==mp_unspecified_mode) {
25837 undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
25839 undump(mp_unspecified_mode,mp_error_stop_mode,x);
25841 undump_string(mp->mem_ident);
25842 undump(1,hash_end,mp->bg_loc);
25843 undump(1,hash_end,mp->eg_loc);
25844 undump_int(mp->serial_no);
25846 if (x!=69073) goto OFF_BASE
25848 @ @<Create the |mem_ident|...@>=
25850 xfree(mp->mem_ident);
25851 mp->mem_ident = xmalloc(256,1);
25852 mp_snprintf(mp->mem_ident,256," (mem=%s %i.%i.%i)",
25854 (int)(mp_round_unscaled(mp, mp->internal[mp_year]) % 100),
25855 (int)mp_round_unscaled(mp, mp->internal[mp_month]),
25856 (int)mp_round_unscaled(mp, mp->internal[mp_day]));
25857 mp_pack_job_name(mp, mem_extension);
25858 while (! mp_w_open_out(mp, &mp->mem_file) )
25859 mp_prompt_file_name(mp, "mem file name", mem_extension);
25860 mp_print_nl(mp, "Beginning to dump on file ");
25861 @.Beginning to dump...@>
25862 mp_print(mp, mp->name_of_file);
25863 mp_print_nl(mp, mp->mem_ident);
25866 @ @<Dealloc variables@>=
25867 xfree(mp->mem_ident);
25869 @ @<Close the mem file@>=
25870 (mp->close_file)(mp,mp->mem_file)
25872 @* \[46] The main program.
25873 This is it: the part of \MP\ that executes all those procedures we have
25876 Well---almost. We haven't put the parsing subroutines into the
25877 program yet; and we'd better leave space for a few more routines that may
25878 have been forgotten.
25880 @c @<Declare the basic parsing subroutines@>
25881 @<Declare miscellaneous procedures that were declared |forward|@>
25882 @<Last-minute procedures@>
25884 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
25886 has to be run first; it initializes everything from scratch, without
25887 reading a mem file, and it has the capability of dumping a mem file.
25888 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
25890 to input a mem file in order to get started. \.{VIRMP} typically has
25891 a bit more memory capacity than \.{INIMP}, because it does not need the
25892 space consumed by the dumping/undumping routines and the numerous calls on
25895 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
25896 the best implementations therefore allow for production versions of \MP\ that
25897 not only avoid the loading routine for object code, they also have
25898 a mem file pre-loaded.
25900 @ @<Option variables@>=
25901 int ini_version; /* are we iniMP? */
25903 @ @<Set |ini_version|@>=
25904 mp->ini_version = (opt->ini_version ? true : false);
25906 @ Here we do whatever is needed to complete \MP's job gracefully on the
25907 local operating system. The code here might come into play after a fatal
25908 error; it must therefore consist entirely of ``safe'' operations that
25909 cannot produce error messages. For example, it would be a mistake to call
25910 |str_room| or |make_string| at this time, because a call on |overflow|
25911 might lead to an infinite loop.
25912 @^system dependencies@>
25914 This program doesn't bother to close the input files that may still be open.
25916 @<Last-minute...@>=
25917 void mp_close_files_and_terminate (MP mp) {
25918 integer k; /* all-purpose index */
25919 integer LH; /* the length of the \.{TFM} header, in words */
25920 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
25921 pointer p; /* runs through a list of \.{TFM} dimensions */
25922 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
25923 if ( mp->internal[mp_tracing_stats]>0 )
25924 @<Output statistics about this job@>;
25926 @<Do all the finishing work on the \.{TFM} file@>;
25927 @<Explain what output files were written@>;
25928 if ( mp->log_opened ){
25930 (mp->close_file)(mp,mp->log_file);
25931 mp->selector=mp->selector-2;
25932 if ( mp->selector==term_only ) {
25933 mp_print_nl(mp, "Transcript written on ");
25934 @.Transcript written...@>
25935 mp_print(mp, mp->log_name); mp_print_char(mp, '.');
25943 @ @<Declarations@>=
25944 void mp_close_files_and_terminate (MP mp) ;
25946 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
25947 if (mp->rd_fname!=NULL) {
25948 for (k=0;k<=(int)mp->read_files-1;k++ ) {
25949 if ( mp->rd_fname[k]!=NULL ) {
25950 (mp->close_file)(mp,mp->rd_file[k]);
25951 xfree(mp->rd_fname[k]);
25955 if (mp->wr_fname!=NULL) {
25956 for (k=0;k<=(int)mp->write_files-1;k++) {
25957 if ( mp->wr_fname[k]!=NULL ) {
25958 (mp->close_file)(mp,mp->wr_file[k]);
25959 xfree(mp->wr_fname[k]);
25965 for (k=0;k<(int)mp->max_read_files;k++ ) {
25966 if ( mp->rd_fname[k]!=NULL ) {
25967 (mp->close_file)(mp,mp->rd_file[k]);
25968 xfree(mp->rd_fname[k]);
25971 xfree(mp->rd_file);
25972 xfree(mp->rd_fname);
25973 for (k=0;k<(int)mp->max_write_files;k++) {
25974 if ( mp->wr_fname[k]!=NULL ) {
25975 (mp->close_file)(mp,mp->wr_file[k]);
25976 xfree(mp->wr_fname[k]);
25979 xfree(mp->wr_file);
25980 xfree(mp->wr_fname);
25983 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
25985 We reclaim all of the variable-size memory at this point, so that
25986 there is no chance of another memory overflow after the memory capacity
25987 has already been exceeded.
25989 @<Do all the finishing work on the \.{TFM} file@>=
25990 if ( mp->internal[mp_fontmaking]>0 ) {
25991 @<Make the dynamic memory into one big available node@>;
25992 @<Massage the \.{TFM} widths@>;
25993 mp_fix_design_size(mp); mp_fix_check_sum(mp);
25994 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
25995 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
25996 @<Finish the \.{TFM} file@>;
25999 @ @<Make the dynamic memory into one big available node@>=
26000 mp->rover=lo_mem_stat_max+1; link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26001 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26002 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26003 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
26004 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
26006 @ The present section goes directly to the log file instead of using
26007 |print| commands, because there's no need for these strings to take
26008 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26010 @<Output statistics...@>=
26011 if ( mp->log_opened ) {
26014 wlog_ln("Here is how much of MetaPost's memory you used:");
26015 @.Here is how much...@>
26016 mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26017 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26018 (int)(mp->max_strings-1-mp->init_str_use));
26020 mp_snprintf(s,128," %i string characters out of %i",
26021 (int)mp->max_pl_used-mp->init_pool_ptr,
26022 (int)mp->pool_size-mp->init_pool_ptr);
26024 mp_snprintf(s,128," %i words of memory out of %i",
26025 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26028 mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26030 mp_snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
26031 (int)mp->max_in_stack,(int)mp->int_ptr,
26032 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26033 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26035 mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26036 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26040 @ It is nice to have have some of the stats available from the API.
26042 @<Exported function ...@>=
26043 int mp_memory_usage (MP mp );
26044 int mp_hash_usage (MP mp );
26045 int mp_param_usage (MP mp );
26046 int mp_open_usage (MP mp );
26049 int mp_memory_usage (MP mp ) {
26050 return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
26052 int mp_hash_usage (MP mp ) {
26053 return (int)mp->st_count;
26055 int mp_param_usage (MP mp ) {
26056 return (int)mp->max_param_stack;
26058 int mp_open_usage (MP mp ) {
26059 return (int)mp->max_in_stack;
26062 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26065 @<Last-minute...@>=
26066 void mp_final_cleanup (MP mp) {
26067 small_number c; /* 0 for \&{end}, 1 for \&{dump} */
26069 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26070 while ( mp->input_ptr>0 ) {
26071 if ( token_state ) mp_end_token_list(mp);
26072 else mp_end_file_reading(mp);
26074 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26075 while ( mp->open_parens>0 ) {
26076 mp_print(mp, " )"); decr(mp->open_parens);
26078 while ( mp->cond_ptr!=null ) {
26079 mp_print_nl(mp, "(end occurred when ");
26080 @.end occurred...@>
26081 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26082 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26083 if ( mp->if_line!=0 ) {
26084 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26086 mp_print(mp, " was incomplete)");
26087 mp->if_line=if_line_field(mp->cond_ptr);
26088 mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=link(mp->cond_ptr);
26090 if ( mp->history!=mp_spotless )
26091 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26092 if ( mp->selector==term_and_log ) {
26093 mp->selector=term_only;
26094 mp_print_nl(mp, "(see the transcript file for additional information)");
26095 @.see the transcript file...@>
26096 mp->selector=term_and_log;
26099 if (mp->ini_version) {
26100 mp_store_mem_file(mp); return;
26102 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26103 @.dump...only by INIMP@>
26107 @ @<Declarations@>=
26108 void mp_final_cleanup (MP mp) ;
26109 void mp_init_prim (MP mp) ;
26110 void mp_init_tab (MP mp) ;
26112 @ @<Last-minute...@>=
26113 void mp_init_prim (MP mp) { /* initialize all the primitives */
26117 void mp_init_tab (MP mp) { /* initialize other tables */
26118 integer k; /* all-purpose index */
26119 @<Initialize table entries (done by \.{INIMP} only)@>;
26123 @ When we begin the following code, \MP's tables may still contain garbage;
26124 the strings might not even be present. Thus we must proceed cautiously to get
26127 But when we finish this part of the program, \MP\ is ready to call on the
26128 |main_control| routine to do its work.
26130 @<Get the first line...@>=
26132 @<Initialize the input routines@>;
26133 if ( (mp->mem_ident==NULL)||(mp->buffer[loc]=='&') ) {
26134 if ( mp->mem_ident!=NULL ) {
26135 mp_do_initialize(mp); /* erase preloaded mem */
26137 if ( ! mp_open_mem_file(mp) ) return mp_fatal_error_stop;
26138 if ( ! mp_load_mem_file(mp) ) {
26139 (mp->close_file)(mp, mp->mem_file);
26140 return mp_fatal_error_stop;
26142 (mp->close_file)(mp, mp->mem_file);
26143 while ( (loc<limit)&&(mp->buffer[loc]==' ') ) incr(loc);
26145 mp->buffer[limit]='%';
26146 mp_fix_date_and_time(mp);
26147 if (mp->random_seed==0)
26148 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
26149 mp_init_randoms(mp, mp->random_seed);
26150 @<Initialize the print |selector|...@>;
26151 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26152 mp_start_input(mp); /* \&{input} assumed */
26155 @ @<Run inimpost commands@>=
26157 mp_get_strings_started(mp);
26158 mp_init_tab(mp); /* initialize the tables */
26159 mp_init_prim(mp); /* call |primitive| for each primitive */
26160 mp->init_str_use=mp->str_ptr; mp->init_pool_ptr=mp->pool_ptr;
26161 mp->max_str_ptr=mp->str_ptr; mp->max_pool_ptr=mp->pool_ptr;
26162 mp_fix_date_and_time(mp);
26166 @* \[47] Debugging.
26167 Once \MP\ is working, you should be able to diagnose most errors with
26168 the \.{show} commands and other diagnostic features. But for the initial
26169 stages of debugging, and for the revelation of really deep mysteries, you
26170 can compile \MP\ with a few more aids. An additional routine called |debug_help|
26171 will also come into play when you type `\.D' after an error message;
26172 |debug_help| also occurs just before a fatal error causes \MP\ to succumb.
26174 @^system dependencies@>
26176 The interface to |debug_help| is primitive, but it is good enough when used
26177 with a debugger that allows you to set breakpoints and to read
26178 variables and change their values. After getting the prompt `\.{debug \#}', you
26179 type either a negative number (this exits |debug_help|), or zero (this
26180 goes to a location where you can set a breakpoint, thereby entering into
26181 dialog with the debugger), or a positive number |m| followed by
26182 an argument |n|. The meaning of |m| and |n| will be clear from the
26183 program below. (If |m=13|, there is an additional argument, |l|.)
26186 @<Last-minute...@>=
26187 void mp_debug_help (MP mp) { /* routine to display various things */
26194 mp_print_nl(mp, "debug # (-1 to exit):"); update_terminal;
26197 aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
26198 if (len) { sscanf(aline,"%i",&m); xfree(aline); }
26202 aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
26203 if (len) { sscanf(aline,"%i",&n); xfree(aline); }
26205 @<Numbered cases for |debug_help|@>;
26206 default: mp_print(mp, "?"); break;
26211 @ @<Numbered cases...@>=
26212 case 1: mp_print_word(mp, mp->mem[n]); /* display |mem[n]| in all forms */
26214 case 2: mp_print_int(mp, info(n));
26216 case 3: mp_print_int(mp, link(n));
26218 case 4: mp_print_int(mp, eq_type(n)); mp_print_char(mp, ':'); mp_print_int(mp, equiv(n));
26220 case 5: mp_print_variable_name(mp, n);
26222 case 6: mp_print_int(mp, mp->internal[n]);
26224 case 7: mp_do_show_dependencies(mp);
26226 case 9: mp_show_token_list(mp, n,null,100000,0);
26228 case 10: mp_print_str(mp, n);
26230 case 11: mp_check_mem(mp, n>0); /* check wellformedness; print new busy locations if |n>0| */
26232 case 12: mp_search_mem(mp, n); /* look for pointers to |n| */
26236 aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
26237 if (len) { sscanf(aline,"%i",&l); xfree(aline); }
26238 mp_print_cmd_mod(mp, n,l);
26240 case 14: for (k=0;k<=n;k++) mp_print_str(mp, mp->buffer[k]);
26242 case 15: mp->panicking=! mp->panicking;
26246 @ Saving the filename template
26248 @<Save the filename template@>=
26250 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26251 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26253 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26257 @* \[48] System-dependent changes.
26258 This section should be replaced, if necessary, by any special
26259 modification of the program
26260 that are necessary to make \MP\ work at a particular installation.
26261 It is usually best to design your change file so that all changes to
26262 previous sections preserve the section numbering; then everybody's version
26263 will be consistent with the published program. More extensive changes,
26264 which introduce new sections, can be inserted here; then only the index
26265 itself will get a new section number.
26266 @^system dependencies@>
26269 Here is where you can find all uses of each identifier in the program,
26270 with underlined entries pointing to where the identifier was defined.
26271 If the identifier is only one letter long, however, you get to see only
26272 the underlined entries. {\sl All references are to section numbers instead of
26275 This index also lists error messages and other aspects of the program
26276 that you might want to look up some day. For example, the entry
26277 for ``system dependencies'' lists all sections that should receive
26278 special attention from people who are installing \MP\ in a new
26279 operating environment. A list of various things that can't happen appears
26280 under ``this can't happen''.
26281 Approximately 25 sections are listed under ``inner loop''; these account
26282 for more than 60\pct! of \MP's running time, exclusive of input and output.