1 % $Id: mp.w 1313 2008-06-15 14:32:34Z 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.060" /* printed when \MP\ starts */
77 @d metapost_version "1.060"
78 @d mplib_version "0.60"
79 @d version_string " (Cweb version)"
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;
117 @<Types in the outer block@>
118 @<Constants in the outer block@>
119 # ifndef LIBAVL_ALLOCATOR
120 # define LIBAVL_ALLOCATOR
121 struct libavl_allocator {
122 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
123 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
126 typedef struct MP_instance {
130 @<Internal library declarations@>
139 #include <unistd.h> /* for access() */
140 #include <time.h> /* for struct tm \& co */
142 #include "mpmp.h" /* internal header */
143 #include "mppsout.h" /* internal header */
146 @<Basic printing procedures@>
147 @<Error handling procedures@>
149 @ Here are the functions that set up the \MP\ instance.
152 @<Declare |mp_reallocate| functions@>
153 struct MP_options *mp_options (void);
154 MP mp_new (struct MP_options *opt);
157 struct MP_options *mp_options (void) {
158 struct MP_options *opt;
159 opt = malloc(sizeof(MP_options));
161 memset (opt,0,sizeof(MP_options));
166 @ The |__attribute__| pragma is gcc-only.
168 @<Internal library ... @>=
169 #if !defined(__GNUC__) || (__GNUC__ < 2)
170 # define __attribute__(x)
171 #endif /* !defined(__GNUC__) || (__GNUC__ < 2) */
174 MP __attribute__ ((noinline))
175 mp_do_new (struct MP_options *opt, jmp_buf *buf) {
176 MP mp = malloc(sizeof(MP_instance));
180 @<Set |ini_version|@>;
181 @<Allocate or initialize variables@>
182 if (opt->main_memory>mp->mem_max)
183 mp_reallocate_memory(mp,opt->main_memory);
184 mp_reallocate_paths(mp,1000);
185 mp_reallocate_fonts(mp,8);
188 MP __attribute__ ((noinline))
189 mp_new (struct MP_options *opt) {
191 @<Setup the non-local jump buffer in |mp_new|@>;
192 return mp_do_new(opt, &buf);
197 void mp_free (MP mp) {
198 int k; /* loop variable */
199 @<Dealloc variables@>
204 void __attribute__((noinline))
205 mp_do_initialize ( MP mp) {
206 @<Local variables for initialization@>
207 @<Set initial values of key variables@>
209 int mp_initialize (MP mp) { /* this procedure gets things started properly */
210 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
212 @<Install and test the non-local jump buffer@>;
213 t_open_out; /* open the terminal for output */
214 @<Check the ``constant'' values...@>;
217 mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
218 "---case %i",(int)mp->bad);
219 do_fprintf(mp->err_out,(char *)ss);
223 mp_do_initialize(mp); /* erase preloaded mem */
224 if (mp->ini_version) {
225 @<Run inimpost commands@>;
227 @<Initialize the output routines@>;
228 @<Get the first line of input and prepare to start@>;
230 mp_init_map_file(mp, mp->troff_mode);
231 mp->history=mp_spotless; /* ready to go! */
232 if (mp->troff_mode) {
233 mp->internal[mp_gtroffmode]=unity;
234 mp->internal[mp_prologues]=unity;
236 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
237 mp->cur_sym=mp->start_sym; mp_back_input(mp);
243 @<Exported function headers@>=
244 extern struct MP_options *mp_options (void);
245 extern MP mp_new (struct MP_options *opt) ;
246 extern void mp_free (MP mp);
247 extern int mp_initialize (MP mp);
249 @ The overall \MP\ program begins with the heading just shown, after which
250 comes a bunch of procedure declarations and function declarations.
251 Finally we will get to the main program, which begins with the
252 comment `|start_here|'. If you want to skip down to the
253 main program now, you can look up `|start_here|' in the index.
254 But the author suggests that the best way to understand this program
255 is to follow pretty much the order of \MP's components as they appear in the
256 \.{WEB} description you are now reading, since the present ordering is
257 intended to combine the advantages of the ``bottom up'' and ``top down''
258 approaches to the problem of understanding a somewhat complicated system.
260 @ Some of the code below is intended to be used only when diagnosing the
261 strange behavior that sometimes occurs when \MP\ is being installed or
262 when system wizards are fooling around with \MP\ without quite knowing
263 what they are doing. Such code will not normally be compiled; it is
264 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
266 @ This program has two important variations: (1) There is a long and slow
267 version called \.{INIMP}, which does the extra calculations needed to
269 initialize \MP's internal tables; and (2)~there is a shorter and faster
270 production version, which cuts the initialization to a bare minimum.
272 Which is which is decided at runtime.
274 @ The following parameters can be changed at compile time to extend or
275 reduce \MP's capacity. They may have different values in \.{INIMP} and
276 in production versions of \MP.
278 @^system dependencies@>
281 #define file_name_size 255 /* file names shouldn't be longer than this */
282 #define bistack_size 1500 /* size of stack for bisection algorithms;
283 should probably be left at this value */
285 @ Like the preceding parameters, the following quantities can be changed
286 at compile time to extend or reduce \MP's capacity. But if they are changed,
287 it is necessary to rerun the initialization program \.{INIMP}
289 to generate new tables for the production \MP\ program.
290 One can't simply make helter-skelter changes to the following constants,
291 since certain rather complex initialization
292 numbers are computed from them.
295 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
296 int pool_size; /* maximum number of characters in strings, including all
297 error messages and help texts, and the names of all identifiers */
298 int mem_max; /* greatest index in \MP's internal |mem| array;
299 must be strictly less than |max_halfword|;
300 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
301 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
302 must not be greater than |mem_max| */
304 @ @<Option variables@>=
305 int error_line; /* width of context lines on terminal error messages */
306 int half_error_line; /* width of first lines of contexts in terminal
307 error messages; should be between 30 and |error_line-15| */
308 int max_print_line; /* width of longest text lines output; should be at least 60 */
309 int hash_size; /* maximum number of symbolic tokens,
310 must be less than |max_halfword-3*param_size| */
311 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
312 int param_size; /* maximum number of simultaneous macro parameters */
313 int max_in_open; /* maximum number of input files and error insertions that
314 can be going on simultaneously */
315 int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
316 void *userdata; /* this allows the calling application to setup local */
319 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
324 set_value(mp->error_line,opt->error_line,79);
325 set_value(mp->half_error_line,opt->half_error_line,50);
326 set_value(mp->max_print_line,opt->max_print_line,100);
327 mp->main_memory=5000;
330 set_value(mp->hash_size,opt->hash_size,9500);
331 set_value(mp->hash_prime,opt->hash_prime,7919);
332 set_value(mp->param_size,opt->param_size,150);
333 set_value(mp->max_in_open,opt->max_in_open,10);
334 mp->userdata=opt->userdata;
336 @ In case somebody has inadvertently made bad settings of the ``constants,''
337 \MP\ checks them using a global variable called |bad|.
339 This is the first of many sections of \MP\ where global variables are
343 integer bad; /* is some ``constant'' wrong? */
345 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
346 or something similar. (We can't do that until |max_halfword| has been defined.)
348 @<Check the ``constant'' values for consistency@>=
350 if ( (mp->half_error_line<30)||(mp->half_error_line>mp->error_line-15) ) mp->bad=1;
351 if ( mp->max_print_line<60 ) mp->bad=2;
352 if ( mp->mem_top<=1100 ) mp->bad=4;
353 if (mp->hash_prime>mp->hash_size ) mp->bad=5;
355 @ Some |goto| labels are used by the following definitions. The label
356 `|restart|' is occasionally used at the very beginning of a procedure; and
357 the label `|reswitch|' is occasionally used just prior to a |case|
358 statement in which some cases change the conditions and we wish to branch
359 to the newly applicable case. Loops that are set up with the |loop|
360 construction defined below are commonly exited by going to `|done|' or to
361 `|found|' or to `|not_found|', and they are sometimes repeated by going to
362 `|continue|'. If two or more parts of a subroutine start differently but
363 end up the same, the shared code may be gathered together at
366 @ Here are some macros for common programming idioms.
368 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
369 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
370 @d negate(A) (A)=-(A) /* change the sign of a variable */
371 @d double(A) (A)=(A)+(A)
374 @d do_nothing /* empty statement */
375 @d Return goto exit /* terminate a procedure call */
376 @f return nil /* \.{WEB} will henceforth say |return| instead of \\{return} */
378 @* \[2] The character set.
379 In order to make \MP\ readily portable to a wide variety of
380 computers, all of its input text is converted to an internal eight-bit
381 code that includes standard ASCII, the ``American Standard Code for
382 Information Interchange.'' This conversion is done immediately when each
383 character is read in. Conversely, characters are converted from ASCII to
384 the user's external representation just before they are output to a
388 Such an internal code is relevant to users of \MP\ only with respect to
389 the \&{char} and \&{ASCII} operations, and the comparison of strings.
391 @ Characters of text that have been converted to \MP's internal form
392 are said to be of type |ASCII_code|, which is a subrange of the integers.
395 typedef unsigned char ASCII_code; /* eight-bit numbers */
397 @ The present specification of \MP\ has been written under the assumption
398 that the character set contains at least the letters and symbols associated
399 with ASCII codes 040 through 0176; all of these characters are now
400 available on most computer terminals.
402 We shall use the name |text_char| to stand for the data type of the characters
403 that are converted to and from |ASCII_code| when they are input and output.
404 We shall also assume that |text_char| consists of the elements
405 |chr(first_text_char)| through |chr(last_text_char)|, inclusive.
406 The following definitions should be adjusted if necessary.
407 @^system dependencies@>
409 @d first_text_char 0 /* ordinal number of the smallest element of |text_char| */
410 @d last_text_char 255 /* ordinal number of the largest element of |text_char| */
413 typedef unsigned char text_char; /* the data type of characters in text files */
415 @ @<Local variables for init...@>=
418 @ The \MP\ processor converts between ASCII code and
419 the user's external character set by means of arrays |xord| and |xchr|
420 that are analogous to Pascal's |ord| and |chr| functions.
422 @d xchr(A) mp->xchr[(A)]
423 @d xord(A) mp->xord[(A)]
426 ASCII_code xord[256]; /* specifies conversion of input characters */
427 text_char xchr[256]; /* specifies conversion of output characters */
429 @ The core system assumes all 8-bit is acceptable. If it is not,
430 a change file has to alter the below section.
431 @^system dependencies@>
433 Additionally, people with extended character sets can
434 assign codes arbitrarily, giving an |xchr| equivalent to whatever
435 characters the users of \MP\ are allowed to have in their input files.
436 Appropriate changes to \MP's |char_class| table should then be made.
437 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
438 codes, called the |char_class|.) Such changes make portability of programs
439 more difficult, so they should be introduced cautiously if at all.
440 @^character set dependencies@>
441 @^system dependencies@>
444 for (i=0;i<=0377;i++) { xchr(i)=i; }
446 @ The following system-independent code makes the |xord| array contain a
447 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
448 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
449 |j| or more; hence, standard ASCII code numbers will be used instead of
450 codes below 040 in case there is a coincidence.
453 for (i=first_text_char;i<=last_text_char;i++) {
456 for (i=0200;i<=0377;i++) { xord(xchr(i))=i;}
457 for (i=0;i<=0176;i++) { xord(xchr(i))=i;}
459 @* \[3] Input and output.
460 The bane of portability is the fact that different operating systems treat
461 input and output quite differently, perhaps because computer scientists
462 have not given sufficient attention to this problem. People have felt somehow
463 that input and output are not part of ``real'' programming. Well, it is true
464 that some kinds of programming are more fun than others. With existing
465 input/output conventions being so diverse and so messy, the only sources of
466 joy in such parts of the code are the rare occasions when one can find a
467 way to make the program a little less bad than it might have been. We have
468 two choices, either to attack I/O now and get it over with, or to postpone
469 I/O until near the end. Neither prospect is very attractive, so let's
472 The basic operations we need to do are (1)~inputting and outputting of
473 text, to or from a file or the user's terminal; (2)~inputting and
474 outputting of eight-bit bytes, to or from a file; (3)~instructing the
475 operating system to initiate (``open'') or to terminate (``close'') input or
476 output from a specified file; (4)~testing whether the end of an input
477 file has been reached; (5)~display of bits on the user's screen.
478 The bit-display operation will be discussed in a later section; we shall
479 deal here only with more traditional kinds of I/O.
481 @ Finding files happens in a slightly roundabout fashion: the \MP\
482 instance object contains a field that holds a function pointer that finds a
483 file, and returns its name, or NULL. For this, it receives three
484 parameters: the non-qualified name |fname|, the intended |fopen|
485 operation type |fmode|, and the type of the file |ftype|.
487 The file types that are passed on in |ftype| can be used to
488 differentiate file searches if a library like kpathsea is used,
489 the fopen mode is passed along for the same reason.
492 typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
494 @ @<Exported types@>=
496 mp_filetype_terminal = 0, /* the terminal */
497 mp_filetype_error, /* the terminal */
498 mp_filetype_program , /* \MP\ language input */
499 mp_filetype_log, /* the log file */
500 mp_filetype_postscript, /* the postscript output */
501 mp_filetype_memfile, /* memory dumps */
502 mp_filetype_metrics, /* TeX font metric files */
503 mp_filetype_fontmap, /* PostScript font mapping files */
504 mp_filetype_font, /* PostScript type1 font programs */
505 mp_filetype_encoding, /* PostScript font encoding files */
506 mp_filetype_text /* first text file for readfrom and writeto primitives */
508 typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
509 typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
510 typedef char *(*mp_file_reader)(MP, void *, size_t *);
511 typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
512 typedef void (*mp_file_closer)(MP, void *);
513 typedef int (*mp_file_eoftest)(MP, void *);
514 typedef void (*mp_file_flush)(MP, void *);
515 typedef void (*mp_file_writer)(MP, void *, const char *);
516 typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
519 @ @<Option variables@>=
520 mp_file_finder find_file;
521 mp_file_opener open_file;
522 mp_file_reader read_ascii_file;
523 mp_binfile_reader read_binary_file;
524 mp_file_closer close_file;
525 mp_file_eoftest eof_file;
526 mp_file_flush flush_file;
527 mp_file_writer write_ascii_file;
528 mp_binfile_writer write_binary_file;
530 @ The default function for finding files is |mp_find_file|. It is
531 pretty stupid: it will only find files in the current directory.
533 This function may disappear altogether, it is currently only
534 used for the default font map file.
537 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
539 if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
540 return strdup(fname);
545 @ This has to be done very early on, so it is best to put it in with
546 the |mp_new| allocations
548 @d set_callback_option(A) do { mp->A = mp_##A;
549 if (opt->A!=NULL) mp->A = opt->A;
552 @<Allocate or initialize ...@>=
553 set_callback_option(find_file);
554 set_callback_option(open_file);
555 set_callback_option(read_ascii_file);
556 set_callback_option(read_binary_file);
557 set_callback_option(close_file);
558 set_callback_option(eof_file);
559 set_callback_option(flush_file);
560 set_callback_option(write_ascii_file);
561 set_callback_option(write_binary_file);
563 @ Because |mp_find_file| is used so early, it has to be in the helpers
567 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
568 void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
569 char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
570 void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
571 void mp_close_file (MP mp, void *f) ;
572 int mp_eof_file (MP mp, void *f) ;
573 void mp_flush_file (MP mp, void *f) ;
574 void mp_write_ascii_file (MP mp, void *f, const char *s) ;
575 void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
577 @ The function to open files can now be very short.
580 void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
583 realmode[0] = *fmode;
587 if (ftype==mp_filetype_terminal) {
588 return (fmode[0] == 'r' ? stdin : stdout);
589 } else if (ftype==mp_filetype_error) {
591 } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
592 return (void *)fopen(fname, realmode);
598 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
601 char name_of_file[file_name_size+1]; /* the name of a system file */
602 int name_length;/* this many characters are actually
603 relevant in |name_of_file| (the rest are blank) */
605 @ @<Option variables@>=
606 int print_found_names; /* configuration parameter */
608 @ If this parameter is true, the terminal and log will report the found
609 file names for input files instead of the requested ones.
610 It is off by default because it creates an extra filename lookup.
612 @<Allocate or initialize ...@>=
613 mp->print_found_names = (opt->print_found_names>0 ? true : false);
615 @ \MP's file-opening procedures return |false| if no file identified by
616 |name_of_file| could be opened.
618 The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
619 It is not used for opening a mem file for read, because that file name
623 if (mp->print_found_names) {
624 char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
626 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
627 strncpy(mp->name_of_file,s,file_name_size);
633 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
636 return (*f ? true : false)
639 boolean mp_a_open_in (MP mp, void **f, int ftype) {
640 /* open a text file for input */
644 boolean mp_w_open_in (MP mp, void **f) {
645 /* open a word file for input */
646 *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
647 return (*f ? true : false);
650 boolean mp_a_open_out (MP mp, void **f, int ftype) {
651 /* open a text file for output */
655 boolean mp_b_open_out (MP mp, void **f, int ftype) {
656 /* open a binary file for output */
660 boolean mp_w_open_out (MP mp, void **f) {
661 /* open a word file for output */
662 int ftype = mp_filetype_memfile;
667 char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
669 size_t len = 0, lim = 128;
671 FILE *f = (FILE *)ff;
673 (void) mp; /* for -Wunused */
681 if (s==NULL) return NULL;
682 while (c!=EOF && c!='\n' && c!='\r') {
684 s =realloc(s, (lim+(lim>>2)));
685 if (s==NULL) return NULL;
693 if (c!=EOF && c!='\n')
703 void mp_write_ascii_file (MP mp, void *f, const char *s) {
713 void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
718 len = fread(*data,1,*size,(FILE *)f);
724 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
728 fwrite(s,size,1,(FILE *)f);
734 void mp_close_file (MP mp, void *f) {
743 int mp_eof_file (MP mp, void *f) {
747 return feof((FILE *)f);
756 void mp_flush_file (MP mp, void *f) {
764 @ Input from text files is read one line at a time, using a routine called
765 |input_ln|. This function is defined in terms of global variables called
766 |buffer|, |first|, and |last| that will be described in detail later; for
767 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
768 values, and that |first| and |last| are indices into this array
769 representing the beginning and ending of a line of text.
772 size_t buf_size; /* maximum number of characters simultaneously present in
773 current lines of open files */
774 ASCII_code *buffer; /* lines of characters being read */
775 size_t first; /* the first unused position in |buffer| */
776 size_t last; /* end of the line just input to |buffer| */
777 size_t max_buf_stack; /* largest index used in |buffer| */
779 @ @<Allocate or initialize ...@>=
781 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
783 @ @<Dealloc variables@>=
787 void mp_reallocate_buffer(MP mp, size_t l) {
789 if (l>max_halfword) {
790 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
792 buffer = xmalloc((l+1),sizeof(ASCII_code));
793 memcpy(buffer,mp->buffer,(mp->buf_size+1));
795 mp->buffer = buffer ;
799 @ The |input_ln| function brings the next line of input from the specified
800 field into available positions of the buffer array and returns the value
801 |true|, unless the file has already been entirely read, in which case it
802 returns |false| and sets |last:=first|. In general, the |ASCII_code|
803 numbers that represent the next line of the file are input into
804 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
805 global variable |last| is set equal to |first| plus the length of the
806 line. Trailing blanks are removed from the line; thus, either |last=first|
807 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
810 The variable |max_buf_stack|, which is used to keep track of how large
811 the |buf_size| parameter must be to accommodate the present job, is
812 also kept up to date by |input_ln|.
815 boolean mp_input_ln (MP mp, void *f ) {
816 /* inputs the next line or returns |false| */
819 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
820 s = (mp->read_ascii_file)(mp,f, &size);
824 mp->last = mp->first+size;
825 if ( mp->last>=mp->max_buf_stack ) {
826 mp->max_buf_stack=mp->last+1;
827 while ( mp->max_buf_stack>=mp->buf_size ) {
828 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
831 memcpy((mp->buffer+mp->first),s,size);
832 /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
838 @ The user's terminal acts essentially like other files of text, except
839 that it is used both for input and for output. When the terminal is
840 considered an input file, the file variable is called |term_in|, and when it
841 is considered an output file the file variable is |term_out|.
842 @^system dependencies@>
845 void * term_in; /* the terminal as an input file */
846 void * term_out; /* the terminal as an output file */
847 void * err_out; /* the terminal as an output file */
849 @ Here is how to open the terminal files. In the default configuration,
850 nothing happens except that the command line (if there is one) is copied
851 to the input buffer. The variable |command_line| will be filled by the
852 |main| procedure. The copying can not be done earlier in the program
853 logic because in the |INI| version, the |buffer| is also used for primitive
856 @^system dependencies@>
858 @d t_open_out do {/* open the terminal for text output */
859 mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
860 mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
862 @d t_open_in do { /* open the terminal for text input */
863 mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
864 if (mp->command_line!=NULL) {
865 mp->last = strlen(mp->command_line);
866 strncpy((char *)mp->buffer,mp->command_line,mp->last);
867 xfree(mp->command_line);
873 @d t_close_out do { /* close the terminal */
874 /* (mp->close_file)(mp,mp->term_out); */
875 /* (mp->close_file)(mp,mp->err_out); */
878 @d t_close_in do { /* close the terminal */
879 /* (mp->close_file)(mp,mp->term_in); */
882 @<Option variables@>=
885 @ @<Allocate or initialize ...@>=
886 mp->command_line = xstrdup(opt->command_line);
888 @ Sometimes it is necessary to synchronize the input/output mixture that
889 happens on the user's terminal, and three system-dependent
890 procedures are used for this
891 purpose. The first of these, |update_terminal|, is called when we want
892 to make sure that everything we have output to the terminal so far has
893 actually left the computer's internal buffers and been sent.
894 The second, |clear_terminal|, is called when we wish to cancel any
895 input that the user may have typed ahead (since we are about to
896 issue an unexpected error message). The third, |wake_up_terminal|,
897 is supposed to revive the terminal if the user has disabled it by
898 some instruction to the operating system. The following macros show how
899 these operations can be specified:
900 @^system dependencies@>
902 @d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
903 @d clear_terminal do_nothing /* clear the terminal input buffer */
904 @d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
905 /* cancel the user's cancellation of output */
907 @ We need a special routine to read the first line of \MP\ input from
908 the user's terminal. This line is different because it is read before we
909 have opened the transcript file; there is sort of a ``chicken and
910 egg'' problem here. If the user types `\.{input cmr10}' on the first
911 line, or if some macro invoked by that line does such an \.{input},
912 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
913 commands are performed during the first line of terminal input, the transcript
914 file will acquire its default name `\.{mpout.log}'. (The transcript file
915 will not contain error messages generated by the first line before the
916 first \.{input} command.)
918 The first line is even more special. It's nice to let the user start
919 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
920 such a case, \MP\ will operate as if the first line of input were
921 `\.{cmr10}', i.e., the first line will consist of the remainder of the
922 command line, after the part that invoked \MP.
924 @ Different systems have different ways to get started. But regardless of
925 what conventions are adopted, the routine that initializes the terminal
926 should satisfy the following specifications:
928 \yskip\textindent{1)}It should open file |term_in| for input from the
929 terminal. (The file |term_out| will already be open for output to the
932 \textindent{2)}If the user has given a command line, this line should be
933 considered the first line of terminal input. Otherwise the
934 user should be prompted with `\.{**}', and the first line of input
935 should be whatever is typed in response.
937 \textindent{3)}The first line of input, which might or might not be a
938 command line, should appear in locations |first| to |last-1| of the
941 \textindent{4)}The global variable |loc| should be set so that the
942 character to be read next by \MP\ is in |buffer[loc]|. This
943 character should not be blank, and we should have |loc<last|.
945 \yskip\noindent(It may be necessary to prompt the user several times
946 before a non-blank line comes in. The prompt is `\.{**}' instead of the
947 later `\.*' because the meaning is slightly different: `\.{input}' need
948 not be typed immediately after~`\.{**}'.)
950 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
952 @ The following program does the required initialization
953 without retrieving a possible command line.
954 It should be clear how to modify this routine to deal with command lines,
955 if the system permits them.
956 @^system dependencies@>
959 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
966 if (!mp->noninteractive) {
967 wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
970 if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
971 do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
972 @.End of file on the terminal@>
976 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
978 if ( loc<(int)mp->last ) {
979 return true; /* return unless the line was all blank */
981 if (!mp->noninteractive) {
982 do_fprintf(mp->term_out,"Please type the name of your input file.\n");
988 boolean mp_init_terminal (MP mp) ;
991 @* \[4] String handling.
992 Symbolic token names and diagnostic messages are variable-length strings
993 of eight-bit characters. Many strings \MP\ uses are simply literals
994 in the compiled source, like the error messages and the names of the
995 internal parameters. Other strings are used or defined from the \MP\ input
996 language, and these have to be interned.
998 \MP\ uses strings more extensively than \MF\ does, but the necessary
999 operations can still be handled with a fairly simple data structure.
1000 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
1001 of the strings, and the array |str_start| contains indices of the starting
1002 points of each string. Strings are referred to by integer numbers, so that
1003 string number |s| comprises the characters |str_pool[j]| for
1004 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
1005 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
1006 location. The first string number not currently in use is |str_ptr|
1007 and |next_str[str_ptr]| begins a list of free string numbers. String
1008 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
1009 string currently being constructed.
1011 String numbers 0 to 255 are reserved for strings that correspond to single
1012 ASCII characters. This is in accordance with the conventions of \.{WEB},
1014 which converts single-character strings into the ASCII code number of the
1015 single character involved, while it converts other strings into integers
1016 and builds a string pool file. Thus, when the string constant \.{"."} appears
1017 in the program below, \.{WEB} converts it into the integer 46, which is the
1018 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
1019 into some integer greater than~255. String number 46 will presumably be the
1020 single character `\..'\thinspace; but some ASCII codes have no standard visible
1021 representation, and \MP\ may need to be able to print an arbitrary
1022 ASCII character, so the first 256 strings are used to specify exactly what
1023 should be printed for each of the 256 possibilities.
1026 typedef int pool_pointer; /* for variables that point into |str_pool| */
1027 typedef int str_number; /* for variables that point into |str_start| */
1030 ASCII_code *str_pool; /* the characters */
1031 pool_pointer *str_start; /* the starting pointers */
1032 str_number *next_str; /* for linking strings in order */
1033 pool_pointer pool_ptr; /* first unused position in |str_pool| */
1034 str_number str_ptr; /* number of the current string being created */
1035 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
1036 str_number init_str_use; /* the initial number of strings in use */
1037 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
1038 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
1040 @ @<Allocate or initialize ...@>=
1041 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
1042 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
1043 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
1045 @ @<Dealloc variables@>=
1046 xfree(mp->str_pool);
1047 xfree(mp->str_start);
1048 xfree(mp->next_str);
1050 @ Most printing is done from |char *|s, but sometimes not. Here are
1051 functions that convert an internal string into a |char *| for use
1052 by the printing routines, and vice versa.
1054 @d str(A) mp_str(mp,A)
1055 @d rts(A) mp_rts(mp,A)
1058 int mp_xstrcmp (const char *a, const char *b);
1059 char * mp_str (MP mp, str_number s);
1062 str_number mp_rts (MP mp, const char *s);
1063 str_number mp_make_string (MP mp);
1065 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1066 very good: it does not handle nesting over more than one level.
1069 int mp_xstrcmp (const char *a, const char *b) {
1070 if (a==NULL && b==NULL)
1080 char * mp_str (MP mp, str_number ss) {
1083 if (ss==mp->str_ptr) {
1087 s = xmalloc(len+1,sizeof(char));
1088 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1093 str_number mp_rts (MP mp, const char *s) {
1094 int r; /* the new string */
1095 int old; /* a possible string in progress */
1099 } else if (strlen(s)==1) {
1103 str_room((integer)strlen(s));
1104 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1105 old = mp_make_string(mp);
1110 r = mp_make_string(mp);
1112 str_room(length(old));
1113 while (i<length(old)) {
1114 append_char((mp->str_start[old]+i));
1116 mp_flush_string(mp,old);
1122 @ Except for |strs_used_up|, the following string statistics are only
1123 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1127 integer strs_used_up; /* strings in use or unused but not reclaimed */
1128 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1129 integer strs_in_use; /* total number of strings actually in use */
1130 integer max_pl_used; /* maximum |pool_in_use| so far */
1131 integer max_strs_used; /* maximum |strs_in_use| so far */
1133 @ Several of the elementary string operations are performed using \.{WEB}
1134 macros instead of functions, because many of the
1135 operations are done quite frequently and we want to avoid the
1136 overhead of procedure calls. For example, here is
1137 a simple macro that computes the length of a string.
1140 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string
1142 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1144 @ The length of the current string is called |cur_length|. If we decide that
1145 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1146 |cur_length| becomes zero.
1148 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1149 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1151 @ Strings are created by appending character codes to |str_pool|.
1152 The |append_char| macro, defined here, does not check to see if the
1153 value of |pool_ptr| has gotten too high; this test is supposed to be
1154 made before |append_char| is used.
1156 To test if there is room to append |l| more characters to |str_pool|,
1157 we shall write |str_room(l)|, which tries to make sure there is enough room
1158 by compacting the string pool if necessary. If this does not work,
1159 |do_compaction| aborts \MP\ and gives an apologetic error message.
1161 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1162 { mp->str_pool[mp->pool_ptr]=(A); incr(mp->pool_ptr);
1164 @d str_room(A) /* make sure that the pool hasn't overflowed */
1165 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1166 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1167 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1170 @ The following routine is similar to |str_room(1)| but it uses the
1171 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1172 string space is exhausted.
1174 @<Declare the procedure called |unit_str_room|@>=
1175 void mp_unit_str_room (MP mp);
1178 void mp_unit_str_room (MP mp) {
1179 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1180 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1183 @ \MP's string expressions are implemented in a brute-force way: Every
1184 new string or substring that is needed is simply copied into the string pool.
1185 Space is eventually reclaimed by a procedure called |do_compaction| with
1186 the aid of a simple system system of reference counts.
1187 @^reference counts@>
1189 The number of references to string number |s| will be |str_ref[s]|. The
1190 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1191 positive number of references; such strings will never be recycled. If
1192 a string is ever referred to more than 126 times, simultaneously, we
1193 put it in this category. Hence a single byte suffices to store each |str_ref|.
1195 @d max_str_ref 127 /* ``infinite'' number of references */
1196 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]);
1202 @ @<Allocate or initialize ...@>=
1203 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1205 @ @<Dealloc variables@>=
1208 @ Here's what we do when a string reference disappears:
1210 @d delete_str_ref(A) {
1211 if ( mp->str_ref[(A)]<max_str_ref ) {
1212 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1213 else mp_flush_string(mp, (A));
1217 @<Declare the procedure called |flush_string|@>=
1218 void mp_flush_string (MP mp,str_number s) ;
1221 @ We can't flush the first set of static strings at all, so there
1222 is no point in trying
1225 void mp_flush_string (MP mp,str_number s) {
1227 mp->pool_in_use=mp->pool_in_use-length(s);
1228 decr(mp->strs_in_use);
1229 if ( mp->next_str[s]!=mp->str_ptr ) {
1233 decr(mp->strs_used_up);
1235 mp->pool_ptr=mp->str_start[mp->str_ptr];
1239 @ C literals cannot be simply added, they need to be set so they can't
1242 @d intern(A) mp_intern(mp,(A))
1245 str_number mp_intern (MP mp, const char *s) {
1248 mp->str_ref[r] = max_str_ref;
1253 str_number mp_intern (MP mp, const char *s);
1256 @ Once a sequence of characters has been appended to |str_pool|, it
1257 officially becomes a string when the function |make_string| is called.
1258 This function returns the identification number of the new string as its
1261 When getting the next unused string number from the linked list, we pretend
1263 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1264 are linked sequentially even though the |next_str| entries have not been
1265 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1266 |do_compaction| is responsible for making sure of this.
1269 @<Declare the procedure called |do_compaction|@>
1270 @<Declare the procedure called |unit_str_room|@>
1271 str_number mp_make_string (MP mp);
1274 str_number mp_make_string (MP mp) { /* current string enters the pool */
1275 str_number s; /* the new string */
1278 mp->str_ptr=mp->next_str[s];
1279 if ( mp->str_ptr>mp->max_str_ptr ) {
1280 if ( mp->str_ptr==mp->max_strings ) {
1282 mp_do_compaction(mp, 0);
1286 if ( mp->strs_used_up!=mp->max_str_ptr ) mp_confusion(mp, "s");
1287 @:this can't happen s}{\quad \.s@>
1289 mp->max_str_ptr=mp->str_ptr;
1290 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1294 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1295 incr(mp->strs_used_up);
1296 incr(mp->strs_in_use);
1297 mp->pool_in_use=mp->pool_in_use+length(s);
1298 if ( mp->pool_in_use>mp->max_pl_used )
1299 mp->max_pl_used=mp->pool_in_use;
1300 if ( mp->strs_in_use>mp->max_strs_used )
1301 mp->max_strs_used=mp->strs_in_use;
1305 @ The most interesting string operation is string pool compaction. The idea
1306 is to recover unused space in the |str_pool| array by recopying the strings
1307 to close the gaps created when some strings become unused. All string
1308 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1309 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1310 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1311 with |needed=mp->pool_size| supresses all overflow tests.
1313 The compaction process starts with |last_fixed_str| because all lower numbered
1314 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1317 str_number last_fixed_str; /* last permanently allocated string */
1318 str_number fixed_str_use; /* number of permanently allocated strings */
1320 @ @<Declare the procedure called |do_compaction|@>=
1321 void mp_do_compaction (MP mp, pool_pointer needed) ;
1324 void mp_do_compaction (MP mp, pool_pointer needed) {
1325 str_number str_use; /* a count of strings in use */
1326 str_number r,s,t; /* strings being manipulated */
1327 pool_pointer p,q; /* destination and source for copying string characters */
1328 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1329 r=mp->last_fixed_str;
1332 while ( s!=mp->str_ptr ) {
1333 while ( mp->str_ref[s]==0 ) {
1334 @<Advance |s| and add the old |s| to the list of free string numbers;
1335 then |break| if |s=str_ptr|@>;
1337 r=s; s=mp->next_str[s];
1339 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1340 after the end of the string@>;
1343 @<Move the current string back so that it starts at |p|@>;
1344 if ( needed<mp->pool_size ) {
1345 @<Make sure that there is room for another string with |needed| characters@>;
1347 @<Account for the compaction and make sure the statistics agree with the
1349 mp->strs_used_up=str_use;
1352 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1353 t=mp->next_str[mp->last_fixed_str];
1354 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1355 incr(mp->fixed_str_use);
1356 mp->last_fixed_str=t;
1359 str_use=mp->fixed_str_use
1361 @ Because of the way |flush_string| has been written, it should never be
1362 necessary to |break| here. The extra line of code seems worthwhile to
1363 preserve the generality of |do_compaction|.
1365 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1370 mp->next_str[t]=mp->next_str[mp->str_ptr];
1371 mp->next_str[mp->str_ptr]=t;
1372 if ( s==mp->str_ptr ) goto DONE;
1375 @ The string currently starts at |str_start[r]| and ends just before
1376 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1377 to locate the next string.
1379 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1382 while ( q<mp->str_start[s] ) {
1383 mp->str_pool[p]=mp->str_pool[q];
1387 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1388 we do this, anything between them should be moved.
1390 @ @<Move the current string back so that it starts at |p|@>=
1391 q=mp->str_start[mp->str_ptr];
1392 mp->str_start[mp->str_ptr]=p;
1393 while ( q<mp->pool_ptr ) {
1394 mp->str_pool[p]=mp->str_pool[q];
1399 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1401 @<Make sure that there is room for another string with |needed| char...@>=
1402 if ( str_use>=mp->max_strings-1 )
1403 mp_reallocate_strings (mp,str_use);
1404 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1405 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1406 mp->max_pool_ptr=mp->pool_ptr+needed;
1410 void mp_reallocate_strings (MP mp, str_number str_use) ;
1411 void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1414 void mp_reallocate_strings (MP mp, str_number str_use) {
1415 while ( str_use>=mp->max_strings-1 ) {
1416 int l = mp->max_strings + (mp->max_strings>>2);
1417 XREALLOC (mp->str_ref, l, int);
1418 XREALLOC (mp->str_start, l, pool_pointer);
1419 XREALLOC (mp->next_str, l, str_number);
1420 mp->max_strings = l;
1423 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1424 while ( needed>mp->pool_size ) {
1425 int l = mp->pool_size + (mp->pool_size>>2);
1426 XREALLOC (mp->str_pool, l, ASCII_code);
1431 @ @<Account for the compaction and make sure the statistics agree with...@>=
1432 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1433 mp_confusion(mp, "string");
1434 @:this can't happen string}{\quad string@>
1435 incr(mp->pact_count);
1436 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1437 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1439 s=mp->str_ptr; t=str_use;
1440 while ( s<=mp->max_str_ptr ){
1441 if ( t>mp->max_str_ptr ) mp_confusion(mp, "\"");
1442 incr(t); s=mp->next_str[s];
1444 if ( t<=mp->max_str_ptr ) mp_confusion(mp, "\"");
1447 @ A few more global variables are needed to keep track of statistics when
1448 |stat| $\ldots$ |tats| blocks are not commented out.
1451 integer pact_count; /* number of string pool compactions so far */
1452 integer pact_chars; /* total number of characters moved during compactions */
1453 integer pact_strs; /* total number of strings moved during compactions */
1455 @ @<Initialize compaction statistics@>=
1460 @ The following subroutine compares string |s| with another string of the
1461 same length that appears in |buffer| starting at position |k|;
1462 the result is |true| if and only if the strings are equal.
1465 boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1466 /* test equality of strings */
1467 pool_pointer j; /* running index */
1469 while ( j<str_stop(s) ) {
1470 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1476 @ Here is a similar routine, but it compares two strings in the string pool,
1477 and it does not assume that they have the same length. If the first string
1478 is lexicographically greater than, less than, or equal to the second,
1479 the result is respectively positive, negative, or zero.
1482 integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1483 /* test equality of strings */
1484 pool_pointer j,k; /* running indices */
1485 integer ls,lt; /* lengths */
1486 integer l; /* length remaining to test */
1487 ls=length(s); lt=length(t);
1488 if ( ls<=lt ) l=ls; else l=lt;
1489 j=mp->str_start[s]; k=mp->str_start[t];
1491 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1492 return (mp->str_pool[j]-mp->str_pool[k]);
1499 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1500 and |str_ptr| are computed by the \.{INIMP} program, based in part
1501 on the information that \.{WEB} has output while processing \MP.
1506 void mp_get_strings_started (MP mp) {
1507 /* initializes the string pool,
1508 but returns |false| if something goes wrong */
1509 int k; /* small indices or counters */
1510 str_number g; /* a new string */
1511 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1514 mp->pool_in_use=0; mp->strs_in_use=0;
1515 mp->max_pl_used=0; mp->max_strs_used=0;
1516 @<Initialize compaction statistics@>;
1518 @<Make the first 256 strings@>;
1519 g=mp_make_string(mp); /* string 256 == "" */
1520 mp->str_ref[g]=max_str_ref;
1521 mp->last_fixed_str=mp->str_ptr-1;
1522 mp->fixed_str_use=mp->str_ptr;
1527 void mp_get_strings_started (MP mp);
1529 @ The first 256 strings will consist of a single character only.
1531 @<Make the first 256...@>=
1532 for (k=0;k<=255;k++) {
1534 g=mp_make_string(mp);
1535 mp->str_ref[g]=max_str_ref;
1538 @ The first 128 strings will contain 95 standard ASCII characters, and the
1539 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1540 unless a system-dependent change is made here. Installations that have
1541 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1542 would like string 032 to be printed as the single character 032 instead
1543 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1544 even people with an extended character set will want to represent string
1545 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1546 to produce visible strings instead of tabs or line-feeds or carriage-returns
1547 or bell-rings or characters that are treated anomalously in text files.
1549 Unprintable characters of codes 128--255 are, similarly, rendered
1550 \.{\^\^80}--\.{\^\^ff}.
1552 The boolean expression defined here should be |true| unless \MP\ internal
1553 code number~|k| corresponds to a non-troublesome visible symbol in the
1554 local character set.
1555 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1556 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1558 @^character set dependencies@>
1559 @^system dependencies@>
1561 @<Character |k| cannot be printed@>=
1564 @* \[5] On-line and off-line printing.
1565 Messages that are sent to a user's terminal and to the transcript-log file
1566 are produced by several `|print|' procedures. These procedures will
1567 direct their output to a variety of places, based on the setting of
1568 the global variable |selector|, which has the following possible
1572 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1575 \hang |log_only|, prints only on the transcript file.
1577 \hang |term_only|, prints only on the terminal.
1579 \hang |no_print|, doesn't print at all. This is used only in rare cases
1580 before the transcript file is open.
1582 \hang |pseudo|, puts output into a cyclic buffer that is used
1583 by the |show_context| routine; when we get to that routine we shall discuss
1584 the reasoning behind this curious mode.
1586 \hang |new_string|, appends the output to the current string in the
1589 \hang |>=write_file| prints on one of the files used for the \&{write}
1590 @:write_}{\&{write} primitive@>
1594 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1595 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1596 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1597 relations are not used when |selector| could be |pseudo|, or |new_string|.
1598 We need not check for unprintable characters when |selector<pseudo|.
1600 Three additional global variables, |tally|, |term_offset| and |file_offset|
1601 record the number of characters that have been printed
1602 since they were most recently cleared to zero. We use |tally| to record
1603 the length of (possibly very long) stretches of printing; |term_offset|,
1604 and |file_offset|, on the other hand, keep track of how many
1605 characters have appeared so far on the current line that has been output
1606 to the terminal, the transcript file, or the \ps\ output file, respectively.
1608 @d new_string 0 /* printing is deflected to the string pool */
1609 @d pseudo 2 /* special |selector| setting for |show_context| */
1610 @d no_print 3 /* |selector| setting that makes data disappear */
1611 @d term_only 4 /* printing is destined for the terminal only */
1612 @d log_only 5 /* printing is destined for the transcript file only */
1613 @d term_and_log 6 /* normal |selector| setting */
1614 @d write_file 7 /* first write file selector */
1617 void * log_file; /* transcript of \MP\ session */
1618 void * ps_file; /* the generic font output goes here */
1619 unsigned int selector; /* where to print a message */
1620 unsigned char dig[23]; /* digits in a number being output */
1621 integer tally; /* the number of characters recently printed */
1622 unsigned int term_offset;
1623 /* the number of characters on the current terminal line */
1624 unsigned int file_offset;
1625 /* the number of characters on the current file line */
1626 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1627 integer trick_count; /* threshold for pseudoprinting, explained later */
1628 integer first_count; /* another variable for pseudoprinting */
1630 @ @<Allocate or initialize ...@>=
1631 memset(mp->dig,0,23);
1632 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1634 @ @<Dealloc variables@>=
1635 xfree(mp->trick_buf);
1637 @ @<Initialize the output routines@>=
1638 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
1640 @ Macro abbreviations for output to the terminal and to the log file are
1641 defined here for convenience. Some systems need special conventions
1642 for terminal output, and it is possible to adhere to those conventions
1643 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1644 @^system dependencies@>
1646 @d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
1647 @d wterm(A) do_fprintf(mp->term_out,(A))
1648 @d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->term_out,(char *)ss); }
1649 @d wterm_cr do_fprintf(mp->term_out,"\n")
1650 @d wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
1651 @d wlog(A) do_fprintf(mp->log_file,(A))
1652 @d wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->log_file,(char *)ss); }
1653 @d wlog_cr do_fprintf(mp->log_file, "\n")
1654 @d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
1657 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1658 use an array |wr_file| that will be declared later.
1660 @d mp_print_text(A) mp_print_str(mp,text((A)))
1663 void mp_print_ln (MP mp);
1664 void mp_print_visible_char (MP mp, ASCII_code s);
1665 void mp_print_char (MP mp, ASCII_code k);
1666 void mp_print (MP mp, const char *s);
1667 void mp_print_str (MP mp, str_number s);
1668 void mp_print_nl (MP mp, const char *s);
1669 void mp_print_two (MP mp,scaled x, scaled y) ;
1670 void mp_print_scaled (MP mp,scaled s);
1672 @ @<Basic print...@>=
1673 void mp_print_ln (MP mp) { /* prints an end-of-line */
1674 switch (mp->selector) {
1677 mp->term_offset=0; mp->file_offset=0;
1680 wlog_cr; mp->file_offset=0;
1683 wterm_cr; mp->term_offset=0;
1690 do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1692 } /* note that |tally| is not affected */
1694 @ The |print_visible_char| procedure sends one character to the desired
1695 destination, using the |xchr| array to map it into an external character
1696 compatible with |input_ln|. (It assumes that it is always called with
1697 a visible ASCII character.) All printing comes through |print_ln| or
1698 |print_char|, which ultimately calls |print_visible_char|, hence these
1699 routines are the ones that limit lines to at most |max_print_line| characters.
1700 But we must make an exception for the \ps\ output file since it is not safe
1701 to cut up lines arbitrarily in \ps.
1703 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1704 |do_compaction| and |do_compaction| can call the error routines. Actually,
1705 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1707 @<Basic printing...@>=
1708 void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1709 switch (mp->selector) {
1711 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1712 incr(mp->term_offset); incr(mp->file_offset);
1713 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1714 wterm_cr; mp->term_offset=0;
1716 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1717 wlog_cr; mp->file_offset=0;
1721 wlog_chr(xchr(s)); incr(mp->file_offset);
1722 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1725 wterm_chr(xchr(s)); incr(mp->term_offset);
1726 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1731 if ( mp->tally<mp->trick_count )
1732 mp->trick_buf[mp->tally % mp->error_line]=s;
1735 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1736 mp_unit_str_room(mp);
1737 if ( mp->pool_ptr>=mp->pool_size )
1738 goto DONE; /* drop characters if string space is full */
1743 { char ss[2]; ss[0] = xchr(s); ss[1]=0;
1744 do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
1751 @ The |print_char| procedure sends one character to the desired destination.
1752 File names and string expressions might contain |ASCII_code| values that
1753 can't be printed using |print_visible_char|. These characters will be
1754 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1755 (This procedure assumes that it is safe to bypass all checks for unprintable
1756 characters when |selector| is in the range |0..max_write_files-1|.
1757 The user might want to write unprintable characters.
1759 @d print_lc_hex(A) do { l=(A);
1760 mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
1763 @<Basic printing...@>=
1764 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1765 int l; /* small index or counter */
1766 if ( mp->selector<pseudo || mp->selector>=write_file) {
1767 mp_print_visible_char(mp, k);
1768 } else if ( @<Character |k| cannot be printed@> ) {
1771 mp_print_visible_char(mp, k+0100);
1772 } else if ( k<0200 ) {
1773 mp_print_visible_char(mp, k-0100);
1775 print_lc_hex(k / 16);
1776 print_lc_hex(k % 16);
1779 mp_print_visible_char(mp, k);
1783 @ An entire string is output by calling |print|. Note that if we are outputting
1784 the single standard ASCII character \.c, we could call |print("c")|, since
1785 |"c"=99| is the number of a single-character string, as explained above. But
1786 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1787 routine when it knows that this is safe. (The present implementation
1788 assumes that it is always safe to print a visible ASCII character.)
1789 @^system dependencies@>
1792 void mp_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
1795 mp_print_char(mp, ss[j]); incr(j);
1801 void mp_print (MP mp, const char *ss) {
1802 mp_do_print(mp, ss, strlen(ss));
1804 void mp_print_str (MP mp, str_number s) {
1805 pool_pointer j; /* current character code position */
1806 if ( (s<0)||(s>mp->max_str_ptr) ) {
1807 mp_do_print(mp,"???",3); /* this can't happen */
1811 mp_do_print(mp, (char *)(mp->str_pool+j), (str_stop(s)-j));
1815 @ Here is the very first thing that \MP\ prints: a headline that identifies
1816 the version number and base name. The |term_offset| variable is temporarily
1817 incorrect, but the discrepancy is not serious since we assume that the banner
1818 and mem identifier together will occupy at most |max_print_line|
1819 character positions.
1821 @<Initialize the output...@>=
1823 wterm (version_string);
1824 if (mp->mem_ident!=NULL)
1825 mp_print(mp,mp->mem_ident);
1829 @ The procedure |print_nl| is like |print|, but it makes sure that the
1830 string appears at the beginning of a new line.
1833 void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1834 switch(mp->selector) {
1836 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1839 if ( mp->file_offset>0 ) mp_print_ln(mp);
1842 if ( mp->term_offset>0 ) mp_print_ln(mp);
1848 } /* there are no other cases */
1852 @ An array of digits in the range |0..9| is printed by |print_the_digs|.
1855 void mp_print_the_digs (MP mp, eight_bits k) {
1856 /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */
1858 decr(k); mp_print_char(mp, '0'+mp->dig[k]);
1862 @ The following procedure, which prints out the decimal representation of a
1863 given integer |n|, has been written carefully so that it works properly
1864 if |n=0| or if |(-n)| would cause overflow. It does not apply |%| or |/|
1865 to negative arguments, since such operations are not implemented consistently
1869 void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1870 integer m; /* used to negate |n| in possibly dangerous cases */
1871 int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
1873 mp_print_char(mp, '-');
1874 if ( n>-100000000 ) {
1877 m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
1881 mp->dig[0]=0; incr(n);
1886 mp->dig[k]=n % 10; n=n / 10; incr(k);
1888 mp_print_the_digs(mp, k);
1892 void mp_print_int (MP mp,integer n);
1894 @ \MP\ also makes use of a trivial procedure to print two digits. The
1895 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1898 void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1900 mp_print_char(mp, '0'+(n / 10));
1901 mp_print_char(mp, '0'+(n % 10));
1906 void mp_print_dd (MP mp,integer n);
1908 @ Here is a procedure that asks the user to type a line of input,
1909 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1910 The input is placed into locations |first| through |last-1| of the
1911 |buffer| array, and echoed on the transcript file if appropriate.
1913 This procedure is never called when |interaction<mp_scroll_mode|.
1915 @d prompt_input(A) do {
1916 if (!mp->noninteractive) {
1917 wake_up_terminal; mp_print(mp, (A));
1920 } while (0) /* prints a string and gets a line of input */
1923 void mp_term_input (MP mp) { /* gets a line from the terminal */
1924 size_t k; /* index into |buffer| */
1925 update_terminal; /* Now the user sees the prompt for sure */
1926 if (!mp_input_ln(mp, mp->term_in )) {
1927 if (!mp->noninteractive) {
1928 mp_fatal_error(mp, "End of file on the terminal!");
1929 @.End of file on the terminal@>
1930 } else { /* we are done with this input chunk */
1931 longjmp(*(mp->jump_buf),1);
1934 if (!mp->noninteractive) {
1935 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1936 decr(mp->selector); /* prepare to echo the input */
1937 if ( mp->last!=mp->first ) {
1938 for (k=mp->first;k<=mp->last-1;k++) {
1939 mp_print_char(mp, mp->buffer[k]);
1943 mp->buffer[mp->last]='%';
1944 incr(mp->selector); /* restore previous status */
1948 @* \[6] Reporting errors.
1949 When something anomalous is detected, \MP\ typically does something like this:
1950 $$\vbox{\halign{#\hfil\cr
1951 |print_err("Something anomalous has been detected");|\cr
1952 |help3("This is the first line of my offer to help.")|\cr
1953 |("This is the second line. I'm trying to")|\cr
1954 |("explain the best way for you to proceed.");|\cr
1956 A two-line help message would be given using |help2|, etc.; these informal
1957 helps should use simple vocabulary that complements the words used in the
1958 official error message that was printed. (Outside the U.S.A., the help
1959 messages should preferably be translated into the local vernacular. Each
1960 line of help is at most 60 characters long, in the present implementation,
1961 so that |max_print_line| will not be exceeded.)
1963 The |print_err| procedure supplies a `\.!' before the official message,
1964 and makes sure that the terminal is awake if a stop is going to occur.
1965 The |error| procedure supplies a `\..' after the official message, then it
1966 shows the location of the error; and if |interaction=error_stop_mode|,
1967 it also enters into a dialog with the user, during which time the help
1968 message may be printed.
1969 @^system dependencies@>
1971 @ The global variable |interaction| has four settings, representing increasing
1972 amounts of user interaction:
1975 enum mp_interaction_mode {
1976 mp_unspecified_mode=0, /* extra value for command-line switch */
1977 mp_batch_mode, /* omits all stops and omits terminal output */
1978 mp_nonstop_mode, /* omits all stops */
1979 mp_scroll_mode, /* omits error stops */
1980 mp_error_stop_mode /* stops at every opportunity to interact */
1983 @ @<Option variables@>=
1984 int interaction; /* current level of interaction */
1985 int noninteractive; /* do we have a terminal? */
1987 @ Set it here so it can be overwritten by the commandline
1989 @<Allocate or initialize ...@>=
1990 mp->interaction=opt->interaction;
1991 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
1992 mp->interaction=mp_error_stop_mode;
1993 if (mp->interaction<mp_unspecified_mode)
1994 mp->interaction=mp_batch_mode;
1995 mp->noninteractive=opt->noninteractive;
1999 @d print_err(A) mp_print_err(mp,(A))
2002 void mp_print_err(MP mp, const char * A);
2005 void mp_print_err(MP mp, const char * A) {
2006 if ( mp->interaction==mp_error_stop_mode )
2008 mp_print_nl(mp, "! ");
2014 @ \MP\ is careful not to call |error| when the print |selector| setting
2015 might be unusual. The only possible values of |selector| at the time of
2018 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
2019 and |log_file| not yet open);
2021 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
2023 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
2025 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
2027 @<Initialize the print |selector| based on |interaction|@>=
2028 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
2030 @ A global variable |deletions_allowed| is set |false| if the |get_next|
2031 routine is active when |error| is called; this ensures that |get_next|
2032 will never be called recursively.
2035 The global variable |history| records the worst level of error that
2036 has been detected. It has four possible values: |spotless|, |warning_issued|,
2037 |error_message_issued|, and |fatal_error_stop|.
2039 Another global variable, |error_count|, is increased by one when an
2040 |error| occurs without an interactive dialog, and it is reset to zero at
2041 the end of every statement. If |error_count| reaches 100, \MP\ decides
2042 that there is no point in continuing further.
2045 enum mp_history_states {
2046 mp_spotless=0, /* |history| value when nothing has been amiss yet */
2047 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
2048 mp_error_message_issued, /* |history| value when |error| has been called */
2049 mp_fatal_error_stop, /* |history| value when termination was premature */
2050 mp_system_error_stop /* |history| value when termination was due to disaster */
2054 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
2055 int history; /* has the source input been clean so far? */
2056 int error_count; /* the number of scrolled errors since the last statement ended */
2058 @ The value of |history| is initially |fatal_error_stop|, but it will
2059 be changed to |spotless| if \MP\ survives the initialization process.
2061 @<Allocate or ...@>=
2062 mp->deletions_allowed=true; mp->error_count=0; /* |history| is initialized elsewhere */
2064 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2065 error procedures near the beginning of the program. But the error procedures
2066 in turn use some other procedures, which need to be declared |forward|
2067 before we get to |error| itself.
2069 It is possible for |error| to be called recursively if some error arises
2070 when |get_next| is being used to delete a token, and/or if some fatal error
2071 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2073 is never more than two levels deep.
2076 void mp_get_next (MP mp);
2077 void mp_term_input (MP mp);
2078 void mp_show_context (MP mp);
2079 void mp_begin_file_reading (MP mp);
2080 void mp_open_log_file (MP mp);
2081 void mp_clear_for_error_prompt (MP mp);
2082 void mp_debug_help (MP mp);
2083 @<Declare the procedure called |flush_string|@>
2086 void mp_normalize_selector (MP mp);
2088 @ Individual lines of help are recorded in the array |help_line|, which
2089 contains entries in positions |0..(help_ptr-1)|. They should be printed
2090 in reverse order, i.e., with |help_line[0]| appearing last.
2092 @d hlp1(A) mp->help_line[0]=(A); }
2093 @d hlp2(A) mp->help_line[1]=(A); hlp1
2094 @d hlp3(A) mp->help_line[2]=(A); hlp2
2095 @d hlp4(A) mp->help_line[3]=(A); hlp3
2096 @d hlp5(A) mp->help_line[4]=(A); hlp4
2097 @d hlp6(A) mp->help_line[5]=(A); hlp5
2098 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2099 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2100 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2101 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2102 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2103 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2104 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2107 const char * help_line[6]; /* helps for the next |error| */
2108 unsigned int help_ptr; /* the number of help lines present */
2109 boolean use_err_help; /* should the |err_help| string be shown? */
2110 str_number err_help; /* a string set up by \&{errhelp} */
2111 str_number filename_template; /* a string set up by \&{filenametemplate} */
2113 @ @<Allocate or ...@>=
2114 mp->help_ptr=0; mp->use_err_help=false; mp->err_help=0; mp->filename_template=0;
2116 @ The |jump_out| procedure just cuts across all active procedure levels and
2117 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2118 whole program. It is used when there is no recovery from a particular error.
2120 The program uses a |jump_buf| to handle this, this is initialized at three
2121 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2122 of |mp_run|. Those are the only library enty points.
2124 @^system dependencies@>
2129 @ @<Install and test the non-local jump buffer@>=
2130 mp->jump_buf = &buf;
2131 if (setjmp(*(mp->jump_buf)) != 0) { return mp->history; }
2133 @ @<Setup the non-local jump buffer in |mp_new|@>=
2134 if (setjmp(buf) != 0) { return NULL; }
2137 @ If the array of internals is still |NULL| when |jump_out| is called, a
2138 crash occured during initialization, and it is not safe to run the normal
2142 void mp_jump_out (MP mp) {
2143 if (mp->internal!=NULL && mp->history < mp_system_error_stop)
2144 mp_close_files_and_terminate(mp);
2145 longjmp(*(mp->jump_buf),1);
2148 @ Here now is the general |error| routine.
2151 void mp_error (MP mp) { /* completes the job of error reporting */
2152 ASCII_code c; /* what the user types */
2153 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2154 pool_pointer j; /* character position being printed */
2155 if ( mp->history<mp_error_message_issued )
2156 mp->history=mp_error_message_issued;
2157 mp_print_char(mp, '.'); mp_show_context(mp);
2158 if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
2159 @<Get user's advice and |return|@>;
2161 incr(mp->error_count);
2162 if ( mp->error_count==100 ) {
2163 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2164 @.That makes 100 errors...@>
2165 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2167 @<Put help message on the transcript file@>;
2169 void mp_warn (MP mp, const char *msg) {
2170 int saved_selector = mp->selector;
2171 mp_normalize_selector(mp);
2172 mp_print_nl(mp,"Warning: ");
2175 mp->selector = saved_selector;
2178 @ @<Exported function ...@>=
2179 void mp_error (MP mp);
2180 void mp_warn (MP mp, const char *msg);
2183 @ @<Get user's advice...@>=
2186 mp_clear_for_error_prompt(mp); prompt_input("? ");
2188 if ( mp->last==mp->first ) return;
2189 c=mp->buffer[mp->first];
2190 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2191 @<Interpret code |c| and |return| if done@>;
2194 @ It is desirable to provide an `\.E' option here that gives the user
2195 an easy way to return from \MP\ to the system editor, with the offending
2196 line ready to be edited. But such an extension requires some system
2197 wizardry, so the present implementation simply types out the name of the
2199 edited and the relevant line number.
2200 @^system dependencies@>
2203 typedef void (*mp_run_editor_command)(MP, char *, int);
2205 @ @<Option variables@>=
2206 mp_run_editor_command run_editor;
2208 @ @<Allocate or initialize ...@>=
2209 set_callback_option(run_editor);
2212 void mp_run_editor (MP mp, char *fname, int fline);
2214 @ @c void mp_run_editor (MP mp, char *fname, int fline) {
2215 mp_print_nl(mp, "You want to edit file ");
2216 @.You want to edit file x@>
2217 mp_print(mp, fname);
2218 mp_print(mp, " at line ");
2219 mp_print_int(mp, fline);
2220 mp->interaction=mp_scroll_mode;
2225 There is a secret `\.D' option available when the debugging routines haven't
2229 @<Interpret code |c| and |return| if done@>=
2231 case '0': case '1': case '2': case '3': case '4':
2232 case '5': case '6': case '7': case '8': case '9':
2233 if ( mp->deletions_allowed ) {
2234 @<Delete |c-"0"| tokens and |continue|@>;
2239 mp_debug_help(mp); continue;
2243 if ( mp->file_ptr>0 ){
2244 (mp->run_editor)(mp,
2245 str(mp->input_stack[mp->file_ptr].name_field),
2250 @<Print the help information and |continue|@>;
2253 @<Introduce new material from the terminal and |return|@>;
2255 case 'Q': case 'R': case 'S':
2256 @<Change the interaction level and |return|@>;
2259 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2264 @<Print the menu of available options@>
2266 @ @<Print the menu...@>=
2268 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2269 @.Type <return> to proceed...@>
2270 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2271 mp_print_nl(mp, "I to insert something, ");
2272 if ( mp->file_ptr>0 )
2273 mp_print(mp, "E to edit your file,");
2274 if ( mp->deletions_allowed )
2275 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2276 mp_print_nl(mp, "H for help, X to quit.");
2279 @ Here the author of \MP\ apologizes for making use of the numerical
2280 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2281 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2282 @^Knuth, Donald Ervin@>
2284 @<Change the interaction...@>=
2286 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2287 mp_print(mp, "OK, entering ");
2289 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2290 case 'R': mp_print(mp, "nonstopmode"); break;
2291 case 'S': mp_print(mp, "scrollmode"); break;
2292 } /* there are no other cases */
2293 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2296 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2297 contain the material inserted by the user; otherwise another prompt will
2298 be given. In order to understand this part of the program fully, you need
2299 to be familiar with \MP's input stacks.
2301 @<Introduce new material...@>=
2303 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2304 if ( mp->last>mp->first+1 ) {
2305 loc=mp->first+1; mp->buffer[mp->first]=' ';
2307 prompt_input("insert>"); loc=mp->first;
2310 mp->first=mp->last+1; mp->cur_input.limit_field=mp->last; return;
2313 @ We allow deletion of up to 99 tokens at a time.
2315 @<Delete |c-"0"| tokens...@>=
2317 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2318 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2319 c=c*10+mp->buffer[mp->first+1]-'0'*11;
2323 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2324 @<Decrease the string reference count, if the current token is a string@>;
2327 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2328 help2("I have just deleted some text, as you asked.")
2329 ("You can now delete more, or insert, or whatever.");
2330 mp_show_context(mp);
2334 @ @<Print the help info...@>=
2336 if ( mp->use_err_help ) {
2337 @<Print the string |err_help|, possibly on several lines@>;
2338 mp->use_err_help=false;
2340 if ( mp->help_ptr==0 ) {
2341 help2("Sorry, I don't know how to help in this situation.")
2342 ("Maybe you should try asking a human?");
2345 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2346 } while (mp->help_ptr!=0);
2348 help4("Sorry, I already gave what help I could...")
2349 ("Maybe you should try asking a human?")
2350 ("An error might have occurred before I noticed any problems.")
2351 ("``If all else fails, read the instructions.''");
2355 @ @<Print the string |err_help|, possibly on several lines@>=
2356 j=mp->str_start[mp->err_help];
2357 while ( j<str_stop(mp->err_help) ) {
2358 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2359 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2360 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2361 else { incr(j); mp_print_char(mp, '%'); };
2365 @ @<Put help message on the transcript file@>=
2366 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2367 if ( mp->use_err_help ) {
2368 mp_print_nl(mp, "");
2369 @<Print the string |err_help|, possibly on several lines@>;
2371 while ( mp->help_ptr>0 ){
2372 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2376 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2379 @ In anomalous cases, the print selector might be in an unknown state;
2380 the following subroutine is called to fix things just enough to keep
2381 running a bit longer.
2384 void mp_normalize_selector (MP mp) {
2385 if ( mp->log_opened ) mp->selector=term_and_log;
2386 else mp->selector=term_only;
2387 if ( mp->job_name==NULL ) mp_open_log_file(mp);
2388 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2391 @ The following procedure prints \MP's last words before dying.
2393 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2394 mp->interaction=mp_scroll_mode; /* no more interaction */
2395 if ( mp->log_opened ) mp_error(mp);
2396 /*| if ( mp->interaction>mp_batch_mode ) mp_debug_help(mp); |*/
2397 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2401 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2402 mp_normalize_selector(mp);
2403 print_err("Emergency stop"); help1(s); succumb;
2407 @ @<Exported function ...@>=
2408 void mp_fatal_error (MP mp, const char *s);
2411 @ Here is the most dreaded error message.
2414 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2415 mp_normalize_selector(mp);
2416 print_err("MetaPost capacity exceeded, sorry [");
2417 @.MetaPost capacity exceeded ...@>
2418 mp_print(mp, s); mp_print_char(mp, '='); mp_print_int(mp, n); mp_print_char(mp, ']');
2419 help2("If you really absolutely need more capacity,")
2420 ("you can ask a wizard to enlarge me.");
2424 @ @<Internal library declarations@>=
2425 void mp_overflow (MP mp, const char *s, integer n);
2427 @ The program might sometime run completely amok, at which point there is
2428 no choice but to stop. If no previous error has been detected, that's bad
2429 news; a message is printed that is really intended for the \MP\
2430 maintenance person instead of the user (unless the user has been
2431 particularly diabolical). The index entries for `this can't happen' may
2432 help to pinpoint the problem.
2435 @<Internal library ...@>=
2436 void mp_confusion (MP mp, const char *s);
2438 @ @<Error hand...@>=
2439 void mp_confusion (MP mp, const char *s) {
2440 /* consistency check violated; |s| tells where */
2441 mp_normalize_selector(mp);
2442 if ( mp->history<mp_error_message_issued ) {
2443 print_err("This can't happen ("); mp_print(mp, s); mp_print_char(mp, ')');
2444 @.This can't happen@>
2445 help1("I'm broken. Please show this to someone who can fix can fix");
2447 print_err("I can\'t go on meeting you like this");
2448 @.I can't go on...@>
2449 help2("One of your faux pas seems to have wounded me deeply...")
2450 ("in fact, I'm barely conscious. Please fix it and try again.");
2455 @ Users occasionally want to interrupt \MP\ while it's running.
2456 If the runtime system allows this, one can implement
2457 a routine that sets the global variable |interrupt| to some nonzero value
2458 when such an interrupt is signaled. Otherwise there is probably at least
2459 a way to make |interrupt| nonzero using the C debugger.
2460 @^system dependencies@>
2463 @d check_interrupt { if ( mp->interrupt!=0 )
2464 mp_pause_for_instructions(mp); }
2467 integer interrupt; /* should \MP\ pause for instructions? */
2468 boolean OK_to_interrupt; /* should interrupts be observed? */
2469 integer run_state; /* are we processing input ?*/
2471 @ @<Allocate or ...@>=
2472 mp->interrupt=0; mp->OK_to_interrupt=true; mp->run_state=0;
2474 @ When an interrupt has been detected, the program goes into its
2475 highest interaction level and lets the user have the full flexibility of
2476 the |error| routine. \MP\ checks for interrupts only at times when it is
2480 void mp_pause_for_instructions (MP mp) {
2481 if ( mp->OK_to_interrupt ) {
2482 mp->interaction=mp_error_stop_mode;
2483 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2485 print_err("Interruption");
2488 ("Try to insert some instructions for me (e.g.,`I show x'),")
2489 ("unless you just want to quit by typing `X'.");
2490 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2495 @ Many of \MP's error messages state that a missing token has been
2496 inserted behind the scenes. We can save string space and program space
2497 by putting this common code into a subroutine.
2500 void mp_missing_err (MP mp, const char *s) {
2501 print_err("Missing `"); mp_print(mp, s); mp_print(mp, "' has been inserted");
2502 @.Missing...inserted@>
2505 @* \[7] Arithmetic with scaled numbers.
2506 The principal computations performed by \MP\ are done entirely in terms of
2507 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2508 program can be carried out in exactly the same way on a wide variety of
2509 computers, including some small ones.
2512 But C does not rigidly define the |/| operation in the case of negative
2513 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2514 computers and |-n| on others (is this true ?). There are two principal
2515 types of arithmetic: ``translation-preserving,'' in which the identity
2516 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2517 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2518 different results, although the differences should be negligible when the
2519 language is being used properly. The \TeX\ processor has been defined
2520 carefully so that both varieties of arithmetic will produce identical
2521 output, but it would be too inefficient to constrain \MP\ in a similar way.
2523 @d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */
2525 @ One of \MP's most common operations is the calculation of
2526 $\lfloor{a+b\over2}\rfloor$,
2527 the midpoint of two given integers |a| and~|b|. The most decent way to do
2528 this is to write `|(a+b)/2|'; but on many machines it is more efficient
2529 to calculate `|(a+b)>>1|'.
2531 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2532 in this program. If \MP\ is being implemented with languages that permit
2533 binary shifting, the |half| macro should be changed to make this operation
2534 as efficient as possible. Since some systems have shift operators that can
2535 only be trusted to work on positive numbers, there is also a macro |halfp|
2536 that is used only when the quantity being halved is known to be positive
2539 @d half(A) ((A) / 2)
2540 @d halfp(A) ((A) >> 1)
2542 @ A single computation might use several subroutine calls, and it is
2543 desirable to avoid producing multiple error messages in case of arithmetic
2544 overflow. So the routines below set the global variable |arith_error| to |true|
2545 instead of reporting errors directly to the user.
2546 @^overflow in arithmetic@>
2549 boolean arith_error; /* has arithmetic overflow occurred recently? */
2551 @ @<Allocate or ...@>=
2552 mp->arith_error=false;
2554 @ At crucial points the program will say |check_arith|, to test if
2555 an arithmetic error has been detected.
2557 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2560 void mp_clear_arith (MP mp) {
2561 print_err("Arithmetic overflow");
2562 @.Arithmetic overflow@>
2563 help4("Uh, oh. A little while ago one of the quantities that I was")
2564 ("computing got too large, so I'm afraid your answers will be")
2565 ("somewhat askew. You'll probably have to adopt different")
2566 ("tactics next time. But I shall try to carry on anyway.");
2568 mp->arith_error=false;
2571 @ Addition is not always checked to make sure that it doesn't overflow,
2572 but in places where overflow isn't too unlikely the |slow_add| routine
2575 @c integer mp_slow_add (MP mp,integer x, integer y) {
2577 if ( y<=el_gordo-x ) {
2580 mp->arith_error=true;
2583 } else if ( -y<=el_gordo+x ) {
2586 mp->arith_error=true;
2591 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2592 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2593 positions from the right end of a binary computer word.
2595 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2596 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2597 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2598 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2599 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2600 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2603 typedef integer scaled; /* this type is used for scaled integers */
2604 typedef unsigned char small_number; /* this type is self-explanatory */
2606 @ The following function is used to create a scaled integer from a given decimal
2607 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2608 given in |dig[i]|, and the calculation produces a correctly rounded result.
2611 scaled mp_round_decimals (MP mp,small_number k) {
2612 /* converts a decimal fraction */
2613 integer a = 0; /* the accumulator */
2615 a=(a+mp->dig[k]*two) / 10;
2620 @ Conversely, here is a procedure analogous to |print_int|. If the output
2621 of this procedure is subsequently read by \MP\ and converted by the
2622 |round_decimals| routine above, it turns out that the original value will
2623 be reproduced exactly. A decimal point is printed only if the value is
2624 not an integer. If there is more than one way to print the result with
2625 the optimum number of digits following the decimal point, the closest
2626 possible value is given.
2628 The invariant relation in the \&{repeat} loop is that a sequence of
2629 decimal digits yet to be printed will yield the original number if and only if
2630 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2631 We can stop if and only if $f=0$ satisfies this condition; the loop will
2632 terminate before $s$ can possibly become zero.
2634 @<Basic printing...@>=
2635 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2636 scaled delta; /* amount of allowable inaccuracy */
2638 mp_print_char(mp, '-');
2639 negate(s); /* print the sign, if negative */
2641 mp_print_int(mp, s / unity); /* print the integer part */
2645 mp_print_char(mp, '.');
2648 s=s+0100000-(delta / 2); /* round the final digit */
2649 mp_print_char(mp, '0'+(s / unity));
2656 @ We often want to print two scaled quantities in parentheses,
2657 separated by a comma.
2659 @<Basic printing...@>=
2660 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2661 mp_print_char(mp, '(');
2662 mp_print_scaled(mp, x);
2663 mp_print_char(mp, ',');
2664 mp_print_scaled(mp, y);
2665 mp_print_char(mp, ')');
2668 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2669 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2670 arithmetic with 28~significant bits of precision. A |fraction| denotes
2671 a scaled integer whose binary point is assumed to be 28 bit positions
2674 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2675 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2676 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2677 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2678 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2681 typedef integer fraction; /* this type is used for scaled fractions */
2683 @ In fact, the two sorts of scaling discussed above aren't quite
2684 sufficient; \MP\ has yet another, used internally to keep track of angles
2685 in units of $2^{-20}$ degrees.
2687 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2688 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2689 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2690 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2693 typedef integer angle; /* this type is used for scaled angles */
2695 @ The |make_fraction| routine produces the |fraction| equivalent of
2696 |p/q|, given integers |p| and~|q|; it computes the integer
2697 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2698 positive. If |p| and |q| are both of the same scaled type |t|,
2699 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2700 and it's also possible to use the subroutine ``backwards,'' using
2701 the relation |make_fraction(t,fraction)=t| between scaled types.
2703 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2704 sets |arith_error:=true|. Most of \MP's internal computations have
2705 been designed to avoid this sort of error.
2707 If this subroutine were programmed in assembly language on a typical
2708 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2709 double-precision product can often be input to a fixed-point division
2710 instruction. But when we are restricted to int-eger arithmetic it
2711 is necessary either to resort to multiple-precision maneuvering
2712 or to use a simple but slow iteration. The multiple-precision technique
2713 would be about three times faster than the code adopted here, but it
2714 would be comparatively long and tricky, involving about sixteen
2715 additional multiplications and divisions.
2717 This operation is part of \MP's ``inner loop''; indeed, it will
2718 consume nearly 10\pct! of the running time (exclusive of input and output)
2719 if the code below is left unchanged. A machine-dependent recoding
2720 will therefore make \MP\ run faster. The present implementation
2721 is highly portable, but slow; it avoids multiplication and division
2722 except in the initial stage. System wizards should be careful to
2723 replace it with a routine that is guaranteed to produce identical
2724 results in all cases.
2725 @^system dependencies@>
2727 As noted below, a few more routines should also be replaced by machine-dependent
2728 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2729 such changes aren't advisable; simplicity and robustness are
2730 preferable to trickery, unless the cost is too high.
2734 fraction mp_make_fraction (MP mp,integer p, integer q);
2735 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2737 @ If FIXPT is not defined, we need these preprocessor values
2739 @d ELGORDO 0x7fffffff
2740 @d TWEXP31 2147483648.0
2741 @d TWEXP28 268435456.0
2743 @d TWEXP_16 (1.0/65536.0)
2744 @d TWEXP_28 (1.0/268435456.0)
2748 fraction mp_make_fraction (MP mp,integer p, integer q) {
2750 integer f; /* the fraction bits, with a leading 1 bit */
2751 integer n; /* the integer part of $\vert p/q\vert$ */
2752 integer be_careful; /* disables certain compiler optimizations */
2753 boolean negative = false; /* should the result be negated? */
2755 negate(p); negative=true;
2759 if ( q==0 ) mp_confusion(mp, '/');
2761 @:this can't happen /}{\quad \./@>
2762 negate(q); negative = ! negative;
2766 mp->arith_error=true;
2767 return ( negative ? -el_gordo : el_gordo);
2769 n=(n-1)*fraction_one;
2770 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2771 return (negative ? (-(f+n)) : (f+n));
2777 if (q==0) mp_confusion(mp,'/');
2779 d = TWEXP28 * (double)p /(double)q;
2782 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
2784 if (d==i && ( ((q>0 ? -q : q)&077777)
2785 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2788 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
2790 if (d==i && ( ((q>0 ? q : -q)&077777)
2791 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2797 @ The |repeat| loop here preserves the following invariant relations
2798 between |f|, |p|, and~|q|:
2799 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2800 $p_0$ is the original value of~$p$.
2802 Notice that the computation specifies
2803 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2804 Let us hope that optimizing compilers do not miss this point; a
2805 special variable |be_careful| is used to emphasize the necessary
2806 order of computation. Optimizing compilers should keep |be_careful|
2807 in a register, not store it in memory.
2810 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2814 be_careful=p-q; p=be_careful+p;
2820 } while (f<fraction_one);
2822 if ( be_careful+p>=0 ) incr(f);
2825 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2826 given integer~|q| by a fraction~|f|. When the operands are positive, it
2827 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2830 This routine is even more ``inner loopy'' than |make_fraction|;
2831 the present implementation consumes almost 20\pct! of \MP's computation
2832 time during typical jobs, so a machine-language substitute is advisable.
2833 @^inner loop@> @^system dependencies@>
2836 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2840 integer mp_take_fraction (MP mp,integer q, fraction f) {
2841 integer p; /* the fraction so far */
2842 boolean negative; /* should the result be negated? */
2843 integer n; /* additional multiple of $q$ */
2844 integer be_careful; /* disables certain compiler optimizations */
2845 @<Reduce to the case that |f>=0| and |q>=0|@>;
2846 if ( f<fraction_one ) {
2849 n=f / fraction_one; f=f % fraction_one;
2850 if ( q<=el_gordo / n ) {
2853 mp->arith_error=true; n=el_gordo;
2857 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2858 be_careful=n-el_gordo;
2859 if ( be_careful+p>0 ){
2860 mp->arith_error=true; n=el_gordo-p;
2867 integer mp_take_fraction (MP mp,integer p, fraction q) {
2870 d = (double)p * (double)q * TWEXP_28;
2874 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2875 mp->arith_error = true;
2879 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2883 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2884 mp->arith_error = true;
2888 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2894 @ @<Reduce to the case that |f>=0| and |q>=0|@>=
2898 negate( f); negative=true;
2901 negate(q); negative=! negative;
2904 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2905 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2906 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2909 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2910 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2911 if ( q<fraction_four ) {
2913 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2918 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2924 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2925 analogous to |take_fraction| but with a different scaling.
2926 Given positive operands, |take_scaled|
2927 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2929 Once again it is a good idea to use a machine-language replacement if
2930 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2931 when the Computer Modern fonts are being generated.
2936 integer mp_take_scaled (MP mp,integer q, scaled f) {
2937 integer p; /* the fraction so far */
2938 boolean negative; /* should the result be negated? */
2939 integer n; /* additional multiple of $q$ */
2940 integer be_careful; /* disables certain compiler optimizations */
2941 @<Reduce to the case that |f>=0| and |q>=0|@>;
2945 n=f / unity; f=f % unity;
2946 if ( q<=el_gordo / n ) {
2949 mp->arith_error=true; n=el_gordo;
2953 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2954 be_careful=n-el_gordo;
2955 if ( be_careful+p>0 ) {
2956 mp->arith_error=true; n=el_gordo-p;
2958 return ( negative ?(-(n+p)) :(n+p));
2960 integer mp_take_scaled (MP mp,integer p, scaled q) {
2963 d = (double)p * (double)q * TWEXP_16;
2967 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2968 mp->arith_error = true;
2972 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2976 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2977 mp->arith_error = true;
2981 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2987 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
2988 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
2990 if ( q<fraction_four ) {
2992 p = (odd(f) ? halfp(p+q) : halfp(p));
2997 p = (odd(f) ? p+halfp(q-p) : halfp(p));
3002 @ For completeness, there's also |make_scaled|, which computes a
3003 quotient as a |scaled| number instead of as a |fraction|.
3004 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
3005 operands are positive. \ (This procedure is not used especially often,
3006 so it is not part of \MP's inner loop.)
3008 @<Internal library ...@>=
3009 scaled mp_make_scaled (MP mp,integer p, integer q) ;
3012 scaled mp_make_scaled (MP mp,integer p, integer q) {
3014 integer f; /* the fraction bits, with a leading 1 bit */
3015 integer n; /* the integer part of $\vert p/q\vert$ */
3016 boolean negative; /* should the result be negated? */
3017 integer be_careful; /* disables certain compiler optimizations */
3018 if ( p>=0 ) negative=false;
3019 else { negate(p); negative=true; };
3022 if ( q==0 ) mp_confusion(mp, "/");
3023 @:this can't happen /}{\quad \./@>
3025 negate(q); negative=! negative;
3029 mp->arith_error=true;
3030 return (negative ? (-el_gordo) : el_gordo);
3033 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
3034 return ( negative ? (-(f+n)) :(f+n));
3040 if (q==0) mp_confusion(mp,"/");
3042 d = TWEXP16 * (double)p /(double)q;
3045 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
3047 if (d==i && ( ((q>0 ? -q : q)&077777)
3048 * (((i&037777)<<1)-1) & 04000)!=0) --i;
3051 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
3053 if (d==i && ( ((q>0 ? q : -q)&077777)
3054 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
3060 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
3063 be_careful=p-q; p=be_careful+p;
3064 if ( p>=0 ) f=f+f+1;
3065 else { f+=f; p=p+q; };
3068 if ( be_careful+p>=0 ) incr(f)
3070 @ Here is a typical example of how the routines above can be used.
3071 It computes the function
3072 $${1\over3\tau}f(\theta,\phi)=
3073 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3074 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3075 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3076 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3077 fudge factor for placing the first control point of a curve that starts
3078 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3079 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3081 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3082 (It's a sum of eight terms whose absolute values can be bounded using
3083 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3084 is positive; and since the tension $\tau$ is constrained to be at least
3085 $3\over4$, the numerator is less than $16\over3$. The denominator is
3086 nonnegative and at most~6. Hence the fixed-point calculations below
3087 are guaranteed to stay within the bounds of a 32-bit computer word.
3089 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3090 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3091 $\sin\phi$, and $\cos\phi$, respectively.
3094 fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3095 fraction cf, scaled t) {
3096 integer acc,num,denom; /* registers for intermediate calculations */
3097 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3098 acc=mp_take_fraction(mp, acc,ct-cf);
3099 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3100 /* $2^{28}\sqrt2\approx379625062.497$ */
3101 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3102 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3103 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3104 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3105 /* |make_scaled(fraction,scaled)=fraction| */
3106 if ( num / 4>=denom )
3107 return fraction_four;
3109 return mp_make_fraction(mp, num, denom);
3112 @ The following somewhat different subroutine tests rigorously if $ab$ is
3113 greater than, equal to, or less than~$cd$,
3114 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3115 The result is $+1$, 0, or~$-1$ in the three respective cases.
3117 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3120 integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3121 integer q,r; /* temporary registers */
3122 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3124 q = a / d; r = c / b;
3126 return ( q>r ? 1 : -1);
3127 q = a % d; r = c % b;
3130 if ( q==0 ) return -1;
3132 } /* now |a>d>0| and |c>b>0| */
3135 @ @<Reduce to the case that |a...@>=
3136 if ( a<0 ) { negate(a); negate(b); };
3137 if ( c<0 ) { negate(c); negate(d); };
3140 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3144 return ( a==0 ? 0 : -1);
3145 q=a; a=c; c=q; q=-b; b=-d; d=q;
3146 } else if ( b<=0 ) {
3147 if ( b<0 ) if ( a>0 ) return -1;
3148 return (c==0 ? 0 : -1);
3151 @ We conclude this set of elementary routines with some simple rounding
3152 and truncation operations.
3154 @<Internal library declarations@>=
3155 #define mp_floor_scaled(M,i) ((i)&(-65536))
3156 #define mp_round_unscaled(M,i) (((i>>15)+1)>>1)
3157 #define mp_round_fraction(M,i) (((i>>11)+1)>>1)
3160 @* \[8] Algebraic and transcendental functions.
3161 \MP\ computes all of the necessary special functions from scratch, without
3162 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3164 @ To get the square root of a |scaled| number |x|, we want to calculate
3165 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3166 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3167 determines $s$ by an iterative method that maintains the invariant
3168 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3169 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3170 might, however, be zero at the start of the first iteration.
3173 scaled mp_square_rt (MP mp,scaled x) ;
3176 scaled mp_square_rt (MP mp,scaled x) {
3177 small_number k; /* iteration control counter */
3178 integer y,q; /* registers for intermediate calculations */
3180 @<Handle square root of zero or negative argument@>;
3183 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3186 if ( x<fraction_four ) y=0;
3187 else { x=x-fraction_four; y=1; };
3189 @<Decrease |k| by 1, maintaining the invariant
3190 relations between |x|, |y|, and~|q|@>;
3196 @ @<Handle square root of zero...@>=
3199 print_err("Square root of ");
3200 @.Square root...replaced by 0@>
3201 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3202 help2("Since I don't take square roots of negative numbers,")
3203 ("I'm zeroing this one. Proceed, with fingers crossed.");
3209 @ @<Decrease |k| by 1, maintaining...@>=
3211 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3212 x=x-fraction_four; incr(y);
3214 x+=x; y=y+y-q; q+=q;
3215 if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
3216 if ( y>q ){ y=y-q; q=q+2; }
3217 else if ( y<=0 ) { q=q-2; y=y+q; };
3220 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3221 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3222 @^Moler, Cleve Barry@>
3223 @^Morrison, Donald Ross@>
3224 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3225 in such a way that their Pythagorean sum remains invariant, while the
3226 smaller argument decreases.
3228 @<Internal library ...@>=
3229 integer mp_pyth_add (MP mp,integer a, integer b);
3233 integer mp_pyth_add (MP mp,integer a, integer b) {
3234 fraction r; /* register used to transform |a| and |b| */
3235 boolean big; /* is the result dangerously near $2^{31}$? */
3237 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3239 if ( a<fraction_two ) {
3242 a=a / 4; b=b / 4; big=true;
3243 }; /* we reduced the precision to avoid arithmetic overflow */
3244 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3246 if ( a<fraction_two ) {
3249 mp->arith_error=true; a=el_gordo;
3256 @ The key idea here is to reflect the vector $(a,b)$ about the
3257 line through $(a,b/2)$.
3259 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3261 r=mp_make_fraction(mp, b,a);
3262 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3264 r=mp_make_fraction(mp, r,fraction_four+r);
3265 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3269 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3270 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3273 integer mp_pyth_sub (MP mp,integer a, integer b) {
3274 fraction r; /* register used to transform |a| and |b| */
3275 boolean big; /* is the input dangerously near $2^{31}$? */
3278 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3280 if ( a<fraction_four ) {
3283 a=halfp(a); b=halfp(b); big=true;
3285 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3286 if ( big ) double(a);
3291 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3293 r=mp_make_fraction(mp, b,a);
3294 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3296 r=mp_make_fraction(mp, r,fraction_four-r);
3297 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3300 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3303 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3304 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3305 mp_print(mp, " has been replaced by 0");
3307 help2("Since I don't take square roots of negative numbers,")
3308 ("I'm zeroing this one. Proceed, with fingers crossed.");
3314 @ The subroutines for logarithm and exponential involve two tables.
3315 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3316 a bit more calculation, which the author claims to have done correctly:
3317 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3318 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3321 @d two_to_the(A) (1<<(A))
3324 static const integer spec_log[29] = { 0, /* special logarithms */
3325 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3326 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3327 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3329 @ @<Local variables for initialization@>=
3330 integer k; /* all-purpose loop index */
3333 @ Here is the routine that calculates $2^8$ times the natural logarithm
3334 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3335 when |x| is a given positive integer.
3337 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3338 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3339 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3340 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3341 during the calculation, and sixteen auxiliary bits to extend |y| are
3342 kept in~|z| during the initial argument reduction. (We add
3343 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3344 not become negative; also, the actual amount subtracted from~|y| is~96,
3345 not~100, because we want to add~4 for rounding before the final division by~8.)
3348 scaled mp_m_log (MP mp,scaled x) {
3349 integer y,z; /* auxiliary registers */
3350 integer k; /* iteration counter */
3352 @<Handle non-positive logarithm@>;
3354 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3355 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3356 while ( x<fraction_four ) {
3357 double(x); y-=93032639; z-=48782;
3358 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3359 y=y+(z / unity); k=2;
3360 while ( x>fraction_four+4 ) {
3361 @<Increase |k| until |x| can be multiplied by a
3362 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3368 @ @<Increase |k| until |x| can...@>=
3370 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3371 while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
3372 y+=spec_log[k]; x-=z;
3375 @ @<Handle non-positive logarithm@>=
3377 print_err("Logarithm of ");
3378 @.Logarithm...replaced by 0@>
3379 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3380 help2("Since I don't take logs of non-positive numbers,")
3381 ("I'm zeroing this one. Proceed, with fingers crossed.");
3386 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3387 when |x| is |scaled|. The result is an integer approximation to
3388 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3391 scaled mp_m_exp (MP mp,scaled x) {
3392 small_number k; /* loop control index */
3393 integer y,z; /* auxiliary registers */
3394 if ( x>174436200 ) {
3395 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3396 mp->arith_error=true;
3398 } else if ( x<-197694359 ) {
3399 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3403 z=-8*x; y=04000000; /* $y=2^{20}$ */
3405 if ( x<=127919879 ) {
3407 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3409 z=8*(174436200-x); /* |z| is always nonnegative */
3413 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3415 return ((y+8) / 16);
3421 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3422 to multiplying |y| by $1-2^{-k}$.
3424 A subtle point (which had to be checked) was that if $x=127919879$, the
3425 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3426 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3427 and by~16 when |k=27|.
3429 @<Multiply |y| by...@>=
3432 while ( z>=spec_log[k] ) {
3434 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3439 @ The trigonometric subroutines use an auxiliary table such that
3440 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3441 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3444 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3445 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3446 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3448 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3449 returns the |angle| whose tangent points in the direction $(x,y)$.
3450 This subroutine first determines the correct octant, then solves the
3451 problem for |0<=y<=x|, then converts the result appropriately to
3452 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3453 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3454 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3456 The octants are represented in a ``Gray code,'' since that turns out
3457 to be computationally simplest.
3463 @d second_octant (first_octant+switch_x_and_y)
3464 @d third_octant (first_octant+switch_x_and_y+negate_x)
3465 @d fourth_octant (first_octant+negate_x)
3466 @d fifth_octant (first_octant+negate_x+negate_y)
3467 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3468 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3469 @d eighth_octant (first_octant+negate_y)
3472 angle mp_n_arg (MP mp,integer x, integer y) {
3473 angle z; /* auxiliary register */
3474 integer t; /* temporary storage */
3475 small_number k; /* loop counter */
3476 int octant; /* octant code */
3478 octant=first_octant;
3480 negate(x); octant=first_octant+negate_x;
3483 negate(y); octant=octant+negate_y;
3486 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3489 @<Handle undefined arg@>;
3491 @<Set variable |z| to the arg of $(x,y)$@>;
3492 @<Return an appropriate answer based on |z| and |octant|@>;
3496 @ @<Handle undefined arg@>=
3498 print_err("angle(0,0) is taken as zero");
3499 @.angle(0,0)...zero@>
3500 help2("The `angle' between two identical points is undefined.")
3501 ("I'm zeroing this one. Proceed, with fingers crossed.");
3506 @ @<Return an appropriate answer...@>=
3508 case first_octant: return z;
3509 case second_octant: return (ninety_deg-z);
3510 case third_octant: return (ninety_deg+z);
3511 case fourth_octant: return (one_eighty_deg-z);
3512 case fifth_octant: return (z-one_eighty_deg);
3513 case sixth_octant: return (-z-ninety_deg);
3514 case seventh_octant: return (z-ninety_deg);
3515 case eighth_octant: return (-z);
3516 }; /* there are no other cases */
3519 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3520 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3523 @<Set variable |z| to the arg...@>=
3524 while ( x>=fraction_two ) {
3525 x=halfp(x); y=halfp(y);
3529 while ( x<fraction_one ) {
3532 @<Increase |z| to the arg of $(x,y)$@>;
3535 @ During the calculations of this section, variables |x| and~|y|
3536 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3537 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3538 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3539 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3540 coordinates whose angle has decreased by~$\phi$; in the special case
3541 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3542 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3543 @^Meggitt, John E.@>
3544 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3546 The initial value of |x| will be multiplied by at most
3547 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3548 there is no chance of integer overflow.
3550 @<Increase |z|...@>=
3555 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3560 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3563 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3564 and cosine of that angle. The results of this routine are
3565 stored in global integer variables |n_sin| and |n_cos|.
3568 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3570 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3571 the purpose of |n_sin_cos(z)| is to set
3572 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3573 for some rather large number~|r|. The maximum of |x| and |y|
3574 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3575 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3578 void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3580 small_number k; /* loop control variable */
3581 int q; /* specifies the quadrant */
3582 fraction r; /* magnitude of |(x,y)| */
3583 integer x,y,t; /* temporary registers */
3584 while ( z<0 ) z=z+three_sixty_deg;
3585 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3586 q=z / forty_five_deg; z=z % forty_five_deg;
3587 x=fraction_one; y=x;
3588 if ( ! odd(q) ) z=forty_five_deg-z;
3589 @<Subtract angle |z| from |(x,y)|@>;
3590 @<Convert |(x,y)| to the octant determined by~|q|@>;
3591 r=mp_pyth_add(mp, x,y);
3592 mp->n_cos=mp_make_fraction(mp, x,r);
3593 mp->n_sin=mp_make_fraction(mp, y,r);
3596 @ In this case the octants are numbered sequentially.
3598 @<Convert |(x,...@>=
3601 case 1: t=x; x=y; y=t; break;
3602 case 2: t=x; x=-y; y=t; break;
3603 case 3: negate(x); break;
3604 case 4: negate(x); negate(y); break;
3605 case 5: t=x; x=-y; y=-t; break;
3606 case 6: t=x; x=y; y=-t; break;
3607 case 7: negate(y); break;
3608 } /* there are no other cases */
3610 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3611 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3612 that this loop is guaranteed to terminate before the (nonexistent) value
3613 |spec_atan[27]| would be required.
3615 @<Subtract angle |z|...@>=
3618 if ( z>=spec_atan[k] ) {
3619 z=z-spec_atan[k]; t=x;
3620 x=t+y / two_to_the(k);
3621 y=y-t / two_to_the(k);
3625 if ( y<0 ) y=0 /* this precaution may never be needed */
3627 @ And now let's complete our collection of numeric utility routines
3628 by considering random number generation.
3629 \MP\ generates pseudo-random numbers with the additive scheme recommended
3630 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3631 results are random fractions between 0 and |fraction_one-1|, inclusive.
3633 There's an auxiliary array |randoms| that contains 55 pseudo-random
3634 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3635 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3636 The global variable |j_random| tells which element has most recently
3638 The global variable |random_seed| was introduced in version 0.9,
3639 for the sole reason of stressing the fact that the initial value of the
3640 random seed is system-dependant. The initialization code below will initialize
3641 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3642 is not good enough on modern fast machines that are capable of running
3643 multiple MetaPost processes within the same second.
3644 @^system dependencies@>
3647 fraction randoms[55]; /* the last 55 random values generated */
3648 int j_random; /* the number of unused |randoms| */
3650 @ @<Option variables@>=
3651 int random_seed; /* the default random seed */
3653 @ @<Allocate or initialize ...@>=
3654 mp->random_seed = (scaled)opt->random_seed;
3656 @ To consume a random fraction, the program below will say `|next_random|'
3657 and then it will fetch |randoms[j_random]|.
3659 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3660 else decr(mp->j_random); }
3663 void mp_new_randoms (MP mp) {
3664 int k; /* index into |randoms| */
3665 fraction x; /* accumulator */
3666 for (k=0;k<=23;k++) {
3667 x=mp->randoms[k]-mp->randoms[k+31];
3668 if ( x<0 ) x=x+fraction_one;
3671 for (k=24;k<= 54;k++){
3672 x=mp->randoms[k]-mp->randoms[k-24];
3673 if ( x<0 ) x=x+fraction_one;
3680 void mp_init_randoms (MP mp,scaled seed);
3682 @ To initialize the |randoms| table, we call the following routine.
3685 void mp_init_randoms (MP mp,scaled seed) {
3686 fraction j,jj,k; /* more or less random integers */
3687 int i; /* index into |randoms| */
3689 while ( j>=fraction_one ) j=halfp(j);
3691 for (i=0;i<=54;i++ ){
3693 if ( k<0 ) k=k+fraction_one;
3694 mp->randoms[(i*21)% 55]=j;
3698 mp_new_randoms(mp); /* ``warm up'' the array */
3701 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3702 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3704 Note that the call of |take_fraction| will produce the values 0 and~|x|
3705 with about half the probability that it will produce any other particular
3706 values between 0 and~|x|, because it rounds its answers.
3709 scaled mp_unif_rand (MP mp,scaled x) {
3710 scaled y; /* trial value */
3711 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3712 if ( y==abs(x) ) return 0;
3713 else if ( x>0 ) return y;
3717 @ Finally, a normal deviate with mean zero and unit standard deviation
3718 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3719 {\sl The Art of Computer Programming\/}).
3722 scaled mp_norm_rand (MP mp) {
3723 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3727 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3728 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3729 next_random; u=mp->randoms[mp->j_random];
3730 } while (abs(x)>=u);
3731 x=mp_make_fraction(mp, x,u);
3732 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3733 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3737 @* \[9] Packed data.
3738 In order to make efficient use of storage space, \MP\ bases its major data
3739 structures on a |memory_word|, which contains either a (signed) integer,
3740 possibly scaled, or a small number of fields that are one half or one
3741 quarter of the size used for storing integers.
3743 If |x| is a variable of type |memory_word|, it contains up to four
3744 fields that can be referred to as follows:
3745 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3746 |x|&.|int|&(an |integer|)\cr
3747 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3748 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3749 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3751 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3752 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3753 This is somewhat cumbersome to write, and not very readable either, but
3754 macros will be used to make the notation shorter and more transparent.
3755 The code below gives a formal definition of |memory_word| and
3756 its subsidiary types, using packed variant records. \MP\ makes no
3757 assumptions about the relative positions of the fields within a word.
3759 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3760 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3762 @ Here are the inequalities that the quarterword and halfword values
3763 must satisfy (or rather, the inequalities that they mustn't satisfy):
3765 @<Check the ``constant''...@>=
3766 if (mp->ini_version) {
3767 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3769 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3771 if ( max_quarterword<255 ) mp->bad=9;
3772 if ( max_halfword<65535 ) mp->bad=10;
3773 if ( max_quarterword>max_halfword ) mp->bad=11;
3774 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3775 if ( mp->max_strings>max_halfword ) mp->bad=13;
3777 @ The macros |qi| and |qo| are used for input to and output
3778 from quarterwords. These are legacy macros.
3779 @^system dependencies@>
3781 @d qo(A) (A) /* to read eight bits from a quarterword */
3782 @d qi(A) (A) /* to store eight bits in a quarterword */
3784 @ The reader should study the following definitions closely:
3785 @^system dependencies@>
3787 @d sc cint /* |scaled| data is equivalent to |integer| */
3790 typedef short quarterword; /* 1/4 of a word */
3791 typedef int halfword; /* 1/2 of a word */
3796 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3803 quarterword B2, B3, B0, B1;
3818 @ When debugging, we may want to print a |memory_word| without knowing
3819 what type it is; so we print it in all modes.
3823 void mp_print_word (MP mp,memory_word w) {
3824 /* prints |w| in all ways */
3825 mp_print_int(mp, w.cint); mp_print_char(mp, ' ');
3826 mp_print_scaled(mp, w.sc); mp_print_char(mp, ' ');
3827 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3828 mp_print_int(mp, w.hh.lh); mp_print_char(mp, '=');
3829 mp_print_int(mp, w.hh.b0); mp_print_char(mp, ':');
3830 mp_print_int(mp, w.hh.b1); mp_print_char(mp, ';');
3831 mp_print_int(mp, w.hh.rh); mp_print_char(mp, ' ');
3832 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, ':');
3833 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, ':');
3834 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, ':');
3835 mp_print_int(mp, w.qqqq.b3);
3839 @* \[10] Dynamic memory allocation.
3841 The \MP\ system does nearly all of its own memory allocation, so that it
3842 can readily be transported into environments that do not have automatic
3843 facilities for strings, garbage collection, etc., and so that it can be in
3844 control of what error messages the user receives. The dynamic storage
3845 requirements of \MP\ are handled by providing a large array |mem| in
3846 which consecutive blocks of words are used as nodes by the \MP\ routines.
3848 Pointer variables are indices into this array, or into another array
3849 called |eqtb| that will be explained later. A pointer variable might
3850 also be a special flag that lies outside the bounds of |mem|, so we
3851 allow pointers to assume any |halfword| value. The minimum memory
3852 index represents a null pointer.
3854 @d null 0 /* the null pointer */
3855 @d mp_void (null+1) /* a null pointer different from |null| */
3859 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3861 @ The |mem| array is divided into two regions that are allocated separately,
3862 but the dividing line between these two regions is not fixed; they grow
3863 together until finding their ``natural'' size in a particular job.
3864 Locations less than or equal to |lo_mem_max| are used for storing
3865 variable-length records consisting of two or more words each. This region
3866 is maintained using an algorithm similar to the one described in exercise
3867 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3868 appears in the allocated nodes; the program is responsible for knowing the
3869 relevant size when a node is freed. Locations greater than or equal to
3870 |hi_mem_min| are used for storing one-word records; a conventional
3871 \.{AVAIL} stack is used for allocation in this region.
3873 Locations of |mem| between |0| and |mem_top| may be dumped as part
3874 of preloaded mem files, by the \.{INIMP} preprocessor.
3876 Production versions of \MP\ may extend the memory at the top end in order to
3877 provide more space; these locations, between |mem_top| and |mem_max|,
3878 are always used for single-word nodes.
3880 The key pointers that govern |mem| allocation have a prescribed order:
3881 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3884 memory_word *mem; /* the big dynamic storage area */
3885 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3886 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3890 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3891 @d xrealloc(P,A,B) mp_xrealloc(mp,P,A,B)
3892 @d xmalloc(A,B) mp_xmalloc(mp,A,B)
3893 @d xstrdup(A) mp_xstrdup(mp,A)
3894 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3896 @<Declare helpers@>=
3897 void mp_xfree (void *x);
3898 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3899 void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3900 char *mp_xstrdup(MP mp, const char *s);
3901 void mp_do_snprintf(char *str, int size, const char *fmt, ...);
3903 @ The |max_size_test| guards against overflow, on the assumption that
3904 |size_t| is at least 31bits wide.
3906 @d max_size_test 0x7FFFFFFF
3909 void mp_xfree (void *x) {
3910 if (x!=NULL) free(x);
3912 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3914 if ((max_size_test/size)<nmem) {
3915 do_fprintf(mp->err_out,"Memory size overflow!\n");
3916 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3918 w = realloc (p,(nmem*size));
3920 do_fprintf(mp->err_out,"Out of memory!\n");
3921 mp->history =mp_system_error_stop; mp_jump_out(mp);
3925 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
3927 if ((max_size_test/size)<nmem) {
3928 do_fprintf(mp->err_out,"Memory size overflow!\n");
3929 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3931 w = malloc (nmem*size);
3933 do_fprintf(mp->err_out,"Out of memory!\n");
3934 mp->history =mp_system_error_stop; mp_jump_out(mp);
3938 char *mp_xstrdup(MP mp, const char *s) {
3944 do_fprintf(mp->err_out,"Out of memory!\n");
3945 mp->history =mp_system_error_stop; mp_jump_out(mp);
3950 @ @<Internal library declarations@>=
3951 #ifdef HAVE_SNPRINTF
3952 #define mp_snprintf (void)snprintf
3954 #define mp_snprintf mp_do_snprintf
3957 @ This internal version is rather stupid, but good enough for its purpose.
3960 void mp_do_snprintf (char *str, int size, const char *format, ...) {
3965 work = (char *)workbuf;
3966 va_start(ap, format);
3968 for (fmt=format;*fmt!='\0';fmt++) {
3974 char *s = va_arg(ap, char *);
3977 if (size-->0) res++;
3984 sprintf(work,"%i",va_arg(ap, int));
3987 if (size-->0) res++;
3993 sprintf(work,"%g",va_arg(ap, double));
3996 if (size-->0) res++;
4002 if (size-->0) res++;
4010 if (size-->0) res++;
4018 @<Allocate or initialize ...@>=
4019 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
4020 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
4022 @ @<Dealloc variables@>=
4025 @ Users who wish to study the memory requirements of particular applications can
4026 can use optional special features that keep track of current and
4027 maximum memory usage. When code between the delimiters |stat| $\ldots$
4028 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
4029 report these statistics when |mp_tracing_stats| is positive.
4032 integer var_used; integer dyn_used; /* how much memory is in use */
4034 @ Let's consider the one-word memory region first, since it's the
4035 simplest. The pointer variable |mem_end| holds the highest-numbered location
4036 of |mem| that has ever been used. The free locations of |mem| that
4037 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
4038 |two_halves|, and we write |info(p)| and |link(p)| for the |lh|
4039 and |rh| fields of |mem[p]| when it is of this type. The single-word
4040 free locations form a linked list
4041 $$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
4042 terminated by |null|.
4044 @d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
4045 @d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
4048 pointer avail; /* head of the list of available one-word nodes */
4049 pointer mem_end; /* the last one-word node used in |mem| */
4051 @ If one-word memory is exhausted, it might mean that the user has forgotten
4052 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
4053 later that try to help pinpoint the trouble.
4056 @<Declare the procedure called |show_token_list|@>
4057 @<Declare the procedure called |runaway|@>
4059 @ The function |get_avail| returns a pointer to a new one-word node whose
4060 |link| field is null. However, \MP\ will halt if there is no more room left.
4064 pointer mp_get_avail (MP mp) { /* single-word node allocation */
4065 pointer p; /* the new node being got */
4066 p=mp->avail; /* get top location in the |avail| stack */
4068 mp->avail=link(mp->avail); /* and pop it off */
4069 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
4070 incr(mp->mem_end); p=mp->mem_end;
4072 decr(mp->hi_mem_min); p=mp->hi_mem_min;
4073 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
4074 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
4075 mp_overflow(mp, "main memory size",mp->mem_max);
4076 /* quit; all one-word nodes are busy */
4077 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4080 link(p)=null; /* provide an oft-desired initialization of the new node */
4081 incr(mp->dyn_used);/* maintain statistics */
4085 @ Conversely, a one-word node is recycled by calling |free_avail|.
4087 @d free_avail(A) /* single-word node liberation */
4088 { link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
4090 @ There's also a |fast_get_avail| routine, which saves the procedure-call
4091 overhead at the expense of extra programming. This macro is used in
4092 the places that would otherwise account for the most calls of |get_avail|.
4095 @d fast_get_avail(A) {
4096 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
4097 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4098 else { mp->avail=link((A)); link((A))=null; incr(mp->dyn_used); }
4101 @ The available-space list that keeps track of the variable-size portion
4102 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4103 pointed to by the roving pointer |rover|.
4105 Each empty node has size 2 or more; the first word contains the special
4106 value |max_halfword| in its |link| field and the size in its |info| field;
4107 the second word contains the two pointers for double linking.
4109 Each nonempty node also has size 2 or more. Its first word is of type
4110 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4111 Otherwise there is complete flexibility with respect to the contents
4112 of its other fields and its other words.
4114 (We require |mem_max<max_halfword| because terrible things can happen
4115 when |max_halfword| appears in the |link| field of a nonempty node.)
4117 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4118 @d is_empty(A) (link((A))==empty_flag) /* tests for empty node */
4119 @d node_size info /* the size field in empty variable-size nodes */
4120 @d llink(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
4121 @d rlink(A) link((A)+1) /* right link in doubly-linked list of empty nodes */
4124 pointer rover; /* points to some node in the list of empties */
4126 @ A call to |get_node| with argument |s| returns a pointer to a new node
4127 of size~|s|, which must be 2~or more. The |link| field of the first word
4128 of this new node is set to null. An overflow stop occurs if no suitable
4131 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4132 areas and returns the value |max_halfword|.
4134 @<Internal library declarations@>=
4135 pointer mp_get_node (MP mp,integer s) ;
4138 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4139 pointer p; /* the node currently under inspection */
4140 pointer q; /* the node physically after node |p| */
4141 integer r; /* the newly allocated node, or a candidate for this honor */
4142 integer t,tt; /* temporary registers */
4145 p=mp->rover; /* start at some free node in the ring */
4147 @<Try to allocate within node |p| and its physical successors,
4148 and |goto found| if allocation was possible@>;
4149 if (rlink(p)==null || (rlink(p)==p && p!=mp->rover)) {
4150 print_err("Free list garbled");
4151 help3("I found an entry in the list of free nodes that links")
4152 ("badly. I will try to ignore the broken link, but something")
4153 ("is seriously amiss. It is wise to warn the maintainers.")
4157 p=rlink(p); /* move to the next node in the ring */
4158 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4159 if ( s==010000000000 ) {
4160 return max_halfword;
4162 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4163 if ( mp->lo_mem_max+2<=max_halfword ) {
4164 @<Grow more variable-size memory and |goto restart|@>;
4167 mp_overflow(mp, "main memory size",mp->mem_max);
4168 /* sorry, nothing satisfactory is left */
4169 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4171 link(r)=null; /* this node is now nonempty */
4172 mp->var_used+=s; /* maintain usage statistics */
4176 @ The lower part of |mem| grows by 1000 words at a time, unless
4177 we are very close to going under. When it grows, we simply link
4178 a new node into the available-space list. This method of controlled
4179 growth helps to keep the |mem| usage consecutive when \MP\ is
4180 implemented on ``virtual memory'' systems.
4183 @<Grow more variable-size memory and |goto restart|@>=
4185 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4186 t=mp->lo_mem_max+1000;
4188 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4189 /* |lo_mem_max+2<=t<hi_mem_min| */
4191 if ( t>max_halfword ) t=max_halfword;
4192 p=llink(mp->rover); q=mp->lo_mem_max; rlink(p)=q; llink(mp->rover)=q;
4193 rlink(q)=mp->rover; llink(q)=p; link(q)=empty_flag;
4194 node_size(q)=t-mp->lo_mem_max;
4195 mp->lo_mem_max=t; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4200 @ @<Try to allocate...@>=
4201 q=p+node_size(p); /* find the physical successor */
4202 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4203 t=rlink(q); tt=llink(q);
4205 if ( q==mp->rover ) mp->rover=t;
4206 llink(t)=tt; rlink(tt)=t;
4211 @<Allocate from the top of node |p| and |goto found|@>;
4214 if ( rlink(p)!=p ) {
4215 @<Allocate entire node |p| and |goto found|@>;
4218 node_size(p)=q-p /* reset the size in case it grew */
4220 @ @<Allocate from the top...@>=
4222 node_size(p)=r-p; /* store the remaining size */
4223 mp->rover=p; /* start searching here next time */
4227 @ Here we delete node |p| from the ring, and let |rover| rove around.
4229 @<Allocate entire...@>=
4231 mp->rover=rlink(p); t=llink(p);
4232 llink(mp->rover)=t; rlink(t)=mp->rover;
4236 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4237 the operation |free_node(p,s)| will make its words available, by inserting
4238 |p| as a new empty node just before where |rover| now points.
4240 @<Internal library declarations@>=
4241 void mp_free_node (MP mp, pointer p, halfword s) ;
4244 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4246 pointer q; /* |llink(rover)| */
4247 node_size(p)=s; link(p)=empty_flag;
4249 q=llink(mp->rover); llink(p)=q; rlink(p)=mp->rover; /* set both links */
4250 llink(mp->rover)=p; rlink(q)=p; /* insert |p| into the ring */
4251 mp->var_used-=s; /* maintain statistics */
4254 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4255 available space list. The list is probably very short at such times, so a
4256 simple insertion sort is used. The smallest available location will be
4257 pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
4260 void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4262 pointer p,q,r; /* indices into |mem| */
4263 pointer old_rover; /* initial |rover| setting */
4264 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4265 p=rlink(mp->rover); rlink(mp->rover)=max_halfword; old_rover=mp->rover;
4266 while ( p!=old_rover ) {
4267 @<Sort |p| into the list starting at |rover|
4268 and advance |p| to |rlink(p)|@>;
4271 while ( rlink(p)!=max_halfword ) {
4272 llink(rlink(p))=p; p=rlink(p);
4274 rlink(p)=mp->rover; llink(mp->rover)=p;
4277 @ The following |while| loop is guaranteed to
4278 terminate, since the list that starts at
4279 |rover| ends with |max_halfword| during the sorting procedure.
4282 if ( p<mp->rover ) {
4283 q=p; p=rlink(q); rlink(q)=mp->rover; mp->rover=q;
4286 while ( rlink(q)<p ) q=rlink(q);
4287 r=rlink(p); rlink(p)=rlink(q); rlink(q)=p; p=r;
4290 @* \[11] Memory layout.
4291 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4292 more efficient than dynamic allocation when we can get away with it. For
4293 example, locations |0| to |1| are always used to store a
4294 two-word dummy token whose second word is zero.
4295 The following macro definitions accomplish the static allocation by giving
4296 symbolic names to the fixed positions. Static variable-size nodes appear
4297 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4298 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4300 @d null_dash (2) /* the first two words are reserved for a null value */
4301 @d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4302 @d zero_val (dep_head+2) /* two words for a permanently zero value */
4303 @d temp_val (zero_val+2) /* two words for a temporary value node */
4304 @d end_attr temp_val /* we use |end_attr+2| only */
4305 @d inf_val (end_attr+2) /* and |inf_val+1| only */
4306 @d test_pen (inf_val+2)
4307 /* nine words for a pen used when testing the turning number */
4308 @d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
4309 @d lo_mem_stat_max (bad_vardef+1) /* largest statically
4310 allocated word in the variable-size |mem| */
4312 @d sentinel mp->mem_top /* end of sorted lists */
4313 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4314 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4315 @d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4316 @d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4317 the one-word |mem| */
4319 @ The following code gets the dynamic part of |mem| off to a good start,
4320 when \MP\ is initializing itself the slow way.
4322 @<Initialize table entries (done by \.{INIMP} only)@>=
4323 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4324 link(mp->rover)=empty_flag;
4325 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4326 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
4327 mp->lo_mem_max=mp->rover+1000;
4328 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4329 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4330 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4332 mp->avail=null; mp->mem_end=mp->mem_top;
4333 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4334 mp->var_used=lo_mem_stat_max+1;
4335 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4336 @<Initialize a pen at |test_pen| so that it fits in nine words@>;
4338 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4339 nodes that starts at a given position, until coming to |sentinel| or a
4340 pointer that is not in the one-word region. Another procedure,
4341 |flush_node_list|, frees an entire linked list of one-word and two-word
4342 nodes, until coming to a |null| pointer.
4346 void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4347 pointer q,r; /* list traversers */
4348 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4353 if ( r<mp->hi_mem_min ) break;
4354 } while (r!=sentinel);
4355 /* now |q| is the last node on the list */
4356 link(q)=mp->avail; mp->avail=p;
4360 void mp_flush_node_list (MP mp,pointer p) {
4361 pointer q; /* the node being recycled */
4364 if ( q<mp->hi_mem_min )
4365 mp_free_node(mp, q,2);
4371 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4372 For example, some pointers might be wrong, or some ``dead'' nodes might not
4373 have been freed when the last reference to them disappeared. Procedures
4374 |check_mem| and |search_mem| are available to help diagnose such
4375 problems. These procedures make use of two arrays called |free| and
4376 |was_free| that are present only if \MP's debugging routines have
4377 been included. (You may want to decrease the size of |mem| while you
4381 Because |boolean|s are typedef-d as ints, it is better to use
4382 unsigned chars here.
4385 unsigned char *free; /* free cells */
4386 unsigned char *was_free; /* previously free cells */
4387 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4388 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4389 boolean panicking; /* do we want to check memory constantly? */
4391 @ @<Allocate or initialize ...@>=
4392 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4393 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4395 @ @<Dealloc variables@>=
4397 xfree(mp->was_free);
4399 @ @<Allocate or ...@>=
4400 mp->was_mem_end=0; /* indicate that everything was previously free */
4401 mp->was_lo_max=0; mp->was_hi_min=mp->mem_max;
4402 mp->panicking=false;
4404 @ @<Declare |mp_reallocate| functions@>=
4405 void mp_reallocate_memory(MP mp, int l) ;
4408 void mp_reallocate_memory(MP mp, int l) {
4409 XREALLOC(mp->free, l, unsigned char);
4410 XREALLOC(mp->was_free, l, unsigned char);
4412 int newarea = l-mp->mem_max;
4413 XREALLOC(mp->mem, l, memory_word);
4414 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4416 XREALLOC(mp->mem, l, memory_word);
4417 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4420 if (mp->ini_version)
4426 @ Procedure |check_mem| makes sure that the available space lists of
4427 |mem| are well formed, and it optionally prints out all locations
4428 that are reserved now but were free the last time this procedure was called.
4431 void mp_check_mem (MP mp,boolean print_locs ) {
4432 pointer p,q,r; /* current locations of interest in |mem| */
4433 boolean clobbered; /* is something amiss? */
4434 for (p=0;p<=mp->lo_mem_max;p++) {
4435 mp->free[p]=false; /* you can probably do this faster */
4437 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4438 mp->free[p]=false; /* ditto */
4440 @<Check single-word |avail| list@>;
4441 @<Check variable-size |avail| list@>;
4442 @<Check flags of unavailable nodes@>;
4443 @<Check the list of linear dependencies@>;
4445 @<Print newly busy locations@>;
4447 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4448 mp->was_mem_end=mp->mem_end;
4449 mp->was_lo_max=mp->lo_mem_max;
4450 mp->was_hi_min=mp->hi_mem_min;
4453 @ @<Check single-word...@>=
4454 p=mp->avail; q=null; clobbered=false;
4456 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4457 else if ( mp->free[p] ) clobbered=true;
4459 mp_print_nl(mp, "AVAIL list clobbered at ");
4460 @.AVAIL list clobbered...@>
4461 mp_print_int(mp, q); break;
4463 mp->free[p]=true; q=p; p=link(q);
4466 @ @<Check variable-size...@>=
4467 p=mp->rover; q=null; clobbered=false;
4469 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4470 else if ( (rlink(p)>=mp->lo_mem_max)||(rlink(p)<0) ) clobbered=true;
4471 else if ( !(is_empty(p))||(node_size(p)<2)||
4472 (p+node_size(p)>mp->lo_mem_max)|| (llink(rlink(p))!=p) ) clobbered=true;
4474 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4475 @.Double-AVAIL list clobbered...@>
4476 mp_print_int(mp, q); break;
4478 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4479 if ( mp->free[q] ) {
4480 mp_print_nl(mp, "Doubly free location at ");
4481 @.Doubly free location...@>
4482 mp_print_int(mp, q); break;
4487 } while (p!=mp->rover)
4490 @ @<Check flags...@>=
4492 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4493 if ( is_empty(p) ) {
4494 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4497 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
4498 while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
4501 @ @<Print newly busy...@>=
4503 @<Do intialization required before printing new busy locations@>;
4504 mp_print_nl(mp, "New busy locs:");
4506 for (p=0;p<= mp->lo_mem_max;p++ ) {
4507 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4508 @<Indicate that |p| is a new busy location@>;
4511 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4512 if ( ! mp->free[p] &&
4513 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4514 @<Indicate that |p| is a new busy location@>;
4517 @<Finish printing new busy locations@>;
4520 @ There might be many new busy locations so we are careful to print contiguous
4521 blocks compactly. During this operation |q| is the last new busy location and
4522 |r| is the start of the block containing |q|.
4524 @<Indicate that |p| is a new busy location@>=
4528 mp_print(mp, ".."); mp_print_int(mp, q);
4530 mp_print_char(mp, ' '); mp_print_int(mp, p);
4536 @ @<Do intialization required before printing new busy locations@>=
4537 q=mp->mem_max; r=mp->mem_max
4539 @ @<Finish printing new busy locations@>=
4541 mp_print(mp, ".."); mp_print_int(mp, q);
4544 @ The |search_mem| procedure attempts to answer the question ``Who points
4545 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4546 that might not be of type |two_halves|. Strictly speaking, this is
4547 undefined, and it can lead to ``false drops'' (words that seem to
4548 point to |p| purely by coincidence). But for debugging purposes, we want
4549 to rule out the places that do {\sl not\/} point to |p|, so a few false
4550 drops are tolerable.
4553 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4554 integer q; /* current position being searched */
4555 for (q=0;q<=mp->lo_mem_max;q++) {
4557 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4560 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4563 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4565 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4568 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4571 @<Search |eqtb| for equivalents equal to |p|@>;
4574 @* \[12] The command codes.
4575 Before we can go much further, we need to define symbolic names for the internal
4576 code numbers that represent the various commands obeyed by \MP. These codes
4577 are somewhat arbitrary, but not completely so. For example,
4578 some codes have been made adjacent so that |case| statements in the
4579 program need not consider cases that are widely spaced, or so that |case|
4580 statements can be replaced by |if| statements. A command can begin an
4581 expression if and only if its code lies between |min_primary_command| and
4582 |max_primary_command|, inclusive. The first token of a statement that doesn't
4583 begin with an expression has a command code between |min_command| and
4584 |max_statement_command|, inclusive. Anything less than |min_command| is
4585 eliminated during macro expansions, and anything no more than |max_pre_command|
4586 is eliminated when expanding \TeX\ material. Ranges such as
4587 |min_secondary_command..max_secondary_command| are used when parsing
4588 expressions, but the relative ordering within such a range is generally not
4591 The ordering of the highest-numbered commands
4592 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4593 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4594 for the smallest two commands. The ordering is also important in the ranges
4595 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4597 At any rate, here is the list, for future reference.
4599 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4600 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4601 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4602 @d max_pre_command mpx_break
4603 @d if_test 4 /* conditional text (\&{if}) */
4604 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
4605 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4606 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4607 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4608 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4609 @d relax 10 /* do nothing (\.{\char`\\}) */
4610 @d scan_tokens 11 /* put a string into the input buffer */
4611 @d expand_after 12 /* look ahead one token */
4612 @d defined_macro 13 /* a macro defined by the user */
4613 @d min_command (defined_macro+1)
4614 @d save_command 14 /* save a list of tokens (\&{save}) */
4615 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4616 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4617 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4618 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4619 @d ship_out_command 19 /* output a character (\&{shipout}) */
4620 @d add_to_command 20 /* add to edges (\&{addto}) */
4621 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4622 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4623 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4624 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4625 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4626 @d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
4627 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4628 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4629 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4630 @d special_command 30 /* output special info (\&{special})
4631 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4632 @d write_command 31 /* write text to a file (\&{write}) */
4633 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
4634 @d max_statement_command type_name
4635 @d min_primary_command type_name
4636 @d left_delimiter 33 /* the left delimiter of a matching pair */
4637 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4638 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4639 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4640 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4641 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4642 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4643 @d capsule_token 40 /* a value that has been put into a token list */
4644 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4645 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4646 @d min_suffix_token internal_quantity
4647 @d tag_token 43 /* a symbolic token without a primitive meaning */
4648 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4649 @d max_suffix_token numeric_token
4650 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4651 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4652 @d min_tertiary_command plus_or_minus
4653 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4654 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4655 @d max_tertiary_command tertiary_binary
4656 @d left_brace 48 /* the operator `\.{\char`\{}' */
4657 @d min_expression_command left_brace
4658 @d path_join 49 /* the operator `\.{..}' */
4659 @d ampersand 50 /* the operator `\.\&' */
4660 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4661 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4662 @d equals 53 /* the operator `\.=' */
4663 @d max_expression_command equals
4664 @d and_command 54 /* the operator `\&{and}' */
4665 @d min_secondary_command and_command
4666 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4667 @d slash 56 /* the operator `\./' */
4668 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4669 @d max_secondary_command secondary_binary
4670 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4671 @d controls 59 /* specify control points explicitly (\&{controls}) */
4672 @d tension 60 /* specify tension between knots (\&{tension}) */
4673 @d at_least 61 /* bounded tension value (\&{atleast}) */
4674 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4675 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4676 @d right_delimiter 64 /* the right delimiter of a matching pair */
4677 @d left_bracket 65 /* the operator `\.[' */
4678 @d right_bracket 66 /* the operator `\.]' */
4679 @d right_brace 67 /* the operator `\.{\char`\}}' */
4680 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4682 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4683 @d of_token 70 /* the operator `\&{of}' */
4684 @d to_token 71 /* the operator `\&{to}' */
4685 @d step_token 72 /* the operator `\&{step}' */
4686 @d until_token 73 /* the operator `\&{until}' */
4687 @d within_token 74 /* the operator `\&{within}' */
4688 @d lig_kern_token 75
4689 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
4690 @d assignment 76 /* the operator `\.{:=}' */
4691 @d skip_to 77 /* the operation `\&{skipto}' */
4692 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4693 @d double_colon 79 /* the operator `\.{::}' */
4694 @d colon 80 /* the operator `\.:' */
4696 @d comma 81 /* the operator `\.,', must be |colon+1| */
4697 @d end_of_statement (mp->cur_cmd>comma)
4698 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4699 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4700 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4701 @d max_command_code stop
4702 @d outer_tag (max_command_code+1) /* protection code added to command code */
4705 typedef int command_code;
4707 @ Variables and capsules in \MP\ have a variety of ``types,''
4708 distinguished by the code numbers defined here. These numbers are also
4709 not completely arbitrary. Things that get expanded must have types
4710 |>mp_independent|; a type remaining after expansion is numeric if and only if
4711 its code number is at least |numeric_type|; objects containing numeric
4712 parts must have types between |transform_type| and |pair_type|;
4713 all other types must be smaller than |transform_type|; and among the types
4714 that are not unknown or vacuous, the smallest two must be |boolean_type|
4715 and |string_type| in that order.
4717 @d undefined 0 /* no type has been declared */
4718 @d unknown_tag 1 /* this constant is added to certain type codes below */
4719 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4720 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4723 enum mp_variable_type {
4724 mp_vacuous=1, /* no expression was present */
4725 mp_boolean_type, /* \&{boolean} with a known value */
4727 mp_string_type, /* \&{string} with a known value */
4729 mp_pen_type, /* \&{pen} with a known value */
4731 mp_path_type, /* \&{path} with a known value */
4733 mp_picture_type, /* \&{picture} with a known value */
4735 mp_transform_type, /* \&{transform} variable or capsule */
4736 mp_color_type, /* \&{color} variable or capsule */
4737 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4738 mp_pair_type, /* \&{pair} variable or capsule */
4739 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4740 mp_known, /* \&{numeric} with a known value */
4741 mp_dependent, /* a linear combination with |fraction| coefficients */
4742 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4743 mp_independent, /* \&{numeric} with unknown value */
4744 mp_token_list, /* variable name or suffix argument or text argument */
4745 mp_structured, /* variable with subscripts and attributes */
4746 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4747 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4751 void mp_print_type (MP mp,small_number t) ;
4753 @ @<Basic printing procedures@>=
4754 void mp_print_type (MP mp,small_number t) {
4756 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4757 case mp_boolean_type:mp_print(mp, "boolean"); break;
4758 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4759 case mp_string_type:mp_print(mp, "string"); break;
4760 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4761 case mp_pen_type:mp_print(mp, "pen"); break;
4762 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4763 case mp_path_type:mp_print(mp, "path"); break;
4764 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4765 case mp_picture_type:mp_print(mp, "picture"); break;
4766 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4767 case mp_transform_type:mp_print(mp, "transform"); break;
4768 case mp_color_type:mp_print(mp, "color"); break;
4769 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4770 case mp_pair_type:mp_print(mp, "pair"); break;
4771 case mp_known:mp_print(mp, "known numeric"); break;
4772 case mp_dependent:mp_print(mp, "dependent"); break;
4773 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4774 case mp_numeric_type:mp_print(mp, "numeric"); break;
4775 case mp_independent:mp_print(mp, "independent"); break;
4776 case mp_token_list:mp_print(mp, "token list"); break;
4777 case mp_structured:mp_print(mp, "mp_structured"); break;
4778 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4779 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4780 default: mp_print(mp, "undefined"); break;
4784 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4785 as well as a |type|. The possibilities for |name_type| are defined
4786 here; they will be explained in more detail later.
4790 mp_root=0, /* |name_type| at the top level of a variable */
4791 mp_saved_root, /* same, when the variable has been saved */
4792 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4793 mp_subscr, /* |name_type| in a subscript node */
4794 mp_attr, /* |name_type| in an attribute node */
4795 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4796 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4797 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4798 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4799 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4800 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4801 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4802 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4803 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4804 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4805 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4806 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4807 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4808 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4809 mp_capsule, /* |name_type| in stashed-away subexpressions */
4810 mp_token /* |name_type| in a numeric token or string token */
4813 @ Primitive operations that produce values have a secondary identification
4814 code in addition to their command code; it's something like genera and species.
4815 For example, `\.*' has the command code |primary_binary|, and its
4816 secondary identification is |times|. The secondary codes start at 30 so that
4817 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4818 are used as operators as well as type identifications. The relative values
4819 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4820 and |filled_op..bounded_op|. The restrictions are that
4821 |and_op-false_code=or_op-true_code|, that the ordering of
4822 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4823 and the ordering of |filled_op..bounded_op| must match that of the code
4824 values they test for.
4826 @d true_code 30 /* operation code for \.{true} */
4827 @d false_code 31 /* operation code for \.{false} */
4828 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4829 @d null_pen_code 33 /* operation code for \.{nullpen} */
4830 @d job_name_op 34 /* operation code for \.{jobname} */
4831 @d read_string_op 35 /* operation code for \.{readstring} */
4832 @d pen_circle 36 /* operation code for \.{pencircle} */
4833 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4834 @d read_from_op 38 /* operation code for \.{readfrom} */
4835 @d close_from_op 39 /* operation code for \.{closefrom} */
4836 @d odd_op 40 /* operation code for \.{odd} */
4837 @d known_op 41 /* operation code for \.{known} */
4838 @d unknown_op 42 /* operation code for \.{unknown} */
4839 @d not_op 43 /* operation code for \.{not} */
4840 @d decimal 44 /* operation code for \.{decimal} */
4841 @d reverse 45 /* operation code for \.{reverse} */
4842 @d make_path_op 46 /* operation code for \.{makepath} */
4843 @d make_pen_op 47 /* operation code for \.{makepen} */
4844 @d oct_op 48 /* operation code for \.{oct} */
4845 @d hex_op 49 /* operation code for \.{hex} */
4846 @d ASCII_op 50 /* operation code for \.{ASCII} */
4847 @d char_op 51 /* operation code for \.{char} */
4848 @d length_op 52 /* operation code for \.{length} */
4849 @d turning_op 53 /* operation code for \.{turningnumber} */
4850 @d color_model_part 54 /* operation code for \.{colormodel} */
4851 @d x_part 55 /* operation code for \.{xpart} */
4852 @d y_part 56 /* operation code for \.{ypart} */
4853 @d xx_part 57 /* operation code for \.{xxpart} */
4854 @d xy_part 58 /* operation code for \.{xypart} */
4855 @d yx_part 59 /* operation code for \.{yxpart} */
4856 @d yy_part 60 /* operation code for \.{yypart} */
4857 @d red_part 61 /* operation code for \.{redpart} */
4858 @d green_part 62 /* operation code for \.{greenpart} */
4859 @d blue_part 63 /* operation code for \.{bluepart} */
4860 @d cyan_part 64 /* operation code for \.{cyanpart} */
4861 @d magenta_part 65 /* operation code for \.{magentapart} */
4862 @d yellow_part 66 /* operation code for \.{yellowpart} */
4863 @d black_part 67 /* operation code for \.{blackpart} */
4864 @d grey_part 68 /* operation code for \.{greypart} */
4865 @d font_part 69 /* operation code for \.{fontpart} */
4866 @d text_part 70 /* operation code for \.{textpart} */
4867 @d path_part 71 /* operation code for \.{pathpart} */
4868 @d pen_part 72 /* operation code for \.{penpart} */
4869 @d dash_part 73 /* operation code for \.{dashpart} */
4870 @d sqrt_op 74 /* operation code for \.{sqrt} */
4871 @d m_exp_op 75 /* operation code for \.{mexp} */
4872 @d m_log_op 76 /* operation code for \.{mlog} */
4873 @d sin_d_op 77 /* operation code for \.{sind} */
4874 @d cos_d_op 78 /* operation code for \.{cosd} */
4875 @d floor_op 79 /* operation code for \.{floor} */
4876 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4877 @d char_exists_op 81 /* operation code for \.{charexists} */
4878 @d font_size 82 /* operation code for \.{fontsize} */
4879 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4880 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4881 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4882 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4883 @d arc_length 87 /* operation code for \.{arclength} */
4884 @d angle_op 88 /* operation code for \.{angle} */
4885 @d cycle_op 89 /* operation code for \.{cycle} */
4886 @d filled_op 90 /* operation code for \.{filled} */
4887 @d stroked_op 91 /* operation code for \.{stroked} */
4888 @d textual_op 92 /* operation code for \.{textual} */
4889 @d clipped_op 93 /* operation code for \.{clipped} */
4890 @d bounded_op 94 /* operation code for \.{bounded} */
4891 @d plus 95 /* operation code for \.+ */
4892 @d minus 96 /* operation code for \.- */
4893 @d times 97 /* operation code for \.* */
4894 @d over 98 /* operation code for \./ */
4895 @d pythag_add 99 /* operation code for \.{++} */
4896 @d pythag_sub 100 /* operation code for \.{+-+} */
4897 @d or_op 101 /* operation code for \.{or} */
4898 @d and_op 102 /* operation code for \.{and} */
4899 @d less_than 103 /* operation code for \.< */
4900 @d less_or_equal 104 /* operation code for \.{<=} */
4901 @d greater_than 105 /* operation code for \.> */
4902 @d greater_or_equal 106 /* operation code for \.{>=} */
4903 @d equal_to 107 /* operation code for \.= */
4904 @d unequal_to 108 /* operation code for \.{<>} */
4905 @d concatenate 109 /* operation code for \.\& */
4906 @d rotated_by 110 /* operation code for \.{rotated} */
4907 @d slanted_by 111 /* operation code for \.{slanted} */
4908 @d scaled_by 112 /* operation code for \.{scaled} */
4909 @d shifted_by 113 /* operation code for \.{shifted} */
4910 @d transformed_by 114 /* operation code for \.{transformed} */
4911 @d x_scaled 115 /* operation code for \.{xscaled} */
4912 @d y_scaled 116 /* operation code for \.{yscaled} */
4913 @d z_scaled 117 /* operation code for \.{zscaled} */
4914 @d in_font 118 /* operation code for \.{infont} */
4915 @d intersect 119 /* operation code for \.{intersectiontimes} */
4916 @d double_dot 120 /* operation code for improper \.{..} */
4917 @d substring_of 121 /* operation code for \.{substring} */
4918 @d min_of substring_of
4919 @d subpath_of 122 /* operation code for \.{subpath} */
4920 @d direction_time_of 123 /* operation code for \.{directiontime} */
4921 @d point_of 124 /* operation code for \.{point} */
4922 @d precontrol_of 125 /* operation code for \.{precontrol} */
4923 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4924 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4925 @d arc_time_of 128 /* operation code for \.{arctime} */
4926 @d mp_version 129 /* operation code for \.{mpversion} */
4927 @d envelope_of 130 /* operation code for \.{envelope} */
4929 @c void mp_print_op (MP mp,quarterword c) {
4930 if (c<=mp_numeric_type ) {
4931 mp_print_type(mp, c);
4934 case true_code:mp_print(mp, "true"); break;
4935 case false_code:mp_print(mp, "false"); break;
4936 case null_picture_code:mp_print(mp, "nullpicture"); break;
4937 case null_pen_code:mp_print(mp, "nullpen"); break;
4938 case job_name_op:mp_print(mp, "jobname"); break;
4939 case read_string_op:mp_print(mp, "readstring"); break;
4940 case pen_circle:mp_print(mp, "pencircle"); break;
4941 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4942 case read_from_op:mp_print(mp, "readfrom"); break;
4943 case close_from_op:mp_print(mp, "closefrom"); break;
4944 case odd_op:mp_print(mp, "odd"); break;
4945 case known_op:mp_print(mp, "known"); break;
4946 case unknown_op:mp_print(mp, "unknown"); break;
4947 case not_op:mp_print(mp, "not"); break;
4948 case decimal:mp_print(mp, "decimal"); break;
4949 case reverse:mp_print(mp, "reverse"); break;
4950 case make_path_op:mp_print(mp, "makepath"); break;
4951 case make_pen_op:mp_print(mp, "makepen"); break;
4952 case oct_op:mp_print(mp, "oct"); break;
4953 case hex_op:mp_print(mp, "hex"); break;
4954 case ASCII_op:mp_print(mp, "ASCII"); break;
4955 case char_op:mp_print(mp, "char"); break;
4956 case length_op:mp_print(mp, "length"); break;
4957 case turning_op:mp_print(mp, "turningnumber"); break;
4958 case x_part:mp_print(mp, "xpart"); break;
4959 case y_part:mp_print(mp, "ypart"); break;
4960 case xx_part:mp_print(mp, "xxpart"); break;
4961 case xy_part:mp_print(mp, "xypart"); break;
4962 case yx_part:mp_print(mp, "yxpart"); break;
4963 case yy_part:mp_print(mp, "yypart"); break;
4964 case red_part:mp_print(mp, "redpart"); break;
4965 case green_part:mp_print(mp, "greenpart"); break;
4966 case blue_part:mp_print(mp, "bluepart"); break;
4967 case cyan_part:mp_print(mp, "cyanpart"); break;
4968 case magenta_part:mp_print(mp, "magentapart"); break;
4969 case yellow_part:mp_print(mp, "yellowpart"); break;
4970 case black_part:mp_print(mp, "blackpart"); break;
4971 case grey_part:mp_print(mp, "greypart"); break;
4972 case color_model_part:mp_print(mp, "colormodel"); break;
4973 case font_part:mp_print(mp, "fontpart"); break;
4974 case text_part:mp_print(mp, "textpart"); break;
4975 case path_part:mp_print(mp, "pathpart"); break;
4976 case pen_part:mp_print(mp, "penpart"); break;
4977 case dash_part:mp_print(mp, "dashpart"); break;
4978 case sqrt_op:mp_print(mp, "sqrt"); break;
4979 case m_exp_op:mp_print(mp, "mexp"); break;
4980 case m_log_op:mp_print(mp, "mlog"); break;
4981 case sin_d_op:mp_print(mp, "sind"); break;
4982 case cos_d_op:mp_print(mp, "cosd"); break;
4983 case floor_op:mp_print(mp, "floor"); break;
4984 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4985 case char_exists_op:mp_print(mp, "charexists"); break;
4986 case font_size:mp_print(mp, "fontsize"); break;
4987 case ll_corner_op:mp_print(mp, "llcorner"); break;
4988 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4989 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4990 case ur_corner_op:mp_print(mp, "urcorner"); break;
4991 case arc_length:mp_print(mp, "arclength"); break;
4992 case angle_op:mp_print(mp, "angle"); break;
4993 case cycle_op:mp_print(mp, "cycle"); break;
4994 case filled_op:mp_print(mp, "filled"); break;
4995 case stroked_op:mp_print(mp, "stroked"); break;
4996 case textual_op:mp_print(mp, "textual"); break;
4997 case clipped_op:mp_print(mp, "clipped"); break;
4998 case bounded_op:mp_print(mp, "bounded"); break;
4999 case plus:mp_print_char(mp, '+'); break;
5000 case minus:mp_print_char(mp, '-'); break;
5001 case times:mp_print_char(mp, '*'); break;
5002 case over:mp_print_char(mp, '/'); break;
5003 case pythag_add:mp_print(mp, "++"); break;
5004 case pythag_sub:mp_print(mp, "+-+"); break;
5005 case or_op:mp_print(mp, "or"); break;
5006 case and_op:mp_print(mp, "and"); break;
5007 case less_than:mp_print_char(mp, '<'); break;
5008 case less_or_equal:mp_print(mp, "<="); break;
5009 case greater_than:mp_print_char(mp, '>'); break;
5010 case greater_or_equal:mp_print(mp, ">="); break;
5011 case equal_to:mp_print_char(mp, '='); break;
5012 case unequal_to:mp_print(mp, "<>"); break;
5013 case concatenate:mp_print(mp, "&"); break;
5014 case rotated_by:mp_print(mp, "rotated"); break;
5015 case slanted_by:mp_print(mp, "slanted"); break;
5016 case scaled_by:mp_print(mp, "scaled"); break;
5017 case shifted_by:mp_print(mp, "shifted"); break;
5018 case transformed_by:mp_print(mp, "transformed"); break;
5019 case x_scaled:mp_print(mp, "xscaled"); break;
5020 case y_scaled:mp_print(mp, "yscaled"); break;
5021 case z_scaled:mp_print(mp, "zscaled"); break;
5022 case in_font:mp_print(mp, "infont"); break;
5023 case intersect:mp_print(mp, "intersectiontimes"); break;
5024 case substring_of:mp_print(mp, "substring"); break;
5025 case subpath_of:mp_print(mp, "subpath"); break;
5026 case direction_time_of:mp_print(mp, "directiontime"); break;
5027 case point_of:mp_print(mp, "point"); break;
5028 case precontrol_of:mp_print(mp, "precontrol"); break;
5029 case postcontrol_of:mp_print(mp, "postcontrol"); break;
5030 case pen_offset_of:mp_print(mp, "penoffset"); break;
5031 case arc_time_of:mp_print(mp, "arctime"); break;
5032 case mp_version:mp_print(mp, "mpversion"); break;
5033 case envelope_of:mp_print(mp, "envelope"); break;
5034 default: mp_print(mp, ".."); break;
5039 @ \MP\ also has a bunch of internal parameters that a user might want to
5040 fuss with. Every such parameter has an identifying code number, defined here.
5043 enum mp_given_internal {
5044 mp_tracing_titles=1, /* show titles online when they appear */
5045 mp_tracing_equations, /* show each variable when it becomes known */
5046 mp_tracing_capsules, /* show capsules too */
5047 mp_tracing_choices, /* show the control points chosen for paths */
5048 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
5049 mp_tracing_commands, /* show commands and operations before they are performed */
5050 mp_tracing_restores, /* show when a variable or internal is restored */
5051 mp_tracing_macros, /* show macros before they are expanded */
5052 mp_tracing_output, /* show digitized edges as they are output */
5053 mp_tracing_stats, /* show memory usage at end of job */
5054 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
5055 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
5056 mp_year, /* the current year (e.g., 1984) */
5057 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
5058 mp_day, /* the current day of the month */
5059 mp_time, /* the number of minutes past midnight when this job started */
5060 mp_char_code, /* the number of the next character to be output */
5061 mp_char_ext, /* the extension code of the next character to be output */
5062 mp_char_wd, /* the width of the next character to be output */
5063 mp_char_ht, /* the height of the next character to be output */
5064 mp_char_dp, /* the depth of the next character to be output */
5065 mp_char_ic, /* the italic correction of the next character to be output */
5066 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
5067 mp_pausing, /* positive to display lines on the terminal before they are read */
5068 mp_showstopping, /* positive to stop after each \&{show} command */
5069 mp_fontmaking, /* positive if font metric output is to be produced */
5070 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
5071 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
5072 mp_miterlimit, /* controls miter length as in \ps */
5073 mp_warning_check, /* controls error message when variable value is large */
5074 mp_boundary_char, /* the right boundary character for ligatures */
5075 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
5076 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
5077 mp_default_color_model, /* the default color model for unspecified items */
5078 mp_restore_clip_color,
5079 mp_procset, /* wether or not create PostScript command shortcuts */
5080 mp_gtroffmode /* whether the user specified |-troff| on the command line */
5085 @d max_given_internal mp_gtroffmode
5088 scaled *internal; /* the values of internal quantities */
5089 char **int_name; /* their names */
5090 int int_ptr; /* the maximum internal quantity defined so far */
5091 int max_internal; /* current maximum number of internal quantities */
5093 @ @<Option variables@>=
5096 @ @<Allocate or initialize ...@>=
5097 mp->max_internal=2*max_given_internal;
5098 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
5099 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
5100 mp->troff_mode=(opt->troff_mode>0 ? true : false);
5102 @ @<Exported function ...@>=
5103 int mp_troff_mode(MP mp);
5106 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5108 @ @<Set initial ...@>=
5109 for (k=0;k<= mp->max_internal; k++ ) {
5111 mp->int_name[k]=NULL;
5113 mp->int_ptr=max_given_internal;
5115 @ The symbolic names for internal quantities are put into \MP's hash table
5116 by using a routine called |primitive|, which will be defined later. Let us
5117 enter them now, so that we don't have to list all those names again
5120 @<Put each of \MP's primitives into the hash table@>=
5121 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5122 @:tracingtitles_}{\&{tracingtitles} primitive@>
5123 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5124 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5125 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5126 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5127 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5128 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5129 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5130 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5131 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5132 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5133 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5134 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5135 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5136 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5137 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5138 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5139 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5140 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5141 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5142 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5143 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5144 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5145 mp_primitive(mp, "year",internal_quantity,mp_year);
5146 @:mp_year_}{\&{year} primitive@>
5147 mp_primitive(mp, "month",internal_quantity,mp_month);
5148 @:mp_month_}{\&{month} primitive@>
5149 mp_primitive(mp, "day",internal_quantity,mp_day);
5150 @:mp_day_}{\&{day} primitive@>
5151 mp_primitive(mp, "time",internal_quantity,mp_time);
5152 @:time_}{\&{time} primitive@>
5153 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5154 @:mp_char_code_}{\&{charcode} primitive@>
5155 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5156 @:mp_char_ext_}{\&{charext} primitive@>
5157 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5158 @:mp_char_wd_}{\&{charwd} primitive@>
5159 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5160 @:mp_char_ht_}{\&{charht} primitive@>
5161 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5162 @:mp_char_dp_}{\&{chardp} primitive@>
5163 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5164 @:mp_char_ic_}{\&{charic} primitive@>
5165 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5166 @:mp_design_size_}{\&{designsize} primitive@>
5167 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5168 @:mp_pausing_}{\&{pausing} primitive@>
5169 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5170 @:mp_showstopping_}{\&{showstopping} primitive@>
5171 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5172 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5173 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5174 @:mp_linejoin_}{\&{linejoin} primitive@>
5175 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5176 @:mp_linecap_}{\&{linecap} primitive@>
5177 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5178 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5179 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5180 @:mp_warning_check_}{\&{warningcheck} primitive@>
5181 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5182 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5183 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5184 @:mp_prologues_}{\&{prologues} primitive@>
5185 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5186 @:mp_true_corners_}{\&{truecorners} primitive@>
5187 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5188 @:mp_procset_}{\&{mpprocset} primitive@>
5189 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5190 @:troffmode_}{\&{troffmode} primitive@>
5191 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5192 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5193 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5194 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5196 @ Colors can be specified in four color models. In the special
5197 case of |no_model|, MetaPost does not output any color operator to
5198 the postscript output.
5200 Note: these values are passed directly on to |with_option|. This only
5201 works because the other possible values passed to |with_option| are
5202 8 and 10 respectively (from |with_pen| and |with_picture|).
5204 There is a first state, that is only used for |gs_colormodel|. It flags
5205 the fact that there has not been any kind of color specification by
5206 the user so far in the game.
5209 enum mp_color_model {
5214 mp_uninitialized_model=9
5218 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5219 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5220 mp->internal[mp_restore_clip_color]=unity;
5222 @ Well, we do have to list the names one more time, for use in symbolic
5225 @<Initialize table...@>=
5226 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5227 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5228 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5229 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5230 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5231 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5232 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5233 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5234 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5235 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5236 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5237 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5238 mp->int_name[mp_year]=xstrdup("year");
5239 mp->int_name[mp_month]=xstrdup("month");
5240 mp->int_name[mp_day]=xstrdup("day");
5241 mp->int_name[mp_time]=xstrdup("time");
5242 mp->int_name[mp_char_code]=xstrdup("charcode");
5243 mp->int_name[mp_char_ext]=xstrdup("charext");
5244 mp->int_name[mp_char_wd]=xstrdup("charwd");
5245 mp->int_name[mp_char_ht]=xstrdup("charht");
5246 mp->int_name[mp_char_dp]=xstrdup("chardp");
5247 mp->int_name[mp_char_ic]=xstrdup("charic");
5248 mp->int_name[mp_design_size]=xstrdup("designsize");
5249 mp->int_name[mp_pausing]=xstrdup("pausing");
5250 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5251 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5252 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5253 mp->int_name[mp_linecap]=xstrdup("linecap");
5254 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5255 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5256 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5257 mp->int_name[mp_prologues]=xstrdup("prologues");
5258 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5259 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5260 mp->int_name[mp_procset]=xstrdup("mpprocset");
5261 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5262 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5264 @ The following procedure, which is called just before \MP\ initializes its
5265 input and output, establishes the initial values of the date and time.
5266 @^system dependencies@>
5268 Note that the values are |scaled| integers. Hence \MP\ can no longer
5269 be used after the year 32767.
5272 void mp_fix_date_and_time (MP mp) {
5273 time_t aclock = time ((time_t *) 0);
5274 struct tm *tmptr = localtime (&aclock);
5275 mp->internal[mp_time]=
5276 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5277 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5278 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5279 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5283 void mp_fix_date_and_time (MP mp) ;
5285 @ \MP\ is occasionally supposed to print diagnostic information that
5286 goes only into the transcript file, unless |mp_tracing_online| is positive.
5287 Now that we have defined |mp_tracing_online| we can define
5288 two routines that adjust the destination of print commands:
5291 void mp_begin_diagnostic (MP mp) ;
5292 void mp_end_diagnostic (MP mp,boolean blank_line);
5293 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
5295 @ @<Basic printing...@>=
5296 @<Declare a function called |true_line|@>
5297 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5298 mp->old_setting=mp->selector;
5299 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5301 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5305 void mp_end_diagnostic (MP mp,boolean blank_line) {
5306 /* restore proper conditions after tracing */
5307 mp_print_nl(mp, "");
5308 if ( blank_line ) mp_print_ln(mp);
5309 mp->selector=mp->old_setting;
5315 unsigned int old_setting;
5317 @ We will occasionally use |begin_diagnostic| in connection with line-number
5318 printing, as follows. (The parameter |s| is typically |"Path"| or
5319 |"Cycle spec"|, etc.)
5321 @<Basic printing...@>=
5322 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
5323 mp_begin_diagnostic(mp);
5324 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5325 mp_print(mp, " at line ");
5326 mp_print_int(mp, mp_true_line(mp));
5327 mp_print(mp, t); mp_print_char(mp, ':');
5330 @ The 256 |ASCII_code| characters are grouped into classes by means of
5331 the |char_class| table. Individual class numbers have no semantic
5332 or syntactic significance, except in a few instances defined here.
5333 There's also |max_class|, which can be used as a basis for additional
5334 class numbers in nonstandard extensions of \MP.
5336 @d digit_class 0 /* the class number of \.{0123456789} */
5337 @d period_class 1 /* the class number of `\..' */
5338 @d space_class 2 /* the class number of spaces and nonstandard characters */
5339 @d percent_class 3 /* the class number of `\.\%' */
5340 @d string_class 4 /* the class number of `\."' */
5341 @d right_paren_class 8 /* the class number of `\.)' */
5342 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5343 @d letter_class 9 /* letters and the underline character */
5344 @d left_bracket_class 17 /* `\.[' */
5345 @d right_bracket_class 18 /* `\.]' */
5346 @d invalid_class 20 /* bad character in the input */
5347 @d max_class 20 /* the largest class number */
5350 int char_class[256]; /* the class numbers */
5352 @ If changes are made to accommodate non-ASCII character sets, they should
5353 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5354 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5355 @^system dependencies@>
5357 @<Set initial ...@>=
5358 for (k='0';k<='9';k++)
5359 mp->char_class[k]=digit_class;
5360 mp->char_class['.']=period_class;
5361 mp->char_class[' ']=space_class;
5362 mp->char_class['%']=percent_class;
5363 mp->char_class['"']=string_class;
5364 mp->char_class[',']=5;
5365 mp->char_class[';']=6;
5366 mp->char_class['(']=7;
5367 mp->char_class[')']=right_paren_class;
5368 for (k='A';k<= 'Z';k++ )
5369 mp->char_class[k]=letter_class;
5370 for (k='a';k<='z';k++)
5371 mp->char_class[k]=letter_class;
5372 mp->char_class['_']=letter_class;
5373 mp->char_class['<']=10;
5374 mp->char_class['=']=10;
5375 mp->char_class['>']=10;
5376 mp->char_class[':']=10;
5377 mp->char_class['|']=10;
5378 mp->char_class['`']=11;
5379 mp->char_class['\'']=11;
5380 mp->char_class['+']=12;
5381 mp->char_class['-']=12;
5382 mp->char_class['/']=13;
5383 mp->char_class['*']=13;
5384 mp->char_class['\\']=13;
5385 mp->char_class['!']=14;
5386 mp->char_class['?']=14;
5387 mp->char_class['#']=15;
5388 mp->char_class['&']=15;
5389 mp->char_class['@@']=15;
5390 mp->char_class['$']=15;
5391 mp->char_class['^']=16;
5392 mp->char_class['~']=16;
5393 mp->char_class['[']=left_bracket_class;
5394 mp->char_class[']']=right_bracket_class;
5395 mp->char_class['{']=19;
5396 mp->char_class['}']=19;
5398 mp->char_class[k]=invalid_class;
5399 mp->char_class['\t']=space_class;
5400 mp->char_class['\f']=space_class;
5401 for (k=127;k<=255;k++)
5402 mp->char_class[k]=invalid_class;
5404 @* \[13] The hash table.
5405 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5406 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5407 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5408 table, it is never removed.
5410 The actual sequence of characters forming a symbolic token is
5411 stored in the |str_pool| array together with all the other strings. An
5412 auxiliary array |hash| consists of items with two halfword fields per
5413 word. The first of these, called |next(p)|, points to the next identifier
5414 belonging to the same coalesced list as the identifier corresponding to~|p|;
5415 and the other, called |text(p)|, points to the |str_start| entry for
5416 |p|'s identifier. If position~|p| of the hash table is empty, we have
5417 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5418 hash list, we have |next(p)=0|.
5420 An auxiliary pointer variable called |hash_used| is maintained in such a
5421 way that all locations |p>=hash_used| are nonempty. The global variable
5422 |st_count| tells how many symbolic tokens have been defined, if statistics
5425 The first 256 locations of |hash| are reserved for symbols of length one.
5427 There's a parallel array called |eqtb| that contains the current equivalent
5428 values of each symbolic token. The entries of this array consist of
5429 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5430 piece of information that qualifies the |eq_type|).
5432 @d next(A) mp->hash[(A)].lh /* link for coalesced lists */
5433 @d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5434 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5435 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5436 @d hash_base 257 /* hashing actually starts here */
5437 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5440 pointer hash_used; /* allocation pointer for |hash| */
5441 integer st_count; /* total number of known identifiers */
5443 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5444 since they are used in error recovery.
5446 @d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
5447 @d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5448 @d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5449 @d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5450 @d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5451 @d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5452 @d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5453 @d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5454 @d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5455 @d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5456 @d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5457 @d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5458 @d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5459 @d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5460 @d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5461 @d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5462 @d hash_end (hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5465 two_halves *hash; /* the hash table */
5466 two_halves *eqtb; /* the equivalents */
5468 @ @<Allocate or initialize ...@>=
5469 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5470 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5472 @ @<Dealloc variables@>=
5477 next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5478 for (k=2;k<=hash_end;k++) {
5479 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5482 @ @<Initialize table entries...@>=
5483 mp->hash_used=frozen_inaccessible; /* nothing is used */
5485 text(frozen_bad_vardef)=intern("a bad variable");
5486 text(frozen_etex)=intern("etex");
5487 text(frozen_mpx_break)=intern("mpxbreak");
5488 text(frozen_fi)=intern("fi");
5489 text(frozen_end_group)=intern("endgroup");
5490 text(frozen_end_def)=intern("enddef");
5491 text(frozen_end_for)=intern("endfor");
5492 text(frozen_semicolon)=intern(";");
5493 text(frozen_colon)=intern(":");
5494 text(frozen_slash)=intern("/");
5495 text(frozen_left_bracket)=intern("[");
5496 text(frozen_right_delimiter)=intern(")");
5497 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5498 eq_type(frozen_right_delimiter)=right_delimiter;
5500 @ @<Check the ``constant'' values...@>=
5501 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5503 @ Here is the subroutine that searches the hash table for an identifier
5504 that matches a given string of length~|l| appearing in |buffer[j..
5505 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5506 will always be found, and the corresponding hash table address
5510 pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5511 integer h; /* hash code */
5512 pointer p; /* index in |hash| array */
5513 pointer k; /* index in |buffer| array */
5515 @<Treat special case of length 1 and |break|@>;
5517 @<Compute the hash code |h|@>;
5518 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5520 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5523 @<Insert a new symbolic token after |p|, then
5524 make |p| point to it and |break|@>;
5531 @ @<Treat special case of length 1...@>=
5532 p=mp->buffer[j]+1; text(p)=p-1; return p;
5535 @ @<Insert a new symbolic...@>=
5540 mp_overflow(mp, "hash size",mp->hash_size);
5541 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5542 decr(mp->hash_used);
5543 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5544 next(p)=mp->hash_used;
5548 for (k=j;k<=j+l-1;k++) {
5549 append_char(mp->buffer[k]);
5551 text(p)=mp_make_string(mp);
5552 mp->str_ref[text(p)]=max_str_ref;
5558 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5559 should be a prime number. The theory of hashing tells us to expect fewer
5560 than two table probes, on the average, when the search is successful.
5561 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5562 @^Vitter, Jeffrey Scott@>
5564 @<Compute the hash code |h|@>=
5566 for (k=j+1;k<=j+l-1;k++){
5567 h=h+h+mp->buffer[k];
5568 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5571 @ @<Search |eqtb| for equivalents equal to |p|@>=
5572 for (q=1;q<=hash_end;q++) {
5573 if ( equiv(q)==p ) {
5574 mp_print_nl(mp, "EQUIV(");
5575 mp_print_int(mp, q);
5576 mp_print_char(mp, ')');
5580 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5581 table, together with their command code (which will be the |eq_type|)
5582 and an operand (which will be the |equiv|). The |primitive| procedure
5583 does this, in a way that no \MP\ user can. The global value |cur_sym|
5584 contains the new |eqtb| pointer after |primitive| has acted.
5587 void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
5588 pool_pointer k; /* index into |str_pool| */
5589 small_number j; /* index into |buffer| */
5590 small_number l; /* length of the string */
5593 k=mp->str_start[s]; l=str_stop(s)-k;
5594 /* we will move |s| into the (empty) |buffer| */
5595 for (j=0;j<=l-1;j++) {
5596 mp->buffer[j]=mp->str_pool[k+j];
5598 mp->cur_sym=mp_id_lookup(mp, 0,l);
5599 if ( s>=256 ) { /* we don't want to have the string twice */
5600 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5602 eq_type(mp->cur_sym)=c;
5603 equiv(mp->cur_sym)=o;
5607 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5608 by their |eq_type| alone. These primitives are loaded into the hash table
5611 @<Put each of \MP's primitives into the hash table@>=
5612 mp_primitive(mp, "..",path_join,0);
5613 @:.._}{\.{..} primitive@>
5614 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5615 @:[ }{\.{[} primitive@>
5616 mp_primitive(mp, "]",right_bracket,0);
5617 @:] }{\.{]} primitive@>
5618 mp_primitive(mp, "}",right_brace,0);
5619 @:]]}{\.{\char`\}} primitive@>
5620 mp_primitive(mp, "{",left_brace,0);
5621 @:][}{\.{\char`\{} primitive@>
5622 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5623 @:: }{\.{:} primitive@>
5624 mp_primitive(mp, "::",double_colon,0);
5625 @::: }{\.{::} primitive@>
5626 mp_primitive(mp, "||:",bchar_label,0);
5627 @:::: }{\.{\char'174\char'174:} primitive@>
5628 mp_primitive(mp, ":=",assignment,0);
5629 @::=_}{\.{:=} primitive@>
5630 mp_primitive(mp, ",",comma,0);
5631 @:, }{\., primitive@>
5632 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5633 @:; }{\.; primitive@>
5634 mp_primitive(mp, "\\",relax,0);
5635 @:]]\\}{\.{\char`\\} primitive@>
5637 mp_primitive(mp, "addto",add_to_command,0);
5638 @:add_to_}{\&{addto} primitive@>
5639 mp_primitive(mp, "atleast",at_least,0);
5640 @:at_least_}{\&{atleast} primitive@>
5641 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5642 @:begin_group_}{\&{begingroup} primitive@>
5643 mp_primitive(mp, "controls",controls,0);
5644 @:controls_}{\&{controls} primitive@>
5645 mp_primitive(mp, "curl",curl_command,0);
5646 @:curl_}{\&{curl} primitive@>
5647 mp_primitive(mp, "delimiters",delimiters,0);
5648 @:delimiters_}{\&{delimiters} primitive@>
5649 mp_primitive(mp, "endgroup",end_group,0);
5650 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5651 @:endgroup_}{\&{endgroup} primitive@>
5652 mp_primitive(mp, "everyjob",every_job_command,0);
5653 @:every_job_}{\&{everyjob} primitive@>
5654 mp_primitive(mp, "exitif",exit_test,0);
5655 @:exit_if_}{\&{exitif} primitive@>
5656 mp_primitive(mp, "expandafter",expand_after,0);
5657 @:expand_after_}{\&{expandafter} primitive@>
5658 mp_primitive(mp, "interim",interim_command,0);
5659 @:interim_}{\&{interim} primitive@>
5660 mp_primitive(mp, "let",let_command,0);
5661 @:let_}{\&{let} primitive@>
5662 mp_primitive(mp, "newinternal",new_internal,0);
5663 @:new_internal_}{\&{newinternal} primitive@>
5664 mp_primitive(mp, "of",of_token,0);
5665 @:of_}{\&{of} primitive@>
5666 mp_primitive(mp, "randomseed",mp_random_seed,0);
5667 @:mp_random_seed_}{\&{randomseed} primitive@>
5668 mp_primitive(mp, "save",save_command,0);
5669 @:save_}{\&{save} primitive@>
5670 mp_primitive(mp, "scantokens",scan_tokens,0);
5671 @:scan_tokens_}{\&{scantokens} primitive@>
5672 mp_primitive(mp, "shipout",ship_out_command,0);
5673 @:ship_out_}{\&{shipout} primitive@>
5674 mp_primitive(mp, "skipto",skip_to,0);
5675 @:skip_to_}{\&{skipto} primitive@>
5676 mp_primitive(mp, "special",special_command,0);
5677 @:special}{\&{special} primitive@>
5678 mp_primitive(mp, "fontmapfile",special_command,1);
5679 @:fontmapfile}{\&{fontmapfile} primitive@>
5680 mp_primitive(mp, "fontmapline",special_command,2);
5681 @:fontmapline}{\&{fontmapline} primitive@>
5682 mp_primitive(mp, "step",step_token,0);
5683 @:step_}{\&{step} primitive@>
5684 mp_primitive(mp, "str",str_op,0);
5685 @:str_}{\&{str} primitive@>
5686 mp_primitive(mp, "tension",tension,0);
5687 @:tension_}{\&{tension} primitive@>
5688 mp_primitive(mp, "to",to_token,0);
5689 @:to_}{\&{to} primitive@>
5690 mp_primitive(mp, "until",until_token,0);
5691 @:until_}{\&{until} primitive@>
5692 mp_primitive(mp, "within",within_token,0);
5693 @:within_}{\&{within} primitive@>
5694 mp_primitive(mp, "write",write_command,0);
5695 @:write_}{\&{write} primitive@>
5697 @ Each primitive has a corresponding inverse, so that it is possible to
5698 display the cryptic numeric contents of |eqtb| in symbolic form.
5699 Every call of |primitive| in this program is therefore accompanied by some
5700 straightforward code that forms part of the |print_cmd_mod| routine
5703 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5704 case add_to_command:mp_print(mp, "addto"); break;
5705 case assignment:mp_print(mp, ":="); break;
5706 case at_least:mp_print(mp, "atleast"); break;
5707 case bchar_label:mp_print(mp, "||:"); break;
5708 case begin_group:mp_print(mp, "begingroup"); break;
5709 case colon:mp_print(mp, ":"); break;
5710 case comma:mp_print(mp, ","); break;
5711 case controls:mp_print(mp, "controls"); break;
5712 case curl_command:mp_print(mp, "curl"); break;
5713 case delimiters:mp_print(mp, "delimiters"); break;
5714 case double_colon:mp_print(mp, "::"); break;
5715 case end_group:mp_print(mp, "endgroup"); break;
5716 case every_job_command:mp_print(mp, "everyjob"); break;
5717 case exit_test:mp_print(mp, "exitif"); break;
5718 case expand_after:mp_print(mp, "expandafter"); break;
5719 case interim_command:mp_print(mp, "interim"); break;
5720 case left_brace:mp_print(mp, "{"); break;
5721 case left_bracket:mp_print(mp, "["); break;
5722 case let_command:mp_print(mp, "let"); break;
5723 case new_internal:mp_print(mp, "newinternal"); break;
5724 case of_token:mp_print(mp, "of"); break;
5725 case path_join:mp_print(mp, ".."); break;
5726 case mp_random_seed:mp_print(mp, "randomseed"); break;
5727 case relax:mp_print_char(mp, '\\'); break;
5728 case right_brace:mp_print(mp, "}"); break;
5729 case right_bracket:mp_print(mp, "]"); break;
5730 case save_command:mp_print(mp, "save"); break;
5731 case scan_tokens:mp_print(mp, "scantokens"); break;
5732 case semicolon:mp_print(mp, ";"); break;
5733 case ship_out_command:mp_print(mp, "shipout"); break;
5734 case skip_to:mp_print(mp, "skipto"); break;
5735 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5736 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5737 mp_print(mp, "special"); break;
5738 case step_token:mp_print(mp, "step"); break;
5739 case str_op:mp_print(mp, "str"); break;
5740 case tension:mp_print(mp, "tension"); break;
5741 case to_token:mp_print(mp, "to"); break;
5742 case until_token:mp_print(mp, "until"); break;
5743 case within_token:mp_print(mp, "within"); break;
5744 case write_command:mp_print(mp, "write"); break;
5746 @ We will deal with the other primitives later, at some point in the program
5747 where their |eq_type| and |equiv| values are more meaningful. For example,
5748 the primitives for macro definitions will be loaded when we consider the
5749 routines that define macros.
5750 It is easy to find where each particular
5751 primitive was treated by looking in the index at the end; for example, the
5752 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5754 @* \[14] Token lists.
5755 A \MP\ token is either symbolic or numeric or a string, or it denotes
5756 a macro parameter or capsule; so there are five corresponding ways to encode it
5758 internally: (1)~A symbolic token whose hash code is~|p|
5759 is represented by the number |p|, in the |info| field of a single-word
5760 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5761 represented in a two-word node of~|mem|; the |type| field is |known|,
5762 the |name_type| field is |token|, and the |value| field holds~|v|.
5763 The fact that this token appears in a two-word node rather than a
5764 one-word node is, of course, clear from the node address.
5765 (3)~A string token is also represented in a two-word node; the |type|
5766 field is |mp_string_type|, the |name_type| field is |token|, and the
5767 |value| field holds the corresponding |str_number|. (4)~Capsules have
5768 |name_type=capsule|, and their |type| and |value| fields represent
5769 arbitrary values (in ways to be explained later). (5)~Macro parameters
5770 are like symbolic tokens in that they appear in |info| fields of
5771 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5772 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5773 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5774 Actual values of these parameters are kept in a separate stack, as we will
5775 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5776 of course, chosen so that there will be no confusion between symbolic
5777 tokens and parameters of various types.
5780 the `\\{type}' field of a node has nothing to do with ``type'' in a
5781 printer's sense. It's curious that the same word is used in such different ways.
5783 @d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5784 @d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5785 @d token_node_size 2 /* the number of words in a large token node */
5786 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5787 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5788 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5789 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5790 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5792 @<Check the ``constant''...@>=
5793 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5795 @ We have set aside a two word node beginning at |null| so that we can have
5796 |value(null)=0|. We will make use of this coincidence later.
5798 @<Initialize table entries...@>=
5799 link(null)=null; value(null)=0;
5801 @ A numeric token is created by the following trivial routine.
5804 pointer mp_new_num_tok (MP mp,scaled v) {
5805 pointer p; /* the new node */
5806 p=mp_get_node(mp, token_node_size); value(p)=v;
5807 type(p)=mp_known; name_type(p)=mp_token;
5811 @ A token list is a singly linked list of nodes in |mem|, where
5812 each node contains a token and a link. Here's a subroutine that gets rid
5813 of a token list when it is no longer needed.
5815 @c void mp_flush_token_list (MP mp,pointer p) {
5816 pointer q; /* the node being recycled */
5819 if ( q>=mp->hi_mem_min ) {
5823 case mp_vacuous: case mp_boolean_type: case mp_known:
5825 case mp_string_type:
5826 delete_str_ref(value(q));
5828 case unknown_types: case mp_pen_type: case mp_path_type:
5829 case mp_picture_type: case mp_pair_type: case mp_color_type:
5830 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5831 case mp_proto_dependent: case mp_independent:
5832 mp_recycle_value(mp,q);
5834 default: mp_confusion(mp, "token");
5835 @:this can't happen token}{\quad token@>
5837 mp_free_node(mp, q,token_node_size);
5842 @ The procedure |show_token_list|, which prints a symbolic form of
5843 the token list that starts at a given node |p|, illustrates these
5844 conventions. The token list being displayed should not begin with a reference
5845 count. However, the procedure is intended to be fairly robust, so that if the
5846 memory links are awry or if |p| is not really a pointer to a token list,
5847 almost nothing catastrophic can happen.
5849 An additional parameter |q| is also given; this parameter is either null
5850 or it points to a node in the token list where a certain magic computation
5851 takes place that will be explained later. (Basically, |q| is non-null when
5852 we are printing the two-line context information at the time of an error
5853 message; |q| marks the place corresponding to where the second line
5856 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5857 of printing exceeds a given limit~|l|; the length of printing upon entry is
5858 assumed to be a given amount called |null_tally|. (Note that
5859 |show_token_list| sometimes uses itself recursively to print
5860 variable names within a capsule.)
5863 Unusual entries are printed in the form of all-caps tokens
5864 preceded by a space, e.g., `\.{\char`\ BAD}'.
5866 @<Declare the procedure called |show_token_list|@>=
5867 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5868 integer null_tally) ;
5871 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5872 integer null_tally) {
5873 small_number class,c; /* the |char_class| of previous and new tokens */
5874 integer r,v; /* temporary registers */
5875 class=percent_class;
5876 mp->tally=null_tally;
5877 while ( (p!=null) && (mp->tally<l) ) {
5879 @<Do magic computation@>;
5880 @<Display token |p| and set |c| to its class;
5881 but |return| if there are problems@>;
5885 mp_print(mp, " ETC.");
5890 @ @<Display token |p| and set |c| to its class...@>=
5891 c=letter_class; /* the default */
5892 if ( (p<0)||(p>mp->mem_end) ) {
5893 mp_print(mp, " CLOBBERED"); return;
5896 if ( p<mp->hi_mem_min ) {
5897 @<Display two-word token@>;
5900 if ( r>=expr_base ) {
5901 @<Display a parameter token@>;
5905 @<Display a collective subscript@>
5907 mp_print(mp, " IMPOSSIBLE");
5912 if ( (r<0)||(r>mp->max_str_ptr) ) {
5913 mp_print(mp, " NONEXISTENT");
5916 @<Print string |r| as a symbolic token
5917 and set |c| to its class@>;
5923 @ @<Display two-word token@>=
5924 if ( name_type(p)==mp_token ) {
5925 if ( type(p)==mp_known ) {
5926 @<Display a numeric token@>;
5927 } else if ( type(p)!=mp_string_type ) {
5928 mp_print(mp, " BAD");
5931 mp_print_char(mp, '"'); mp_print_str(mp, value(p)); mp_print_char(mp, '"');
5934 } else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
5935 mp_print(mp, " BAD");
5937 mp_print_capsule(mp,p); c=right_paren_class;
5940 @ @<Display a numeric token@>=
5941 if ( class==digit_class )
5942 mp_print_char(mp, ' ');
5945 if ( class==left_bracket_class )
5946 mp_print_char(mp, ' ');
5947 mp_print_char(mp, '['); mp_print_scaled(mp, v); mp_print_char(mp, ']');
5948 c=right_bracket_class;
5950 mp_print_scaled(mp, v); c=digit_class;
5954 @ Strictly speaking, a genuine token will never have |info(p)=0|.
5955 But we will see later (in the |print_variable_name| routine) that
5956 it is convenient to let |info(p)=0| stand for `\.{[]}'.
5958 @<Display a collective subscript@>=
5960 if ( class==left_bracket_class )
5961 mp_print_char(mp, ' ');
5962 mp_print(mp, "[]"); c=right_bracket_class;
5965 @ @<Display a parameter token@>=
5967 if ( r<suffix_base ) {
5968 mp_print(mp, "(EXPR"); r=r-(expr_base);
5970 } else if ( r<text_base ) {
5971 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5974 mp_print(mp, "(TEXT"); r=r-(text_base);
5977 mp_print_int(mp, r); mp_print_char(mp, ')'); c=right_paren_class;
5981 @ @<Print string |r| as a symbolic token...@>=
5983 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5986 case letter_class:mp_print_char(mp, '.'); break;
5987 case isolated_classes: break;
5988 default: mp_print_char(mp, ' '); break;
5991 mp_print_str(mp, r);
5995 void mp_print_capsule (MP mp, pointer p);
5997 @ @<Declare miscellaneous procedures that were declared |forward|@>=
5998 void mp_print_capsule (MP mp, pointer p) {
5999 mp_print_char(mp, '('); mp_print_exp(mp,p,0); mp_print_char(mp, ')');
6002 @ Macro definitions are kept in \MP's memory in the form of token lists
6003 that have a few extra one-word nodes at the beginning.
6005 The first node contains a reference count that is used to tell when the
6006 list is no longer needed. To emphasize the fact that a reference count is
6007 present, we shall refer to the |info| field of this special node as the
6009 @^reference counts@>
6011 The next node or nodes after the reference count serve to describe the
6012 formal parameters. They consist of zero or more parameter tokens followed
6013 by a code for the type of macro.
6016 /* reference count preceding a macro definition or picture header */
6017 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
6018 @d general_macro 0 /* preface to a macro defined with a parameter list */
6019 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
6020 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
6021 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
6022 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
6023 @d of_macro 5 /* preface to a macro with
6024 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
6025 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
6026 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
6029 void mp_delete_mac_ref (MP mp,pointer p) {
6030 /* |p| points to the reference count of a macro list that is
6031 losing one reference */
6032 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
6033 else decr(ref_count(p));
6036 @ The following subroutine displays a macro, given a pointer to its
6040 @<Declare the procedure called |print_cmd_mod|@>
6041 void mp_show_macro (MP mp, pointer p, integer q, integer l) {
6042 pointer r; /* temporary storage */
6043 p=link(p); /* bypass the reference count */
6044 while ( info(p)>text_macro ){
6045 r=link(p); link(p)=null;
6046 mp_show_token_list(mp, p,null,l,0); link(p)=r; p=r;
6047 if ( l>0 ) l=l-mp->tally; else return;
6048 } /* control printing of `\.{ETC.}' */
6052 case general_macro:mp_print(mp, "->"); break;
6054 case primary_macro: case secondary_macro: case tertiary_macro:
6055 mp_print_char(mp, '<');
6056 mp_print_cmd_mod(mp, param_type,info(p));
6057 mp_print(mp, ">->");
6059 case expr_macro:mp_print(mp, "<expr>->"); break;
6060 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
6061 case suffix_macro:mp_print(mp, "<suffix>->"); break;
6062 case text_macro:mp_print(mp, "<text>->"); break;
6063 } /* there are no other cases */
6064 mp_show_token_list(mp, link(p),q,l-mp->tally,0);
6067 @* \[15] Data structures for variables.
6068 The variables of \MP\ programs can be simple, like `\.x', or they can
6069 combine the structural properties of arrays and records, like `\.{x20a.b}'.
6070 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
6071 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
6072 things are represented inside of the computer.
6074 Each variable value occupies two consecutive words, either in a two-word
6075 node called a value node, or as a two-word subfield of a larger node. One
6076 of those two words is called the |value| field; it is an integer,
6077 containing either a |scaled| numeric value or the representation of some
6078 other type of quantity. (It might also be subdivided into halfwords, in
6079 which case it is referred to by other names instead of |value|.) The other
6080 word is broken into subfields called |type|, |name_type|, and |link|. The
6081 |type| field is a quarterword that specifies the variable's type, and
6082 |name_type| is a quarterword from which \MP\ can reconstruct the
6083 variable's name (sometimes by using the |link| field as well). Thus, only
6084 1.25 words are actually devoted to the value itself; the other
6085 three-quarters of a word are overhead, but they aren't wasted because they
6086 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6088 In this section we shall be concerned only with the structural aspects of
6089 variables, not their values. Later parts of the program will change the
6090 |type| and |value| fields, but we shall treat those fields as black boxes
6091 whose contents should not be touched.
6093 However, if the |type| field is |mp_structured|, there is no |value| field,
6094 and the second word is broken into two pointer fields called |attr_head|
6095 and |subscr_head|. Those fields point to additional nodes that
6096 contain structural information, as we shall see.
6098 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6099 @d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
6100 @d subscr_head(A) link(subscr_head_loc((A))) /* pointer to subscript info */
6101 @d value_node_size 2 /* the number of words in a value node */
6103 @ An attribute node is three words long. Two of these words contain |type|
6104 and |value| fields as described above, and the third word contains
6105 additional information: There is an |attr_loc| field, which contains the
6106 hash address of the token that names this attribute; and there's also a
6107 |parent| field, which points to the value node of |mp_structured| type at the
6108 next higher level (i.e., at the level to which this attribute is
6109 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6110 |link| field points to the next attribute with the same parent; these are
6111 arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
6112 final attribute node links to the constant |end_attr|, whose |attr_loc|
6113 field is greater than any legal hash address. The |attr_head| in the
6114 parent points to a node whose |name_type| is |mp_structured_root|; this
6115 node represents the null attribute, i.e., the variable that is relevant
6116 when no attributes are attached to the parent. The |attr_head| node
6117 has the fields of either
6118 a value node, a subscript node, or an attribute node, depending on what
6119 the parent would be if it were not structured; but the subscript and
6120 attribute fields are ignored, so it effectively contains only the data of
6121 a value node. The |link| field in this special node points to an attribute
6122 node whose |attr_loc| field is zero; the latter node represents a collective
6123 subscript `\.{[]}' attached to the parent, and its |link| field points to
6124 the first non-special attribute node (or to |end_attr| if there are none).
6126 A subscript node likewise occupies three words, with |type| and |value| fields
6127 plus extra information; its |name_type| is |subscr|. In this case the
6128 third word is called the |subscript| field, which is a |scaled| integer.
6129 The |link| field points to the subscript node with the next larger
6130 subscript, if any; otherwise the |link| points to the attribute node
6131 for collective subscripts at this level. We have seen that the latter node
6132 contains an upward pointer, so that the parent can be deduced.
6134 The |name_type| in a parent-less value node is |root|, and the |link|
6135 is the hash address of the token that names this value.
6137 In other words, variables have a hierarchical structure that includes
6138 enough threads running around so that the program is able to move easily
6139 between siblings, parents, and children. An example should be helpful:
6140 (The reader is advised to draw a picture while reading the following
6141 description, since that will help to firm up the ideas.)
6142 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6143 and `\.{x20b}' have been mentioned in a user's program, where
6144 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6145 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6146 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6147 node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=mp_structured|,
6148 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6149 node and |r| to a subscript node. (Are you still following this? Use
6150 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6151 |type(q)| and |value(q)|; furthermore
6152 |name_type(q)=mp_structured_root| and |link(q)=q1|, where |q1| points
6153 to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
6154 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6155 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6156 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
6157 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
6158 with no further attributes), |name_type(qq)=structured_root|,
6159 |attr_loc(qq)=0|, |parent(qq)=p|, and
6160 |link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6161 an attribute node representing `\.{x[][]}', which has never yet
6162 occurred; its |type| field is |undefined|, and its |value| field is
6163 undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6164 |parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
6165 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6166 |parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
6167 (Maybe colored lines will help untangle your picture.)
6168 Node |r| is a subscript node with |type| and |value|
6169 representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
6170 and |link(r)=r1| is another subscript node. To complete the picture,
6171 see if you can guess what |link(r1)| is; give up? It's~|q1|.
6172 Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
6173 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6174 and we finish things off with three more nodes
6175 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6176 with a larger sheet of paper.) The value of variable \.{x20b}
6177 appears in node~|qqq2|, as you can well imagine.
6179 If the example in the previous paragraph doesn't make things crystal
6180 clear, a glance at some of the simpler subroutines below will reveal how
6181 things work out in practice.
6183 The only really unusual thing about these conventions is the use of
6184 collective subscript attributes. The idea is to avoid repeating a lot of
6185 type information when many elements of an array are identical macros
6186 (for which distinct values need not be stored) or when they don't have
6187 all of the possible attributes. Branches of the structure below collective
6188 subscript attributes do not carry actual values except for macro identifiers;
6189 branches of the structure below subscript nodes do not carry significant
6190 information in their collective subscript attributes.
6192 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6193 @d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
6194 @d parent(A) link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6195 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6196 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6197 @d attr_node_size 3 /* the number of words in an attribute node */
6198 @d subscr_node_size 3 /* the number of words in a subscript node */
6199 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6201 @<Initialize table...@>=
6202 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6204 @ Variables of type \&{pair} will have values that point to four-word
6205 nodes containing two numeric values. The first of these values has
6206 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6207 the |link| in the first points back to the node whose |value| points
6208 to this four-word node.
6210 Variables of type \&{transform} are similar, but in this case their
6211 |value| points to a 12-word node containing six values, identified by
6212 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6213 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6214 Finally, variables of type \&{color} have 3~values in 6~words
6215 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6217 When an entire structured variable is saved, the |root| indication
6218 is temporarily replaced by |saved_root|.
6220 Some variables have no name; they just are used for temporary storage
6221 while expressions are being evaluated. We call them {\sl capsules}.
6223 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6224 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6225 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6226 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6227 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6228 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6229 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6230 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6231 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6232 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6233 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6234 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6235 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6236 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6238 @d pair_node_size 4 /* the number of words in a pair node */
6239 @d transform_node_size 12 /* the number of words in a transform node */
6240 @d color_node_size 6 /* the number of words in a color node */
6241 @d cmykcolor_node_size 8 /* the number of words in a color node */
6244 small_number big_node_size[mp_pair_type+1];
6245 small_number sector0[mp_pair_type+1];
6246 small_number sector_offset[mp_black_part_sector+1];
6248 @ The |sector0| array gives for each big node type, |name_type| values
6249 for its first subfield; the |sector_offset| array gives for each
6250 |name_type| value, the offset from the first subfield in words;
6251 and the |big_node_size| array gives the size in words for each type of
6255 mp->big_node_size[mp_transform_type]=transform_node_size;
6256 mp->big_node_size[mp_pair_type]=pair_node_size;
6257 mp->big_node_size[mp_color_type]=color_node_size;
6258 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6259 mp->sector0[mp_transform_type]=mp_x_part_sector;
6260 mp->sector0[mp_pair_type]=mp_x_part_sector;
6261 mp->sector0[mp_color_type]=mp_red_part_sector;
6262 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6263 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6264 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6266 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6267 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6269 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6270 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6273 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6274 procedure call |init_big_node(p)| will allocate a pair or transform node
6275 for~|p|. The individual parts of such nodes are initially of type
6279 void mp_init_big_node (MP mp,pointer p) {
6280 pointer q; /* the new node */
6281 small_number s; /* its size */
6282 s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
6285 @<Make variable |q+s| newly independent@>;
6286 name_type(q+s)=halfp(s)+mp->sector0[type(p)];
6289 link(q)=p; value(p)=q;
6292 @ The |id_transform| function creates a capsule for the
6293 identity transformation.
6296 pointer mp_id_transform (MP mp) {
6297 pointer p,q,r; /* list manipulation registers */
6298 p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
6299 name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6300 r=q+transform_node_size;
6303 type(r)=mp_known; value(r)=0;
6305 value(xx_part_loc(q))=unity;
6306 value(yy_part_loc(q))=unity;
6310 @ Tokens are of type |tag_token| when they first appear, but they point
6311 to |null| until they are first used as the root of a variable.
6312 The following subroutine establishes the root node on such grand occasions.
6315 void mp_new_root (MP mp,pointer x) {
6316 pointer p; /* the new node */
6317 p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
6318 link(p)=x; equiv(x)=p;
6321 @ These conventions for variable representation are illustrated by the
6322 |print_variable_name| routine, which displays the full name of a
6323 variable given only a pointer to its two-word value packet.
6326 void mp_print_variable_name (MP mp, pointer p);
6329 void mp_print_variable_name (MP mp, pointer p) {
6330 pointer q; /* a token list that will name the variable's suffix */
6331 pointer r; /* temporary for token list creation */
6332 while ( name_type(p)>=mp_x_part_sector ) {
6333 @<Preface the output with a part specifier; |return| in the
6334 case of a capsule@>;
6337 while ( name_type(p)>mp_saved_root ) {
6338 @<Ascend one level, pushing a token onto list |q|
6339 and replacing |p| by its parent@>;
6341 r=mp_get_avail(mp); info(r)=link(p); link(r)=q;
6342 if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6344 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6345 mp_flush_token_list(mp, r);
6348 @ @<Ascend one level, pushing a token onto list |q|...@>=
6350 if ( name_type(p)==mp_subscr ) {
6351 r=mp_new_num_tok(mp, subscript(p));
6354 } while (name_type(p)!=mp_attr);
6355 } else if ( name_type(p)==mp_structured_root ) {
6356 p=link(p); goto FOUND;
6358 if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6359 @:this can't happen var}{\quad var@>
6360 r=mp_get_avail(mp); info(r)=attr_loc(p);
6367 @ @<Preface the output with a part specifier...@>=
6368 { switch (name_type(p)) {
6369 case mp_x_part_sector: mp_print_char(mp, 'x'); break;
6370 case mp_y_part_sector: mp_print_char(mp, 'y'); break;
6371 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6372 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6373 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6374 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6375 case mp_red_part_sector: mp_print(mp, "red"); break;
6376 case mp_green_part_sector: mp_print(mp, "green"); break;
6377 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6378 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6379 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6380 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6381 case mp_black_part_sector: mp_print(mp, "black"); break;
6382 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6384 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6387 } /* there are no other cases */
6388 mp_print(mp, "part ");
6389 p=link(p-mp->sector_offset[name_type(p)]);
6392 @ The |interesting| function returns |true| if a given variable is not
6393 in a capsule, or if the user wants to trace capsules.
6396 boolean mp_interesting (MP mp,pointer p) {
6397 small_number t; /* a |name_type| */
6398 if ( mp->internal[mp_tracing_capsules]>0 ) {
6402 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6403 t=name_type(link(p-mp->sector_offset[t]));
6404 return (t!=mp_capsule);
6408 @ Now here is a subroutine that converts an unstructured type into an
6409 equivalent structured type, by inserting a |mp_structured| node that is
6410 capable of growing. This operation is done only when |name_type(p)=root|,
6411 |subscr|, or |attr|.
6413 The procedure returns a pointer to the new node that has taken node~|p|'s
6414 place in the structure. Node~|p| itself does not move, nor are its
6415 |value| or |type| fields changed in any way.
6418 pointer mp_new_structure (MP mp,pointer p) {
6419 pointer q,r=0; /* list manipulation registers */
6420 switch (name_type(p)) {
6422 q=link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6425 @<Link a new subscript node |r| in place of node |p|@>;
6428 @<Link a new attribute node |r| in place of node |p|@>;
6431 mp_confusion(mp, "struct");
6432 @:this can't happen struct}{\quad struct@>
6435 link(r)=link(p); type(r)=mp_structured; name_type(r)=name_type(p);
6436 attr_head(r)=p; name_type(p)=mp_structured_root;
6437 q=mp_get_node(mp, attr_node_size); link(p)=q; subscr_head(r)=q;
6438 parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; link(q)=end_attr;
6439 attr_loc(q)=collective_subscript;
6443 @ @<Link a new subscript node |r| in place of node |p|@>=
6448 } while (name_type(q)!=mp_attr);
6449 q=parent(q); r=subscr_head_loc(q); /* |link(r)=subscr_head(q)| */
6453 r=mp_get_node(mp, subscr_node_size);
6454 link(q)=r; subscript(r)=subscript(p);
6457 @ If the attribute is |collective_subscript|, there are two pointers to
6458 node~|p|, so we must change both of them.
6460 @<Link a new attribute node |r| in place of node |p|@>=
6462 q=parent(p); r=attr_head(q);
6466 r=mp_get_node(mp, attr_node_size); link(q)=r;
6467 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6468 if ( attr_loc(p)==collective_subscript ) {
6469 q=subscr_head_loc(parent(p));
6470 while ( link(q)!=p ) q=link(q);
6475 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6476 list of suffixes; it returns a pointer to the corresponding two-word
6477 value. For example, if |t| points to token \.x followed by a numeric
6478 token containing the value~7, |find_variable| finds where the value of
6479 \.{x7} is stored in memory. This may seem a simple task, and it
6480 usually is, except when \.{x7} has never been referenced before.
6481 Indeed, \.x may never have even been subscripted before; complexities
6482 arise with respect to updating the collective subscript information.
6484 If a macro type is detected anywhere along path~|t|, or if the first
6485 item on |t| isn't a |tag_token|, the value |null| is returned.
6486 Otherwise |p| will be a non-null pointer to a node such that
6487 |undefined<type(p)<mp_structured|.
6489 @d abort_find { return null; }
6492 pointer mp_find_variable (MP mp,pointer t) {
6493 pointer p,q,r,s; /* nodes in the ``value'' line */
6494 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6495 integer n; /* subscript or attribute */
6496 memory_word save_word; /* temporary storage for a word of |mem| */
6498 p=info(t); t=link(t);
6499 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6500 if ( equiv(p)==null ) mp_new_root(mp, p);
6503 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6504 if ( t<mp->hi_mem_min ) {
6505 @<Descend one level for the subscript |value(t)|@>
6507 @<Descend one level for the attribute |info(t)|@>;
6511 if ( type(pp)>=mp_structured ) {
6512 if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6514 if ( type(p)==mp_structured ) p=attr_head(p);
6515 if ( type(p)==undefined ) {
6516 if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
6517 type(p)=type(pp); value(p)=null;
6522 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6523 |pp|~stays in the collective line while |p|~goes through actual subscript
6526 @<Make sure that both nodes |p| and |pp|...@>=
6527 if ( type(pp)!=mp_structured ) {
6528 if ( type(pp)>mp_structured ) abort_find;
6529 ss=mp_new_structure(mp, pp);
6532 }; /* now |type(pp)=mp_structured| */
6533 if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6534 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6536 @ We want this part of the program to be reasonably fast, in case there are
6538 lots of subscripts at the same level of the data structure. Therefore
6539 we store an ``infinite'' value in the word that appears at the end of the
6540 subscript list, even though that word isn't part of a subscript node.
6542 @<Descend one level for the subscript |value(t)|@>=
6545 pp=link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6546 q=link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6547 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |link(s)=subscr_head(p)| */
6550 } while (n>subscript(s));
6551 if ( n==subscript(s) ) {
6554 p=mp_get_node(mp, subscr_node_size); link(r)=p; link(p)=s;
6555 subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
6557 mp->mem[subscript_loc(q)]=save_word;
6560 @ @<Descend one level for the attribute |info(t)|@>=
6566 } while (n>attr_loc(ss));
6567 if ( n<attr_loc(ss) ) {
6568 qq=mp_get_node(mp, attr_node_size); link(rr)=qq; link(qq)=ss;
6569 attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
6570 parent(qq)=pp; ss=qq;
6575 pp=ss; s=attr_head(p);
6578 } while (n>attr_loc(s));
6579 if ( n==attr_loc(s) ) {
6582 q=mp_get_node(mp, attr_node_size); link(r)=q; link(q)=s;
6583 attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
6589 @ Variables lose their former values when they appear in a type declaration,
6590 or when they are defined to be macros or \&{let} equal to something else.
6591 A subroutine will be defined later that recycles the storage associated
6592 with any particular |type| or |value|; our goal now is to study a higher
6593 level process called |flush_variable|, which selectively frees parts of a
6596 This routine has some complexity because of examples such as
6597 `\hbox{\tt numeric x[]a[]b}'
6598 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6599 `\hbox{\tt vardef x[]a[]=...}'
6600 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6601 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6602 to handle such examples is to use recursion; so that's what we~do.
6605 Parameter |p| points to the root information of the variable;
6606 parameter |t| points to a list of one-word nodes that represent
6607 suffixes, with |info=collective_subscript| for subscripts.
6610 @<Declare subroutines for printing expressions@>
6611 @<Declare basic dependency-list subroutines@>
6612 @<Declare the recycling subroutines@>
6613 void mp_flush_cur_exp (MP mp,scaled v) ;
6614 @<Declare the procedure called |flush_below_variable|@>
6617 void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6618 pointer q,r; /* list manipulation */
6619 halfword n; /* attribute to match */
6621 if ( type(p)!=mp_structured ) return;
6622 n=info(t); t=link(t);
6623 if ( n==collective_subscript ) {
6624 r=subscr_head_loc(p); q=link(r); /* |q=subscr_head(p)| */
6625 while ( name_type(q)==mp_subscr ){
6626 mp_flush_variable(mp, q,t,discard_suffixes);
6628 if ( type(q)==mp_structured ) r=q;
6629 else { link(r)=link(q); mp_free_node(mp, q,subscr_node_size); }
6639 } while (attr_loc(p)<n);
6640 if ( attr_loc(p)!=n ) return;
6642 if ( discard_suffixes ) {
6643 mp_flush_below_variable(mp, p);
6645 if ( type(p)==mp_structured ) p=attr_head(p);
6646 mp_recycle_value(mp, p);
6650 @ The next procedure is simpler; it wipes out everything but |p| itself,
6651 which becomes undefined.
6653 @<Declare the procedure called |flush_below_variable|@>=
6654 void mp_flush_below_variable (MP mp, pointer p);
6657 void mp_flush_below_variable (MP mp,pointer p) {
6658 pointer q,r; /* list manipulation registers */
6659 if ( type(p)!=mp_structured ) {
6660 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6663 while ( name_type(q)==mp_subscr ) {
6664 mp_flush_below_variable(mp, q); r=q; q=link(q);
6665 mp_free_node(mp, r,subscr_node_size);
6667 r=attr_head(p); q=link(r); mp_recycle_value(mp, r);
6668 if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6669 else mp_free_node(mp, r,subscr_node_size);
6670 /* we assume that |subscr_node_size=attr_node_size| */
6672 mp_flush_below_variable(mp, q); r=q; q=link(q); mp_free_node(mp, r,attr_node_size);
6673 } while (q!=end_attr);
6678 @ Just before assigning a new value to a variable, we will recycle the
6679 old value and make the old value undefined. The |und_type| routine
6680 determines what type of undefined value should be given, based on
6681 the current type before recycling.
6684 small_number mp_und_type (MP mp,pointer p) {
6686 case undefined: case mp_vacuous:
6688 case mp_boolean_type: case mp_unknown_boolean:
6689 return mp_unknown_boolean;
6690 case mp_string_type: case mp_unknown_string:
6691 return mp_unknown_string;
6692 case mp_pen_type: case mp_unknown_pen:
6693 return mp_unknown_pen;
6694 case mp_path_type: case mp_unknown_path:
6695 return mp_unknown_path;
6696 case mp_picture_type: case mp_unknown_picture:
6697 return mp_unknown_picture;
6698 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6699 case mp_pair_type: case mp_numeric_type:
6701 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6702 return mp_numeric_type;
6703 } /* there are no other cases */
6707 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6708 of a symbolic token. It must remove any variable structure or macro
6709 definition that is currently attached to that symbol. If the |saving|
6710 parameter is true, a subsidiary structure is saved instead of destroyed.
6713 void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6714 pointer q; /* |equiv(p)| */
6716 switch (eq_type(p) % outer_tag) {
6718 case secondary_primary_macro:
6719 case tertiary_secondary_macro:
6720 case expression_tertiary_macro:
6721 if ( ! saving ) mp_delete_mac_ref(mp, q);
6726 name_type(q)=mp_saved_root;
6728 mp_flush_below_variable(mp, q);
6729 mp_free_node(mp,q,value_node_size);
6736 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6739 @* \[16] Saving and restoring equivalents.
6740 The nested structure given by \&{begingroup} and \&{endgroup}
6741 allows |eqtb| entries to be saved and restored, so that temporary changes
6742 can be made without difficulty. When the user requests a current value to
6743 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6744 \&{endgroup} ultimately causes the old values to be removed from the save
6745 stack and put back in their former places.
6747 The save stack is a linked list containing three kinds of entries,
6748 distinguished by their |info| fields. If |p| points to a saved item,
6752 |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6753 such an item to the save stack and each \&{endgroup} cuts back the stack
6754 until the most recent such entry has been removed.
6757 |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6758 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6762 |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6763 integer to be restored to internal parameter number~|q|. Such entries
6764 are generated by \&{interim} commands.
6767 The global variable |save_ptr| points to the top item on the save stack.
6769 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6770 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6771 @d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
6772 link((A))=mp->save_ptr; mp->save_ptr=(A);
6776 pointer save_ptr; /* the most recently saved item */
6778 @ @<Set init...@>=mp->save_ptr=null;
6780 @ The |save_variable| routine is given a hash address |q|; it salts this
6781 address in the save stack, together with its current equivalent,
6782 then makes token~|q| behave as though it were brand new.
6784 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6785 things from the stack when the program is not inside a group, so there's
6786 no point in wasting the space.
6788 @c void mp_save_variable (MP mp,pointer q) {
6789 pointer p; /* temporary register */
6790 if ( mp->save_ptr!=null ){
6791 p=mp_get_node(mp, save_node_size); info(p)=q; link(p)=mp->save_ptr;
6792 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6794 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6797 @ Similarly, |save_internal| is given the location |q| of an internal
6798 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6801 @c void mp_save_internal (MP mp,halfword q) {
6802 pointer p; /* new item for the save stack */
6803 if ( mp->save_ptr!=null ){
6804 p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
6805 link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6809 @ At the end of a group, the |unsave| routine restores all of the saved
6810 equivalents in reverse order. This routine will be called only when there
6811 is at least one boundary item on the save stack.
6814 void mp_unsave (MP mp) {
6815 pointer q; /* index to saved item */
6816 pointer p; /* temporary register */
6817 while ( info(mp->save_ptr)!=0 ) {
6818 q=info(mp->save_ptr);
6820 if ( mp->internal[mp_tracing_restores]>0 ) {
6821 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6822 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, '=');
6823 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, '}');
6824 mp_end_diagnostic(mp, false);
6826 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6828 if ( mp->internal[mp_tracing_restores]>0 ) {
6829 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6830 mp_print_text(q); mp_print_char(mp, '}');
6831 mp_end_diagnostic(mp, false);
6833 mp_clear_symbol(mp, q,false);
6834 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6835 if ( eq_type(q) % outer_tag==tag_token ) {
6837 if ( p!=null ) name_type(p)=mp_root;
6840 p=link(mp->save_ptr);
6841 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6843 p=link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6846 @* \[17] Data structures for paths.
6847 When a \MP\ user specifies a path, \MP\ will create a list of knots
6848 and control points for the associated cubic spline curves. If the
6849 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6850 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6851 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6852 @:Bezier}{B\'ezier, Pierre Etienne@>
6853 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6854 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6857 There is a 8-word node for each knot $z_k$, containing one word of
6858 control information and six words for the |x| and |y| coordinates of
6859 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6860 |left_type| and |right_type| fields, which each occupy a quarter of
6861 the first word in the node; they specify properties of the curve as it
6862 enters and leaves the knot. There's also a halfword |link| field,
6863 which points to the following knot, and a final supplementary word (of
6864 which only a quarter is used).
6866 If the path is a closed contour, knots 0 and |n| are identical;
6867 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6868 is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
6869 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6870 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6872 @d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6873 @d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6874 @d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6875 @d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6876 @d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6877 @d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6878 @d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6879 @d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6880 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6881 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6882 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6883 @d left_coord(A) mp->mem[(A)+2].sc
6884 /* coordinate of previous control point given |x_loc| or |y_loc| */
6885 @d right_coord(A) mp->mem[(A)+4].sc
6886 /* coordinate of next control point given |x_loc| or |y_loc| */
6887 @d knot_node_size 8 /* number of words in a knot node */
6891 mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
6892 mp_explicit, /* |left_type| or |right_type| when control points are known */
6893 mp_given, /* |left_type| or |right_type| when a direction is given */
6894 mp_curl, /* |left_type| or |right_type| when a curl is desired */
6895 mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
6899 @ Before the B\'ezier control points have been calculated, the memory
6900 space they will ultimately occupy is taken up by information that can be
6901 used to compute them. There are four cases:
6904 \textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
6905 the knot in the same direction it entered; \MP\ will figure out a
6909 \textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
6910 knot in a direction depending on the angle at which it enters the next
6911 knot and on the curl parameter stored in |right_curl|.
6914 \textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
6915 knot in a nonzero direction stored as an |angle| in |right_given|.
6918 \textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
6919 point for leaving this knot has already been computed; it is in the
6920 |right_x| and |right_y| fields.
6923 The rules for |left_type| are similar, but they refer to the curve entering
6924 the knot, and to \\{left} fields instead of \\{right} fields.
6926 Non-|explicit| control points will be chosen based on ``tension'' parameters
6927 in the |left_tension| and |right_tension| fields. The
6928 `\&{atleast}' option is represented by negative tension values.
6929 @:at_least_}{\&{atleast} primitive@>
6931 For example, the \MP\ path specification
6932 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6934 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6936 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6937 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6938 |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
6940 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6941 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6942 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6943 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6944 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6945 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6946 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6947 Of course, this example is more complicated than anything a normal user
6950 These types must satisfy certain restrictions because of the form of \MP's
6952 (i)~|open| type never appears in the same node together with |endpoint|,
6954 (ii)~The |right_type| of a node is |explicit| if and only if the
6955 |left_type| of the following node is |explicit|.
6956 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6958 @d left_curl left_x /* curl information when entering this knot */
6959 @d left_given left_x /* given direction when entering this knot */
6960 @d left_tension left_y /* tension information when entering this knot */
6961 @d right_curl right_x /* curl information when leaving this knot */
6962 @d right_given right_x /* given direction when leaving this knot */
6963 @d right_tension right_y /* tension information when leaving this knot */
6965 @ Knots can be user-supplied, or they can be created by program code,
6966 like the |split_cubic| function, or |copy_path|. The distinction is
6967 needed for the cleanup routine that runs after |split_cubic|, because
6968 it should only delete knots it has previously inserted, and never
6969 anything that was user-supplied. In order to be able to differentiate
6970 one knot from another, we will set |originator(p):=mp_metapost_user| when
6971 it appeared in the actual metapost program, and
6972 |originator(p):=mp_program_code| in all other cases.
6974 @d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6978 mp_program_code=0, /* not created by a user */
6979 mp_metapost_user /* created by a user */
6982 @ Here is a routine that prints a given knot list
6983 in symbolic form. It illustrates the conventions discussed above,
6984 and checks for anomalies that might arise while \MP\ is being debugged.
6986 @<Declare subroutines for printing expressions@>=
6987 void mp_pr_path (MP mp,pointer h);
6990 void mp_pr_path (MP mp,pointer h) {
6991 pointer p,q; /* for list traversal */
6995 if ( (p==null)||(q==null) ) {
6996 mp_print_nl(mp, "???"); return; /* this won't happen */
6999 @<Print information for adjacent knots |p| and |q|@>;
7002 if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
7003 @<Print two dots, followed by |given| or |curl| if present@>;
7006 if ( left_type(h)!=mp_endpoint )
7007 mp_print(mp, "cycle");
7010 @ @<Print information for adjacent knots...@>=
7011 mp_print_two(mp, x_coord(p),y_coord(p));
7012 switch (right_type(p)) {
7014 if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
7016 if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
7020 @<Print control points between |p| and |q|, then |goto done1|@>;
7023 @<Print information for a curve that begins |open|@>;
7027 @<Print information for a curve that begins |curl| or |given|@>;
7030 mp_print(mp, "???"); /* can't happen */
7034 if ( left_type(q)<=mp_explicit ) {
7035 mp_print(mp, "..control?"); /* can't happen */
7037 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
7038 @<Print tension between |p| and |q|@>;
7041 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
7042 were |scaled|, the magnitude of a |given| direction vector will be~4096.
7044 @<Print two dots...@>=
7046 mp_print_nl(mp, " ..");
7047 if ( left_type(p)==mp_given ) {
7048 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, '{');
7049 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7050 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, '}');
7051 } else if ( left_type(p)==mp_curl ){
7052 mp_print(mp, "{curl ");
7053 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, '}');
7057 @ @<Print tension between |p| and |q|@>=
7059 mp_print(mp, "..tension ");
7060 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
7061 mp_print_scaled(mp, abs(right_tension(p)));
7062 if ( right_tension(p)!=left_tension(q) ){
7063 mp_print(mp, " and ");
7064 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
7065 mp_print_scaled(mp, abs(left_tension(q)));
7069 @ @<Print control points between |p| and |q|, then |goto done1|@>=
7071 mp_print(mp, "..controls ");
7072 mp_print_two(mp, right_x(p),right_y(p));
7073 mp_print(mp, " and ");
7074 if ( left_type(q)!=mp_explicit ) {
7075 mp_print(mp, "??"); /* can't happen */
7078 mp_print_two(mp, left_x(q),left_y(q));
7083 @ @<Print information for a curve that begins |open|@>=
7084 if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
7085 mp_print(mp, "{open?}"); /* can't happen */
7089 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7090 \MP's default curl is present.
7092 @<Print information for a curve that begins |curl|...@>=
7094 if ( left_type(p)==mp_open )
7095 mp_print(mp, "??"); /* can't happen */
7097 if ( right_type(p)==mp_curl ) {
7098 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7100 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, '{');
7101 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7102 mp_print_scaled(mp, mp->n_sin);
7104 mp_print_char(mp, '}');
7107 @ It is convenient to have another version of |pr_path| that prints the path
7108 as a diagnostic message.
7110 @<Declare subroutines for printing expressions@>=
7111 void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
7112 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7115 mp_end_diagnostic(mp, true);
7118 @ If we want to duplicate a knot node, we can say |copy_knot|:
7121 pointer mp_copy_knot (MP mp,pointer p) {
7122 pointer q; /* the copy */
7123 int k; /* runs through the words of a knot node */
7124 q=mp_get_node(mp, knot_node_size);
7125 for (k=0;k<knot_node_size;k++) {
7126 mp->mem[q+k]=mp->mem[p+k];
7128 originator(q)=originator(p);
7132 @ The |copy_path| routine makes a clone of a given path.
7135 pointer mp_copy_path (MP mp, pointer p) {
7136 pointer q,pp,qq; /* for list manipulation */
7137 q=mp_copy_knot(mp, p);
7140 link(qq)=mp_copy_knot(mp, pp);
7149 @ Just before |ship_out|, knot lists are exported for printing.
7151 The |gr_XXXX| macros are defined in |mppsout.h|.
7154 mp_knot *mp_export_knot (MP mp,pointer p) {
7155 mp_knot *q; /* the copy */
7158 q = mp_xmalloc(mp, 1, sizeof (mp_knot));
7159 memset(q,0,sizeof (mp_knot));
7160 gr_left_type(q) = left_type(p);
7161 gr_right_type(q) = right_type(p);
7162 gr_x_coord(q) = x_coord(p);
7163 gr_y_coord(q) = y_coord(p);
7164 gr_left_x(q) = left_x(p);
7165 gr_left_y(q) = left_y(p);
7166 gr_right_x(q) = right_x(p);
7167 gr_right_y(q) = right_y(p);
7168 gr_originator(q) = originator(p);
7172 @ The |export_knot_list| routine therefore also makes a clone
7176 mp_knot *mp_export_knot_list (MP mp, pointer p) {
7177 mp_knot *q, *qq; /* for list manipulation */
7178 pointer pp; /* for list manipulation */
7181 q=mp_export_knot(mp, p);
7184 gr_next_knot(qq)=mp_export_knot(mp, pp);
7185 qq=gr_next_knot(qq);
7193 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7194 returns a pointer to the first node of the copy, if the path is a cycle,
7195 but to the final node of a non-cyclic copy. The global
7196 variable |path_tail| will point to the final node of the original path;
7197 this trick makes it easier to implement `\&{doublepath}'.
7199 All node types are assumed to be |endpoint| or |explicit| only.
7202 pointer mp_htap_ypoc (MP mp,pointer p) {
7203 pointer q,pp,qq,rr; /* for list manipulation */
7204 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7207 right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
7208 x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
7209 right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
7210 left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
7211 originator(qq)=originator(pp);
7212 if ( link(pp)==p ) {
7213 link(q)=qq; mp->path_tail=pp; return q;
7215 rr=mp_get_node(mp, knot_node_size); link(rr)=qq; qq=rr; pp=link(pp);
7220 pointer path_tail; /* the node that links to the beginning of a path */
7222 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7223 calling the following subroutine.
7225 @<Declare the recycling subroutines@>=
7226 void mp_toss_knot_list (MP mp,pointer p) ;
7229 void mp_toss_knot_list (MP mp,pointer p) {
7230 pointer q; /* the node being freed */
7231 pointer r; /* the next node */
7235 mp_free_node(mp, q,knot_node_size); q=r;
7239 @* \[18] Choosing control points.
7240 Now we must actually delve into one of \MP's more difficult routines,
7241 the |make_choices| procedure that chooses angles and control points for
7242 the splines of a curve when the user has not specified them explicitly.
7243 The parameter to |make_choices| points to a list of knots and
7244 path information, as described above.
7246 A path decomposes into independent segments at ``breakpoint'' knots,
7247 which are knots whose left and right angles are both prespecified in
7248 some way (i.e., their |left_type| and |right_type| aren't both open).
7251 @<Declare the procedure called |solve_choices|@>
7252 void mp_make_choices (MP mp,pointer knots) {
7253 pointer h; /* the first breakpoint */
7254 pointer p,q; /* consecutive breakpoints being processed */
7255 @<Other local variables for |make_choices|@>;
7256 check_arith; /* make sure that |arith_error=false| */
7257 if ( mp->internal[mp_tracing_choices]>0 )
7258 mp_print_path(mp, knots,", before choices",true);
7259 @<If consecutive knots are equal, join them explicitly@>;
7260 @<Find the first breakpoint, |h|, on the path;
7261 insert an artificial breakpoint if the path is an unbroken cycle@>;
7264 @<Fill in the control points between |p| and the next breakpoint,
7265 then advance |p| to that breakpoint@>;
7267 if ( mp->internal[mp_tracing_choices]>0 )
7268 mp_print_path(mp, knots,", after choices",true);
7269 if ( mp->arith_error ) {
7270 @<Report an unexpected problem during the choice-making@>;
7274 @ @<Report an unexpected problem during the choice...@>=
7276 print_err("Some number got too big");
7277 @.Some number got too big@>
7278 help2("The path that I just computed is out of range.")
7279 ("So it will probably look funny. Proceed, for a laugh.");
7280 mp_put_get_error(mp); mp->arith_error=false;
7283 @ Two knots in a row with the same coordinates will always be joined
7284 by an explicit ``curve'' whose control points are identical with the
7287 @<If consecutive knots are equal, join them explicitly@>=
7291 if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
7292 right_type(p)=mp_explicit;
7293 if ( left_type(p)==mp_open ) {
7294 left_type(p)=mp_curl; left_curl(p)=unity;
7296 left_type(q)=mp_explicit;
7297 if ( right_type(q)==mp_open ) {
7298 right_type(q)=mp_curl; right_curl(q)=unity;
7300 right_x(p)=x_coord(p); left_x(q)=x_coord(p);
7301 right_y(p)=y_coord(p); left_y(q)=y_coord(p);
7306 @ If there are no breakpoints, it is necessary to compute the direction
7307 angles around an entire cycle. In this case the |left_type| of the first
7308 node is temporarily changed to |end_cycle|.
7310 @<Find the first breakpoint, |h|, on the path...@>=
7313 if ( left_type(h)!=mp_open ) break;
7314 if ( right_type(h)!=mp_open ) break;
7317 left_type(h)=mp_end_cycle; break;
7321 @ If |right_type(p)<given| and |q=link(p)|, we must have
7322 |right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
7324 @<Fill in the control points between |p| and the next breakpoint...@>=
7326 if ( right_type(p)>=mp_given ) {
7327 while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=link(q);
7328 @<Fill in the control information between
7329 consecutive breakpoints |p| and |q|@>;
7330 } else if ( right_type(p)==mp_endpoint ) {
7331 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7335 @ This step makes it possible to transform an explicitly computed path without
7336 checking the |left_type| and |right_type| fields.
7338 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7340 right_x(p)=x_coord(p); right_y(p)=y_coord(p);
7341 left_x(q)=x_coord(q); left_y(q)=y_coord(q);
7344 @ Before we can go further into the way choices are made, we need to
7345 consider the underlying theory. The basic ideas implemented in |make_choices|
7346 are due to John Hobby, who introduced the notion of ``mock curvature''
7347 @^Hobby, John Douglas@>
7348 at a knot. Angles are chosen so that they preserve mock curvature when
7349 a knot is passed, and this has been found to produce excellent results.
7351 It is convenient to introduce some notations that simplify the necessary
7352 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7353 between knots |k| and |k+1|; and let
7354 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7355 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7356 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7357 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7358 $$\eqalign{z_k^+&=z_k+
7359 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7361 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7362 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7363 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7364 corresponding ``offset angles.'' These angles satisfy the condition
7365 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7366 whenever the curve leaves an intermediate knot~|k| in the direction that
7369 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7370 the curve at its beginning and ending points. This means that
7371 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7372 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7373 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7374 z\k^-,z\k^{\phantom+};t)$
7377 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7378 \qquad{\rm and}\qquad
7379 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7380 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7382 approximation to this true curvature that arises in the limit for
7383 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7384 The standard velocity function satisfies
7385 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7386 hence the mock curvatures are respectively
7387 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7388 \qquad{\rm and}\qquad
7389 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7391 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7392 determines $\phi_k$ when $\theta_k$ is known, so the task of
7393 angle selection is essentially to choose appropriate values for each
7394 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7395 from $(**)$, we obtain a system of linear equations of the form
7396 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7398 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7399 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7400 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7401 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7402 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7403 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7404 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7405 hence they have a unique solution. Moreover, in most cases the tensions
7406 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7407 solution numerically stable, and there is an exponential damping
7408 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7409 a factor of~$O(2^{-j})$.
7411 @ However, we still must consider the angles at the starting and ending
7412 knots of a non-cyclic path. These angles might be given explicitly, or
7413 they might be specified implicitly in terms of an amount of ``curl.''
7415 Let's assume that angles need to be determined for a non-cyclic path
7416 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7417 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7418 have been given for $0<k<n$, and it will be convenient to introduce
7419 equations of the same form for $k=0$ and $k=n$, where
7420 $$A_0=B_0=C_n=D_n=0.$$
7421 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7422 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7423 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7424 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7425 mock curvature at $z_1$; i.e.,
7426 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7427 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7428 This equation simplifies to
7429 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7430 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7431 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7432 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7433 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7434 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7435 hence the linear equations remain nonsingular.
7437 Similar considerations apply at the right end, when the final angle $\phi_n$
7438 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7439 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7441 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7442 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7443 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7445 When |make_choices| chooses angles, it must compute the coefficients of
7446 these linear equations, then solve the equations. To compute the coefficients,
7447 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7448 When the equations are solved, the chosen directions $\theta_k$ are put
7449 back into the form of control points by essentially computing sines and
7452 @ OK, we are ready to make the hard choices of |make_choices|.
7453 Most of the work is relegated to an auxiliary procedure
7454 called |solve_choices|, which has been introduced to keep
7455 |make_choices| from being extremely long.
7457 @<Fill in the control information between...@>=
7458 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7459 set $n$ to the length of the path@>;
7460 @<Remove |open| types at the breakpoints@>;
7461 mp_solve_choices(mp, p,q,n)
7463 @ It's convenient to precompute quantities that will be needed several
7464 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7465 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7466 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7467 and $z\k-z_k$ will be stored in |psi[k]|.
7470 int path_size; /* maximum number of knots between breakpoints of a path */
7473 scaled *delta; /* knot differences */
7474 angle *psi; /* turning angles */
7476 @ @<Allocate or initialize ...@>=
7482 @ @<Dealloc variables@>=
7488 @ @<Other local variables for |make_choices|@>=
7489 int k,n; /* current and final knot numbers */
7490 pointer s,t; /* registers for list traversal */
7491 scaled delx,dely; /* directions where |open| meets |explicit| */
7492 fraction sine,cosine; /* trig functions of various angles */
7494 @ @<Calculate the turning angles...@>=
7497 k=0; s=p; n=mp->path_size;
7500 mp->delta_x[k]=x_coord(t)-x_coord(s);
7501 mp->delta_y[k]=y_coord(t)-y_coord(s);
7502 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7504 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7505 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7506 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7507 mp_take_fraction(mp, mp->delta_y[k],sine),
7508 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7509 mp_take_fraction(mp, mp->delta_x[k],sine));
7512 if ( k==mp->path_size ) {
7513 mp_reallocate_paths(mp, mp->path_size+(mp->path_size>>2));
7514 goto RESTART; /* retry, loop size has changed */
7517 } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
7518 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7521 @ When we get to this point of the code, |right_type(p)| is either
7522 |given| or |curl| or |open|. If it is |open|, we must have
7523 |left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
7524 case, the |open| type is converted to |given|; however, if the
7525 velocity coming into this knot is zero, the |open| type is
7526 converted to a |curl|, since we don't know the incoming direction.
7528 Similarly, |left_type(q)| is either |given| or |curl| or |open| or
7529 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7531 @<Remove |open| types at the breakpoints@>=
7532 if ( left_type(q)==mp_open ) {
7533 delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
7534 if ( (delx==0)&&(dely==0) ) {
7535 left_type(q)=mp_curl; left_curl(q)=unity;
7537 left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7540 if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
7541 delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
7542 if ( (delx==0)&&(dely==0) ) {
7543 right_type(p)=mp_curl; right_curl(p)=unity;
7545 right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7549 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7550 and exactly one of the breakpoints involves a curl. The simplest case occurs
7551 when |n=1| and there is a curl at both breakpoints; then we simply draw
7554 But before coding up the simple cases, we might as well face the general case,
7555 since we must deal with it sooner or later, and since the general case
7556 is likely to give some insight into the way simple cases can be handled best.
7558 When there is no cycle, the linear equations to be solved form a tridiagonal
7559 system, and we can apply the standard technique of Gaussian elimination
7560 to convert that system to a sequence of equations of the form
7561 $$\theta_0+u_0\theta_1=v_0,\quad
7562 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7563 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7565 It is possible to do this diagonalization while generating the equations.
7566 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7567 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7569 The procedure is slightly more complex when there is a cycle, but the
7570 basic idea will be nearly the same. In the cyclic case the right-hand
7571 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7572 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7573 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7574 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7575 eliminate the $w$'s from the system, after which the solution can be
7578 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7579 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7580 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7581 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7584 angle *theta; /* values of $\theta_k$ */
7585 fraction *uu; /* values of $u_k$ */
7586 angle *vv; /* values of $v_k$ */
7587 fraction *ww; /* values of $w_k$ */
7589 @ @<Allocate or initialize ...@>=
7595 @ @<Dealloc variables@>=
7601 @ @<Declare |mp_reallocate| functions@>=
7602 void mp_reallocate_paths (MP mp, int l);
7605 void mp_reallocate_paths (MP mp, int l) {
7606 XREALLOC (mp->delta_x, l, scaled);
7607 XREALLOC (mp->delta_y, l, scaled);
7608 XREALLOC (mp->delta, l, scaled);
7609 XREALLOC (mp->psi, l, angle);
7610 XREALLOC (mp->theta, l, angle);
7611 XREALLOC (mp->uu, l, fraction);
7612 XREALLOC (mp->vv, l, angle);
7613 XREALLOC (mp->ww, l, fraction);
7617 @ Our immediate problem is to get the ball rolling by setting up the
7618 first equation or by realizing that no equations are needed, and to fit
7619 this initialization into a framework suitable for the overall computation.
7621 @<Declare the procedure called |solve_choices|@>=
7622 @<Declare subroutines needed by |solve_choices|@>
7623 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7624 int k; /* current knot number */
7625 pointer r,s,t; /* registers for list traversal */
7626 @<Other local variables for |solve_choices|@>;
7631 @<Get the linear equations started; or |return|
7632 with the control points in place, if linear equations
7635 switch (left_type(s)) {
7636 case mp_end_cycle: case mp_open:
7637 @<Set up equation to match mock curvatures
7638 at $z_k$; then |goto found| with $\theta_n$
7639 adjusted to equal $\theta_0$, if a cycle has ended@>;
7642 @<Set up equation for a curl at $\theta_n$
7646 @<Calculate the given value of $\theta_n$
7649 } /* there are no other cases */
7654 @<Finish choosing angles and assigning control points@>;
7657 @ On the first time through the loop, we have |k=0| and |r| is not yet
7658 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7660 @<Get the linear equations started...@>=
7661 switch (right_type(s)) {
7663 if ( left_type(t)==mp_given ) {
7664 @<Reduce to simple case of two givens and |return|@>
7666 @<Set up the equation for a given value of $\theta_0$@>;
7670 if ( left_type(t)==mp_curl ) {
7671 @<Reduce to simple case of straight line and |return|@>
7673 @<Set up the equation for a curl at $\theta_0$@>;
7677 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7678 /* this begins a cycle */
7680 } /* there are no other cases */
7682 @ The general equation that specifies equality of mock curvature at $z_k$ is
7683 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7684 as derived above. We want to combine this with the already-derived equation
7685 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7687 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7689 $$(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}
7690 -A_kw_{k-1}\theta_0$$
7691 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7692 fixed-point arithmetic, avoiding the chance of overflow while retaining
7695 The calculations will be performed in several registers that
7696 provide temporary storage for intermediate quantities.
7698 @<Other local variables for |solve_choices|@>=
7699 fraction aa,bb,cc,ff,acc; /* temporary registers */
7700 scaled dd,ee; /* likewise, but |scaled| */
7701 scaled lt,rt; /* tension values */
7703 @ @<Set up equation to match mock curvatures...@>=
7704 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7705 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7706 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7707 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7708 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7709 @<Calculate the values of $v_k$ and $w_k$@>;
7710 if ( left_type(s)==mp_end_cycle ) {
7711 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7715 @ Since tension values are never less than 3/4, the values |aa| and
7716 |bb| computed here are never more than 4/5.
7718 @<Calculate the values $\\{aa}=...@>=
7719 if ( abs(right_tension(r))==unity) {
7720 aa=fraction_half; dd=2*mp->delta[k];
7722 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7723 dd=mp_take_fraction(mp, mp->delta[k],
7724 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7726 if ( abs(left_tension(t))==unity ){
7727 bb=fraction_half; ee=2*mp->delta[k-1];
7729 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7730 ee=mp_take_fraction(mp, mp->delta[k-1],
7731 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7733 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7735 @ The ratio to be calculated in this step can be written in the form
7736 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7737 \\{cc}\cdot\\{dd},$$
7738 because of the quantities just calculated. The values of |dd| and |ee|
7739 will not be needed after this step has been performed.
7741 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7742 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7743 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7745 ff=mp_make_fraction(mp, lt,rt);
7746 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7747 dd=mp_take_fraction(mp, dd,ff);
7749 ff=mp_make_fraction(mp, rt,lt);
7750 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7751 ee=mp_take_fraction(mp, ee,ff);
7754 ff=mp_make_fraction(mp, ee,ee+dd)
7756 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7757 equation was specified by a curl. In that case we must use a special
7758 method of computation to prevent overflow.
7760 Fortunately, the calculations turn out to be even simpler in this ``hard''
7761 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7762 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7764 @<Calculate the values of $v_k$ and $w_k$@>=
7765 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7766 if ( right_type(r)==mp_curl ) {
7768 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7770 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7771 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7772 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7773 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7774 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7775 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7776 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7779 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7780 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7781 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7782 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7785 The idea in the following code is to observe that
7786 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7787 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7788 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7789 so we can solve for $\theta_n=\theta_0$.
7791 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7793 aa=0; bb=fraction_one; /* we have |k=n| */
7796 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7797 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7798 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7799 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7800 mp->theta[n]=aa; mp->vv[0]=aa;
7801 for (k=1;k<=n-1;k++) {
7802 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7807 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7808 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7810 @<Calculate the given value of $\theta_n$...@>=
7812 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7813 reduce_angle(mp->theta[n]);
7817 @ @<Set up the equation for a given value of $\theta_0$@>=
7819 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7820 reduce_angle(mp->vv[0]);
7821 mp->uu[0]=0; mp->ww[0]=0;
7824 @ @<Set up the equation for a curl at $\theta_0$@>=
7825 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7826 if ( (rt==unity)&&(lt==unity) )
7827 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7829 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7830 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7833 @ @<Set up equation for a curl at $\theta_n$...@>=
7834 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7835 if ( (rt==unity)&&(lt==unity) )
7836 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7838 ff=mp_curl_ratio(mp, cc,lt,rt);
7839 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7840 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7844 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7845 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7846 a somewhat tedious program to calculate
7847 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7848 \alpha^3\gamma+(3-\beta)\beta^2},$$
7849 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7850 is necessary only if the curl and tension are both large.)
7851 The values of $\alpha$ and $\beta$ will be at most~4/3.
7853 @<Declare subroutines needed by |solve_choices|@>=
7854 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7856 fraction alpha,beta,num,denom,ff; /* registers */
7857 alpha=mp_make_fraction(mp, unity,a_tension);
7858 beta=mp_make_fraction(mp, unity,b_tension);
7859 if ( alpha<=beta ) {
7860 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7861 gamma=mp_take_fraction(mp, gamma,ff);
7862 beta=beta / 010000; /* convert |fraction| to |scaled| */
7863 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7864 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7866 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7867 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7868 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7869 /* $1365\approx 2^{12}/3$ */
7870 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7872 if ( num>=denom+denom+denom+denom ) return fraction_four;
7873 else return mp_make_fraction(mp, num,denom);
7876 @ We're in the home stretch now.
7878 @<Finish choosing angles and assigning control points@>=
7879 for (k=n-1;k>=0;k--) {
7880 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7885 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7886 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7887 mp_set_controls(mp, s,t,k);
7891 @ The |set_controls| routine actually puts the control points into
7892 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7893 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7894 $\cos\phi$ needed in this calculation.
7900 fraction cf; /* sines and cosines */
7902 @ @<Declare subroutines needed by |solve_choices|@>=
7903 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7904 fraction rr,ss; /* velocities, divided by thrice the tension */
7905 scaled lt,rt; /* tensions */
7906 fraction sine; /* $\sin(\theta+\phi)$ */
7907 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7908 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7909 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7910 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7911 @<Decrease the velocities,
7912 if necessary, to stay inside the bounding triangle@>;
7914 right_x(p)=x_coord(p)+mp_take_fraction(mp,
7915 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7916 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7917 right_y(p)=y_coord(p)+mp_take_fraction(mp,
7918 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7919 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7920 left_x(q)=x_coord(q)-mp_take_fraction(mp,
7921 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7922 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7923 left_y(q)=y_coord(q)-mp_take_fraction(mp,
7924 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7925 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7926 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7929 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7930 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7931 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7932 there is no ``bounding triangle.''
7934 @<Decrease the velocities, if necessary...@>=
7935 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7936 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7937 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7939 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7940 if ( right_tension(p)<0 )
7941 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7942 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7943 if ( left_tension(q)<0 )
7944 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7945 ss=mp_make_fraction(mp, abs(mp->st),sine);
7949 @ Only the simple cases remain to be handled.
7951 @<Reduce to simple case of two givens and |return|@>=
7953 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7954 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7955 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7956 mp_set_controls(mp, p,q,0); return;
7959 @ @<Reduce to simple case of straight line and |return|@>=
7961 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7962 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7964 if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
7965 else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
7966 if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
7967 else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
7969 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7970 right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7971 right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7974 if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
7975 else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
7976 if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
7977 else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
7979 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7980 left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7981 left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7986 @* \[19] Measuring paths.
7987 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7988 allow the user to measure the bounding box of anything that can go into a
7989 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7990 by just finding the bounding box of the knots and the control points. We
7991 need a more accurate version of the bounding box, but we can still use the
7992 easy estimate to save time by focusing on the interesting parts of the path.
7994 @ Computing an accurate bounding box involves a theme that will come up again
7995 and again. Given a Bernshte{\u\i}n polynomial
7996 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
7997 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
7998 we can conveniently bisect its range as follows:
8001 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
8004 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
8005 |0<=k<n-j|, for |0<=j<n|.
8009 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
8010 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
8011 This formula gives us the coefficients of polynomials to use over the ranges
8012 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
8014 @ Now here's a subroutine that's handy for all sorts of path computations:
8015 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
8016 returns the unique |fraction| value |t| between 0 and~1 at which
8017 $B(a,b,c;t)$ changes from positive to negative, or returns
8018 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
8019 is already negative at |t=0|), |crossing_point| returns the value zero.
8021 @d no_crossing { return (fraction_one+1); }
8022 @d one_crossing { return fraction_one; }
8023 @d zero_crossing { return 0; }
8024 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
8026 @c fraction mp_do_crossing_point (integer a, integer b, integer c) {
8027 integer d; /* recursive counter */
8028 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
8029 if ( a<0 ) zero_crossing;
8032 if ( c>0 ) { no_crossing; }
8033 else if ( (a==0)&&(b==0) ) { no_crossing;}
8034 else { one_crossing; }
8036 if ( a==0 ) zero_crossing;
8037 } else if ( a==0 ) {
8038 if ( b<=0 ) zero_crossing;
8040 @<Use bisection to find the crossing point, if one exists@>;
8043 @ The general bisection method is quite simple when $n=2$, hence
8044 |crossing_point| does not take much time. At each stage in the
8045 recursion we have a subinterval defined by |l| and~|j| such that
8046 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
8047 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
8049 It is convenient for purposes of calculation to combine the values
8050 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
8051 of bisection then corresponds simply to doubling $d$ and possibly
8052 adding~1. Furthermore it proves to be convenient to modify
8053 our previous conventions for bisection slightly, maintaining the
8054 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
8055 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
8056 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
8058 The following code maintains the invariant relations
8059 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
8060 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
8061 it has been constructed in such a way that no arithmetic overflow
8062 will occur if the inputs satisfy
8063 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
8065 @<Use bisection to find the crossing point...@>=
8066 d=1; x0=a; x1=a-b; x2=b-c;
8077 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
8081 } while (d<fraction_one);
8082 return (d-fraction_one)
8084 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
8085 a cubic corresponding to the |fraction| value~|t|.
8087 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
8088 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
8090 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
8092 @c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
8093 scaled x1,x2,x3; /* intermediate values */
8094 x1=t_of_the_way(knot_coord(p),right_coord(p));
8095 x2=t_of_the_way(right_coord(p),left_coord(q));
8096 x3=t_of_the_way(left_coord(q),knot_coord(q));
8097 x1=t_of_the_way(x1,x2);
8098 x2=t_of_the_way(x2,x3);
8099 return t_of_the_way(x1,x2);
8102 @ The actual bounding box information is stored in global variables.
8103 Since it is convenient to address the $x$ and $y$ information
8104 separately, we define arrays indexed by |x_code..y_code| and use
8105 macros to give them more convenient names.
8109 mp_x_code=0, /* index for |minx| and |maxx| */
8110 mp_y_code /* index for |miny| and |maxy| */
8114 @d minx mp->bbmin[mp_x_code]
8115 @d maxx mp->bbmax[mp_x_code]
8116 @d miny mp->bbmin[mp_y_code]
8117 @d maxy mp->bbmax[mp_y_code]
8120 scaled bbmin[mp_y_code+1];
8121 scaled bbmax[mp_y_code+1];
8122 /* the result of procedures that compute bounding box information */
8124 @ Now we're ready for the key part of the bounding box computation.
8125 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
8126 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
8127 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8129 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8130 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8131 The |c| parameter is |x_code| or |y_code|.
8133 @c void mp_bound_cubic (MP mp,pointer p, pointer q, small_number c) {
8134 boolean wavy; /* whether we need to look for extremes */
8135 scaled del1,del2,del3,del,dmax; /* proportional to the control
8136 points of a quadratic derived from a cubic */
8137 fraction t,tt; /* where a quadratic crosses zero */
8138 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8140 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8141 @<Check the control points against the bounding box and set |wavy:=true|
8142 if any of them lie outside@>;
8144 del1=right_coord(p)-knot_coord(p);
8145 del2=left_coord(q)-right_coord(p);
8146 del3=knot_coord(q)-left_coord(q);
8147 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8148 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8150 negate(del1); negate(del2); negate(del3);
8152 t=mp_crossing_point(mp, del1,del2,del3);
8153 if ( t<fraction_one ) {
8154 @<Test the extremes of the cubic against the bounding box@>;
8159 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8160 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8161 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8163 @ @<Check the control points against the bounding box and set...@>=
8165 if ( mp->bbmin[c]<=right_coord(p) )
8166 if ( right_coord(p)<=mp->bbmax[c] )
8167 if ( mp->bbmin[c]<=left_coord(q) )
8168 if ( left_coord(q)<=mp->bbmax[c] )
8171 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8172 section. We just set |del=0| in that case.
8174 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8175 if ( del1!=0 ) del=del1;
8176 else if ( del2!=0 ) del=del2;
8180 if ( abs(del2)>dmax ) dmax=abs(del2);
8181 if ( abs(del3)>dmax ) dmax=abs(del3);
8182 while ( dmax<fraction_half ) {
8183 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8187 @ Since |crossing_point| has tried to choose |t| so that
8188 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8189 slope, the value of |del2| computed below should not be positive.
8190 But rounding error could make it slightly positive in which case we
8191 must cut it to zero to avoid confusion.
8193 @<Test the extremes of the cubic against the bounding box@>=
8195 x=mp_eval_cubic(mp, p,q,t);
8196 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8197 del2=t_of_the_way(del2,del3);
8198 /* now |0,del2,del3| represent the derivative on the remaining interval */
8199 if ( del2>0 ) del2=0;
8200 tt=mp_crossing_point(mp, 0,-del2,-del3);
8201 if ( tt<fraction_one ) {
8202 @<Test the second extreme against the bounding box@>;
8206 @ @<Test the second extreme against the bounding box@>=
8208 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8209 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8212 @ Finding the bounding box of a path is basically a matter of applying
8213 |bound_cubic| twice for each pair of adjacent knots.
8215 @c void mp_path_bbox (MP mp,pointer h) {
8216 pointer p,q; /* a pair of adjacent knots */
8217 minx=x_coord(h); miny=y_coord(h);
8218 maxx=minx; maxy=miny;
8221 if ( right_type(p)==mp_endpoint ) return;
8223 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8224 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8229 @ Another important way to measure a path is to find its arc length. This
8230 is best done by using the general bisection algorithm to subdivide the path
8231 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8234 Since the arc length is the integral with respect to time of the magnitude of
8235 the velocity, it is natural to use Simpson's rule for the approximation.
8237 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8238 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8239 for the arc length of a path of length~1. For a cubic spline
8240 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8241 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8243 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8245 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8246 is the result of the bisection algorithm.
8248 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8249 This could be done via the theoretical error bound for Simpson's rule,
8251 but this is impractical because it requires an estimate of the fourth
8252 derivative of the quantity being integrated. It is much easier to just perform
8253 a bisection step and see how much the arc length estimate changes. Since the
8254 error for Simpson's rule is proportional to the fourth power of the sample
8255 spacing, the remaining error is typically about $1\over16$ of the amount of
8256 the change. We say ``typically'' because the error has a pseudo-random behavior
8257 that could cause the two estimates to agree when each contain large errors.
8259 To protect against disasters such as undetected cusps, the bisection process
8260 should always continue until all the $dz_i$ vectors belong to a single
8261 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8262 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8263 If such a spline happens to produce an erroneous arc length estimate that
8264 is little changed by bisection, the amount of the error is likely to be fairly
8265 small. We will try to arrange things so that freak accidents of this type do
8266 not destroy the inverse relationship between the \&{arclength} and
8267 \&{arctime} operations.
8268 @:arclength_}{\&{arclength} primitive@>
8269 @:arctime_}{\&{arctime} primitive@>
8271 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8273 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8274 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8275 returns the time when the arc length reaches |a_goal| if there is such a time.
8276 Thus the return value is either an arc length less than |a_goal| or, if the
8277 arc length would be at least |a_goal|, it returns a time value decreased by
8278 |two|. This allows the caller to use the sign of the result to distinguish
8279 between arc lengths and time values. On certain types of overflow, it is
8280 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8281 Otherwise, the result is always less than |a_goal|.
8283 Rather than halving the control point coordinates on each recursive call to
8284 |arc_test|, it is better to keep them proportional to velocity on the original
8285 curve and halve the results instead. This means that recursive calls can
8286 potentially use larger error tolerances in their arc length estimates. How
8287 much larger depends on to what extent the errors behave as though they are
8288 independent of each other. To save computing time, we use optimistic assumptions
8289 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8292 In addition to the tolerance parameter, |arc_test| should also have parameters
8293 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8294 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8295 and they are needed in different instances of |arc_test|.
8297 @c @<Declare subroutines needed by |arc_test|@>
8298 scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8299 scaled dx2, scaled dy2, scaled v0, scaled v02,
8300 scaled v2, scaled a_goal, scaled tol) {
8301 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8302 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8304 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8305 scaled arc; /* best arc length estimate before recursion */
8306 @<Other local variables in |arc_test|@>;
8307 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8309 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8310 set |arc_test| and |return|@>;
8311 @<Test if the control points are confined to one quadrant or rotating them
8312 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8313 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8314 if ( arc < a_goal ) {
8317 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8318 that time minus |two|@>;
8321 @<Use one or two recursive calls to compute the |arc_test| function@>;
8325 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8326 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8327 |make_fraction| in this inner loop.
8330 @<Use one or two recursive calls to compute the |arc_test| function@>=
8332 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8333 large as possible@>;
8334 tol = tol + halfp(tol);
8335 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8336 halfp(v02), a_new, tol);
8338 return (-halfp(two-a));
8340 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8341 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8342 halfp(v02), v022, v2, a_new, tol);
8344 return (-halfp(-b) - half_unit);
8346 return (a + half(b-a));
8350 @ @<Other local variables in |arc_test|@>=
8351 scaled a,b; /* results of recursive calls */
8352 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8354 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8355 a_aux = el_gordo - a_goal;
8356 if ( a_goal > a_aux ) {
8357 a_aux = a_goal - a_aux;
8360 a_new = a_goal + a_goal;
8364 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8365 to force the additions and subtractions to be done in an order that avoids
8368 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8371 a_new = a_new + a_aux;
8374 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8375 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8376 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8377 this bound. Note that recursive calls will maintain this invariant.
8379 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8380 dx01 = half(dx0 + dx1);
8381 dx12 = half(dx1 + dx2);
8382 dx02 = half(dx01 + dx12);
8383 dy01 = half(dy0 + dy1);
8384 dy12 = half(dy1 + dy2);
8385 dy02 = half(dy01 + dy12)
8387 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8388 |a_goal=el_gordo| is guaranteed to yield the arc length.
8390 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8391 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8392 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8394 arc1 = v002 + half(halfp(v0+tmp) - v002);
8395 arc = v022 + half(halfp(v2+tmp) - v022);
8396 if ( (arc < el_gordo-arc1) ) {
8399 mp->arith_error = true;
8400 if ( a_goal==el_gordo ) return (el_gordo);
8404 @ @<Other local variables in |arc_test|@>=
8405 scaled tmp, tmp2; /* all purpose temporary registers */
8406 scaled arc1; /* arc length estimate for the first half */
8408 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8409 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8410 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8412 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8413 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8415 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8416 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8418 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8419 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8422 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8424 it is appropriate to use the same approximation to decide when the integral
8425 reaches the intermediate value |a_goal|. At this point
8427 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8428 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8429 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8430 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8431 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8435 $$ {\vb\dot B(t)\vb\over 3} \approx
8436 \cases{B\left(\hbox{|v0|},
8437 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8438 {1\over 2}\hbox{|v02|}; 2t \right)&
8439 if $t\le{1\over 2}$\cr
8440 B\left({1\over 2}\hbox{|v02|},
8441 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8442 \hbox{|v2|}; 2t-1 \right)&
8443 if $t\ge{1\over 2}$.\cr}
8446 We can integrate $\vb\dot B(t)\vb$ by using
8447 $$\int 3B(a,b,c;\tau)\,dt =
8448 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8451 This construction allows us to find the time when the arc length reaches
8452 |a_goal| by solving a cubic equation of the form
8453 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8454 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8455 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8456 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8457 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8458 $\tau$ given $a$, $b$, $c$, and $x$.
8460 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8462 tmp = (v02 + 2) / 4;
8463 if ( a_goal<=arc1 ) {
8466 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8469 return ((half_unit - two) +
8470 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8474 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8475 $$ B(0, a, a+b, a+b+c; t) = x. $$
8476 This routine is based on |crossing_point| but is simplified by the
8477 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8478 If rounding error causes this condition to be violated slightly, we just ignore
8479 it and proceed with binary search. This finds a time when the function value
8480 reaches |x| and the slope is positive.
8482 @<Declare subroutines needed by |arc_test|@>=
8483 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8484 scaled ab, bc, ac; /* bisection results */
8485 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8486 integer xx; /* temporary for updating |x| */
8487 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8488 @:this can't happen rising?}{\quad rising?@>
8491 } else if ( x >= a+b+c ) {
8495 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8499 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8500 xx = x - a - ab - ac;
8501 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8502 else { x = x + xx; a=ac; b=bc; t = t+1; };
8503 } while (t < unity);
8508 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8513 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8515 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8516 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8523 @ It is convenient to have a simpler interface to |arc_test| that requires no
8524 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8525 length less than |fraction_four|.
8527 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8529 @c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8530 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8531 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8532 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8533 v0 = mp_pyth_add(mp, dx0,dy0);
8534 v1 = mp_pyth_add(mp, dx1,dy1);
8535 v2 = mp_pyth_add(mp, dx2,dy2);
8536 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8537 mp->arith_error = true;
8538 if ( a_goal==el_gordo ) return el_gordo;
8541 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8542 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8543 v0, v02, v2, a_goal, arc_tol));
8547 @ Now it is easy to find the arc length of an entire path.
8549 @c scaled mp_get_arc_length (MP mp,pointer h) {
8550 pointer p,q; /* for traversing the path */
8551 scaled a,a_tot; /* current and total arc lengths */
8554 while ( right_type(p)!=mp_endpoint ){
8556 a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8557 left_x(q)-right_x(p), left_y(q)-right_y(p),
8558 x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
8559 a_tot = mp_slow_add(mp, a, a_tot);
8560 if ( q==h ) break; else p=q;
8566 @ The inverse operation of finding the time on a path~|h| when the arc length
8567 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8568 is required to handle very large times or negative times on cyclic paths. For
8569 non-cyclic paths, |arc0| values that are negative or too large cause
8570 |get_arc_time| to return 0 or the length of path~|h|.
8572 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8573 time value greater than the length of the path. Since it could be much greater,
8574 we must be prepared to compute the arc length of path~|h| and divide this into
8575 |arc0| to find how many multiples of the length of path~|h| to add.
8577 @c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8578 pointer p,q; /* for traversing the path */
8579 scaled t_tot; /* accumulator for the result */
8580 scaled t; /* the result of |do_arc_test| */
8581 scaled arc; /* portion of |arc0| not used up so far */
8582 integer n; /* number of extra times to go around the cycle */
8584 @<Deal with a negative |arc0| value and |return|@>;
8586 if ( arc0==el_gordo ) decr(arc0);
8590 while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
8592 t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8593 left_x(q)-right_x(p), left_y(q)-right_y(p),
8594 x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
8595 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8597 @<Update |t_tot| and |arc| to avoid going around the cyclic
8598 path too many times but set |arith_error:=true| and |goto done| on
8607 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8608 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8609 else { t_tot = t_tot + unity; arc = arc - t; }
8611 @ @<Deal with a negative |arc0| value and |return|@>=
8613 if ( left_type(h)==mp_endpoint ) {
8616 p = mp_htap_ypoc(mp, h);
8617 t_tot = -mp_get_arc_time(mp, p, -arc0);
8618 mp_toss_knot_list(mp, p);
8624 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8626 n = arc / (arc0 - arc);
8627 arc = arc - n*(arc0 - arc);
8628 if ( t_tot > (el_gordo / (n+1)) ) {
8631 t_tot = (n + 1)*t_tot;
8634 @* \[20] Data structures for pens.
8635 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8636 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8637 @:stroke}{\&{stroke} command@>
8638 converted into an area fill as described in the next part of this program.
8639 The mathematics behind this process is based on simple aspects of the theory
8640 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8641 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8642 Foundations of Computer Science {\bf 24} (1983), 100--111].
8644 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8645 @:makepen_}{\&{makepen} primitive@>
8646 This path representation is almost sufficient for our purposes except that
8647 a pen path should always be a convex polygon with the vertices in
8648 counter-clockwise order.
8649 Since we will need to scan pen polygons both forward and backward, a pen
8650 should be represented as a doubly linked ring of knot nodes. There is
8651 room for the extra back pointer because we do not need the
8652 |left_type| or |right_type| fields. In fact, we don't need the |left_x|,
8653 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
8654 so that certain procedures can operate on both pens and paths. In particular,
8655 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8658 /* this replaces the |left_type| and |right_type| fields in a pen knot */
8660 @ The |make_pen| procedure turns a path into a pen by initializing
8661 the |knil| pointers and making sure the knots form a convex polygon.
8662 Thus each cubic in the given path becomes a straight line and the control
8663 points are ignored. If the path is not cyclic, the ends are connected by a
8666 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8668 @c @<Declare a function called |convex_hull|@>
8669 pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8670 pointer p,q; /* two consecutive knots */
8677 h=mp_convex_hull(mp, h);
8678 @<Make sure |h| isn't confused with an elliptical pen@>;
8683 @ The only information required about an elliptical pen is the overall
8684 transformation that has been applied to the original \&{pencircle}.
8685 @:pencircle_}{\&{pencircle} primitive@>
8686 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8687 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8688 knot node and transformed as if it were a path.
8690 @d pen_is_elliptical(A) ((A)==link((A)))
8692 @c pointer mp_get_pen_circle (MP mp,scaled diam) {
8693 pointer h; /* the knot node to return */
8694 h=mp_get_node(mp, knot_node_size);
8695 link(h)=h; knil(h)=h;
8696 originator(h)=mp_program_code;
8697 x_coord(h)=0; y_coord(h)=0;
8698 left_x(h)=diam; left_y(h)=0;
8699 right_x(h)=0; right_y(h)=diam;
8703 @ If the polygon being returned by |make_pen| has only one vertex, it will
8704 be interpreted as an elliptical pen. This is no problem since a degenerate
8705 polygon can equally well be thought of as a degenerate ellipse. We need only
8706 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
8708 @<Make sure |h| isn't confused with an elliptical pen@>=
8709 if ( pen_is_elliptical( h) ){
8710 left_x(h)=x_coord(h); left_y(h)=y_coord(h);
8711 right_x(h)=x_coord(h); right_y(h)=y_coord(h);
8714 @ We have to cheat a little here but most operations on pens only use
8715 the first three words in each knot node.
8716 @^data structure assumptions@>
8718 @<Initialize a pen at |test_pen| so that it fits in nine words@>=
8719 x_coord(test_pen)=-half_unit;
8720 y_coord(test_pen)=0;
8721 x_coord(test_pen+3)=half_unit;
8722 y_coord(test_pen+3)=0;
8723 x_coord(test_pen+6)=0;
8724 y_coord(test_pen+6)=unity;
8725 link(test_pen)=test_pen+3;
8726 link(test_pen+3)=test_pen+6;
8727 link(test_pen+6)=test_pen;
8728 knil(test_pen)=test_pen+6;
8729 knil(test_pen+3)=test_pen;
8730 knil(test_pen+6)=test_pen+3
8732 @ Printing a polygonal pen is very much like printing a path
8734 @<Declare subroutines for printing expressions@>=
8735 void mp_pr_pen (MP mp,pointer h) {
8736 pointer p,q; /* for list traversal */
8737 if ( pen_is_elliptical(h) ) {
8738 @<Print the elliptical pen |h|@>;
8742 mp_print_two(mp, x_coord(p),y_coord(p));
8743 mp_print_nl(mp, " .. ");
8744 @<Advance |p| making sure the links are OK and |return| if there is
8747 mp_print(mp, "cycle");
8751 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8753 if ( (q==null) || (knil(q)!=p) ) {
8754 mp_print_nl(mp, "???"); return; /* this won't happen */
8759 @ @<Print the elliptical pen |h|@>=
8761 mp_print(mp, "pencircle transformed (");
8762 mp_print_scaled(mp, x_coord(h));
8763 mp_print_char(mp, ',');
8764 mp_print_scaled(mp, y_coord(h));
8765 mp_print_char(mp, ',');
8766 mp_print_scaled(mp, left_x(h)-x_coord(h));
8767 mp_print_char(mp, ',');
8768 mp_print_scaled(mp, right_x(h)-x_coord(h));
8769 mp_print_char(mp, ',');
8770 mp_print_scaled(mp, left_y(h)-y_coord(h));
8771 mp_print_char(mp, ',');
8772 mp_print_scaled(mp, right_y(h)-y_coord(h));
8773 mp_print_char(mp, ')');
8776 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8779 @<Declare subroutines for printing expressions@>=
8780 void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
8781 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8784 mp_end_diagnostic(mp, true);
8787 @ Making a polygonal pen into a path involves restoring the |left_type| and
8788 |right_type| fields and setting the control points so as to make a polygonal
8792 void mp_make_path (MP mp,pointer h) {
8793 pointer p; /* for traversing the knot list */
8794 small_number k; /* a loop counter */
8795 @<Other local variables in |make_path|@>;
8796 if ( pen_is_elliptical(h) ) {
8797 @<Make the elliptical pen |h| into a path@>;
8801 left_type(p)=mp_explicit;
8802 right_type(p)=mp_explicit;
8803 @<copy the coordinates of knot |p| into its control points@>;
8809 @ @<copy the coordinates of knot |p| into its control points@>=
8810 left_x(p)=x_coord(p);
8811 left_y(p)=y_coord(p);
8812 right_x(p)=x_coord(p);
8813 right_y(p)=y_coord(p)
8815 @ We need an eight knot path to get a good approximation to an ellipse.
8817 @<Make the elliptical pen |h| into a path@>=
8819 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8821 for (k=0;k<=7;k++ ) {
8822 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8823 transforming it appropriately@>;
8824 if ( k==7 ) link(p)=h; else link(p)=mp_get_node(mp, knot_node_size);
8829 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8830 center_x=x_coord(h);
8831 center_y=y_coord(h);
8832 width_x=left_x(h)-center_x;
8833 width_y=left_y(h)-center_y;
8834 height_x=right_x(h)-center_x;
8835 height_y=right_y(h)-center_y
8837 @ @<Other local variables in |make_path|@>=
8838 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8839 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8840 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8841 scaled dx,dy; /* the vector from knot |p| to its right control point */
8843 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8845 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8846 find the point $k/8$ of the way around the circle and the direction vector
8849 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8851 x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8852 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8853 y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8854 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8855 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8856 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8857 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8858 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8859 right_x(p)=x_coord(p)+dx;
8860 right_y(p)=y_coord(p)+dy;
8861 left_x(p)=x_coord(p)-dx;
8862 left_y(p)=y_coord(p)-dy;
8863 left_type(p)=mp_explicit;
8864 right_type(p)=mp_explicit;
8865 originator(p)=mp_program_code
8868 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8869 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8871 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8872 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8873 function for $\theta=\phi=22.5^\circ$. This comes out to be
8874 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8875 \approx 0.132608244919772.
8879 mp->half_cos[0]=fraction_half;
8880 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8882 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8883 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8885 for (k=3;k<= 4;k++ ) {
8886 mp->half_cos[k]=-mp->half_cos[4-k];
8887 mp->d_cos[k]=-mp->d_cos[4-k];
8889 for (k=5;k<= 7;k++ ) {
8890 mp->half_cos[k]=mp->half_cos[8-k];
8891 mp->d_cos[k]=mp->d_cos[8-k];
8894 @ The |convex_hull| function forces a pen polygon to be convex when it is
8895 returned by |make_pen| and after any subsequent transformation where rounding
8896 error might allow the convexity to be lost.
8897 The convex hull algorithm used here is described by F.~P. Preparata and
8898 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8900 @<Declare a function called |convex_hull|@>=
8901 @<Declare a procedure called |move_knot|@>
8902 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8903 pointer l,r; /* the leftmost and rightmost knots */
8904 pointer p,q; /* knots being scanned */
8905 pointer s; /* the starting point for an upcoming scan */
8906 scaled dx,dy; /* a temporary pointer */
8907 if ( pen_is_elliptical(h) ) {
8910 @<Set |l| to the leftmost knot in polygon~|h|@>;
8911 @<Set |r| to the rightmost knot in polygon~|h|@>;
8914 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8915 move them past~|r|@>;
8916 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8917 move them past~|l|@>;
8918 @<Sort the path from |l| to |r| by increasing $x$@>;
8919 @<Sort the path from |r| to |l| by decreasing $x$@>;
8922 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8928 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8930 @<Set |l| to the leftmost knot in polygon~|h|@>=
8934 if ( x_coord(p)<=x_coord(l) )
8935 if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
8940 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8944 if ( x_coord(p)>=x_coord(r) )
8945 if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
8950 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8951 dx=x_coord(r)-x_coord(l);
8952 dy=y_coord(r)-y_coord(l);
8956 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
8957 mp_move_knot(mp, p, r);
8961 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8964 @ @<Declare a procedure called |move_knot|@>=
8965 void mp_move_knot (MP mp,pointer p, pointer q) {
8966 link(knil(p))=link(p);
8967 knil(link(p))=knil(p);
8974 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8978 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
8979 mp_move_knot(mp, p,l);
8983 @ The list is likely to be in order already so we just do linear insertions.
8984 Secondary comparisons on $y$ ensure that the sort is consistent with the
8985 choice of |l| and |r|.
8987 @<Sort the path from |l| to |r| by increasing $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 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
9003 while ( x_coord(q)<x_coord(p) ) q=knil(q);
9004 while ( x_coord(q)==x_coord(p) ) {
9005 if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
9007 if ( q==knil(p) ) p=link(p);
9008 else { p=link(p); mp_move_knot(mp, knil(p),q); };
9011 @ The condition involving |ab_vs_cd| tests if there is not a left turn
9012 at knot |q|. There usually will be a left turn so we streamline the case
9013 where the |then| clause is not executed.
9015 @<Do a Gramm scan and remove vertices where there...@>=
9019 dx=x_coord(q)-x_coord(p);
9020 dy=y_coord(q)-y_coord(p);
9024 if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
9025 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
9030 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
9033 mp_free_node(mp, p,knot_node_size);
9034 link(s)=q; knil(q)=s;
9036 else { p=knil(s); q=s; };
9039 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
9040 offset associated with the given direction |(x,y)|. If two different offsets
9041 apply, it chooses one of them.
9044 void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
9045 pointer p,q; /* consecutive knots */
9047 /* the transformation matrix for an elliptical pen */
9048 fraction xx,yy; /* untransformed offset for an elliptical pen */
9049 fraction d; /* a temporary register */
9050 if ( pen_is_elliptical(h) ) {
9051 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
9056 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
9059 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
9060 mp->cur_x=x_coord(p);
9061 mp->cur_y=y_coord(p);
9067 scaled cur_y; /* all-purpose return value registers */
9069 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
9070 if ( (x==0) && (y==0) ) {
9071 mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
9073 @<Find the non-constant part of the transformation for |h|@>;
9074 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
9077 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
9078 untransformed version of |(x,y)|@>;
9079 mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
9080 mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
9083 @ @<Find the non-constant part of the transformation for |h|@>=
9084 wx=left_x(h)-x_coord(h);
9085 wy=left_y(h)-y_coord(h);
9086 hx=right_x(h)-x_coord(h);
9087 hy=right_y(h)-y_coord(h)
9089 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
9090 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
9091 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
9092 d=mp_pyth_add(mp, xx,yy);
9094 xx=half(mp_make_fraction(mp, xx,d));
9095 yy=half(mp_make_fraction(mp, yy,d));
9098 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
9099 But we can handle that case by just calling |find_offset| twice. The answer
9100 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
9103 void mp_pen_bbox (MP mp,pointer h) {
9104 pointer p; /* for scanning the knot list */
9105 if ( pen_is_elliptical(h) ) {
9106 @<Find the bounding box of an elliptical pen@>;
9108 minx=x_coord(h); maxx=minx;
9109 miny=y_coord(h); maxy=miny;
9112 if ( x_coord(p)<minx ) minx=x_coord(p);
9113 if ( y_coord(p)<miny ) miny=y_coord(p);
9114 if ( x_coord(p)>maxx ) maxx=x_coord(p);
9115 if ( y_coord(p)>maxy ) maxy=y_coord(p);
9121 @ @<Find the bounding box of an elliptical pen@>=
9123 mp_find_offset(mp, 0,fraction_one,h);
9125 minx=2*x_coord(h)-mp->cur_x;
9126 mp_find_offset(mp, -fraction_one,0,h);
9128 miny=2*y_coord(h)-mp->cur_y;
9131 @* \[21] Edge structures.
9132 Now we come to \MP's internal scheme for representing pictures.
9133 The representation is very different from \MF's edge structures
9134 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9135 images. However, the basic idea is somewhat similar in that shapes
9136 are represented via their boundaries.
9138 The main purpose of edge structures is to keep track of graphical objects
9139 until it is time to translate them into \ps. Since \MP\ does not need to
9140 know anything about an edge structure other than how to translate it into
9141 \ps\ and how to find its bounding box, edge structures can be just linked
9142 lists of graphical objects. \MP\ has no easy way to determine whether
9143 two such objects overlap, but it suffices to draw the first one first and
9144 let the second one overwrite it if necessary.
9147 enum mp_graphical_object_code {
9148 @<Graphical object codes@>
9152 @ Let's consider the types of graphical objects one at a time.
9153 First of all, a filled contour is represented by a eight-word node. The first
9154 word contains |type| and |link| fields, and the next six words contain a
9155 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9156 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9157 give the relevant information.
9159 @d path_p(A) link((A)+1)
9160 /* a pointer to the path that needs filling */
9161 @d pen_p(A) info((A)+1)
9162 /* a pointer to the pen to fill or stroke with */
9163 @d color_model(A) type((A)+2) /* the color model */
9164 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9165 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9166 @d obj_grey_loc obj_red_loc /* the location for the color */
9167 @d red_val(A) mp->mem[(A)+3].sc
9168 /* the red component of the color in the range $0\ldots1$ */
9171 @d green_val(A) mp->mem[(A)+4].sc
9172 /* the green component of the color in the range $0\ldots1$ */
9173 @d magenta_val green_val
9174 @d blue_val(A) mp->mem[(A)+5].sc
9175 /* the blue component of the color in the range $0\ldots1$ */
9176 @d yellow_val blue_val
9177 @d black_val(A) mp->mem[(A)+6].sc
9178 /* the blue component of the color in the range $0\ldots1$ */
9179 @d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
9180 @:mp_linejoin_}{\&{linejoin} primitive@>
9181 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9182 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9183 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9184 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9185 @d pre_script(A) mp->mem[(A)+8].hh.lh
9186 @d post_script(A) mp->mem[(A)+8].hh.rh
9189 @ @<Graphical object codes@>=
9193 pointer mp_new_fill_node (MP mp,pointer p) {
9194 /* make a fill node for cyclic path |p| and color black */
9195 pointer t; /* the new node */
9196 t=mp_get_node(mp, fill_node_size);
9197 type(t)=mp_fill_code;
9199 pen_p(t)=null; /* |null| means don't use a pen */
9204 color_model(t)=mp_uninitialized_model;
9206 post_script(t)=null;
9207 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9211 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9212 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9213 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9214 else ljoin_val(t)=0;
9215 if ( mp->internal[mp_miterlimit]<unity )
9216 miterlim_val(t)=unity;
9218 miterlim_val(t)=mp->internal[mp_miterlimit]
9220 @ A stroked path is represented by an eight-word node that is like a filled
9221 contour node except that it contains the current \&{linecap} value, a scale
9222 factor for the dash pattern, and a pointer that is non-null if the stroke
9223 is to be dashed. The purpose of the scale factor is to allow a picture to
9224 be transformed without touching the picture that |dash_p| points to.
9226 @d dash_p(A) link((A)+9)
9227 /* a pointer to the edge structure that gives the dash pattern */
9228 @d lcap_val(A) type((A)+9)
9229 /* the value of \&{linecap} */
9230 @:mp_linecap_}{\&{linecap} primitive@>
9231 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9232 @d stroked_node_size 11
9234 @ @<Graphical object codes@>=
9238 pointer mp_new_stroked_node (MP mp,pointer p) {
9239 /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
9240 pointer t; /* the new node */
9241 t=mp_get_node(mp, stroked_node_size);
9242 type(t)=mp_stroked_code;
9243 path_p(t)=p; pen_p(t)=null;
9245 dash_scale(t)=unity;
9250 color_model(t)=mp_uninitialized_model;
9252 post_script(t)=null;
9253 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9254 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9255 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9260 @ When a dashed line is computed in a transformed coordinate system, the dash
9261 lengths get scaled like the pen shape and we need to compensate for this. Since
9262 there is no unique scale factor for an arbitrary transformation, we use the
9263 the square root of the determinant. The properties of the determinant make it
9264 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9265 except for the initialization of the scale factor |s|. The factor of 64 is
9266 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9267 to counteract the effect of |take_fraction|.
9269 @<Declare subroutines needed by |print_edges|@>=
9270 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9271 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9272 integer s; /* amount by which the result of |square_rt| needs to be scaled */
9273 @<Initialize |maxabs|@>;
9275 while ( (maxabs<fraction_one) && (s>1) ){
9276 a+=a; b+=b; c+=c; d+=d;
9277 maxabs+=maxabs; s=halfp(s);
9279 return s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)));
9282 scaled mp_get_pen_scale (MP mp,pointer p) {
9283 return mp_sqrt_det(mp,
9284 left_x(p)-x_coord(p), right_x(p)-x_coord(p),
9285 left_y(p)-y_coord(p), right_y(p)-y_coord(p));
9288 @ @<Internal library ...@>=
9289 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9292 @ @<Initialize |maxabs|@>=
9294 if ( abs(b)>maxabs ) maxabs=abs(b);
9295 if ( abs(c)>maxabs ) maxabs=abs(c);
9296 if ( abs(d)>maxabs ) maxabs=abs(d)
9298 @ When a picture contains text, this is represented by a fourteen-word node
9299 where the color information and |type| and |link| fields are augmented by
9300 additional fields that describe the text and how it is transformed.
9301 The |path_p| and |pen_p| pointers are replaced by a number that identifies
9302 the font and a string number that gives the text to be displayed.
9303 The |width|, |height|, and |depth| fields
9304 give the dimensions of the text at its design size, and the remaining six
9305 words give a transformation to be applied to the text. The |new_text_node|
9306 function initializes everything to default values so that the text comes out
9307 black with its reference point at the origin.
9309 @d text_p(A) link((A)+1) /* a string pointer for the text to display */
9310 @d font_n(A) info((A)+1) /* the font number */
9311 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9312 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9313 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9314 @d text_tx_loc(A) ((A)+11)
9315 /* the first of six locations for transformation parameters */
9316 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9317 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9318 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9319 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9320 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9321 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9322 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9323 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9324 @d text_node_size 17
9326 @ @<Graphical object codes@>=
9329 @ @c @<Declare text measuring subroutines@>
9330 pointer mp_new_text_node (MP mp,char *f,str_number s) {
9331 /* make a text node for font |f| and text string |s| */
9332 pointer t; /* the new node */
9333 t=mp_get_node(mp, text_node_size);
9334 type(t)=mp_text_code;
9336 font_n(t)=mp_find_font(mp, f); /* this identifies the font */
9341 color_model(t)=mp_uninitialized_model;
9343 post_script(t)=null;
9344 tx_val(t)=0; ty_val(t)=0;
9345 txx_val(t)=unity; txy_val(t)=0;
9346 tyx_val(t)=0; tyy_val(t)=unity;
9347 mp_set_text_box(mp, t); /* this finds the bounding box */
9351 @ The last two types of graphical objects that can occur in an edge structure
9352 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9353 @:set_bounds_}{\&{setbounds} primitive@>
9354 to implement because we must keep track of exactly what is being clipped or
9355 bounded when pictures get merged together. For this reason, each clipping or
9356 \&{setbounds} operation is represented by a pair of nodes: first comes a
9357 two-word node whose |path_p| gives the relevant path, then there is the list
9358 of objects to clip or bound followed by a two-word node whose second word is
9361 Using at least two words for each graphical object node allows them all to be
9362 allocated and deallocated similarly with a global array |gr_object_size| to
9363 give the size in words for each object type.
9365 @d start_clip_size 2
9366 @d start_bounds_size 2
9367 @d stop_clip_size 2 /* the second word is not used here */
9368 @d stop_bounds_size 2 /* the second word is not used here */
9370 @d stop_type(A) ((A)+2)
9371 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9372 @d has_color(A) (type((A))<mp_start_clip_code)
9373 /* does a graphical object have color fields? */
9374 @d has_pen(A) (type((A))<mp_text_code)
9375 /* does a graphical object have a |pen_p| field? */
9376 @d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
9377 @d is_stop(A) (type((A))>=mp_stop_clip_code)
9379 @ @<Graphical object codes@>=
9380 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9381 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9382 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9383 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9386 pointer mp_new_bounds_node (MP mp,pointer p, small_number c) {
9387 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9388 pointer t; /* the new node */
9389 t=mp_get_node(mp, mp->gr_object_size[c]);
9395 @ We need an array to keep track of the sizes of graphical objects.
9398 small_number gr_object_size[mp_stop_bounds_code+1];
9401 mp->gr_object_size[mp_fill_code]=fill_node_size;
9402 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9403 mp->gr_object_size[mp_text_code]=text_node_size;
9404 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9405 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9406 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9407 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9409 @ All the essential information in an edge structure is encoded as a linked list
9410 of graphical objects as we have just seen, but it is helpful to add some
9411 redundant information. A single edge structure might be used as a dash pattern
9412 many times, and it would be nice to avoid scanning the same structure
9413 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9414 has a header that gives a list of dashes in a sorted order designed for rapid
9415 translation into \ps.
9417 Each dash is represented by a three-word node containing the initial and final
9418 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9419 the dash node with the next higher $x$-coordinates and the final link points
9420 to a special location called |null_dash|. (There should be no overlap between
9421 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9422 the period of repetition, this needs to be stored in the edge header along
9423 with a pointer to the list of dash nodes.
9425 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9426 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9429 /* in an edge header this points to the first dash node */
9430 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9432 @ It is also convenient for an edge header to contain the bounding
9433 box information needed by the \&{llcorner} and \&{urcorner} operators
9434 so that this does not have to be recomputed unnecessarily. This is done by
9435 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9436 how far the bounding box computation has gotten. Thus if the user asks for
9437 the bounding box and then adds some more text to the picture before asking
9438 for more bounding box information, the second computation need only look at
9439 the additional text.
9441 When the bounding box has not been computed, the |bblast| pointer points
9442 to a dummy link at the head of the graphical object list while the |minx_val|
9443 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9444 fields contain |-el_gordo|.
9446 Since the bounding box of pictures containing objects of type
9447 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9448 @:mp_true_corners_}{\&{truecorners} primitive@>
9449 data might not be valid for all values of this parameter. Hence, the |bbtype|
9450 field is needed to keep track of this.
9452 @d minx_val(A) mp->mem[(A)+2].sc
9453 @d miny_val(A) mp->mem[(A)+3].sc
9454 @d maxx_val(A) mp->mem[(A)+4].sc
9455 @d maxy_val(A) mp->mem[(A)+5].sc
9456 @d bblast(A) link((A)+6) /* last item considered in bounding box computation */
9457 @d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9458 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9460 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9462 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9464 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9467 void mp_init_bbox (MP mp,pointer h) {
9468 /* Initialize the bounding box information in edge structure |h| */
9469 bblast(h)=dummy_loc(h);
9470 bbtype(h)=no_bounds;
9471 minx_val(h)=el_gordo;
9472 miny_val(h)=el_gordo;
9473 maxx_val(h)=-el_gordo;
9474 maxy_val(h)=-el_gordo;
9477 @ The only other entries in an edge header are a reference count in the first
9478 word and a pointer to the tail of the object list in the last word.
9480 @d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
9481 @d edge_header_size 8
9484 void mp_init_edges (MP mp,pointer h) {
9485 /* initialize an edge header to null values */
9486 dash_list(h)=null_dash;
9487 obj_tail(h)=dummy_loc(h);
9488 link(dummy_loc(h))=null;
9490 mp_init_bbox(mp, h);
9493 @ Here is how edge structures are deleted. The process can be recursive because
9494 of the need to dereference edge structures that are used as dash patterns.
9497 @d add_edge_ref(A) incr(ref_count(A))
9498 @d delete_edge_ref(A) {
9499 if ( ref_count((A))==null )
9500 mp_toss_edges(mp, A);
9505 @<Declare the recycling subroutines@>=
9506 void mp_flush_dash_list (MP mp,pointer h);
9507 pointer mp_toss_gr_object (MP mp,pointer p) ;
9508 void mp_toss_edges (MP mp,pointer h) ;
9510 @ @c void mp_toss_edges (MP mp,pointer h) {
9511 pointer p,q; /* pointers that scan the list being recycled */
9512 pointer r; /* an edge structure that object |p| refers to */
9513 mp_flush_dash_list(mp, h);
9514 q=link(dummy_loc(h));
9515 while ( (q!=null) ) {
9517 r=mp_toss_gr_object(mp, p);
9518 if ( r!=null ) delete_edge_ref(r);
9520 mp_free_node(mp, h,edge_header_size);
9522 void mp_flush_dash_list (MP mp,pointer h) {
9523 pointer p,q; /* pointers that scan the list being recycled */
9525 while ( q!=null_dash ) {
9527 mp_free_node(mp, p,dash_node_size);
9529 dash_list(h)=null_dash;
9531 pointer mp_toss_gr_object (MP mp,pointer p) {
9532 /* returns an edge structure that needs to be dereferenced */
9533 pointer e; /* the edge structure to return */
9535 @<Prepare to recycle graphical object |p|@>;
9536 mp_free_node(mp, p,mp->gr_object_size[type(p)]);
9540 @ @<Prepare to recycle graphical object |p|@>=
9543 mp_toss_knot_list(mp, path_p(p));
9544 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_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_stroked_code:
9549 mp_toss_knot_list(mp, path_p(p));
9550 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9551 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9552 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9556 delete_str_ref(text_p(p));
9557 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9558 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9560 case mp_start_clip_code:
9561 case mp_start_bounds_code:
9562 mp_toss_knot_list(mp, path_p(p));
9564 case mp_stop_clip_code:
9565 case mp_stop_bounds_code:
9567 } /* there are no other cases */
9569 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9570 to be done before making a significant change to an edge structure. Much of
9571 the work is done in a separate routine |copy_objects| that copies a list of
9572 graphical objects into a new edge header.
9574 @c @<Declare a function called |copy_objects|@>
9575 pointer mp_private_edges (MP mp,pointer h) {
9576 /* make a private copy of the edge structure headed by |h| */
9577 pointer hh; /* the edge header for the new copy */
9578 pointer p,pp; /* pointers for copying the dash list */
9579 if ( ref_count(h)==null ) {
9583 hh=mp_copy_objects(mp, link(dummy_loc(h)),null);
9584 @<Copy the dash list from |h| to |hh|@>;
9585 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9586 point into the new object list@>;
9591 @ Here we use the fact that |dash_list(hh)=link(hh)|.
9592 @^data structure assumptions@>
9594 @<Copy the dash list from |h| to |hh|@>=
9595 pp=hh; p=dash_list(h);
9596 while ( (p!=null_dash) ) {
9597 link(pp)=mp_get_node(mp, dash_node_size);
9599 start_x(pp)=start_x(p);
9600 stop_x(pp)=stop_x(p);
9604 dash_y(hh)=dash_y(h)
9607 @ |h| is an edge structure
9610 mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
9613 scaled scf; /* scale factor */
9614 scaled *dashes = NULL;
9617 if (h==null || dash_list(h)==null_dash)
9620 scf=mp_get_pen_scale(mp, pen_p(q));
9622 if (*w==0) scf = dash_scale(q); else return NULL;
9624 scf=mp_make_scaled(mp, *w,scf);
9625 scf=mp_take_scaled(mp, scf,dash_scale(q));
9628 d = mp_xmalloc(mp,1,sizeof(mp_dash_object));
9629 start_x(null_dash)=start_x(p)+dash_y(h);
9630 while (p != null_dash) {
9631 dashes = mp_xrealloc(mp, dashes, num_dashes+2, sizeof(scaled));
9632 dashes[(num_dashes-1)] =
9633 mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
9634 dashes[(num_dashes)] =
9635 mp_take_scaled(mp,(start_x(link(p))-stop_x(p)),scf);
9636 dashes[(num_dashes+1)] = -1; /* terminus */
9640 d->array_field = dashes;
9642 mp_take_scaled(mp,mp_dash_offset(mp, h),scf);
9648 @ @<Copy the bounding box information from |h| to |hh|...@>=
9649 minx_val(hh)=minx_val(h);
9650 miny_val(hh)=miny_val(h);
9651 maxx_val(hh)=maxx_val(h);
9652 maxy_val(hh)=maxy_val(h);
9653 bbtype(hh)=bbtype(h);
9654 p=dummy_loc(h); pp=dummy_loc(hh);
9655 while ((p!=bblast(h)) ) {
9656 if ( p==null ) mp_confusion(mp, "bblast");
9657 @:this can't happen bblast}{\quad bblast@>
9658 p=link(p); pp=link(pp);
9662 @ Here is the promised routine for copying graphical objects into a new edge
9663 structure. It starts copying at object~|p| and stops just before object~|q|.
9664 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9665 structure requires further initialization by |init_bbox|.
9667 @<Declare a function called |copy_objects|@>=
9668 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9669 pointer hh; /* the new edge header */
9670 pointer pp; /* the last newly copied object */
9671 small_number k; /* temporary register */
9672 hh=mp_get_node(mp, edge_header_size);
9673 dash_list(hh)=null_dash;
9677 @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9684 @ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9685 { k=mp->gr_object_size[type(p)];
9686 link(pp)=mp_get_node(mp, k);
9688 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9689 @<Fix anything in graphical object |pp| that should differ from the
9690 corresponding field in |p|@>;
9694 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9696 case mp_start_clip_code:
9697 case mp_start_bounds_code:
9698 path_p(pp)=mp_copy_path(mp, path_p(p));
9701 path_p(pp)=mp_copy_path(mp, path_p(p));
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 if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
9706 case mp_stroked_code:
9707 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9708 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9709 path_p(pp)=mp_copy_path(mp, path_p(p));
9710 pen_p(pp)=copy_pen(pen_p(p));
9711 if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
9714 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9715 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9716 add_str_ref(text_p(pp));
9718 case mp_stop_clip_code:
9719 case mp_stop_bounds_code:
9721 } /* there are no other cases */
9723 @ Here is one way to find an acceptable value for the second argument to
9724 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9725 skips past one picture component, where a ``picture component'' is a single
9726 graphical object, or a start bounds or start clip object and everything up
9727 through the matching stop bounds or stop clip object. The macro version avoids
9728 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9729 unless |p| points to a stop bounds or stop clip node, in which case it executes
9732 @d skip_component(A)
9733 if ( ! is_start_or_stop((A)) ) (A)=link((A));
9734 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9738 pointer mp_skip_1component (MP mp,pointer p) {
9739 integer lev; /* current nesting level */
9742 if ( is_start_or_stop(p) ) {
9743 if ( is_stop(p) ) decr(lev); else incr(lev);
9750 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9752 @<Declare subroutines for printing expressions@>=
9753 @<Declare subroutines needed by |print_edges|@>
9754 void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
9755 pointer p; /* a graphical object to be printed */
9756 pointer hh,pp; /* temporary pointers */
9757 scaled scf; /* a scale factor for the dash pattern */
9758 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9759 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9761 while ( link(p)!=null ) {
9765 @<Cases for printing graphical object node |p|@>;
9767 mp_print(mp, "[unknown object type!]");
9771 mp_print_nl(mp, "End edges");
9772 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9774 mp_end_diagnostic(mp, true);
9777 @ @<Cases for printing graphical object node |p|@>=
9779 mp_print(mp, "Filled contour ");
9780 mp_print_obj_color(mp, p);
9781 mp_print_char(mp, ':'); mp_print_ln(mp);
9782 mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
9783 if ( (pen_p(p)!=null) ) {
9784 @<Print join type for graphical object |p|@>;
9785 mp_print(mp, " with pen"); mp_print_ln(mp);
9786 mp_pr_pen(mp, pen_p(p));
9790 @ @<Print join type for graphical object |p|@>=
9791 switch (ljoin_val(p)) {
9793 mp_print(mp, "mitered joins limited ");
9794 mp_print_scaled(mp, miterlim_val(p));
9797 mp_print(mp, "round joins");
9800 mp_print(mp, "beveled joins");
9803 mp_print(mp, "?? joins");
9808 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9810 @<Print join and cap types for stroked node |p|@>=
9811 switch (lcap_val(p)) {
9812 case 0:mp_print(mp, "butt"); break;
9813 case 1:mp_print(mp, "round"); break;
9814 case 2:mp_print(mp, "square"); break;
9815 default: mp_print(mp, "??"); break;
9818 mp_print(mp, " ends, ");
9819 @<Print join type for graphical object |p|@>
9821 @ Here is a routine that prints the color of a graphical object if it isn't
9822 black (the default color).
9824 @<Declare subroutines needed by |print_edges|@>=
9825 @<Declare a procedure called |print_compact_node|@>
9826 void mp_print_obj_color (MP mp,pointer p) {
9827 if ( color_model(p)==mp_grey_model ) {
9828 if ( grey_val(p)>0 ) {
9829 mp_print(mp, "greyed ");
9830 mp_print_compact_node(mp, obj_grey_loc(p),1);
9832 } else if ( color_model(p)==mp_cmyk_model ) {
9833 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9834 (yellow_val(p)>0) || (black_val(p)>0) ) {
9835 mp_print(mp, "processcolored ");
9836 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9838 } else if ( color_model(p)==mp_rgb_model ) {
9839 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9840 mp_print(mp, "colored ");
9841 mp_print_compact_node(mp, obj_red_loc(p),3);
9846 @ We also need a procedure for printing consecutive scaled values as if they
9847 were a known big node.
9849 @<Declare a procedure called |print_compact_node|@>=
9850 void mp_print_compact_node (MP mp,pointer p, small_number k) {
9851 pointer q; /* last location to print */
9853 mp_print_char(mp, '(');
9855 mp_print_scaled(mp, mp->mem[p].sc);
9856 if ( p<q ) mp_print_char(mp, ',');
9859 mp_print_char(mp, ')');
9862 @ @<Cases for printing graphical object node |p|@>=
9863 case mp_stroked_code:
9864 mp_print(mp, "Filled pen stroke ");
9865 mp_print_obj_color(mp, p);
9866 mp_print_char(mp, ':'); mp_print_ln(mp);
9867 mp_pr_path(mp, path_p(p));
9868 if ( dash_p(p)!=null ) {
9869 mp_print_nl(mp, "dashed (");
9870 @<Finish printing the dash pattern that |p| refers to@>;
9873 @<Print join and cap types for stroked node |p|@>;
9874 mp_print(mp, " with pen"); mp_print_ln(mp);
9875 if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9877 else mp_pr_pen(mp, pen_p(p));
9880 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9881 when it is not known to define a suitable dash pattern. This is disallowed
9882 here because the |dash_p| field should never point to such an edge header.
9883 Note that memory is allocated for |start_x(null_dash)| and we are free to
9884 give it any convenient value.
9886 @<Finish printing the dash pattern that |p| refers to@>=
9887 ok_to_dash=pen_is_elliptical(pen_p(p));
9888 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9891 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9892 mp_print(mp, " ??");
9893 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9894 while ( pp!=null_dash ) {
9895 mp_print(mp, "on ");
9896 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9897 mp_print(mp, " off ");
9898 mp_print_scaled(mp, mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
9900 if ( pp!=null_dash ) mp_print_char(mp, ' ');
9902 mp_print(mp, ") shifted ");
9903 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9904 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9907 @ @<Declare subroutines needed by |print_edges|@>=
9908 scaled mp_dash_offset (MP mp,pointer h) {
9909 scaled x; /* the answer */
9910 if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
9911 @:this can't happen dash0}{\quad dash0@>
9912 if ( dash_y(h)==0 ) {
9915 x=-(start_x(dash_list(h)) % dash_y(h));
9916 if ( x<0 ) x=x+dash_y(h);
9921 @ @<Cases for printing graphical object node |p|@>=
9923 mp_print_char(mp, '"'); mp_print_str(mp,text_p(p));
9924 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
9925 mp_print_char(mp, '"'); mp_print_ln(mp);
9926 mp_print_obj_color(mp, p);
9927 mp_print(mp, "transformed ");
9928 mp_print_compact_node(mp, text_tx_loc(p),6);
9931 @ @<Cases for printing graphical object node |p|@>=
9932 case mp_start_clip_code:
9933 mp_print(mp, "clipping path:");
9935 mp_pr_path(mp, path_p(p));
9937 case mp_stop_clip_code:
9938 mp_print(mp, "stop clipping");
9941 @ @<Cases for printing graphical object node |p|@>=
9942 case mp_start_bounds_code:
9943 mp_print(mp, "setbounds path:");
9945 mp_pr_path(mp, path_p(p));
9947 case mp_stop_bounds_code:
9948 mp_print(mp, "end of setbounds");
9951 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9952 subroutine that scans an edge structure and tries to interpret it as a dash
9953 pattern. This can only be done when there are no filled regions or clipping
9954 paths and all the pen strokes have the same color. The first step is to let
9955 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9956 project all the pen stroke paths onto the line $y=y_0$ and require that there
9957 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9958 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9959 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9961 @c @<Declare a procedure called |x_retrace_error|@>
9962 pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9963 pointer p; /* this scans the stroked nodes in the object list */
9964 pointer p0; /* if not |null| this points to the first stroked node */
9965 pointer pp,qq,rr; /* pointers into |path_p(p)| */
9966 pointer d,dd; /* pointers used to create the dash list */
9968 @<Other local variables in |make_dashes|@>;
9969 y0=0; /* the initial $y$ coordinate */
9970 if ( dash_list(h)!=null_dash )
9973 p=link(dummy_loc(h));
9975 if ( type(p)!=mp_stroked_code ) {
9976 @<Compain that the edge structure contains a node of the wrong type
9977 and |goto not_found|@>;
9980 if ( p0==null ){ p0=p; y0=y_coord(pp); };
9981 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9982 or |goto not_found| if there is an error@>;
9983 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9986 if ( dash_list(h)==null_dash )
9987 goto NOT_FOUND; /* No error message */
9988 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9989 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
9992 @<Flush the dash list, recycle |h| and return |null|@>;
9995 @ @<Compain that the edge structure contains a node of the wrong type...@>=
9997 print_err("Picture is too complicated to use as a dash pattern");
9998 help3("When you say `dashed p', picture p should not contain any")
9999 ("text, filled regions, or clipping paths. This time it did")
10000 ("so I'll just make it a solid line instead.");
10001 mp_put_get_error(mp);
10005 @ A similar error occurs when monotonicity fails.
10007 @<Declare a procedure called |x_retrace_error|@>=
10008 void mp_x_retrace_error (MP mp) {
10009 print_err("Picture is too complicated to use as a dash pattern");
10010 help3("When you say `dashed p', every path in p should be monotone")
10011 ("in x and there must be no overlapping. This failed")
10012 ("so I'll just make it a solid line instead.");
10013 mp_put_get_error(mp);
10016 @ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
10017 handle the case where the pen stroke |p| is itself dashed.
10019 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
10020 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
10023 if ( link(pp)!=pp ) {
10025 qq=rr; rr=link(rr);
10026 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
10027 if there is a problem@>;
10028 } while (right_type(rr)!=mp_endpoint);
10030 d=mp_get_node(mp, dash_node_size);
10031 if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
10032 if ( x_coord(pp)<x_coord(rr) ) {
10033 start_x(d)=x_coord(pp);
10034 stop_x(d)=x_coord(rr);
10036 start_x(d)=x_coord(rr);
10037 stop_x(d)=x_coord(pp);
10040 @ We also need to check for the case where the segment from |qq| to |rr| is
10041 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
10043 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
10048 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
10049 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
10050 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
10051 mp_x_retrace_error(mp); goto NOT_FOUND;
10055 if ( (x_coord(pp)>x0) || (x0>x3) ) {
10056 if ( (x_coord(pp)<x0) || (x0<x3) ) {
10057 mp_x_retrace_error(mp); goto NOT_FOUND;
10061 @ @<Other local variables in |make_dashes|@>=
10062 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
10064 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
10065 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
10066 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
10067 print_err("Picture is too complicated to use as a dash pattern");
10068 help3("When you say `dashed p', everything in picture p should")
10069 ("be the same color. I can\'t handle your color changes")
10070 ("so I'll just make it a solid line instead.");
10071 mp_put_get_error(mp);
10075 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
10076 start_x(null_dash)=stop_x(d);
10077 dd=h; /* this makes |link(dd)=dash_list(h)| */
10078 while ( start_x(link(dd))<stop_x(d) )
10081 if ( (stop_x(dd)>start_x(d)) )
10082 { mp_x_retrace_error(mp); goto NOT_FOUND; };
10087 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
10089 while ( (link(d)!=null_dash) )
10092 dash_y(h)=stop_x(d)-start_x(dd);
10093 if ( abs(y0)>dash_y(h) ) {
10095 } else if ( d!=dd ) {
10096 dash_list(h)=link(dd);
10097 stop_x(d)=stop_x(dd)+dash_y(h);
10098 mp_free_node(mp, dd,dash_node_size);
10101 @ We get here when the argument is a null picture or when there is an error.
10102 Recovering from an error involves making |dash_list(h)| empty to indicate
10103 that |h| is not known to be a valid dash pattern. We also dereference |h|
10104 since it is not being used for the return value.
10106 @<Flush the dash list, recycle |h| and return |null|@>=
10107 mp_flush_dash_list(mp, h);
10108 delete_edge_ref(h);
10111 @ Having carefully saved the dashed stroked nodes in the
10112 corresponding dash nodes, we must be prepared to break up these dashes into
10115 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
10116 d=h; /* now |link(d)=dash_list(h)| */
10117 while ( link(d)!=null_dash ) {
10123 hsf=dash_scale(ds);
10124 if ( (hh==null) ) mp_confusion(mp, "dash1");
10125 @:this can't happen dash0}{\quad dash1@>
10126 if ( dash_y(hh)==0 ) {
10129 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
10130 @:this can't happen dash0}{\quad dash1@>
10131 @<Replace |link(d)| by a dashed version as determined by edge header
10132 |hh| and scale factor |ds|@>;
10137 @ @<Other local variables in |make_dashes|@>=
10138 pointer dln; /* |link(d)| */
10139 pointer hh; /* an edge header that tells how to break up |dln| */
10140 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
10141 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
10142 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
10144 @ @<Replace |link(d)| by a dashed version as determined by edge header...@>=
10147 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
10148 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
10149 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
10150 +mp_take_scaled(mp, hsf,dash_y(hh));
10151 stop_x(null_dash)=start_x(null_dash);
10152 @<Advance |dd| until finding the first dash that overlaps |dln| when
10153 offset by |xoff|@>;
10154 while ( start_x(dln)<=stop_x(dln) ) {
10155 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
10156 @<Insert a dash between |d| and |dln| for the overlap with the offset version
10159 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10162 mp_free_node(mp, dln,dash_node_size)
10164 @ The name of this module is a bit of a lie because we just find the
10165 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
10166 overlap possible. It could be that the unoffset version of dash |dln| falls
10167 in the gap between |dd| and its predecessor.
10169 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
10170 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
10174 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
10175 if ( dd==null_dash ) {
10177 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10180 @ At this point we already know that
10181 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10183 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10184 if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
10185 link(d)=mp_get_node(mp, dash_node_size);
10188 if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
10189 start_x(d)=start_x(dln);
10191 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10192 if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
10193 stop_x(d)=stop_x(dln);
10195 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10198 @ The next major task is to update the bounding box information in an edge
10199 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10200 header's bounding box to accommodate the box computed by |path_bbox| or
10201 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10204 @c void mp_adjust_bbox (MP mp,pointer h) {
10205 if ( minx<minx_val(h) ) minx_val(h)=minx;
10206 if ( miny<miny_val(h) ) miny_val(h)=miny;
10207 if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
10208 if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
10211 @ Here is a special routine for updating the bounding box information in
10212 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10213 that is to be stroked with the pen~|pp|.
10215 @c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10216 pointer q; /* a knot node adjacent to knot |p| */
10217 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10218 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10219 scaled z; /* a coordinate being tested against the bounding box */
10220 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10221 integer i; /* a loop counter */
10222 if ( right_type(p)!=mp_endpoint ) {
10225 @<Make |(dx,dy)| the final direction for the path segment from
10226 |q| to~|p|; set~|d|@>;
10227 d=mp_pyth_add(mp, dx,dy);
10229 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10230 for (i=1;i<= 2;i++) {
10231 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10232 update the bounding box to accommodate it@>;
10236 if ( right_type(p)==mp_endpoint ) {
10239 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10245 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10246 if ( q==link(p) ) {
10247 dx=x_coord(p)-right_x(p);
10248 dy=y_coord(p)-right_y(p);
10249 if ( (dx==0)&&(dy==0) ) {
10250 dx=x_coord(p)-left_x(q);
10251 dy=y_coord(p)-left_y(q);
10254 dx=x_coord(p)-left_x(p);
10255 dy=y_coord(p)-left_y(p);
10256 if ( (dx==0)&&(dy==0) ) {
10257 dx=x_coord(p)-right_x(q);
10258 dy=y_coord(p)-right_y(q);
10261 dx=x_coord(p)-x_coord(q);
10262 dy=y_coord(p)-y_coord(q)
10264 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10265 dx=mp_make_fraction(mp, dx,d);
10266 dy=mp_make_fraction(mp, dy,d);
10267 mp_find_offset(mp, -dy,dx,pp);
10268 xx=mp->cur_x; yy=mp->cur_y
10270 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10271 mp_find_offset(mp, dx,dy,pp);
10272 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10273 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10274 mp_confusion(mp, "box_ends");
10275 @:this can't happen box ends}{\quad\\{box\_ends}@>
10276 z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10277 if ( z<minx_val(h) ) minx_val(h)=z;
10278 if ( z>maxx_val(h) ) maxx_val(h)=z;
10279 z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10280 if ( z<miny_val(h) ) miny_val(h)=z;
10281 if ( z>maxy_val(h) ) maxy_val(h)=z
10283 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10287 } while (right_type(p)!=mp_endpoint)
10289 @ The major difficulty in finding the bounding box of an edge structure is the
10290 effect of clipping paths. We treat them conservatively by only clipping to the
10291 clipping path's bounding box, but this still
10292 requires recursive calls to |set_bbox| in order to find the bounding box of
10294 the objects to be clipped. Such calls are distinguished by the fact that the
10295 boolean parameter |top_level| is false.
10297 @c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10298 pointer p; /* a graphical object being considered */
10299 scaled sminx,sminy,smaxx,smaxy;
10300 /* for saving the bounding box during recursive calls */
10301 scaled x0,x1,y0,y1; /* temporary registers */
10302 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10303 @<Wipe out any existing bounding box information if |bbtype(h)| is
10304 incompatible with |internal[mp_true_corners]|@>;
10305 while ( link(bblast(h))!=null ) {
10309 case mp_stop_clip_code:
10310 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10311 @:this can't happen bbox}{\quad bbox@>
10313 @<Other cases for updating the bounding box based on the type of object |p|@>;
10314 } /* all cases are enumerated above */
10316 if ( ! top_level ) mp_confusion(mp, "bbox");
10319 @ @<Internal library declarations@>=
10320 void mp_set_bbox (MP mp,pointer h, boolean top_level);
10322 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10323 switch (bbtype(h)) {
10327 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10330 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10332 } /* there are no other cases */
10334 @ @<Other cases for updating the bounding box...@>=
10336 mp_path_bbox(mp, path_p(p));
10337 if ( pen_p(p)!=null ) {
10340 mp_pen_bbox(mp, pen_p(p));
10346 mp_adjust_bbox(mp, h);
10349 @ @<Other cases for updating the bounding box...@>=
10350 case mp_start_bounds_code:
10351 if ( mp->internal[mp_true_corners]>0 ) {
10352 bbtype(h)=bounds_unset;
10354 bbtype(h)=bounds_set;
10355 mp_path_bbox(mp, path_p(p));
10356 mp_adjust_bbox(mp, h);
10357 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10361 case mp_stop_bounds_code:
10362 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10363 @:this can't happen bbox2}{\quad bbox2@>
10366 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10369 if ( link(p)==null ) mp_confusion(mp, "bbox2");
10370 @:this can't happen bbox2}{\quad bbox2@>
10372 if ( type(p)==mp_start_bounds_code ) incr(lev);
10373 else if ( type(p)==mp_stop_bounds_code ) decr(lev);
10377 @ It saves a lot of grief here to be slightly conservative and not account for
10378 omitted parts of dashed lines. We also don't worry about the material omitted
10379 when using butt end caps. The basic computation is for round end caps and
10380 |box_ends| augments it for square end caps.
10382 @<Other cases for updating the bounding box...@>=
10383 case mp_stroked_code:
10384 mp_path_bbox(mp, path_p(p));
10387 mp_pen_bbox(mp, pen_p(p));
10392 mp_adjust_bbox(mp, h);
10393 if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10394 mp_box_ends(mp, path_p(p), pen_p(p), h);
10397 @ The height width and depth information stored in a text node determines a
10398 rectangle that needs to be transformed according to the transformation
10399 parameters stored in the text node.
10401 @<Other cases for updating the bounding box...@>=
10403 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10404 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10405 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10408 if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
10409 else { minx=minx+y1; maxx=maxx+y0; }
10410 if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
10411 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10412 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10413 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10416 if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
10417 else { miny=miny+y1; maxy=maxy+y0; }
10418 if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
10419 mp_adjust_bbox(mp, h);
10422 @ This case involves a recursive call that advances |bblast(h)| to the node of
10423 type |mp_stop_clip_code| that matches |p|.
10425 @<Other cases for updating the bounding box...@>=
10426 case mp_start_clip_code:
10427 mp_path_bbox(mp, path_p(p));
10430 sminx=minx_val(h); sminy=miny_val(h);
10431 smaxx=maxx_val(h); smaxy=maxy_val(h);
10432 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10433 starting at |link(p)|@>;
10434 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10436 minx=sminx; miny=sminy;
10437 maxx=smaxx; maxy=smaxy;
10438 mp_adjust_bbox(mp, h);
10441 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10442 minx_val(h)=el_gordo;
10443 miny_val(h)=el_gordo;
10444 maxx_val(h)=-el_gordo;
10445 maxy_val(h)=-el_gordo;
10446 mp_set_bbox(mp, h,false)
10448 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10449 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10450 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10451 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10452 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10454 @* \[22] Finding an envelope.
10455 When \MP\ has a path and a polygonal pen, it needs to express the desired
10456 shape in terms of things \ps\ can understand. The present task is to compute
10457 a new path that describes the region to be filled. It is convenient to
10458 define this as a two step process where the first step is determining what
10459 offset to use for each segment of the path.
10461 @ Given a pointer |c| to a cyclic path,
10462 and a pointer~|h| to the first knot of a pen polygon,
10463 the |offset_prep| routine changes the path into cubics that are
10464 associated with particular pen offsets. Thus if the cubic between |p|
10465 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10466 has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
10467 to because |l-k| could be negative.)
10469 After overwriting the type information with offset differences, we no longer
10470 have a true path so we refer to the knot list returned by |offset_prep| as an
10473 Since an envelope spec only determines relative changes in pen offsets,
10474 |offset_prep| sets a global variable |spec_offset| to the relative change from
10475 |h| to the first offset.
10477 @d zero_off 16384 /* added to offset changes to make them positive */
10480 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10482 @ @c @<Declare subroutines needed by |offset_prep|@>
10483 pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10484 halfword n; /* the number of vertices in the pen polygon */
10485 pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
10486 integer k_needed; /* amount to be added to |info(p)| when it is computed */
10487 pointer w0; /* a pointer to pen offset to use just before |p| */
10488 scaled dxin,dyin; /* the direction into knot |p| */
10489 integer turn_amt; /* change in pen offsets for the current cubic */
10490 @<Other local variables for |offset_prep|@>;
10492 @<Initialize the pen size~|n|@>;
10493 @<Initialize the incoming direction and pen offset at |c|@>;
10494 p=c; c0=c; k_needed=0;
10497 @<Split the cubic between |p| and |q|, if necessary, into cubics
10498 associated with single offsets, after which |q| should
10499 point to the end of the final such cubic@>;
10501 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10502 might have been introduced by the splitting process@>;
10504 @<Fix the offset change in |info(c)| and set |c| to the return value of
10509 @ We shall want to keep track of where certain knots on the cyclic path
10510 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10511 knot nodes because some nodes are deleted while removing dead cubics. Thus
10512 |offset_prep| updates the following pointers
10516 pointer spec_p2; /* pointers to distinguished knots */
10519 mp->spec_p1=null; mp->spec_p2=null;
10521 @ @<Initialize the pen size~|n|@>=
10528 @ Since the true incoming direction isn't known yet, we just pick a direction
10529 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10532 @<Initialize the incoming direction and pen offset at |c|@>=
10533 dxin=x_coord(link(h))-x_coord(knil(h));
10534 dyin=y_coord(link(h))-y_coord(knil(h));
10535 if ( (dxin==0)&&(dyin==0) ) {
10536 dxin=y_coord(knil(h))-y_coord(h);
10537 dyin=x_coord(h)-x_coord(knil(h));
10541 @ We must be careful not to remove the only cubic in a cycle.
10543 But we must also be careful for another reason. If the user-supplied
10544 path starts with a set of degenerate cubics, the target node |q| can
10545 be collapsed to the initial node |p| which might be the same as the
10546 initial node |c| of the curve. This would cause the |offset_prep| routine
10547 to bail out too early, causing distress later on. (See for example
10548 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10551 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10555 if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
10556 x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
10557 x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
10559 @<Remove the cubic following |p| and update the data structures
10560 to merge |r| into |p|@>;
10564 /* Check if we removed too much */
10565 if ((q!=q0)&&(q!=c||c==c0))
10568 @ @<Remove the cubic following |p| and update the data structures...@>=
10569 { k_needed=info(p)-zero_off;
10573 info(p)=k_needed+info(r);
10576 if ( r==c ) { info(p)=info(c); c=p; };
10577 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10578 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10579 r=p; mp_remove_cubic(mp, p);
10582 @ Not setting the |info| field of the newly created knot allows the splitting
10583 routine to work for paths.
10585 @<Declare subroutines needed by |offset_prep|@>=
10586 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10587 scaled v; /* an intermediate value */
10588 pointer q,r; /* for list manipulation */
10589 q=link(p); r=mp_get_node(mp, knot_node_size); link(p)=r; link(r)=q;
10590 originator(r)=mp_program_code;
10591 left_type(r)=mp_explicit; right_type(r)=mp_explicit;
10592 v=t_of_the_way(right_x(p),left_x(q));
10593 right_x(p)=t_of_the_way(x_coord(p),right_x(p));
10594 left_x(q)=t_of_the_way(left_x(q),x_coord(q));
10595 left_x(r)=t_of_the_way(right_x(p),v);
10596 right_x(r)=t_of_the_way(v,left_x(q));
10597 x_coord(r)=t_of_the_way(left_x(r),right_x(r));
10598 v=t_of_the_way(right_y(p),left_y(q));
10599 right_y(p)=t_of_the_way(y_coord(p),right_y(p));
10600 left_y(q)=t_of_the_way(left_y(q),y_coord(q));
10601 left_y(r)=t_of_the_way(right_y(p),v);
10602 right_y(r)=t_of_the_way(v,left_y(q));
10603 y_coord(r)=t_of_the_way(left_y(r),right_y(r));
10606 @ This does not set |info(p)| or |right_type(p)|.
10608 @<Declare subroutines needed by |offset_prep|@>=
10609 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10610 pointer q; /* the node that disappears */
10611 q=link(p); link(p)=link(q);
10612 right_x(p)=right_x(q); right_y(p)=right_y(q);
10613 mp_free_node(mp, q,knot_node_size);
10616 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10617 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10618 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10619 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10620 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10621 When listed by increasing $k$, these directions occur in counter-clockwise
10622 order so that $d_k\preceq d\k$ for all~$k$.
10623 The goal of |offset_prep| is to find an offset index~|k| to associate with
10624 each cubic, such that the direction $d(t)$ of the cubic satisfies
10625 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10626 We may have to split a cubic into many pieces before each
10627 piece corresponds to a unique offset.
10629 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10630 info(p)=zero_off+k_needed;
10632 @<Prepare for derivative computations;
10633 |goto not_found| if the current cubic is dead@>;
10634 @<Find the initial direction |(dx,dy)|@>;
10635 @<Update |info(p)| and find the offset $w_k$ such that
10636 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10637 the direction change at |p|@>;
10638 @<Find the final direction |(dxin,dyin)|@>;
10639 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10640 @<Complete the offset splitting process@>;
10641 w0=mp_pen_walk(mp, w0,turn_amt)
10643 @ @<Declare subroutines needed by |offset_prep|@>=
10644 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10645 /* walk |k| steps around a pen from |w| */
10646 while ( k>0 ) { w=link(w); decr(k); };
10647 while ( k<0 ) { w=knil(w); incr(k); };
10651 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10652 calculated from the quadratic polynomials
10653 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10654 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10655 Since we may be calculating directions from several cubics
10656 split from the current one, it is desirable to do these calculations
10657 without losing too much precision. ``Scaled up'' values of the
10658 derivatives, which will be less tainted by accumulated errors than
10659 derivatives found from the cubics themselves, are maintained in
10660 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10661 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10662 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)$.
10664 @<Other local variables for |offset_prep|@>=
10665 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10666 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10667 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10668 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10669 integer max_coef; /* used while scaling */
10670 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10671 fraction t; /* where the derivative passes through zero */
10672 fraction s; /* a temporary value */
10674 @ @<Prepare for derivative computations...@>=
10675 x0=right_x(p)-x_coord(p);
10676 x2=x_coord(q)-left_x(q);
10677 x1=left_x(q)-right_x(p);
10678 y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
10679 y1=left_y(q)-right_y(p);
10681 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10682 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10683 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10684 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10685 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10686 if ( max_coef==0 ) goto NOT_FOUND;
10687 while ( max_coef<fraction_half ) {
10689 double(x0); double(x1); double(x2);
10690 double(y0); double(y1); double(y2);
10693 @ Let us first solve a special case of the problem: Suppose we
10694 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10695 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10696 $d(0)\succ d_{k-1}$.
10697 Then, in a sense, we're halfway done, since one of the two relations
10698 in $(*)$ is satisfied, and the other couldn't be satisfied for
10699 any other value of~|k|.
10701 Actually, the conditions can be relaxed somewhat since a relation such as
10702 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10703 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10704 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10705 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10706 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10707 counterclockwise direction.
10709 The |fin_offset_prep| subroutine solves the stated subproblem.
10710 It has a parameter called |rise| that is |1| in
10711 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10712 the derivative of the cubic following |p|.
10713 The |w| parameter should point to offset~$w_k$ and |info(p)| should already
10714 be set properly. The |turn_amt| parameter gives the absolute value of the
10715 overall net change in pen offsets.
10717 @<Declare subroutines needed by |offset_prep|@>=
10718 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10719 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10720 integer rise, integer turn_amt) {
10721 pointer ww; /* for list manipulation */
10722 scaled du,dv; /* for slope calculation */
10723 integer t0,t1,t2; /* test coefficients */
10724 fraction t; /* place where the derivative passes a critical slope */
10725 fraction s; /* slope or reciprocal slope */
10726 integer v; /* intermediate value for updating |x0..y2| */
10727 pointer q; /* original |link(p)| */
10730 if ( rise>0 ) ww=link(w); /* a pointer to $w\k$ */
10731 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10732 @<Compute test coefficients |(t0,t1,t2)|
10733 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10734 t=mp_crossing_point(mp, t0,t1,t2);
10735 if ( t>=fraction_one ) {
10736 if ( turn_amt>0 ) t=fraction_one; else return;
10738 @<Split the cubic at $t$,
10739 and split off another cubic if the derivative crosses back@>;
10744 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10745 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10746 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10749 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10750 du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
10751 if ( abs(du)>=abs(dv) ) {
10752 s=mp_make_fraction(mp, dv,du);
10753 t0=mp_take_fraction(mp, x0,s)-y0;
10754 t1=mp_take_fraction(mp, x1,s)-y1;
10755 t2=mp_take_fraction(mp, x2,s)-y2;
10756 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10758 s=mp_make_fraction(mp, du,dv);
10759 t0=x0-mp_take_fraction(mp, y0,s);
10760 t1=x1-mp_take_fraction(mp, y1,s);
10761 t2=x2-mp_take_fraction(mp, y2,s);
10762 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10764 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10766 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10767 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
10768 respectively, yielding another solution of $(*)$.
10770 @<Split the cubic at $t$, and split off another...@>=
10772 mp_split_cubic(mp, p,t); p=link(p); info(p)=zero_off+rise;
10774 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10775 x0=t_of_the_way(v,x1);
10776 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10777 y0=t_of_the_way(v,y1);
10778 if ( turn_amt<0 ) {
10779 t1=t_of_the_way(t1,t2);
10780 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10781 t=mp_crossing_point(mp, 0,-t1,-t2);
10782 if ( t>fraction_one ) t=fraction_one;
10784 if ( (t==fraction_one)&&(link(p)!=q) ) {
10785 info(link(p))=info(link(p))-rise;
10787 mp_split_cubic(mp, p,t); info(link(p))=zero_off-rise;
10788 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10789 x2=t_of_the_way(x1,v);
10790 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10791 y2=t_of_the_way(y1,v);
10796 @ Now we must consider the general problem of |offset_prep|, when
10797 nothing is known about a given cubic. We start by finding its
10798 direction in the vicinity of |t=0|.
10800 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10801 has not yet introduced any more numerical errors. Thus we can compute
10802 the true initial direction for the given cubic, even if it is almost
10805 @<Find the initial direction |(dx,dy)|@>=
10807 if ( dx==0 && dy==0 ) {
10809 if ( dx==0 && dy==0 ) {
10813 if ( p==c ) { dx0=dx; dy0=dy; }
10815 @ @<Find the final direction |(dxin,dyin)|@>=
10817 if ( dxin==0 && dyin==0 ) {
10819 if ( dxin==0 && dyin==0 ) {
10824 @ The next step is to bracket the initial direction between consecutive
10825 edges of the pen polygon. We must be careful to turn clockwise only if
10826 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10827 counter-clockwise in order to make \&{doublepath} envelopes come out
10828 @:double_path_}{\&{doublepath} primitive@>
10829 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10831 @<Update |info(p)| and find the offset $w_k$ such that...@>=
10832 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10833 w=mp_pen_walk(mp, w0, turn_amt);
10835 info(p)=info(p)+turn_amt
10837 @ Decide how many pen offsets to go away from |w| in order to find the offset
10838 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10839 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10840 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10842 If the pen polygon has only two edges, they could both be parallel
10843 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10844 such edge in order to avoid an infinite loop.
10846 @<Declare subroutines needed by |offset_prep|@>=
10847 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10848 scaled dy, boolean ccw) {
10849 pointer ww; /* a neighbor of knot~|w| */
10850 integer s; /* turn amount so far */
10851 integer t; /* |ab_vs_cd| result */
10856 t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
10857 dx,(y_coord(ww)-y_coord(w)));
10864 while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
10865 dx,(y_coord(w)-y_coord(ww))) < 0) {
10873 @ When we're all done, the final offset is |w0| and the final curve direction
10874 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10875 can correct |info(c)| which was erroneously based on an incoming offset
10878 @d fix_by(A) info(c)=info(c)+(A)
10880 @<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
10881 mp->spec_offset=info(c)-zero_off;
10882 if ( link(c)==c ) {
10883 info(c)=zero_off+n;
10886 while ( w0!=h ) { fix_by(1); w0=link(w0); };
10887 while ( info(c)<=zero_off-n ) fix_by(n);
10888 while ( info(c)>zero_off ) fix_by(-n);
10889 if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10892 @ Finally we want to reduce the general problem to situations that
10893 |fin_offset_prep| can handle. We split the cubic into at most three parts
10894 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10896 @<Complete the offset splitting process@>=
10898 @<Compute test coeff...@>;
10899 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10900 |t:=fraction_one+1|@>;
10901 if ( t>fraction_one ) {
10902 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10904 mp_split_cubic(mp, p,t); r=link(p);
10905 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10906 x2a=t_of_the_way(x1a,x1);
10907 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10908 y2a=t_of_the_way(y1a,y1);
10909 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10910 info(r)=zero_off-1;
10911 if ( turn_amt>=0 ) {
10912 t1=t_of_the_way(t1,t2);
10914 t=mp_crossing_point(mp, 0,-t1,-t2);
10915 if ( t>fraction_one ) t=fraction_one;
10916 @<Split off another rising cubic for |fin_offset_prep|@>;
10917 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10919 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10923 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10924 mp_split_cubic(mp, r,t); info(link(r))=zero_off+1;
10925 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10926 x0a=t_of_the_way(x1,x1a);
10927 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10928 y0a=t_of_the_way(y1,y1a);
10929 mp_fin_offset_prep(mp, link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10932 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10933 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10934 need to decide whether the directions are parallel or antiparallel. We
10935 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10936 should be avoided when the value of |turn_amt| already determines the
10937 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10938 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10939 crossing and the first crossing cannot be antiparallel.
10941 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10942 t=mp_crossing_point(mp, t0,t1,t2);
10943 if ( turn_amt>=0 ) {
10947 u0=t_of_the_way(x0,x1);
10948 u1=t_of_the_way(x1,x2);
10949 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10950 v0=t_of_the_way(y0,y1);
10951 v1=t_of_the_way(y1,y2);
10952 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10953 if ( ss<0 ) t=fraction_one+1;
10955 } else if ( t>fraction_one ) {
10959 @ @<Other local variables for |offset_prep|@>=
10960 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10961 integer ss = 0; /* the part of the dot product computed so far */
10962 int d_sign; /* sign of overall change in direction for this cubic */
10964 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10965 problem to decide which way it loops around but that's OK as long we're
10966 consistent. To make \&{doublepath} envelopes work properly, reversing
10967 the path should always change the sign of |turn_amt|.
10969 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10970 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10972 @<Check rotation direction based on node position@>
10976 if ( dy>0 ) d_sign=1; else d_sign=-1;
10978 if ( dx>0 ) d_sign=1; else d_sign=-1;
10981 @<Make |ss| negative if and only if the total change in direction is
10982 more than $180^\circ$@>;
10983 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10984 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
10986 @ We check rotation direction by looking at the vector connecting the current
10987 node with the next. If its angle with incoming and outgoing tangents has the
10988 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
10989 Otherwise we proceed to the cusp code.
10991 @<Check rotation direction based on node position@>=
10992 u0=x_coord(q)-x_coord(p);
10993 u1=y_coord(q)-y_coord(p);
10994 d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
10995 mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
10997 @ In order to be invariant under path reversal, the result of this computation
10998 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
10999 then swapped with |(x2,y2)|. We make use of the identities
11000 |take_fraction(-a,-b)=take_fraction(a,b)| and
11001 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
11003 @<Make |ss| negative if and only if the total change in direction is...@>=
11004 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
11005 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
11006 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
11008 t=mp_crossing_point(mp, t0,t1,-t0);
11009 u0=t_of_the_way(x0,x1);
11010 u1=t_of_the_way(x1,x2);
11011 v0=t_of_the_way(y0,y1);
11012 v1=t_of_the_way(y1,y2);
11014 t=mp_crossing_point(mp, -t0,t1,t0);
11015 u0=t_of_the_way(x2,x1);
11016 u1=t_of_the_way(x1,x0);
11017 v0=t_of_the_way(y2,y1);
11018 v1=t_of_the_way(y1,y0);
11020 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
11021 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
11023 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
11024 that the |cur_pen| has not been walked around to the first offset.
11027 void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
11028 pointer p,q; /* list traversal */
11029 pointer w; /* the current pen offset */
11030 mp_print_diagnostic(mp, "Envelope spec",s,true);
11031 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
11033 mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
11034 mp_print(mp, " % beginning with offset ");
11035 mp_print_two(mp, x_coord(w),y_coord(w));
11039 @<Print the cubic between |p| and |q|@>;
11041 if ((p==cur_spec) || (info(p)!=zero_off))
11044 if ( info(p)!=zero_off ) {
11045 @<Update |w| as indicated by |info(p)| and print an explanation@>;
11047 } while (p!=cur_spec);
11048 mp_print_nl(mp, " & cycle");
11049 mp_end_diagnostic(mp, true);
11052 @ @<Update |w| as indicated by |info(p)| and print an explanation@>=
11054 w=mp_pen_walk(mp, w, (info(p)-zero_off));
11055 mp_print(mp, " % ");
11056 if ( info(p)>zero_off ) mp_print(mp, "counter");
11057 mp_print(mp, "clockwise to offset ");
11058 mp_print_two(mp, x_coord(w),y_coord(w));
11061 @ @<Print the cubic between |p| and |q|@>=
11063 mp_print_nl(mp, " ..controls ");
11064 mp_print_two(mp, right_x(p),right_y(p));
11065 mp_print(mp, " and ");
11066 mp_print_two(mp, left_x(q),left_y(q));
11067 mp_print_nl(mp, " ..");
11068 mp_print_two(mp, x_coord(q),y_coord(q));
11071 @ Once we have an envelope spec, the remaining task to construct the actual
11072 envelope by offsetting each cubic as determined by the |info| fields in
11073 the knots. First we use |offset_prep| to convert the |c| into an envelope
11074 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
11077 The |ljoin| and |miterlim| parameters control the treatment of points where the
11078 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
11079 The endpoints are easily located because |c| is given in undoubled form
11080 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
11081 track of the endpoints and treat them like very sharp corners.
11082 Butt end caps are treated like beveled joins; round end caps are treated like
11083 round joins; and square end caps are achieved by setting |join_type:=3|.
11085 None of these parameters apply to inside joins where the convolution tracing
11086 has retrograde lines. In such cases we use a simple connect-the-endpoints
11087 approach that is achieved by setting |join_type:=2|.
11089 @c @<Declare a function called |insert_knot|@>
11090 pointer mp_make_envelope (MP mp,pointer c, pointer h, small_number ljoin,
11091 small_number lcap, scaled miterlim) {
11092 pointer p,q,r,q0; /* for manipulating the path */
11093 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
11094 pointer w,w0; /* the pen knot for the current offset */
11095 scaled qx,qy; /* unshifted coordinates of |q| */
11096 halfword k,k0; /* controls pen edge insertion */
11097 @<Other local variables for |make_envelope|@>;
11098 dxin=0; dyin=0; dxout=0; dyout=0;
11099 mp->spec_p1=null; mp->spec_p2=null;
11100 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
11101 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
11102 the initial offset@>;
11107 qx=x_coord(q); qy=y_coord(q);
11110 if ( k!=zero_off ) {
11111 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
11113 @<Add offset |w| to the cubic from |p| to |q|@>;
11114 while ( k!=zero_off ) {
11115 @<Step |w| and move |k| one step closer to |zero_off|@>;
11116 if ( (join_type==1)||(k==zero_off) )
11117 q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
11119 if ( q!=link(p) ) {
11120 @<Set |p=link(p)| and add knots between |p| and |q| as
11121 required by |join_type|@>;
11128 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
11129 c=mp_offset_prep(mp, c,h);
11130 if ( mp->internal[mp_tracing_specs]>0 )
11131 mp_print_spec(mp, c,h,"");
11132 h=mp_pen_walk(mp, h,mp->spec_offset)
11134 @ Mitered and squared-off joins depend on path directions that are difficult to
11135 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
11136 have degenerate cubics only if the entire cycle collapses to a single
11137 degenerate cubic. Setting |join_type:=2| in this case makes the computed
11138 envelope degenerate as well.
11140 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
11141 if ( k<zero_off ) {
11144 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
11145 else if ( lcap==2 ) join_type=3;
11146 else join_type=2-lcap;
11147 if ( (join_type==0)||(join_type==3) ) {
11148 @<Set the incoming and outgoing directions at |q|; in case of
11149 degeneracy set |join_type:=2|@>;
11150 if ( join_type==0 ) {
11151 @<If |miterlim| is less than the secant of half the angle at |q|
11152 then set |join_type:=2|@>;
11157 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
11159 tmp=mp_take_fraction(mp, miterlim,fraction_half+
11160 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
11162 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
11165 @ @<Other local variables for |make_envelope|@>=
11166 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
11167 scaled tmp; /* a temporary value */
11169 @ The coordinates of |p| have already been shifted unless |p| is the first
11170 knot in which case they get shifted at the very end.
11172 @<Add offset |w| to the cubic from |p| to |q|@>=
11173 right_x(p)=right_x(p)+x_coord(w);
11174 right_y(p)=right_y(p)+y_coord(w);
11175 left_x(q)=left_x(q)+x_coord(w);
11176 left_y(q)=left_y(q)+y_coord(w);
11177 x_coord(q)=x_coord(q)+x_coord(w);
11178 y_coord(q)=y_coord(q)+y_coord(w);
11179 left_type(q)=mp_explicit;
11180 right_type(q)=mp_explicit
11182 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
11183 if ( k>zero_off ){ w=link(w); decr(k); }
11184 else { w=knil(w); incr(k); }
11186 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
11187 the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
11188 case the cubic containing these control points is ``yet to be examined.''
11190 @<Declare a function called |insert_knot|@>=
11191 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
11192 /* returns the inserted knot */
11193 pointer r; /* the new knot */
11194 r=mp_get_node(mp, knot_node_size);
11195 link(r)=link(q); link(q)=r;
11196 right_x(r)=right_x(q);
11197 right_y(r)=right_y(q);
11200 right_x(q)=x_coord(q);
11201 right_y(q)=y_coord(q);
11202 left_x(r)=x_coord(r);
11203 left_y(r)=y_coord(r);
11204 left_type(r)=mp_explicit;
11205 right_type(r)=mp_explicit;
11206 originator(r)=mp_program_code;
11210 @ After setting |p:=link(p)|, either |join_type=1| or |q=link(p)|.
11212 @<Set |p=link(p)| and add knots between |p| and |q| as...@>=
11215 if ( (join_type==0)||(join_type==3) ) {
11216 if ( join_type==0 ) {
11217 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11219 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11223 right_x(r)=x_coord(r);
11224 right_y(r)=y_coord(r);
11229 @ For very small angles, adding a knot is unnecessary and would cause numerical
11230 problems, so we just set |r:=null| in that case.
11232 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11234 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11235 if ( abs(det)<26844 ) {
11236 r=null; /* sine $<10^{-4}$ */
11238 tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
11239 mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
11240 tmp=mp_make_fraction(mp, tmp,det);
11241 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11242 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11246 @ @<Other local variables for |make_envelope|@>=
11247 fraction det; /* a determinant used for mitered join calculations */
11249 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11251 ht_x=y_coord(w)-y_coord(w0);
11252 ht_y=x_coord(w0)-x_coord(w);
11253 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11254 ht_x+=ht_x; ht_y+=ht_y;
11256 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11257 product with |(ht_x,ht_y)|@>;
11258 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11259 mp_take_fraction(mp, dyin,ht_y));
11260 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11261 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11262 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11263 mp_take_fraction(mp, dyout,ht_y));
11264 r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11265 y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11268 @ @<Other local variables for |make_envelope|@>=
11269 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11270 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11271 halfword kk; /* keeps track of the pen vertices being scanned */
11272 pointer ww; /* the pen vertex being tested */
11274 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11275 from zero to |max_ht|.
11277 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11282 @<Step |ww| and move |kk| one step closer to |k0|@>;
11283 if ( kk==k0 ) break;
11284 tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
11285 mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
11286 if ( tmp>max_ht ) max_ht=tmp;
11290 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11291 if ( kk>k0 ) { ww=link(ww); decr(kk); }
11292 else { ww=knil(ww); incr(kk); }
11294 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11295 if ( left_type(c)==mp_endpoint ) {
11296 mp->spec_p1=mp_htap_ypoc(mp, c);
11297 mp->spec_p2=mp->path_tail;
11298 originator(mp->spec_p1)=mp_program_code;
11299 link(mp->spec_p2)=link(mp->spec_p1);
11300 link(mp->spec_p1)=c;
11301 mp_remove_cubic(mp, mp->spec_p1);
11303 if ( c!=link(c) ) {
11304 originator(mp->spec_p2)=mp_program_code;
11305 mp_remove_cubic(mp, mp->spec_p2);
11307 @<Make |c| look like a cycle of length one@>;
11311 @ @<Make |c| look like a cycle of length one@>=
11313 left_type(c)=mp_explicit; right_type(c)=mp_explicit;
11314 left_x(c)=x_coord(c); left_y(c)=y_coord(c);
11315 right_x(c)=x_coord(c); right_y(c)=y_coord(c);
11318 @ In degenerate situations we might have to look at the knot preceding~|q|.
11319 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11321 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11322 dxin=x_coord(q)-left_x(q);
11323 dyin=y_coord(q)-left_y(q);
11324 if ( (dxin==0)&&(dyin==0) ) {
11325 dxin=x_coord(q)-right_x(p);
11326 dyin=y_coord(q)-right_y(p);
11327 if ( (dxin==0)&&(dyin==0) ) {
11328 dxin=x_coord(q)-x_coord(p);
11329 dyin=y_coord(q)-y_coord(p);
11330 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11331 dxin=dxin+x_coord(w);
11332 dyin=dyin+y_coord(w);
11336 tmp=mp_pyth_add(mp, dxin,dyin);
11340 dxin=mp_make_fraction(mp, dxin,tmp);
11341 dyin=mp_make_fraction(mp, dyin,tmp);
11342 @<Set the outgoing direction at |q|@>;
11345 @ If |q=c| then the coordinates of |r| and the control points between |q|
11346 and~|r| have already been offset by |h|.
11348 @<Set the outgoing direction at |q|@>=
11349 dxout=right_x(q)-x_coord(q);
11350 dyout=right_y(q)-y_coord(q);
11351 if ( (dxout==0)&&(dyout==0) ) {
11353 dxout=left_x(r)-x_coord(q);
11354 dyout=left_y(r)-y_coord(q);
11355 if ( (dxout==0)&&(dyout==0) ) {
11356 dxout=x_coord(r)-x_coord(q);
11357 dyout=y_coord(r)-y_coord(q);
11361 dxout=dxout-x_coord(h);
11362 dyout=dyout-y_coord(h);
11364 tmp=mp_pyth_add(mp, dxout,dyout);
11365 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11366 @:this can't happen degerate spec}{\quad degenerate spec@>
11367 dxout=mp_make_fraction(mp, dxout,tmp);
11368 dyout=mp_make_fraction(mp, dyout,tmp)
11370 @* \[23] Direction and intersection times.
11371 A path of length $n$ is defined parametrically by functions $x(t)$ and
11372 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11373 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11374 we shall consider operations that determine special times associated with
11375 given paths: the first time that a path travels in a given direction, and
11376 a pair of times at which two paths cross each other.
11378 @ Let's start with the easier task. The function |find_direction_time| is
11379 given a direction |(x,y)| and a path starting at~|h|. If the path never
11380 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11381 it will be nonnegative.
11383 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11384 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11385 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11386 assumed to match any given direction at time~|t|.
11388 The routine solves this problem in nondegenerate cases by rotating the path
11389 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11390 to find when a given path first travels ``due east.''
11393 scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11394 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11395 pointer p,q; /* for list traversal */
11396 scaled n; /* the direction time at knot |p| */
11397 scaled tt; /* the direction time within a cubic */
11398 @<Other local variables for |find_direction_time|@>;
11399 @<Normalize the given direction for better accuracy;
11400 but |return| with zero result if it's zero@>;
11403 if ( right_type(p)==mp_endpoint ) break;
11405 @<Rotate the cubic between |p| and |q|; then
11406 |goto found| if the rotated cubic travels due east at some time |tt|;
11407 but |break| if an entire cyclic path has been traversed@>;
11415 @ @<Normalize the given direction for better accuracy...@>=
11416 if ( abs(x)<abs(y) ) {
11417 x=mp_make_fraction(mp, x,abs(y));
11418 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11419 } else if ( x==0 ) {
11422 y=mp_make_fraction(mp, y,abs(x));
11423 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11426 @ Since we're interested in the tangent directions, we work with the
11427 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
11428 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11429 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11430 in order to achieve better accuracy.
11432 The given path may turn abruptly at a knot, and it might pass the critical
11433 tangent direction at such a time. Therefore we remember the direction |phi|
11434 in which the previous rotated cubic was traveling. (The value of |phi| will be
11435 undefined on the first cubic, i.e., when |n=0|.)
11437 @<Rotate the cubic between |p| and |q|; then...@>=
11439 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11440 points of the rotated derivatives@>;
11441 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11443 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11446 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11447 @<Exit to |found| if the curve whose derivatives are specified by
11448 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11450 @ @<Other local variables for |find_direction_time|@>=
11451 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11452 angle theta,phi; /* angles of exit and entry at a knot */
11453 fraction t; /* temp storage */
11455 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11456 x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
11457 x3=x_coord(q)-left_x(q);
11458 y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
11459 y3=y_coord(q)-left_y(q);
11461 if ( abs(x2)>max ) max=abs(x2);
11462 if ( abs(x3)>max ) max=abs(x3);
11463 if ( abs(y1)>max ) max=abs(y1);
11464 if ( abs(y2)>max ) max=abs(y2);
11465 if ( abs(y3)>max ) max=abs(y3);
11466 if ( max==0 ) goto FOUND;
11467 while ( max<fraction_half ){
11468 max+=max; x1+=x1; x2+=x2; x3+=x3;
11469 y1+=y1; y2+=y2; y3+=y3;
11471 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11472 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11473 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11474 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11475 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11476 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11478 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11479 theta=mp_n_arg(mp, x1,y1);
11480 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11481 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11483 @ In this step we want to use the |crossing_point| routine to find the
11484 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11485 Several complications arise: If the quadratic equation has a double root,
11486 the curve never crosses zero, and |crossing_point| will find nothing;
11487 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11488 equation has simple roots, or only one root, we may have to negate it
11489 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11490 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11493 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11494 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11495 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11496 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11497 either |goto found| or |goto done|@>;
11500 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11501 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11503 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11504 $B(x_1,x_2,x_3;t)\ge0$@>;
11507 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11508 two roots, because we know that it isn't identically zero.
11510 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11511 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11512 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11513 subject to rounding errors. Yet this code optimistically tries to
11514 do the right thing.
11516 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11518 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11519 t=mp_crossing_point(mp, y1,y2,y3);
11520 if ( t>fraction_one ) goto DONE;
11521 y2=t_of_the_way(y2,y3);
11522 x1=t_of_the_way(x1,x2);
11523 x2=t_of_the_way(x2,x3);
11524 x1=t_of_the_way(x1,x2);
11525 if ( x1>=0 ) we_found_it;
11527 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11528 if ( t>fraction_one ) goto DONE;
11529 x1=t_of_the_way(x1,x2);
11530 x2=t_of_the_way(x2,x3);
11531 if ( t_of_the_way(x1,x2)>=0 ) {
11532 t=t_of_the_way(tt,fraction_one); we_found_it;
11535 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11536 either |goto found| or |goto done|@>=
11538 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11539 t=mp_make_fraction(mp, y1,y1-y2);
11540 x1=t_of_the_way(x1,x2);
11541 x2=t_of_the_way(x2,x3);
11542 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11543 } else if ( y3==0 ) {
11545 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11546 } else if ( x3>=0 ) {
11547 tt=unity; goto FOUND;
11553 @ At this point we know that the derivative of |y(t)| is identically zero,
11554 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11557 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11559 t=mp_crossing_point(mp, -x1,-x2,-x3);
11560 if ( t<=fraction_one ) we_found_it;
11561 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11562 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11566 @ The intersection of two cubics can be found by an interesting variant
11567 of the general bisection scheme described in the introduction to
11569 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)$,
11570 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11571 if an intersection exists. First we find the smallest rectangle that
11572 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11573 the smallest rectangle that encloses
11574 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11575 But if the rectangles do overlap, we bisect the intervals, getting
11576 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11577 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11578 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11579 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11580 levels of bisection we will have determined the intersection times $t_1$
11581 and~$t_2$ to $l$~bits of accuracy.
11583 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11584 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11585 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11586 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11587 to determine when the enclosing rectangles overlap. Here's why:
11588 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11589 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11590 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11591 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11592 overlap if and only if $u\submin\L x\submax$ and
11593 $x\submin\L u\submax$. Letting
11594 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11595 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11596 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11598 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11599 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11600 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11601 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11602 because of the overlap condition; i.e., we know that $X\submin$,
11603 $X\submax$, and their relatives are bounded, hence $X\submax-
11604 U\submin$ and $X\submin-U\submax$ are bounded.
11606 @ Incidentally, if the given cubics intersect more than once, the process
11607 just sketched will not necessarily find the lexicographically smallest pair
11608 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11609 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11610 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11611 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11612 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11613 Shuffled order agrees with lexicographic order if all pairs of solutions
11614 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11615 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11616 and the bisection algorithm would be substantially less efficient if it were
11617 constrained by lexicographic order.
11619 For example, suppose that an overlap has been found for $l=3$ and
11620 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11621 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11622 Then there is probably an intersection in one of the subintervals
11623 $(.1011,.011x)$; but lexicographic order would require us to explore
11624 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11625 want to store all of the subdivision data for the second path, so the
11626 subdivisions would have to be regenerated many times. Such inefficiencies
11627 would be associated with every `1' in the binary representation of~$t_1$.
11629 @ The subdivision process introduces rounding errors, hence we need to
11630 make a more liberal test for overlap. It is not hard to show that the
11631 computed values of $U_i$ differ from the truth by at most~$l$, on
11632 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11633 If $\beta$ is an upper bound on the absolute error in the computed
11634 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11635 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11636 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11638 More accuracy is obtained if we try the algorithm first with |tol=0|;
11639 the more liberal tolerance is used only if an exact approach fails.
11640 It is convenient to do this double-take by letting `3' in the preceding
11641 paragraph be a parameter, which is first 0, then 3.
11644 unsigned int tol_step; /* either 0 or 3, usually */
11646 @ We shall use an explicit stack to implement the recursive bisection
11647 method described above. The |bisect_stack| array will contain numerous 5-word
11648 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11649 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11651 The following macros define the allocation of stack positions to
11652 the quantities needed for bisection-intersection.
11654 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11655 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11656 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11657 @d stack_min(A) mp->bisect_stack[(A)+3]
11658 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11659 @d stack_max(A) mp->bisect_stack[(A)+4]
11660 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11661 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11663 @d u_packet(A) ((A)-5)
11664 @d v_packet(A) ((A)-10)
11665 @d x_packet(A) ((A)-15)
11666 @d y_packet(A) ((A)-20)
11667 @d l_packets (mp->bisect_ptr-int_packets)
11668 @d r_packets mp->bisect_ptr
11669 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11670 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11671 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11672 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11673 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11674 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11675 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11676 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11678 @d u1l stack_1(ul_packet) /* $U'_1$ */
11679 @d u2l stack_2(ul_packet) /* $U'_2$ */
11680 @d u3l stack_3(ul_packet) /* $U'_3$ */
11681 @d v1l stack_1(vl_packet) /* $V'_1$ */
11682 @d v2l stack_2(vl_packet) /* $V'_2$ */
11683 @d v3l stack_3(vl_packet) /* $V'_3$ */
11684 @d x1l stack_1(xl_packet) /* $X'_1$ */
11685 @d x2l stack_2(xl_packet) /* $X'_2$ */
11686 @d x3l stack_3(xl_packet) /* $X'_3$ */
11687 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11688 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11689 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11690 @d u1r stack_1(ur_packet) /* $U''_1$ */
11691 @d u2r stack_2(ur_packet) /* $U''_2$ */
11692 @d u3r stack_3(ur_packet) /* $U''_3$ */
11693 @d v1r stack_1(vr_packet) /* $V''_1$ */
11694 @d v2r stack_2(vr_packet) /* $V''_2$ */
11695 @d v3r stack_3(vr_packet) /* $V''_3$ */
11696 @d x1r stack_1(xr_packet) /* $X''_1$ */
11697 @d x2r stack_2(xr_packet) /* $X''_2$ */
11698 @d x3r stack_3(xr_packet) /* $X''_3$ */
11699 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11700 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11701 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11703 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11704 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11705 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11706 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11707 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11708 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11711 integer *bisect_stack;
11712 unsigned int bisect_ptr;
11714 @ @<Allocate or initialize ...@>=
11715 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11717 @ @<Dealloc variables@>=
11718 xfree(mp->bisect_stack);
11720 @ @<Check the ``constant''...@>=
11721 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11723 @ Computation of the min and max is a tedious but fairly fast sequence of
11724 instructions; exactly four comparisons are made in each branch.
11727 if ( stack_1((A))<0 ) {
11728 if ( stack_3((A))>=0 ) {
11729 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11730 else stack_min((A))=stack_1((A));
11731 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11732 if ( stack_max((A))<0 ) stack_max((A))=0;
11734 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11735 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11736 stack_max((A))=stack_1((A))+stack_2((A));
11737 if ( stack_max((A))<0 ) stack_max((A))=0;
11739 } else if ( stack_3((A))<=0 ) {
11740 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11741 else stack_max((A))=stack_1((A));
11742 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11743 if ( stack_min((A))>0 ) stack_min((A))=0;
11745 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11746 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11747 stack_min((A))=stack_1((A))+stack_2((A));
11748 if ( stack_min((A))>0 ) stack_min((A))=0;
11751 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11752 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11753 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11754 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11755 plus the |scaled| values of $t_1$ and~$t_2$.
11757 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11758 finds no intersection. The routine gives up and gives an approximate answer
11759 if it has backtracked
11760 more than 5000 times (otherwise there are cases where several minutes
11761 of fruitless computation would be possible).
11763 @d max_patience 5000
11766 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11767 integer time_to_go; /* this many backtracks before giving up */
11768 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11770 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11771 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
11772 and |(pp,link(pp))|, respectively.
11774 @c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11775 pointer q,qq; /* |link(p)|, |link(pp)| */
11776 mp->time_to_go=max_patience; mp->max_t=2;
11777 @<Initialize for intersections at level zero@>;
11780 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11781 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11782 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11783 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11785 if ( mp->cur_t>=mp->max_t ){
11786 if ( mp->max_t==two ) { /* we've done 17 bisections */
11787 mp->cur_t=halfp(mp->cur_t+1);
11788 mp->cur_tt=halfp(mp->cur_tt+1);
11791 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11793 @<Subdivide for a new level of intersection@>;
11796 if ( mp->time_to_go>0 ) {
11797 decr(mp->time_to_go);
11799 while ( mp->appr_t<unity ) {
11800 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11802 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11804 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11808 @ The following variables are global, although they are used only by
11809 |cubic_intersection|, because it is necessary on some machines to
11810 split |cubic_intersection| up into two procedures.
11813 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11814 integer tol; /* bound on the uncertainty in the overlap test */
11816 unsigned int xy; /* pointers to the current packets of interest */
11817 integer three_l; /* |tol_step| times the bisection level */
11818 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11820 @ We shall assume that the coordinates are sufficiently non-extreme that
11821 integer overflow will not occur.
11822 @^overflow in arithmetic@>
11824 @<Initialize for intersections at level zero@>=
11825 q=link(p); qq=link(pp); mp->bisect_ptr=int_packets;
11826 u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
11827 u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
11828 v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
11829 v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
11830 x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
11831 x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
11832 y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
11833 y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
11834 mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
11835 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11836 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11838 @ @<Subdivide for a new level of intersection@>=
11839 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11840 stack_uv=mp->uv; stack_xy=mp->xy;
11841 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11842 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11843 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11844 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11845 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11846 u3l=half(u2l+u2r); u1r=u3l;
11847 set_min_max(ul_packet); set_min_max(ur_packet);
11848 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11849 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11850 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11851 v3l=half(v2l+v2r); v1r=v3l;
11852 set_min_max(vl_packet); set_min_max(vr_packet);
11853 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11854 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11855 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11856 x3l=half(x2l+x2r); x1r=x3l;
11857 set_min_max(xl_packet); set_min_max(xr_packet);
11858 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11859 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11860 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11861 y3l=half(y2l+y2r); y1r=y3l;
11862 set_min_max(yl_packet); set_min_max(yr_packet);
11863 mp->uv=l_packets; mp->xy=l_packets;
11864 mp->delx+=mp->delx; mp->dely+=mp->dely;
11865 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11866 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11868 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11870 if ( odd(mp->cur_tt) ) {
11871 if ( odd(mp->cur_t) ) {
11872 @<Descend to the previous level and |goto not_found|@>;
11875 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11876 +stack_3(u_packet(mp->uv));
11877 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11878 +stack_3(v_packet(mp->uv));
11879 mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
11880 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11881 /* switch from |r_packets| to |l_packets| */
11882 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11883 +stack_3(x_packet(mp->xy));
11884 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11885 +stack_3(y_packet(mp->xy));
11888 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11889 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11890 -stack_3(x_packet(mp->xy));
11891 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11892 -stack_3(y_packet(mp->xy));
11893 mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
11896 @ @<Descend to the previous level...@>=
11898 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11899 if ( mp->cur_t==0 ) return;
11900 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11901 mp->three_l=mp->three_l-mp->tol_step;
11902 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11903 mp->uv=stack_uv; mp->xy=stack_xy;
11907 @ The |path_intersection| procedure is much simpler.
11908 It invokes |cubic_intersection| in lexicographic order until finding a
11909 pair of cubics that intersect. The final intersection times are placed in
11910 |cur_t| and~|cur_tt|.
11912 @c void mp_path_intersection (MP mp,pointer h, pointer hh) {
11913 pointer p,pp; /* link registers that traverse the given paths */
11914 integer n,nn; /* integer parts of intersection times, minus |unity| */
11915 @<Change one-point paths into dead cycles@>;
11920 if ( right_type(p)!=mp_endpoint ) {
11923 if ( right_type(pp)!=mp_endpoint ) {
11924 mp_cubic_intersection(mp, p,pp);
11925 if ( mp->cur_t>0 ) {
11926 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11930 nn=nn+unity; pp=link(pp);
11933 n=n+unity; p=link(p);
11935 mp->tol_step=mp->tol_step+3;
11936 } while (mp->tol_step<=3);
11937 mp->cur_t=-unity; mp->cur_tt=-unity;
11940 @ @<Change one-point paths...@>=
11941 if ( right_type(h)==mp_endpoint ) {
11942 right_x(h)=x_coord(h); left_x(h)=x_coord(h);
11943 right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
11945 if ( right_type(hh)==mp_endpoint ) {
11946 right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
11947 right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
11950 @* \[24] Dynamic linear equations.
11951 \MP\ users define variables implicitly by stating equations that should be
11952 satisfied; the computer is supposed to be smart enough to solve those equations.
11953 And indeed, the computer tries valiantly to do so, by distinguishing five
11954 different types of numeric values:
11957 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11958 of the variable whose address is~|p|.
11961 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11962 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11963 as a |scaled| number plus a sum of independent variables with |fraction|
11967 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11968 number'' reflecting the time this variable was first used in an equation;
11969 also |0<=m<64|, and each dependent variable
11970 that refers to this one is actually referring to the future value of
11971 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11972 scaling are sometimes needed to keep the coefficients in dependency lists
11973 from getting too large. The value of~|m| will always be even.)
11976 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11977 equation before, but it has been explicitly declared to be numeric.
11980 |type(p)=undefined| means that variable |p| hasn't appeared before.
11982 \smallskip\noindent
11983 We have actually discussed these five types in the reverse order of their
11984 history during a computation: Once |known|, a variable never again
11985 becomes |dependent|; once |dependent|, it almost never again becomes
11986 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
11987 and once |mp_numeric_type|, it never again becomes |undefined| (except
11988 of course when the user specifically decides to scrap the old value
11989 and start again). A backward step may, however, take place: Sometimes
11990 a |dependent| variable becomes |mp_independent| again, when one of the
11991 independent variables it depends on is reverting to |undefined|.
11994 The next patch detects overflow of independent-variable serial
11995 numbers. Diagnosed and patched by Thorsten Dahlheimer.
11997 @d s_scale 64 /* the serial numbers are multiplied by this factor */
11998 @d new_indep(A) /* create a new independent variable */
11999 { if ( mp->serial_no>el_gordo-s_scale )
12000 mp_fatal_error(mp, "variable instance identifiers exhausted");
12001 type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
12002 value((A))=mp->serial_no;
12006 integer serial_no; /* the most recent serial number, times |s_scale| */
12008 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
12010 @ But how are dependency lists represented? It's simple: The linear combination
12011 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
12012 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
12013 @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
12014 of $\alpha_1$; and |link(p)| points to the dependency list
12015 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
12016 then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
12017 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
12018 they appear in decreasing order of their |value| fields (i.e., of
12019 their serial numbers). \ (It is convenient to use decreasing order,
12020 since |value(null)=0|. If the independent variables were not sorted by
12021 serial number but by some other criterion, such as their location in |mem|,
12022 the equation-solving mechanism would be too system-dependent, because
12023 the ordering can affect the computed results.)
12025 The |link| field in the node that contains the constant term $\beta$ is
12026 called the {\sl final link\/} of the dependency list. \MP\ maintains
12027 a doubly-linked master list of all dependency lists, in terms of a permanently
12029 in |mem| called |dep_head|. If there are no dependencies, we have
12030 |link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
12031 otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
12032 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
12033 points to its dependency list. If the final link of that dependency list
12034 occurs in location~|q|, then |link(q)| points to the next dependent
12035 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
12037 @d dep_list(A) link(value_loc((A)))
12038 /* half of the |value| field in a |dependent| variable */
12039 @d prev_dep(A) info(value_loc((A)))
12040 /* the other half; makes a doubly linked list */
12041 @d dep_node_size 2 /* the number of words per dependency node */
12043 @<Initialize table entries...@>= mp->serial_no=0;
12044 link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
12045 info(dep_head)=null; dep_list(dep_head)=null;
12047 @ Actually the description above contains a little white lie. There's
12048 another kind of variable called |mp_proto_dependent|, which is
12049 just like a |dependent| one except that the $\alpha$ coefficients
12050 in its dependency list are |scaled| instead of being fractions.
12051 Proto-dependency lists are mixed with dependency lists in the
12052 nodes reachable from |dep_head|.
12054 @ Here is a procedure that prints a dependency list in symbolic form.
12055 The second parameter should be either |dependent| or |mp_proto_dependent|,
12056 to indicate the scaling of the coefficients.
12058 @<Declare subroutines for printing expressions@>=
12059 void mp_print_dependency (MP mp,pointer p, small_number t) {
12060 integer v; /* a coefficient */
12061 pointer pp,q; /* for list manipulation */
12064 v=abs(value(p)); q=info(p);
12065 if ( q==null ) { /* the constant term */
12066 if ( (v!=0)||(p==pp) ) {
12067 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, '+');
12068 mp_print_scaled(mp, value(p));
12072 @<Print the coefficient, unless it's $\pm1.0$@>;
12073 if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
12074 @:this can't happen dep}{\quad dep@>
12075 mp_print_variable_name(mp, q); v=value(q) % s_scale;
12076 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
12081 @ @<Print the coefficient, unless it's $\pm1.0$@>=
12082 if ( value(p)<0 ) mp_print_char(mp, '-');
12083 else if ( p!=pp ) mp_print_char(mp, '+');
12084 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
12085 if ( v!=unity ) mp_print_scaled(mp, v)
12087 @ The maximum absolute value of a coefficient in a given dependency list
12088 is returned by the following simple function.
12090 @c fraction mp_max_coef (MP mp,pointer p) {
12091 fraction x; /* the maximum so far */
12093 while ( info(p)!=null ) {
12094 if ( abs(value(p))>x ) x=abs(value(p));
12100 @ One of the main operations needed on dependency lists is to add a multiple
12101 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
12102 to dependency lists and |f| is a fraction.
12104 If the coefficient of any independent variable becomes |coef_bound| or
12105 more, in absolute value, this procedure changes the type of that variable
12106 to `|independent_needing_fix|', and sets the global variable |fix_needed|
12107 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
12108 $\mu^2+\mu<8$; this means that the numbers we deal with won't
12109 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
12110 2.3723$, the safer value 7/3 is taken as the threshold.)
12112 The changes mentioned in the preceding paragraph are actually done only if
12113 the global variable |watch_coefs| is |true|. But it usually is; in fact,
12114 it is |false| only when \MP\ is making a dependency list that will soon
12115 be equated to zero.
12117 Several procedures that act on dependency lists, including |p_plus_fq|,
12118 set the global variable |dep_final| to the final (constant term) node of
12119 the dependency list that they produce.
12121 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
12122 @d independent_needing_fix 0
12125 boolean fix_needed; /* does at least one |independent| variable need scaling? */
12126 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
12127 pointer dep_final; /* location of the constant term and final link */
12130 mp->fix_needed=false; mp->watch_coefs=true;
12132 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
12133 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
12134 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
12135 should be |mp_proto_dependent| if |q| is a proto-dependency list.
12137 List |q| is unchanged by the operation; but list |p| is totally destroyed.
12139 The final link of the dependency list or proto-dependency list returned
12140 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
12141 constant term of the result will be located in the same |mem| location
12142 as the original constant term of~|p|.
12144 Coefficients of the result are assumed to be zero if they are less than
12145 a certain threshold. This compensates for inevitable rounding errors,
12146 and tends to make more variables `|known|'. The threshold is approximately
12147 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
12148 proto-dependencies.
12150 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
12151 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
12152 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
12153 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
12155 @<Declare basic dependency-list subroutines@>=
12156 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12157 pointer q, small_number t, small_number tt) ;
12160 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12161 pointer q, small_number t, small_number tt) {
12162 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12163 pointer r,s; /* for list manipulation */
12164 integer threshold; /* defines a neighborhood of zero */
12165 integer v; /* temporary register */
12166 if ( t==mp_dependent ) threshold=fraction_threshold;
12167 else threshold=scaled_threshold;
12168 r=temp_head; pp=info(p); qq=info(q);
12174 @<Contribute a term from |p|, plus |f| times the
12175 corresponding term from |q|@>
12177 } else if ( value(pp)<value(qq) ) {
12178 @<Contribute a term from |q|, multiplied by~|f|@>
12180 link(r)=p; r=p; p=link(p); pp=info(p);
12183 if ( t==mp_dependent )
12184 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
12186 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
12187 link(r)=p; mp->dep_final=p;
12188 return link(temp_head);
12191 @ @<Contribute a term from |p|, plus |f|...@>=
12193 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
12194 else v=value(p)+mp_take_scaled(mp, f,value(q));
12195 value(p)=v; s=p; p=link(p);
12196 if ( abs(v)<threshold ) {
12197 mp_free_node(mp, s,dep_node_size);
12199 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12200 type(qq)=independent_needing_fix; mp->fix_needed=true;
12204 pp=info(p); q=link(q); qq=info(q);
12207 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12209 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12210 else v=mp_take_scaled(mp, f,value(q));
12211 if ( abs(v)>halfp(threshold) ) {
12212 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
12213 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12214 type(qq)=independent_needing_fix; mp->fix_needed=true;
12218 q=link(q); qq=info(q);
12221 @ It is convenient to have another subroutine for the special case
12222 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12223 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12225 @c pointer mp_p_plus_q (MP mp,pointer p, pointer q, small_number t) {
12226 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12227 pointer r,s; /* for list manipulation */
12228 integer threshold; /* defines a neighborhood of zero */
12229 integer v; /* temporary register */
12230 if ( t==mp_dependent ) threshold=fraction_threshold;
12231 else threshold=scaled_threshold;
12232 r=temp_head; pp=info(p); qq=info(q);
12238 @<Contribute a term from |p|, plus the
12239 corresponding term from |q|@>
12242 if ( value(pp)<value(qq) ) {
12243 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
12244 q=link(q); qq=info(q); link(r)=s; r=s;
12246 link(r)=p; r=p; p=link(p); pp=info(p);
12250 value(p)=mp_slow_add(mp, value(p),value(q));
12251 link(r)=p; mp->dep_final=p;
12252 return link(temp_head);
12255 @ @<Contribute a term from |p|, plus the...@>=
12257 v=value(p)+value(q);
12258 value(p)=v; s=p; p=link(p); pp=info(p);
12259 if ( abs(v)<threshold ) {
12260 mp_free_node(mp, s,dep_node_size);
12262 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12263 type(qq)=independent_needing_fix; mp->fix_needed=true;
12267 q=link(q); qq=info(q);
12270 @ A somewhat simpler routine will multiply a dependency list
12271 by a given constant~|v|. The constant is either a |fraction| less than
12272 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12273 convert a dependency list to a proto-dependency list.
12274 Parameters |t0| and |t1| are the list types before and after;
12275 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12276 and |v_is_scaled=true|.
12278 @c pointer mp_p_times_v (MP mp,pointer p, integer v, small_number t0,
12279 small_number t1, boolean v_is_scaled) {
12280 pointer r,s; /* for list manipulation */
12281 integer w; /* tentative coefficient */
12283 boolean scaling_down;
12284 if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
12285 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12286 else threshold=half_scaled_threshold;
12288 while ( info(p)!=null ) {
12289 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12290 else w=mp_take_scaled(mp, v,value(p));
12291 if ( abs(w)<=threshold ) {
12292 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12294 if ( abs(w)>=coef_bound ) {
12295 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12297 link(r)=p; r=p; value(p)=w; p=link(p);
12301 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12302 else value(p)=mp_take_fraction(mp, value(p),v);
12303 return link(temp_head);
12306 @ Similarly, we sometimes need to divide a dependency list
12307 by a given |scaled| constant.
12309 @<Declare basic dependency-list subroutines@>=
12310 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12311 t0, small_number t1) ;
12314 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12315 t0, small_number t1) {
12316 pointer r,s; /* for list manipulation */
12317 integer w; /* tentative coefficient */
12319 boolean scaling_down;
12320 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12321 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12322 else threshold=half_scaled_threshold;
12324 while ( info( p)!=null ) {
12325 if ( scaling_down ) {
12326 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12327 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12329 w=mp_make_scaled(mp, value(p),v);
12331 if ( abs(w)<=threshold ) {
12332 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12334 if ( abs(w)>=coef_bound ) {
12335 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12337 link(r)=p; r=p; value(p)=w; p=link(p);
12340 link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12341 return link(temp_head);
12344 @ Here's another utility routine for dependency lists. When an independent
12345 variable becomes dependent, we want to remove it from all existing
12346 dependencies. The |p_with_x_becoming_q| function computes the
12347 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12349 This procedure has basically the same calling conventions as |p_plus_fq|:
12350 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12351 final link are inherited from~|p|; and the fourth parameter tells whether
12352 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12353 is not altered if |x| does not occur in list~|p|.
12355 @c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12356 pointer x, pointer q, small_number t) {
12357 pointer r,s; /* for list manipulation */
12358 integer v; /* coefficient of |x| */
12359 integer sx; /* serial number of |x| */
12360 s=p; r=temp_head; sx=value(x);
12361 while ( value(info(s))>sx ) { r=s; s=link(s); };
12362 if ( info(s)!=x ) {
12365 link(temp_head)=p; link(r)=link(s); v=value(s);
12366 mp_free_node(mp, s,dep_node_size);
12367 return mp_p_plus_fq(mp, link(temp_head),v,q,t,mp_dependent);
12371 @ Here's a simple procedure that reports an error when a variable
12372 has just received a known value that's out of the required range.
12374 @<Declare basic dependency-list subroutines@>=
12375 void mp_val_too_big (MP mp,scaled x) ;
12377 @ @c void mp_val_too_big (MP mp,scaled x) {
12378 if ( mp->internal[mp_warning_check]>0 ) {
12379 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, ')');
12380 @.Value is too large@>
12381 help4("The equation I just processed has given some variable")
12382 ("a value of 4096 or more. Continue and I'll try to cope")
12383 ("with that big value; but it might be dangerous.")
12384 ("(Set warningcheck:=0 to suppress this message.)");
12389 @ When a dependent variable becomes known, the following routine
12390 removes its dependency list. Here |p| points to the variable, and
12391 |q| points to the dependency list (which is one node long).
12393 @<Declare basic dependency-list subroutines@>=
12394 void mp_make_known (MP mp,pointer p, pointer q) ;
12396 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12397 int t; /* the previous type */
12398 prev_dep(link(q))=prev_dep(p);
12399 link(prev_dep(p))=link(q); t=type(p);
12400 type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12401 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12402 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12403 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12404 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12405 mp_print_variable_name(mp, p);
12406 mp_print_char(mp, '='); mp_print_scaled(mp, value(p));
12407 mp_end_diagnostic(mp, false);
12409 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12410 mp->cur_type=mp_known; mp->cur_exp=value(p);
12411 mp_free_node(mp, p,value_node_size);
12415 @ The |fix_dependencies| routine is called into action when |fix_needed|
12416 has been triggered. The program keeps a list~|s| of independent variables
12417 whose coefficients must be divided by~4.
12419 In unusual cases, this fixup process might reduce one or more coefficients
12420 to zero, so that a variable will become known more or less by default.
12422 @<Declare basic dependency-list subroutines@>=
12423 void mp_fix_dependencies (MP mp);
12425 @ @c void mp_fix_dependencies (MP mp) {
12426 pointer p,q,r,s,t; /* list manipulation registers */
12427 pointer x; /* an independent variable */
12428 r=link(dep_head); s=null;
12429 while ( r!=dep_head ){
12431 @<Run through the dependency list for variable |t|, fixing
12432 all nodes, and ending with final link~|q|@>;
12434 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12436 while ( s!=null ) {
12437 p=link(s); x=info(s); free_avail(s); s=p;
12438 type(x)=mp_independent; value(x)=value(x)+2;
12440 mp->fix_needed=false;
12443 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12445 @<Run through the dependency list for variable |t|...@>=
12446 r=value_loc(t); /* |link(r)=dep_list(t)| */
12448 q=link(r); x=info(q);
12449 if ( x==null ) break;
12450 if ( type(x)<=independent_being_fixed ) {
12451 if ( type(x)<independent_being_fixed ) {
12452 p=mp_get_avail(mp); link(p)=s; s=p;
12453 info(s)=x; type(x)=independent_being_fixed;
12455 value(q)=value(q) / 4;
12456 if ( value(q)==0 ) {
12457 link(r)=link(q); mp_free_node(mp, q,dep_node_size); q=r;
12464 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12465 linking it into the list of all known dependencies. We assume that
12466 |dep_final| points to the final node of list~|p|.
12468 @c void mp_new_dep (MP mp,pointer q, pointer p) {
12469 pointer r; /* what used to be the first dependency */
12470 dep_list(q)=p; prev_dep(q)=dep_head;
12471 r=link(dep_head); link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12475 @ Here is one of the ways a dependency list gets started.
12476 The |const_dependency| routine produces a list that has nothing but
12479 @c pointer mp_const_dependency (MP mp, scaled v) {
12480 mp->dep_final=mp_get_node(mp, dep_node_size);
12481 value(mp->dep_final)=v; info(mp->dep_final)=null;
12482 return mp->dep_final;
12485 @ And here's a more interesting way to start a dependency list from scratch:
12486 The parameter to |single_dependency| is the location of an
12487 independent variable~|x|, and the result is the simple dependency list
12490 In the unlikely event that the given independent variable has been doubled so
12491 often that we can't refer to it with a nonzero coefficient,
12492 |single_dependency| returns the simple list `0'. This case can be
12493 recognized by testing that the returned list pointer is equal to
12496 @c pointer mp_single_dependency (MP mp,pointer p) {
12497 pointer q; /* the new dependency list */
12498 integer m; /* the number of doublings */
12499 m=value(p) % s_scale;
12501 return mp_const_dependency(mp, 0);
12503 q=mp_get_node(mp, dep_node_size);
12504 value(q)=two_to_the(28-m); info(q)=p;
12505 link(q)=mp_const_dependency(mp, 0);
12510 @ We sometimes need to make an exact copy of a dependency list.
12512 @c pointer mp_copy_dep_list (MP mp,pointer p) {
12513 pointer q; /* the new dependency list */
12514 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12516 info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
12517 if ( info(mp->dep_final)==null ) break;
12518 link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12519 mp->dep_final=link(mp->dep_final); p=link(p);
12524 @ But how do variables normally become known? Ah, now we get to the heart of the
12525 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12526 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12527 appears. It equates this list to zero, by choosing an independent variable
12528 with the largest coefficient and making it dependent on the others. The
12529 newly dependent variable is eliminated from all current dependencies,
12530 thereby possibly making other dependent variables known.
12532 The given list |p| is, of course, totally destroyed by all this processing.
12534 @c void mp_linear_eq (MP mp, pointer p, small_number t) {
12535 pointer q,r,s; /* for link manipulation */
12536 pointer x; /* the variable that loses its independence */
12537 integer n; /* the number of times |x| had been halved */
12538 integer v; /* the coefficient of |x| in list |p| */
12539 pointer prev_r; /* lags one step behind |r| */
12540 pointer final_node; /* the constant term of the new dependency list */
12541 integer w; /* a tentative coefficient */
12542 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12543 x=info(q); n=value(x) % s_scale;
12544 @<Divide list |p| by |-v|, removing node |q|@>;
12545 if ( mp->internal[mp_tracing_equations]>0 ) {
12546 @<Display the new dependency@>;
12548 @<Simplify all existing dependencies by substituting for |x|@>;
12549 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12550 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12553 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12554 q=p; r=link(p); v=value(q);
12555 while ( info(r)!=null ) {
12556 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12560 @ Here we want to change the coefficients from |scaled| to |fraction|,
12561 except in the constant term. In the common case of a trivial equation
12562 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12564 @<Divide list |p| by |-v|, removing node |q|@>=
12565 s=temp_head; link(s)=p; r=p;
12568 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12570 w=mp_make_fraction(mp, value(r),v);
12571 if ( abs(w)<=half_fraction_threshold ) {
12572 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12578 } while (info(r)!=null);
12579 if ( t==mp_proto_dependent ) {
12580 value(r)=-mp_make_scaled(mp, value(r),v);
12581 } else if ( v!=-fraction_one ) {
12582 value(r)=-mp_make_fraction(mp, value(r),v);
12584 final_node=r; p=link(temp_head)
12586 @ @<Display the new dependency@>=
12587 if ( mp_interesting(mp, x) ) {
12588 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12589 mp_print_variable_name(mp, x);
12590 @:]]]\#\#_}{\.{\#\#}@>
12592 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12593 mp_print_char(mp, '='); mp_print_dependency(mp, p,mp_dependent);
12594 mp_end_diagnostic(mp, false);
12597 @ @<Simplify all existing dependencies by substituting for |x|@>=
12598 prev_r=dep_head; r=link(dep_head);
12599 while ( r!=dep_head ) {
12600 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
12601 if ( info(q)==null ) {
12602 mp_make_known(mp, r,q);
12605 do { q=link(q); } while (info(q)!=null);
12611 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12612 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12613 if ( info(p)==null ) {
12616 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12617 mp_free_node(mp, p,dep_node_size);
12618 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12619 mp->cur_exp=value(x); mp->cur_type=mp_known;
12620 mp_free_node(mp, x,value_node_size);
12623 type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12624 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12627 @ @<Divide list |p| by $2^n$@>=
12629 s=temp_head; link(temp_head)=p; r=p;
12632 else w=value(r) / two_to_the(n);
12633 if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
12635 mp_free_node(mp, r,dep_node_size);
12640 } while (info(s)!=null);
12644 @ The |check_mem| procedure, which is used only when \MP\ is being
12645 debugged, makes sure that the current dependency lists are well formed.
12647 @<Check the list of linear dependencies@>=
12648 q=dep_head; p=link(q);
12649 while ( p!=dep_head ) {
12650 if ( prev_dep(p)!=q ) {
12651 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12656 r=info(p); q=p; p=link(q);
12657 if ( r==null ) break;
12658 if ( value(info(p))>=value(r) ) {
12659 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12660 @.Out of order...@>
12665 @* \[25] Dynamic nonlinear equations.
12666 Variables of numeric type are maintained by the general scheme of
12667 independent, dependent, and known values that we have just studied;
12668 and the components of pair and transform variables are handled in the
12669 same way. But \MP\ also has five other types of values: \&{boolean},
12670 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12672 Equations are allowed between nonlinear quantities, but only in a
12673 simple form. Two variables that haven't yet been assigned values are
12674 either equal to each other, or they're not.
12676 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12677 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12678 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12679 |null| (which means that no other variables are equivalent to this one), or
12680 it points to another variable of the same undefined type. The pointers in the
12681 latter case form a cycle of nodes, which we shall call a ``ring.''
12682 Rings of undefined variables may include capsules, which arise as
12683 intermediate results within expressions or as \&{expr} parameters to macros.
12685 When one member of a ring receives a value, the same value is given to
12686 all the other members. In the case of paths and pictures, this implies
12687 making separate copies of a potentially large data structure; users should
12688 restrain their enthusiasm for such generality, unless they have lots and
12689 lots of memory space.
12691 @ The following procedure is called when a capsule node is being
12692 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12694 @c pointer mp_new_ring_entry (MP mp,pointer p) {
12695 pointer q; /* the new capsule node */
12696 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
12698 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12703 @ Conversely, we might delete a capsule or a variable before it becomes known.
12704 The following procedure simply detaches a quantity from its ring,
12705 without recycling the storage.
12707 @<Declare the recycling subroutines@>=
12708 void mp_ring_delete (MP mp,pointer p) {
12711 if ( q!=null ) if ( q!=p ){
12712 while ( value(q)!=p ) q=value(q);
12717 @ Eventually there might be an equation that assigns values to all of the
12718 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12719 propagation of values.
12721 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12722 value, it will soon be recycled.
12724 @c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12725 small_number t; /* the type of ring |p| */
12726 pointer q,r; /* link manipulation registers */
12727 t=type(p)-unknown_tag; q=value(p);
12728 if ( flush_p ) type(p)=mp_vacuous; else p=q;
12730 r=value(q); type(q)=t;
12732 case mp_boolean_type: value(q)=v; break;
12733 case mp_string_type: value(q)=v; add_str_ref(v); break;
12734 case mp_pen_type: value(q)=copy_pen(v); break;
12735 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12736 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12737 } /* there ain't no more cases */
12742 @ If two members of rings are equated, and if they have the same type,
12743 the |ring_merge| procedure is called on to make them equivalent.
12745 @c void mp_ring_merge (MP mp,pointer p, pointer q) {
12746 pointer r; /* traverses one list */
12750 @<Exclaim about a redundant equation@>;
12755 r=value(p); value(p)=value(q); value(q)=r;
12758 @ @<Exclaim about a redundant equation@>=
12760 print_err("Redundant equation");
12761 @.Redundant equation@>
12762 help2("I already knew that this equation was true.")
12763 ("But perhaps no harm has been done; let's continue.");
12764 mp_put_get_error(mp);
12767 @* \[26] Introduction to the syntactic routines.
12768 Let's pause a moment now and try to look at the Big Picture.
12769 The \MP\ program consists of three main parts: syntactic routines,
12770 semantic routines, and output routines. The chief purpose of the
12771 syntactic routines is to deliver the user's input to the semantic routines,
12772 while parsing expressions and locating operators and operands. The
12773 semantic routines act as an interpreter responding to these operators,
12774 which may be regarded as commands. And the output routines are
12775 periodically called on to produce compact font descriptions that can be
12776 used for typesetting or for making interim proof drawings. We have
12777 discussed the basic data structures and many of the details of semantic
12778 operations, so we are good and ready to plunge into the part of \MP\ that
12779 actually controls the activities.
12781 Our current goal is to come to grips with the |get_next| procedure,
12782 which is the keystone of \MP's input mechanism. Each call of |get_next|
12783 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12784 representing the next input token.
12785 $$\vbox{\halign{#\hfil\cr
12786 \hbox{|cur_cmd| denotes a command code from the long list of codes
12788 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12789 \hbox{|cur_sym| is the hash address of the symbolic token that was
12791 \hbox{\qquad or zero in the case of a numeric or string
12792 or capsule token.}\cr}}$$
12793 Underlying this external behavior of |get_next| is all the machinery
12794 necessary to convert from character files to tokens. At a given time we
12795 may be only partially finished with the reading of several files (for
12796 which \&{input} was specified), and partially finished with the expansion
12797 of some user-defined macros and/or some macro parameters, and partially
12798 finished reading some text that the user has inserted online,
12799 and so on. When reading a character file, the characters must be
12800 converted to tokens; comments and blank spaces must
12801 be removed, numeric and string tokens must be evaluated.
12803 To handle these situations, which might all be present simultaneously,
12804 \MP\ uses various stacks that hold information about the incomplete
12805 activities, and there is a finite state control for each level of the
12806 input mechanism. These stacks record the current state of an implicitly
12807 recursive process, but the |get_next| procedure is not recursive.
12810 eight_bits cur_cmd; /* current command set by |get_next| */
12811 integer cur_mod; /* operand of current command */
12812 halfword cur_sym; /* hash address of current symbol */
12814 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12815 command code and its modifier.
12816 It consists of a rather tedious sequence of print
12817 commands, and most of it is essentially an inverse to the |primitive|
12818 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12819 all of this procedure appears elsewhere in the program, together with the
12820 corresponding |primitive| calls.
12822 @<Declare the procedure called |print_cmd_mod|@>=
12823 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12825 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12826 default: mp_print(mp, "[unknown command code!]"); break;
12830 @ Here is a procedure that displays a given command in braces, in the
12831 user's transcript file.
12833 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12836 void mp_show_cmd_mod (MP mp,integer c, integer m) {
12837 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12838 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, '}');
12839 mp_end_diagnostic(mp, false);
12842 @* \[27] Input stacks and states.
12843 The state of \MP's input mechanism appears in the input stack, whose
12844 entries are records with five fields, called |index|, |start|, |loc|,
12845 |limit|, and |name|. The top element of this stack is maintained in a
12846 global variable for which no subscripting needs to be done; the other
12847 elements of the stack appear in an array. Hence the stack is declared thus:
12851 quarterword index_field;
12852 halfword start_field, loc_field, limit_field, name_field;
12856 in_state_record *input_stack;
12857 integer input_ptr; /* first unused location of |input_stack| */
12858 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12859 in_state_record cur_input; /* the ``top'' input state */
12860 int stack_size; /* maximum number of simultaneous input sources */
12862 @ @<Allocate or initialize ...@>=
12863 mp->stack_size = 300;
12864 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12866 @ @<Dealloc variables@>=
12867 xfree(mp->input_stack);
12869 @ We've already defined the special variable |loc==cur_input.loc_field|
12870 in our discussion of basic input-output routines. The other components of
12871 |cur_input| are defined in the same way:
12873 @d index mp->cur_input.index_field /* reference for buffer information */
12874 @d start mp->cur_input.start_field /* starting position in |buffer| */
12875 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12876 @d name mp->cur_input.name_field /* name of the current file */
12878 @ Let's look more closely now at the five control variables
12879 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12880 assuming that \MP\ is reading a line of characters that have been input
12881 from some file or from the user's terminal. There is an array called
12882 |buffer| that acts as a stack of all lines of characters that are
12883 currently being read from files, including all lines on subsidiary
12884 levels of the input stack that are not yet completed. \MP\ will return to
12885 the other lines when it is finished with the present input file.
12887 (Incidentally, on a machine with byte-oriented addressing, it would be
12888 appropriate to combine |buffer| with the |str_pool| array,
12889 letting the buffer entries grow downward from the top of the string pool
12890 and checking that these two tables don't bump into each other.)
12892 The line we are currently working on begins in position |start| of the
12893 buffer; the next character we are about to read is |buffer[loc]|; and
12894 |limit| is the location of the last character present. We always have
12895 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12896 that the end of a line is easily sensed.
12898 The |name| variable is a string number that designates the name of
12899 the current file, if we are reading an ordinary text file. Special codes
12900 |is_term..max_spec_src| indicate other sources of input text.
12902 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12903 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12904 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12905 @d max_spec_src is_scantok
12907 @ Additional information about the current line is available via the
12908 |index| variable, which counts how many lines of characters are present
12909 in the buffer below the current level. We have |index=0| when reading
12910 from the terminal and prompting the user for each line; then if the user types,
12911 e.g., `\.{input figs}', we will have |index=1| while reading
12912 the file \.{figs.mp}. However, it does not follow that |index| is the
12913 same as the input stack pointer, since many of the levels on the input
12914 stack may come from token lists and some |index| values may correspond
12915 to \.{MPX} files that are not currently on the stack.
12917 The global variable |in_open| is equal to the highest |index| value counting
12918 \.{MPX} files but excluding token-list input levels. Thus, the number of
12919 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12920 when we are not reading a token list.
12922 If we are not currently reading from the terminal,
12923 we are reading from the file variable |input_file[index]|. We use
12924 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12925 and |cur_file| as an abbreviation for |input_file[index]|.
12927 When \MP\ is not reading from the terminal, the global variable |line| contains
12928 the line number in the current file, for use in error messages. More precisely,
12929 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12930 the line number for each file in the |input_file| array.
12932 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12933 array so that the name doesn't get lost when the file is temporarily removed
12934 from the input stack.
12935 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12936 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12937 Since this is not an \.{MPX} file, we have
12938 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12939 This |name| field is set to |finished| when |input_file[k]| is completely
12942 If more information about the input state is needed, it can be
12943 included in small arrays like those shown here. For example,
12944 the current page or segment number in the input file might be put
12945 into a variable |page|, that is really a macro for the current entry
12946 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12947 by analogy with |line_stack|.
12948 @^system dependencies@>
12950 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12951 @d cur_file mp->input_file[index] /* the current |void *| variable */
12952 @d line mp->line_stack[index] /* current line number in the current source file */
12953 @d in_name mp->iname_stack[index] /* a string used to construct \.{MPX} file names */
12954 @d in_area mp->iarea_stack[index] /* another string for naming \.{MPX} files */
12955 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12956 @d mpx_reading (mp->mpx_name[index]>absent)
12957 /* when reading a file, is it an \.{MPX} file? */
12959 /* |name_field| value when the corresponding \.{MPX} file is finished */
12962 integer in_open; /* the number of lines in the buffer, less one */
12963 unsigned int open_parens; /* the number of open text files */
12964 void * *input_file ;
12965 integer *line_stack ; /* the line number for each file */
12966 char * *iname_stack; /* used for naming \.{MPX} files */
12967 char * *iarea_stack; /* used for naming \.{MPX} files */
12968 halfword*mpx_name ;
12970 @ @<Allocate or ...@>=
12971 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
12972 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
12973 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12974 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12975 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
12978 for (k=0;k<=mp->max_in_open;k++) {
12979 mp->iname_stack[k] =NULL;
12980 mp->iarea_stack[k] =NULL;
12984 @ @<Dealloc variables@>=
12987 for (l=0;l<=mp->max_in_open;l++) {
12988 xfree(mp->iname_stack[l]);
12989 xfree(mp->iarea_stack[l]);
12992 xfree(mp->input_file);
12993 xfree(mp->line_stack);
12994 xfree(mp->iname_stack);
12995 xfree(mp->iarea_stack);
12996 xfree(mp->mpx_name);
12999 @ However, all this discussion about input state really applies only to the
13000 case that we are inputting from a file. There is another important case,
13001 namely when we are currently getting input from a token list. In this case
13002 |index>max_in_open|, and the conventions about the other state variables
13005 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
13006 the node that will be read next. If |loc=null|, the token list has been
13009 \yskip\hang|start| points to the first node of the token list; this node
13010 may or may not contain a reference count, depending on the type of token
13013 \yskip\hang|token_type|, which takes the place of |index| in the
13014 discussion above, is a code number that explains what kind of token list
13017 \yskip\hang|name| points to the |eqtb| address of the control sequence
13018 being expanded, if the current token list is a macro not defined by
13019 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
13020 can be deduced by looking at their first two parameters.
13022 \yskip\hang|param_start|, which takes the place of |limit|, tells where
13023 the parameters of the current macro or loop text begin in the |param_stack|.
13025 \yskip\noindent The |token_type| can take several values, depending on
13026 where the current token list came from:
13029 \indent|forever_text|, if the token list being scanned is the body of
13030 a \&{forever} loop;
13032 \indent|loop_text|, if the token list being scanned is the body of
13033 a \&{for} or \&{forsuffixes} loop;
13035 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
13037 \indent|backed_up|, if the token list being scanned has been inserted as
13038 `to be read again'.
13040 \indent|inserted|, if the token list being scanned has been inserted as
13041 part of error recovery;
13043 \indent|macro|, if the expansion of a user-defined symbolic token is being
13047 The token list begins with a reference count if and only if |token_type=
13049 @^reference counts@>
13051 @d token_type index /* type of current token list */
13052 @d token_state (index>(int)mp->max_in_open) /* are we scanning a token list? */
13053 @d file_state (index<=(int)mp->max_in_open) /* are we scanning a file line? */
13054 @d param_start limit /* base of macro parameters in |param_stack| */
13055 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
13056 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
13057 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
13058 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
13059 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
13060 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
13062 @ The |param_stack| is an auxiliary array used to hold pointers to the token
13063 lists for parameters at the current level and subsidiary levels of input.
13064 This stack grows at a different rate from the others.
13067 pointer *param_stack; /* token list pointers for parameters */
13068 integer param_ptr; /* first unused entry in |param_stack| */
13069 integer max_param_stack; /* largest value of |param_ptr| */
13071 @ @<Allocate or initialize ...@>=
13072 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
13074 @ @<Dealloc variables@>=
13075 xfree(mp->param_stack);
13077 @ Notice that the |line| isn't valid when |token_state| is true because it
13078 depends on |index|. If we really need to know the line number for the
13079 topmost file in the index stack we use the following function. If a page
13080 number or other information is needed, this routine should be modified to
13081 compute it as well.
13082 @^system dependencies@>
13084 @<Declare a function called |true_line|@>=
13085 integer mp_true_line (MP mp) {
13086 int k; /* an index into the input stack */
13087 if ( file_state && (name>max_spec_src) ) {
13092 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
13093 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
13096 return (k>0 ? mp->line_stack[(k-1)] : 0 );
13100 @ Thus, the ``current input state'' can be very complicated indeed; there
13101 can be many levels and each level can arise in a variety of ways. The
13102 |show_context| procedure, which is used by \MP's error-reporting routine to
13103 print out the current input state on all levels down to the most recent
13104 line of characters from an input file, illustrates most of these conventions.
13105 The global variable |file_ptr| contains the lowest level that was
13106 displayed by this procedure.
13109 integer file_ptr; /* shallowest level shown by |show_context| */
13111 @ The status at each level is indicated by printing two lines, where the first
13112 line indicates what was read so far and the second line shows what remains
13113 to be read. The context is cropped, if necessary, so that the first line
13114 contains at most |half_error_line| characters, and the second contains
13115 at most |error_line|. Non-current input levels whose |token_type| is
13116 `|backed_up|' are shown only if they have not been fully read.
13118 @c void mp_show_context (MP mp) { /* prints where the scanner is */
13119 int old_setting; /* saved |selector| setting */
13120 @<Local variables for formatting calculations@>
13121 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
13122 /* store current state */
13124 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
13125 @<Display the current context@>;
13127 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
13128 decr(mp->file_ptr);
13130 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
13133 @ @<Display the current context@>=
13134 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
13135 (token_type!=backed_up) || (loc!=null) ) {
13136 /* we omit backed-up token lists that have already been read */
13137 mp->tally=0; /* get ready to count characters */
13138 old_setting=mp->selector;
13139 if ( file_state ) {
13140 @<Print location of current line@>;
13141 @<Pseudoprint the line@>;
13143 @<Print type of token list@>;
13144 @<Pseudoprint the token list@>;
13146 mp->selector=old_setting; /* stop pseudoprinting */
13147 @<Print two lines using the tricky pseudoprinted information@>;
13150 @ This routine should be changed, if necessary, to give the best possible
13151 indication of where the current line resides in the input file.
13152 For example, on some systems it is best to print both a page and line number.
13153 @^system dependencies@>
13155 @<Print location of current line@>=
13156 if ( name>max_spec_src ) {
13157 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
13158 } else if ( terminal_input ) {
13159 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
13160 else mp_print_nl(mp, "<insert>");
13161 } else if ( name==is_scantok ) {
13162 mp_print_nl(mp, "<scantokens>");
13164 mp_print_nl(mp, "<read>");
13166 mp_print_char(mp, ' ')
13168 @ Can't use case statement here because the |token_type| is not
13169 a constant expression.
13171 @<Print type of token list@>=
13173 if(token_type==forever_text) {
13174 mp_print_nl(mp, "<forever> ");
13175 } else if (token_type==loop_text) {
13176 @<Print the current loop value@>;
13177 } else if (token_type==parameter) {
13178 mp_print_nl(mp, "<argument> ");
13179 } else if (token_type==backed_up) {
13180 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
13181 else mp_print_nl(mp, "<to be read again> ");
13182 } else if (token_type==inserted) {
13183 mp_print_nl(mp, "<inserted text> ");
13184 } else if (token_type==macro) {
13186 if ( name!=null ) mp_print_text(name);
13187 else @<Print the name of a \&{vardef}'d macro@>;
13188 mp_print(mp, "->");
13190 mp_print_nl(mp, "?");/* this should never happen */
13195 @ The parameter that corresponds to a loop text is either a token list
13196 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13197 We'll discuss capsules later; for now, all we need to know is that
13198 the |link| field in a capsule parameter is |void| and that
13199 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13201 @<Print the current loop value@>=
13202 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13204 if ( link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13205 else mp_show_token_list(mp, p,null,20,mp->tally);
13207 mp_print(mp, ")> ");
13210 @ The first two parameters of a macro defined by \&{vardef} will be token
13211 lists representing the macro's prefix and ``at point.'' By putting these
13212 together, we get the macro's full name.
13214 @<Print the name of a \&{vardef}'d macro@>=
13215 { p=mp->param_stack[param_start];
13217 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13220 while ( link(q)!=null ) q=link(q);
13221 link(q)=mp->param_stack[param_start+1];
13222 mp_show_token_list(mp, p,null,20,mp->tally);
13227 @ Now it is necessary to explain a little trick. We don't want to store a long
13228 string that corresponds to a token list, because that string might take up
13229 lots of memory; and we are printing during a time when an error message is
13230 being given, so we dare not do anything that might overflow one of \MP's
13231 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13232 that stores characters into a buffer of length |error_line|, where character
13233 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13234 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13235 |tally:=0| and |trick_count:=1000000|; then when we reach the
13236 point where transition from line 1 to line 2 should occur, we
13237 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13238 tally+1+error_line-half_error_line)|. At the end of the
13239 pseudoprinting, the values of |first_count|, |tally|, and
13240 |trick_count| give us all the information we need to print the two lines,
13241 and all of the necessary text is in |trick_buf|.
13243 Namely, let |l| be the length of the descriptive information that appears
13244 on the first line. The length of the context information gathered for that
13245 line is |k=first_count|, and the length of the context information
13246 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13247 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13248 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13249 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13250 and print `\.{...}' followed by
13251 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13252 where subscripts of |trick_buf| are circular modulo |error_line|. The
13253 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13254 unless |n+m>error_line|; in the latter case, further cropping is done.
13255 This is easier to program than to explain.
13257 @<Local variables for formatting...@>=
13258 int i; /* index into |buffer| */
13259 integer l; /* length of descriptive information on line 1 */
13260 integer m; /* context information gathered for line 2 */
13261 int n; /* length of line 1 */
13262 integer p; /* starting or ending place in |trick_buf| */
13263 integer q; /* temporary index */
13265 @ The following code tells the print routines to gather
13266 the desired information.
13268 @d begin_pseudoprint {
13269 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13270 mp->trick_count=1000000;
13272 @d set_trick_count {
13273 mp->first_count=mp->tally;
13274 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13275 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13278 @ And the following code uses the information after it has been gathered.
13280 @<Print two lines using the tricky pseudoprinted information@>=
13281 if ( mp->trick_count==1000000 ) set_trick_count;
13282 /* |set_trick_count| must be performed */
13283 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13284 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13285 if ( l+mp->first_count<=mp->half_error_line ) {
13286 p=0; n=l+mp->first_count;
13288 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13289 n=mp->half_error_line;
13291 for (q=p;q<=mp->first_count-1;q++) {
13292 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13295 for (q=1;q<=n;q++) {
13296 mp_print_char(mp, ' '); /* print |n| spaces to begin line~2 */
13298 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13299 else p=mp->first_count+(mp->error_line-n-3);
13300 for (q=mp->first_count;q<=p-1;q++) {
13301 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13303 if ( m+n>mp->error_line ) mp_print(mp, "...")
13305 @ But the trick is distracting us from our current goal, which is to
13306 understand the input state. So let's concentrate on the data structures that
13307 are being pseudoprinted as we finish up the |show_context| procedure.
13309 @<Pseudoprint the line@>=
13312 for (i=start;i<=limit-1;i++) {
13313 if ( i==loc ) set_trick_count;
13314 mp_print_str(mp, mp->buffer[i]);
13318 @ @<Pseudoprint the token list@>=
13320 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13321 else mp_show_macro(mp, start,loc,100000)
13323 @ Here is the missing piece of |show_token_list| that is activated when the
13324 token beginning line~2 is about to be shown:
13326 @<Do magic computation@>=set_trick_count
13328 @* \[28] Maintaining the input stacks.
13329 The following subroutines change the input status in commonly needed ways.
13331 First comes |push_input|, which stores the current state and creates a
13332 new level (having, initially, the same properties as the old).
13334 @d push_input { /* enter a new input level, save the old */
13335 if ( mp->input_ptr>mp->max_in_stack ) {
13336 mp->max_in_stack=mp->input_ptr;
13337 if ( mp->input_ptr==mp->stack_size ) {
13338 int l = (mp->stack_size+(mp->stack_size>>2));
13339 XREALLOC(mp->input_stack, l, in_state_record);
13340 mp->stack_size = l;
13343 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13344 incr(mp->input_ptr);
13347 @ And of course what goes up must come down.
13349 @d pop_input { /* leave an input level, re-enter the old */
13350 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13353 @ Here is a procedure that starts a new level of token-list input, given
13354 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13355 set |name|, reset~|loc|, and increase the macro's reference count.
13357 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13359 @c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13360 push_input; start=p; token_type=t;
13361 param_start=mp->param_ptr; loc=p;
13364 @ When a token list has been fully scanned, the following computations
13365 should be done as we leave that level of input.
13368 @c void mp_end_token_list (MP mp) { /* leave a token-list input level */
13369 pointer p; /* temporary register */
13370 if ( token_type>=backed_up ) { /* token list to be deleted */
13371 if ( token_type<=inserted ) {
13372 mp_flush_token_list(mp, start); goto DONE;
13374 mp_delete_mac_ref(mp, start); /* update reference count */
13377 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13378 decr(mp->param_ptr);
13379 p=mp->param_stack[mp->param_ptr];
13381 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
13382 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13384 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13389 pop_input; check_interrupt;
13392 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13393 token by the |cur_tok| routine.
13396 @c @<Declare the procedure called |make_exp_copy|@>
13397 pointer mp_cur_tok (MP mp) {
13398 pointer p; /* a new token node */
13399 small_number save_type; /* |cur_type| to be restored */
13400 integer save_exp; /* |cur_exp| to be restored */
13401 if ( mp->cur_sym==0 ) {
13402 if ( mp->cur_cmd==capsule_token ) {
13403 save_type=mp->cur_type; save_exp=mp->cur_exp;
13404 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); link(p)=null;
13405 mp->cur_type=save_type; mp->cur_exp=save_exp;
13407 p=mp_get_node(mp, token_node_size);
13408 value(p)=mp->cur_mod; name_type(p)=mp_token;
13409 if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
13410 else type(p)=mp_string_type;
13413 fast_get_avail(p); info(p)=mp->cur_sym;
13418 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13419 seen. The |back_input| procedure takes care of this by putting the token
13420 just scanned back into the input stream, ready to be read again.
13421 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13424 void mp_back_input (MP mp);
13426 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13427 pointer p; /* a token list of length one */
13429 while ( token_state &&(loc==null) )
13430 mp_end_token_list(mp); /* conserve stack space */
13434 @ The |back_error| routine is used when we want to restore or replace an
13435 offending token just before issuing an error message. We disable interrupts
13436 during the call of |back_input| so that the help message won't be lost.
13439 void mp_error (MP mp);
13440 void mp_back_error (MP mp);
13442 @ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
13443 mp->OK_to_interrupt=false;
13445 mp->OK_to_interrupt=true; mp_error(mp);
13447 void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13448 mp->OK_to_interrupt=false;
13449 mp_back_input(mp); token_type=inserted;
13450 mp->OK_to_interrupt=true; mp_error(mp);
13453 @ The |begin_file_reading| procedure starts a new level of input for lines
13454 of characters to be read from a file, or as an insertion from the
13455 terminal. It does not take care of opening the file, nor does it set |loc|
13456 or |limit| or |line|.
13457 @^system dependencies@>
13459 @c void mp_begin_file_reading (MP mp) {
13460 if ( mp->in_open==mp->max_in_open )
13461 mp_overflow(mp, "text input levels",mp->max_in_open);
13462 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13463 if ( mp->first==mp->buf_size )
13464 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13465 incr(mp->in_open); push_input; index=mp->in_open;
13466 mp->mpx_name[index]=absent;
13468 name=is_term; /* |terminal_input| is now |true| */
13471 @ Conversely, the variables must be downdated when such a level of input
13472 is finished. Any associated \.{MPX} file must also be closed and popped
13473 off the file stack.
13475 @c void mp_end_file_reading (MP mp) {
13476 if ( mp->in_open>index ) {
13477 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13478 mp_confusion(mp, "endinput");
13479 @:this can't happen endinput}{\quad endinput@>
13481 (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13482 delete_str_ref(mp->mpx_name[mp->in_open]);
13487 if ( index!=mp->in_open ) mp_confusion(mp, "endinput");
13488 if ( name>max_spec_src ) {
13489 (mp->close_file)(mp,cur_file);
13490 delete_str_ref(name);
13494 pop_input; decr(mp->in_open);
13497 @ Here is a function that tries to resume input from an \.{MPX} file already
13498 associated with the current input file. It returns |false| if this doesn't
13501 @c boolean mp_begin_mpx_reading (MP mp) {
13502 if ( mp->in_open!=index+1 ) {
13505 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13506 @:this can't happen mpx}{\quad mpx@>
13507 if ( mp->first==mp->buf_size )
13508 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13509 push_input; index=mp->in_open;
13511 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13512 @<Put an empty line in the input buffer@>;
13517 @ This procedure temporarily stops reading an \.{MPX} file.
13519 @c void mp_end_mpx_reading (MP mp) {
13520 if ( mp->in_open!=index ) mp_confusion(mp, "mpx");
13521 @:this can't happen mpx}{\quad mpx@>
13523 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13529 @ Here we enforce a restriction that simplifies the input stacks considerably.
13530 This should not inconvenience the user because \.{MPX} files are generated
13531 by an auxiliary program called \.{DVItoMP}.
13533 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13535 print_err("`mpxbreak' must be at the end of a line");
13536 help4("This file contains picture expressions for btex...etex")
13537 ("blocks. Such files are normally generated automatically")
13538 ("but this one seems to be messed up. I'm going to ignore")
13539 ("the rest of this line.");
13543 @ In order to keep the stack from overflowing during a long sequence of
13544 inserted `\.{show}' commands, the following routine removes completed
13545 error-inserted lines from memory.
13547 @c void mp_clear_for_error_prompt (MP mp) {
13548 while ( file_state && terminal_input &&
13549 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13550 mp_print_ln(mp); clear_terminal;
13553 @ To get \MP's whole input mechanism going, we perform the following
13556 @<Initialize the input routines@>=
13557 { mp->input_ptr=0; mp->max_in_stack=0;
13558 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13559 mp->param_ptr=0; mp->max_param_stack=0;
13561 start=1; index=0; line=0; name=is_term;
13562 mp->mpx_name[0]=absent;
13563 mp->force_eof=false;
13564 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13565 limit=mp->last; mp->first=mp->last+1;
13566 /* |init_terminal| has set |loc| and |last| */
13569 @* \[29] Getting the next token.
13570 The heart of \MP's input mechanism is the |get_next| procedure, which
13571 we shall develop in the next few sections of the program. Perhaps we
13572 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13573 eyes and mouth, reading the source files and gobbling them up. And it also
13574 helps \MP\ to regurgitate stored token lists that are to be processed again.
13576 The main duty of |get_next| is to input one token and to set |cur_cmd|
13577 and |cur_mod| to that token's command code and modifier. Furthermore, if
13578 the input token is a symbolic token, that token's |hash| address
13579 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13581 Underlying this simple description is a certain amount of complexity
13582 because of all the cases that need to be handled.
13583 However, the inner loop of |get_next| is reasonably short and fast.
13585 @ Before getting into |get_next|, we need to consider a mechanism by which
13586 \MP\ helps keep errors from propagating too far. Whenever the program goes
13587 into a mode where it keeps calling |get_next| repeatedly until a certain
13588 condition is met, it sets |scanner_status| to some value other than |normal|.
13589 Then if an input file ends, or if an `\&{outer}' symbol appears,
13590 an appropriate error recovery will be possible.
13592 The global variable |warning_info| helps in this error recovery by providing
13593 additional information. For example, |warning_info| might indicate the
13594 name of a macro whose replacement text is being scanned.
13596 @d normal 0 /* |scanner_status| at ``quiet times'' */
13597 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13598 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13599 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13600 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13601 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13602 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13603 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13606 integer scanner_status; /* are we scanning at high speed? */
13607 integer warning_info; /* if so, what else do we need to know,
13608 in case an error occurs? */
13610 @ @<Initialize the input routines@>=
13611 mp->scanner_status=normal;
13613 @ The following subroutine
13614 is called when an `\&{outer}' symbolic token has been scanned or
13615 when the end of a file has been reached. These two cases are distinguished
13616 by |cur_sym|, which is zero at the end of a file.
13618 @c boolean mp_check_outer_validity (MP mp) {
13619 pointer p; /* points to inserted token list */
13620 if ( mp->scanner_status==normal ) {
13622 } else if ( mp->scanner_status==tex_flushing ) {
13623 @<Check if the file has ended while flushing \TeX\ material and set the
13624 result value for |check_outer_validity|@>;
13626 mp->deletions_allowed=false;
13627 @<Back up an outer symbolic token so that it can be reread@>;
13628 if ( mp->scanner_status>skipping ) {
13629 @<Tell the user what has run away and try to recover@>;
13631 print_err("Incomplete if; all text was ignored after line ");
13632 @.Incomplete if...@>
13633 mp_print_int(mp, mp->warning_info);
13634 help3("A forbidden `outer' token occurred in skipped text.")
13635 ("This kind of error happens when you say `if...' and forget")
13636 ("the matching `fi'. I've inserted a `fi'; this might work.");
13637 if ( mp->cur_sym==0 )
13638 mp->help_line[2]="The file ended while I was skipping conditional text.";
13639 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13641 mp->deletions_allowed=true;
13646 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13647 if ( mp->cur_sym!=0 ) {
13650 mp->deletions_allowed=false;
13651 print_err("TeX mode didn't end; all text was ignored after line ");
13652 mp_print_int(mp, mp->warning_info);
13653 help2("The file ended while I was looking for the `etex' to")
13654 ("finish this TeX material. I've inserted `etex' now.");
13655 mp->cur_sym = frozen_etex;
13657 mp->deletions_allowed=true;
13661 @ @<Back up an outer symbolic token so that it can be reread@>=
13662 if ( mp->cur_sym!=0 ) {
13663 p=mp_get_avail(mp); info(p)=mp->cur_sym;
13664 back_list(p); /* prepare to read the symbolic token again */
13667 @ @<Tell the user what has run away...@>=
13669 mp_runaway(mp); /* print the definition-so-far */
13670 if ( mp->cur_sym==0 ) {
13671 print_err("File ended");
13672 @.File ended while scanning...@>
13674 print_err("Forbidden token found");
13675 @.Forbidden token found...@>
13677 mp_print(mp, " while scanning ");
13678 help4("I suspect you have forgotten an `enddef',")
13679 ("causing me to read past where you wanted me to stop.")
13680 ("I'll try to recover; but if the error is serious,")
13681 ("you'd better type `E' or `X' now and fix your file.");
13682 switch (mp->scanner_status) {
13683 @<Complete the error message,
13684 and set |cur_sym| to a token that might help recover from the error@>
13685 } /* there are no other cases */
13689 @ As we consider various kinds of errors, it is also appropriate to
13690 change the first line of the help message just given; |help_line[3]|
13691 points to the string that might be changed.
13693 @<Complete the error message,...@>=
13695 mp_print(mp, "to the end of the statement");
13696 mp->help_line[3]="A previous error seems to have propagated,";
13697 mp->cur_sym=frozen_semicolon;
13700 mp_print(mp, "a text argument");
13701 mp->help_line[3]="It seems that a right delimiter was left out,";
13702 if ( mp->warning_info==0 ) {
13703 mp->cur_sym=frozen_end_group;
13705 mp->cur_sym=frozen_right_delimiter;
13706 equiv(frozen_right_delimiter)=mp->warning_info;
13711 mp_print(mp, "the definition of ");
13712 if ( mp->scanner_status==op_defining )
13713 mp_print_text(mp->warning_info);
13715 mp_print_variable_name(mp, mp->warning_info);
13716 mp->cur_sym=frozen_end_def;
13718 case loop_defining:
13719 mp_print(mp, "the text of a ");
13720 mp_print_text(mp->warning_info);
13721 mp_print(mp, " loop");
13722 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13723 mp->cur_sym=frozen_end_for;
13726 @ The |runaway| procedure displays the first part of the text that occurred
13727 when \MP\ began its special |scanner_status|, if that text has been saved.
13729 @<Declare the procedure called |runaway|@>=
13730 void mp_runaway (MP mp) {
13731 if ( mp->scanner_status>flushing ) {
13732 mp_print_nl(mp, "Runaway ");
13733 switch (mp->scanner_status) {
13734 case absorbing: mp_print(mp, "text?"); break;
13736 case op_defining: mp_print(mp,"definition?"); break;
13737 case loop_defining: mp_print(mp, "loop?"); break;
13738 } /* there are no other cases */
13740 mp_show_token_list(mp, link(hold_head),null,mp->error_line-10,0);
13744 @ We need to mention a procedure that may be called by |get_next|.
13747 void mp_firm_up_the_line (MP mp);
13749 @ And now we're ready to take the plunge into |get_next| itself.
13750 Note that the behavior depends on the |scanner_status| because percent signs
13751 and double quotes need to be passed over when skipping TeX material.
13754 void mp_get_next (MP mp) {
13755 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13757 /*restart*/ /* go here to get the next input token */
13758 /*exit*/ /* go here when the next input token has been got */
13759 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13760 /*found*/ /* go here when the end of a symbolic token has been found */
13761 /*switch*/ /* go here to branch on the class of an input character */
13762 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13763 /* go here at crucial stages when scanning a number */
13764 int k; /* an index into |buffer| */
13765 ASCII_code c; /* the current character in the buffer */
13766 ASCII_code class; /* its class number */
13767 integer n,f; /* registers for decimal-to-binary conversion */
13770 if ( file_state ) {
13771 @<Input from external file; |goto restart| if no input found,
13772 or |return| if a non-symbolic token is found@>;
13774 @<Input from token list; |goto restart| if end of list or
13775 if a parameter needs to be expanded,
13776 or |return| if a non-symbolic token is found@>;
13779 @<Finish getting the symbolic token in |cur_sym|;
13780 |goto restart| if it is illegal@>;
13783 @ When a symbolic token is declared to be `\&{outer}', its command code
13784 is increased by |outer_tag|.
13787 @<Finish getting the symbolic token in |cur_sym|...@>=
13788 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13789 if ( mp->cur_cmd>=outer_tag ) {
13790 if ( mp_check_outer_validity(mp) )
13791 mp->cur_cmd=mp->cur_cmd-outer_tag;
13796 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13797 to have a special test for end-of-line.
13800 @<Input from external file;...@>=
13803 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13805 case digit_class: goto START_NUMERIC_TOKEN; break;
13807 class=mp->char_class[mp->buffer[loc]];
13808 if ( class>period_class ) {
13810 } else if ( class<period_class ) { /* |class=digit_class| */
13811 n=0; goto START_DECIMAL_TOKEN;
13815 case space_class: goto SWITCH; break;
13816 case percent_class:
13817 if ( mp->scanner_status==tex_flushing ) {
13818 if ( loc<limit ) goto SWITCH;
13820 @<Move to next line of file, or |goto restart| if there is no next line@>;
13825 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13826 else @<Get a string token and |return|@>;
13828 case isolated_classes:
13829 k=loc-1; goto FOUND; break;
13830 case invalid_class:
13831 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13832 else @<Decry the invalid character and |goto restart|@>;
13834 default: break; /* letters, etc. */
13837 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13839 START_NUMERIC_TOKEN:
13840 @<Get the integer part |n| of a numeric token;
13841 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13842 START_DECIMAL_TOKEN:
13843 @<Get the fraction part |f| of a numeric token@>;
13845 @<Pack the numeric and fraction parts of a numeric token
13848 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13851 @ We go to |restart| instead of to |SWITCH|, because we might enter
13852 |token_state| after the error has been dealt with
13853 (cf.\ |clear_for_error_prompt|).
13855 @<Decry the invalid...@>=
13857 print_err("Text line contains an invalid character");
13858 @.Text line contains...@>
13859 help2("A funny symbol that I can\'t read has just been input.")
13860 ("Continue, and I'll forget that it ever happened.");
13861 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13865 @ @<Get a string token and |return|@>=
13867 if ( mp->buffer[loc]=='"' ) {
13868 mp->cur_mod=rts("");
13870 k=loc; mp->buffer[limit+1]='"';
13873 } while (mp->buffer[loc]!='"');
13875 @<Decry the missing string delimiter and |goto restart|@>;
13878 mp->cur_mod=mp->buffer[k];
13882 append_char(mp->buffer[k]); incr(k);
13884 mp->cur_mod=mp_make_string(mp);
13887 incr(loc); mp->cur_cmd=string_token;
13891 @ We go to |restart| after this error message, not to |SWITCH|,
13892 because the |clear_for_error_prompt| routine might have reinstated
13893 |token_state| after |error| has finished.
13895 @<Decry the missing string delimiter and |goto restart|@>=
13897 loc=limit; /* the next character to be read on this line will be |"%"| */
13898 print_err("Incomplete string token has been flushed");
13899 @.Incomplete string token...@>
13900 help3("Strings should finish on the same line as they began.")
13901 ("I've deleted the partial string; you might want to")
13902 ("insert another by typing, e.g., `I\"new string\"'.");
13903 mp->deletions_allowed=false; mp_error(mp);
13904 mp->deletions_allowed=true;
13908 @ @<Get the integer part |n| of a numeric token...@>=
13910 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13911 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13914 if ( mp->buffer[loc]=='.' )
13915 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13918 goto FIN_NUMERIC_TOKEN;
13921 @ @<Get the fraction part |f| of a numeric token@>=
13924 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13925 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13928 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13929 f=mp_round_decimals(mp, k);
13934 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13936 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13937 } else if ( mp->scanner_status!=tex_flushing ) {
13938 print_err("Enormous number has been reduced");
13939 @.Enormous number...@>
13940 help2("I can\'t handle numbers bigger than 32767.99998;")
13941 ("so I've changed your constant to that maximum amount.");
13942 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13943 mp->cur_mod=el_gordo;
13945 mp->cur_cmd=numeric_token; return
13947 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13949 mp->cur_mod=n*unity+f;
13950 if ( mp->cur_mod>=fraction_one ) {
13951 if ( (mp->internal[mp_warning_check]>0) &&
13952 (mp->scanner_status!=tex_flushing) ) {
13953 print_err("Number is too large (");
13954 mp_print_scaled(mp, mp->cur_mod);
13955 mp_print_char(mp, ')');
13956 help3("It is at least 4096. Continue and I'll try to cope")
13957 ("with that big value; but it might be dangerous.")
13958 ("(Set warningcheck:=0 to suppress this message.)");
13964 @ Let's consider now what happens when |get_next| is looking at a token list.
13967 @<Input from token list;...@>=
13968 if ( loc>=mp->hi_mem_min ) { /* one-word token */
13969 mp->cur_sym=info(loc); loc=link(loc); /* move to next */
13970 if ( mp->cur_sym>=expr_base ) {
13971 if ( mp->cur_sym>=suffix_base ) {
13972 @<Insert a suffix or text parameter and |goto restart|@>;
13974 mp->cur_cmd=capsule_token;
13975 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
13976 mp->cur_sym=0; return;
13979 } else if ( loc>null ) {
13980 @<Get a stored numeric or string or capsule token and |return|@>
13981 } else { /* we are done with this token list */
13982 mp_end_token_list(mp); goto RESTART; /* resume previous level */
13985 @ @<Insert a suffix or text parameter...@>=
13987 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
13988 /* |param_size=text_base-suffix_base| */
13989 mp_begin_token_list(mp,
13990 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
13995 @ @<Get a stored numeric or string or capsule token...@>=
13997 if ( name_type(loc)==mp_token ) {
13998 mp->cur_mod=value(loc);
13999 if ( type(loc)==mp_known ) {
14000 mp->cur_cmd=numeric_token;
14002 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
14005 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
14007 loc=link(loc); return;
14010 @ All of the easy branches of |get_next| have now been taken care of.
14011 There is one more branch.
14013 @<Move to next line of file, or |goto restart|...@>=
14014 if ( name>max_spec_src ) {
14015 @<Read next line of file into |buffer|, or
14016 |goto restart| if the file has ended@>;
14018 if ( mp->input_ptr>0 ) {
14019 /* text was inserted during error recovery or by \&{scantokens} */
14020 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
14022 if ( mp->selector<log_only || mp->selector>=write_file) mp_open_log_file(mp);
14023 if ( mp->interaction>mp_nonstop_mode ) {
14024 if ( limit==start ) /* previous line was empty */
14025 mp_print_nl(mp, "(Please type a command or say `end')");
14027 mp_print_ln(mp); mp->first=start;
14028 prompt_input("*"); /* input on-line into |buffer| */
14030 limit=mp->last; mp->buffer[limit]='%';
14031 mp->first=limit+1; loc=start;
14033 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
14035 /* nonstop mode, which is intended for overnight batch processing,
14036 never waits for on-line input */
14040 @ The global variable |force_eof| is normally |false|; it is set |true|
14041 by an \&{endinput} command.
14044 boolean force_eof; /* should the next \&{input} be aborted early? */
14046 @ We must decrement |loc| in order to leave the buffer in a valid state
14047 when an error condition causes us to |goto restart| without calling
14048 |end_file_reading|.
14050 @<Read next line of file into |buffer|, or
14051 |goto restart| if the file has ended@>=
14053 incr(line); mp->first=start;
14054 if ( ! mp->force_eof ) {
14055 if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
14056 mp_firm_up_the_line(mp); /* this sets |limit| */
14058 mp->force_eof=true;
14060 if ( mp->force_eof ) {
14061 mp->force_eof=false;
14063 if ( mpx_reading ) {
14064 @<Complain that the \.{MPX} file ended unexpectly; then set
14065 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
14067 mp_print_char(mp, ')'); decr(mp->open_parens);
14068 update_terminal; /* show user that file has been read */
14069 mp_end_file_reading(mp); /* resume previous level */
14070 if ( mp_check_outer_validity(mp) ) goto RESTART;
14074 mp->buffer[limit]='%'; mp->first=limit+1; loc=start; /* ready to read */
14077 @ We should never actually come to the end of an \.{MPX} file because such
14078 files should have an \&{mpxbreak} after the translation of the last
14079 \&{btex}$\,\ldots\,$\&{etex} block.
14081 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
14083 mp->mpx_name[index]=finished;
14084 print_err("mpx file ended unexpectedly");
14085 help4("The file had too few picture expressions for btex...etex")
14086 ("blocks. Such files are normally generated automatically")
14087 ("but this one got messed up. You might want to insert a")
14088 ("picture expression now.");
14089 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
14090 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
14093 @ Sometimes we want to make it look as though we have just read a blank line
14094 without really doing so.
14096 @<Put an empty line in the input buffer@>=
14097 mp->last=mp->first; limit=mp->last; /* simulate |input_ln| and |firm_up_the_line| */
14098 mp->buffer[limit]='%'; mp->first=limit+1; loc=start
14100 @ If the user has set the |mp_pausing| parameter to some positive value,
14101 and if nonstop mode has not been selected, each line of input is displayed
14102 on the terminal and the transcript file, followed by `\.{=>}'.
14103 \MP\ waits for a response. If the response is null (i.e., if nothing is
14104 typed except perhaps a few blank spaces), the original
14105 line is accepted as it stands; otherwise the line typed is
14106 used instead of the line in the file.
14108 @c void mp_firm_up_the_line (MP mp) {
14109 size_t k; /* an index into |buffer| */
14111 if ( mp->internal[mp_pausing]>0) if ( mp->interaction>mp_nonstop_mode ) {
14112 wake_up_terminal; mp_print_ln(mp);
14113 if ( start<limit ) {
14114 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
14115 mp_print_str(mp, mp->buffer[k]);
14118 mp->first=limit; prompt_input("=>"); /* wait for user response */
14120 if ( mp->last>mp->first ) {
14121 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
14122 mp->buffer[k+start-mp->first]=mp->buffer[k];
14124 limit=start+mp->last-mp->first;
14129 @* \[30] Dealing with \TeX\ material.
14130 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
14131 features need to be implemented at a low level in the scanning process
14132 so that \MP\ can stay in synch with the a preprocessor that treats
14133 blocks of \TeX\ material as they occur in the input file without trying
14134 to expand \MP\ macros. Thus we need a special version of |get_next|
14135 that does not expand macros and such but does handle \&{btex},
14136 \&{verbatimtex}, etc.
14138 The special version of |get_next| is called |get_t_next|. It works by flushing
14139 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
14140 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
14141 \&{btex}, and switching back when it sees \&{mpxbreak}.
14147 mp_primitive(mp, "btex",start_tex,btex_code);
14148 @:btex_}{\&{btex} primitive@>
14149 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
14150 @:verbatimtex_}{\&{verbatimtex} primitive@>
14151 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
14152 @:etex_}{\&{etex} primitive@>
14153 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
14154 @:mpx_break_}{\&{mpxbreak} primitive@>
14156 @ @<Cases of |print_cmd...@>=
14157 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
14158 else mp_print(mp, "verbatimtex"); break;
14159 case etex_marker: mp_print(mp, "etex"); break;
14160 case mpx_break: mp_print(mp, "mpxbreak"); break;
14162 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
14163 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
14166 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
14169 void mp_start_mpx_input (MP mp);
14172 void mp_t_next (MP mp) {
14173 int old_status; /* saves the |scanner_status| */
14174 integer old_info; /* saves the |warning_info| */
14175 while ( mp->cur_cmd<=max_pre_command ) {
14176 if ( mp->cur_cmd==mpx_break ) {
14177 if ( ! file_state || (mp->mpx_name[index]==absent) ) {
14178 @<Complain about a misplaced \&{mpxbreak}@>;
14180 mp_end_mpx_reading(mp);
14183 } else if ( mp->cur_cmd==start_tex ) {
14184 if ( token_state || (name<=max_spec_src) ) {
14185 @<Complain that we are not reading a file@>;
14186 } else if ( mpx_reading ) {
14187 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
14188 } else if ( (mp->cur_mod!=verbatim_code)&&
14189 (mp->mpx_name[index]!=finished) ) {
14190 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
14195 @<Complain about a misplaced \&{etex}@>;
14197 goto COMMON_ENDING;
14199 @<Flush the \TeX\ material@>;
14205 @ We could be in the middle of an operation such as skipping false conditional
14206 text when \TeX\ material is encountered, so we must be careful to save the
14209 @<Flush the \TeX\ material@>=
14210 old_status=mp->scanner_status;
14211 old_info=mp->warning_info;
14212 mp->scanner_status=tex_flushing;
14213 mp->warning_info=line;
14214 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14215 mp->scanner_status=old_status;
14216 mp->warning_info=old_info
14218 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14219 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14220 help4("This file contains picture expressions for btex...etex")
14221 ("blocks. Such files are normally generated automatically")
14222 ("but this one seems to be messed up. I'll just keep going")
14223 ("and hope for the best.");
14227 @ @<Complain that we are not reading a file@>=
14228 { print_err("You can only use `btex' or `verbatimtex' in a file");
14229 help3("I'll have to ignore this preprocessor command because it")
14230 ("only works when there is a file to preprocess. You might")
14231 ("want to delete everything up to the next `etex`.");
14235 @ @<Complain about a misplaced \&{mpxbreak}@>=
14236 { print_err("Misplaced mpxbreak");
14237 help2("I'll ignore this preprocessor command because it")
14238 ("doesn't belong here");
14242 @ @<Complain about a misplaced \&{etex}@>=
14243 { print_err("Extra etex will be ignored");
14244 help1("There is no btex or verbatimtex for this to match");
14248 @* \[31] Scanning macro definitions.
14249 \MP\ has a variety of ways to tuck tokens away into token lists for later
14250 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14251 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14252 All such operations are handled by the routines in this part of the program.
14254 The modifier part of each command code is zero for the ``ending delimiters''
14255 like \&{enddef} and \&{endfor}.
14257 @d start_def 1 /* command modifier for \&{def} */
14258 @d var_def 2 /* command modifier for \&{vardef} */
14259 @d end_def 0 /* command modifier for \&{enddef} */
14260 @d start_forever 1 /* command modifier for \&{forever} */
14261 @d end_for 0 /* command modifier for \&{endfor} */
14264 mp_primitive(mp, "def",macro_def,start_def);
14265 @:def_}{\&{def} primitive@>
14266 mp_primitive(mp, "vardef",macro_def,var_def);
14267 @:var_def_}{\&{vardef} primitive@>
14268 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14269 @:primary_def_}{\&{primarydef} primitive@>
14270 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14271 @:secondary_def_}{\&{secondarydef} primitive@>
14272 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14273 @:tertiary_def_}{\&{tertiarydef} primitive@>
14274 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14275 @:end_def_}{\&{enddef} primitive@>
14277 mp_primitive(mp, "for",iteration,expr_base);
14278 @:for_}{\&{for} primitive@>
14279 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14280 @:for_suffixes_}{\&{forsuffixes} primitive@>
14281 mp_primitive(mp, "forever",iteration,start_forever);
14282 @:forever_}{\&{forever} primitive@>
14283 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14284 @:end_for_}{\&{endfor} primitive@>
14286 @ @<Cases of |print_cmd...@>=
14288 if ( m<=var_def ) {
14289 if ( m==start_def ) mp_print(mp, "def");
14290 else if ( m<start_def ) mp_print(mp, "enddef");
14291 else mp_print(mp, "vardef");
14292 } else if ( m==secondary_primary_macro ) {
14293 mp_print(mp, "primarydef");
14294 } else if ( m==tertiary_secondary_macro ) {
14295 mp_print(mp, "secondarydef");
14297 mp_print(mp, "tertiarydef");
14301 if ( m<=start_forever ) {
14302 if ( m==start_forever ) mp_print(mp, "forever");
14303 else mp_print(mp, "endfor");
14304 } else if ( m==expr_base ) {
14305 mp_print(mp, "for");
14307 mp_print(mp, "forsuffixes");
14311 @ Different macro-absorbing operations have different syntaxes, but they
14312 also have a lot in common. There is a list of special symbols that are to
14313 be replaced by parameter tokens; there is a special command code that
14314 ends the definition; the quotation conventions are identical. Therefore
14315 it makes sense to have most of the work done by a single subroutine. That
14316 subroutine is called |scan_toks|.
14318 The first parameter to |scan_toks| is the command code that will
14319 terminate scanning (either |macro_def| or |iteration|).
14321 The second parameter, |subst_list|, points to a (possibly empty) list
14322 of two-word nodes whose |info| and |value| fields specify symbol tokens
14323 before and after replacement. The list will be returned to free storage
14326 The third parameter is simply appended to the token list that is built.
14327 And the final parameter tells how many of the special operations
14328 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14329 When such parameters are present, they are called \.{(SUFFIX0)},
14330 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14332 @c pointer mp_scan_toks (MP mp,command_code terminator, pointer
14333 subst_list, pointer tail_end, small_number suffix_count) {
14334 pointer p; /* tail of the token list being built */
14335 pointer q; /* temporary for link management */
14336 integer balance; /* left delimiters minus right delimiters */
14337 p=hold_head; balance=1; link(hold_head)=null;
14340 if ( mp->cur_sym>0 ) {
14341 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14342 if ( mp->cur_cmd==terminator ) {
14343 @<Adjust the balance; |break| if it's zero@>;
14344 } else if ( mp->cur_cmd==macro_special ) {
14345 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14348 link(p)=mp_cur_tok(mp); p=link(p);
14350 link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14351 return link(hold_head);
14354 @ @<Substitute for |cur_sym|...@>=
14357 while ( q!=null ) {
14358 if ( info(q)==mp->cur_sym ) {
14359 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14365 @ @<Adjust the balance; |break| if it's zero@>=
14366 if ( mp->cur_mod>0 ) {
14374 @ Four commands are intended to be used only within macro texts: \&{quote},
14375 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14376 code called |macro_special|.
14378 @d quote 0 /* |macro_special| modifier for \&{quote} */
14379 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14380 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14381 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14384 mp_primitive(mp, "quote",macro_special,quote);
14385 @:quote_}{\&{quote} primitive@>
14386 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14387 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14388 mp_primitive(mp, "@@",macro_special,macro_at);
14389 @:]]]\AT!_}{\.{\AT!} primitive@>
14390 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14391 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14393 @ @<Cases of |print_cmd...@>=
14394 case macro_special:
14396 case macro_prefix: mp_print(mp, "#@@"); break;
14397 case macro_at: mp_print_char(mp, '@@'); break;
14398 case macro_suffix: mp_print(mp, "@@#"); break;
14399 default: mp_print(mp, "quote"); break;
14403 @ @<Handle quoted...@>=
14405 if ( mp->cur_mod==quote ) { get_t_next; }
14406 else if ( mp->cur_mod<=suffix_count )
14407 mp->cur_sym=suffix_base-1+mp->cur_mod;
14410 @ Here is a routine that's used whenever a token will be redefined. If
14411 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14412 substituted; the latter is redefinable but essentially impossible to use,
14413 hence \MP's tables won't get fouled up.
14415 @c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14418 if ( (mp->cur_sym==0)||(mp->cur_sym>frozen_inaccessible) ) {
14419 print_err("Missing symbolic token inserted");
14420 @.Missing symbolic token...@>
14421 help3("Sorry: You can\'t redefine a number, string, or expr.")
14422 ("I've inserted an inaccessible symbol so that your")
14423 ("definition will be completed without mixing me up too badly.");
14424 if ( mp->cur_sym>0 )
14425 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14426 else if ( mp->cur_cmd==string_token )
14427 delete_str_ref(mp->cur_mod);
14428 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14432 @ Before we actually redefine a symbolic token, we need to clear away its
14433 former value, if it was a variable. The following stronger version of
14434 |get_symbol| does that.
14436 @c void mp_get_clear_symbol (MP mp) {
14437 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14440 @ Here's another little subroutine; it checks that an equals sign
14441 or assignment sign comes along at the proper place in a macro definition.
14443 @c void mp_check_equals (MP mp) {
14444 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14445 mp_missing_err(mp, "=");
14447 help5("The next thing in this `def' should have been `=',")
14448 ("because I've already looked at the definition heading.")
14449 ("But don't worry; I'll pretend that an equals sign")
14450 ("was present. Everything from here to `enddef'")
14451 ("will be the replacement text of this macro.");
14456 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14457 handled now that we have |scan_toks|. In this case there are
14458 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14459 |expr_base| and |expr_base+1|).
14461 @c void mp_make_op_def (MP mp) {
14462 command_code m; /* the type of definition */
14463 pointer p,q,r; /* for list manipulation */
14465 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14466 info(q)=mp->cur_sym; value(q)=expr_base;
14467 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14468 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14469 info(p)=mp->cur_sym; value(p)=expr_base+1; link(p)=q;
14470 get_t_next; mp_check_equals(mp);
14471 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14472 r=mp_get_avail(mp); link(q)=r; info(r)=general_macro;
14473 link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14474 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14475 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14478 @ Parameters to macros are introduced by the keywords \&{expr},
14479 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14482 mp_primitive(mp, "expr",param_type,expr_base);
14483 @:expr_}{\&{expr} primitive@>
14484 mp_primitive(mp, "suffix",param_type,suffix_base);
14485 @:suffix_}{\&{suffix} primitive@>
14486 mp_primitive(mp, "text",param_type,text_base);
14487 @:text_}{\&{text} primitive@>
14488 mp_primitive(mp, "primary",param_type,primary_macro);
14489 @:primary_}{\&{primary} primitive@>
14490 mp_primitive(mp, "secondary",param_type,secondary_macro);
14491 @:secondary_}{\&{secondary} primitive@>
14492 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14493 @:tertiary_}{\&{tertiary} primitive@>
14495 @ @<Cases of |print_cmd...@>=
14497 if ( m>=expr_base ) {
14498 if ( m==expr_base ) mp_print(mp, "expr");
14499 else if ( m==suffix_base ) mp_print(mp, "suffix");
14500 else mp_print(mp, "text");
14501 } else if ( m<secondary_macro ) {
14502 mp_print(mp, "primary");
14503 } else if ( m==secondary_macro ) {
14504 mp_print(mp, "secondary");
14506 mp_print(mp, "tertiary");
14510 @ Let's turn next to the more complex processing associated with \&{def}
14511 and \&{vardef}. When the following procedure is called, |cur_mod|
14512 should be either |start_def| or |var_def|.
14514 @c @<Declare the procedure called |check_delimiter|@>
14515 @<Declare the function called |scan_declared_variable|@>
14516 void mp_scan_def (MP mp) {
14517 int m; /* the type of definition */
14518 int n; /* the number of special suffix parameters */
14519 int k; /* the total number of parameters */
14520 int c; /* the kind of macro we're defining */
14521 pointer r; /* parameter-substitution list */
14522 pointer q; /* tail of the macro token list */
14523 pointer p; /* temporary storage */
14524 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14525 pointer l_delim,r_delim; /* matching delimiters */
14526 m=mp->cur_mod; c=general_macro; link(hold_head)=null;
14527 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14528 @<Scan the token or variable to be defined;
14529 set |n|, |scanner_status|, and |warning_info|@>;
14531 if ( mp->cur_cmd==left_delimiter ) {
14532 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14534 if ( mp->cur_cmd==param_type ) {
14535 @<Absorb undelimited parameters, putting them into list |r|@>;
14537 mp_check_equals(mp);
14538 p=mp_get_avail(mp); info(p)=c; link(q)=p;
14539 @<Attach the replacement text to the tail of node |p|@>;
14540 mp->scanner_status=normal; mp_get_x_next(mp);
14543 @ We don't put `|frozen_end_group|' into the replacement text of
14544 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14546 @<Attach the replacement text to the tail of node |p|@>=
14547 if ( m==start_def ) {
14548 link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14550 q=mp_get_avail(mp); info(q)=mp->bg_loc; link(p)=q;
14551 p=mp_get_avail(mp); info(p)=mp->eg_loc;
14552 link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14554 if ( mp->warning_info==bad_vardef )
14555 mp_flush_token_list(mp, value(bad_vardef))
14559 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14561 @ @<Scan the token or variable to be defined;...@>=
14562 if ( m==start_def ) {
14563 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14564 mp->scanner_status=op_defining; n=0;
14565 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14567 p=mp_scan_declared_variable(mp);
14568 mp_flush_variable(mp, equiv(info(p)),link(p),true);
14569 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14570 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14571 mp->scanner_status=var_defining; n=2;
14572 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14575 type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14576 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14578 @ @<Change to `\.{a bad variable}'@>=
14580 print_err("This variable already starts with a macro");
14581 @.This variable already...@>
14582 help2("After `vardef a' you can\'t say `vardef a.b'.")
14583 ("So I'll have to discard this definition.");
14584 mp_error(mp); mp->warning_info=bad_vardef;
14587 @ @<Initialize table entries...@>=
14588 name_type(bad_vardef)=mp_root; link(bad_vardef)=frozen_bad_vardef;
14589 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14591 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14593 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14594 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14597 print_err("Missing parameter type; `expr' will be assumed");
14598 @.Missing parameter type@>
14599 help1("You should've had `expr' or `suffix' or `text' here.");
14600 mp_back_error(mp); base=expr_base;
14602 @<Absorb parameter tokens for type |base|@>;
14603 mp_check_delimiter(mp, l_delim,r_delim);
14605 } while (mp->cur_cmd==left_delimiter)
14607 @ @<Absorb parameter tokens for type |base|@>=
14609 link(q)=mp_get_avail(mp); q=link(q); info(q)=base+k;
14610 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14611 value(p)=base+k; info(p)=mp->cur_sym;
14612 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14613 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14614 incr(k); link(p)=r; r=p; get_t_next;
14615 } while (mp->cur_cmd==comma)
14617 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14619 p=mp_get_node(mp, token_node_size);
14620 if ( mp->cur_mod<expr_base ) {
14621 c=mp->cur_mod; value(p)=expr_base+k;
14623 value(p)=mp->cur_mod+k;
14624 if ( mp->cur_mod==expr_base ) c=expr_macro;
14625 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14628 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14629 incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; link(p)=r; r=p; get_t_next;
14630 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14631 c=of_macro; p=mp_get_node(mp, token_node_size);
14632 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14633 value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
14634 link(p)=r; r=p; get_t_next;
14638 @* \[32] Expanding the next token.
14639 Only a few command codes |<min_command| can possibly be returned by
14640 |get_t_next|; in increasing order, they are
14641 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14642 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14644 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14645 like |get_t_next| except that it keeps getting more tokens until
14646 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14647 macros and removes conditionals or iterations or input instructions that
14650 It follows that |get_x_next| might invoke itself recursively. In fact,
14651 there is massive recursion, since macro expansion can involve the
14652 scanning of arbitrarily complex expressions, which in turn involve
14653 macro expansion and conditionals, etc.
14656 Therefore it's necessary to declare a whole bunch of |forward|
14657 procedures at this point, and to insert some other procedures
14658 that will be invoked by |get_x_next|.
14661 void mp_scan_primary (MP mp);
14662 void mp_scan_secondary (MP mp);
14663 void mp_scan_tertiary (MP mp);
14664 void mp_scan_expression (MP mp);
14665 void mp_scan_suffix (MP mp);
14666 @<Declare the procedure called |macro_call|@>
14667 void mp_get_boolean (MP mp);
14668 void mp_pass_text (MP mp);
14669 void mp_conditional (MP mp);
14670 void mp_start_input (MP mp);
14671 void mp_begin_iteration (MP mp);
14672 void mp_resume_iteration (MP mp);
14673 void mp_stop_iteration (MP mp);
14675 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14676 when it has to do exotic expansion commands.
14678 @c void mp_expand (MP mp) {
14679 pointer p; /* for list manipulation */
14680 size_t k; /* something that we hope is |<=buf_size| */
14681 pool_pointer j; /* index into |str_pool| */
14682 if ( mp->internal[mp_tracing_commands]>unity )
14683 if ( mp->cur_cmd!=defined_macro )
14685 switch (mp->cur_cmd) {
14687 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14690 @<Terminate the current conditional and skip to \&{fi}@>;
14693 @<Initiate or terminate input from a file@>;
14696 if ( mp->cur_mod==end_for ) {
14697 @<Scold the user for having an extra \&{endfor}@>;
14699 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14706 @<Exit a loop if the proper time has come@>;
14711 @<Expand the token after the next token@>;
14714 @<Put a string into the input buffer@>;
14716 case defined_macro:
14717 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14719 }; /* there are no other cases */
14722 @ @<Scold the user...@>=
14724 print_err("Extra `endfor'");
14726 help2("I'm not currently working on a for loop,")
14727 ("so I had better not try to end anything.");
14731 @ The processing of \&{input} involves the |start_input| subroutine,
14732 which will be declared later; the processing of \&{endinput} is trivial.
14735 mp_primitive(mp, "input",input,0);
14736 @:input_}{\&{input} primitive@>
14737 mp_primitive(mp, "endinput",input,1);
14738 @:end_input_}{\&{endinput} primitive@>
14740 @ @<Cases of |print_cmd_mod|...@>=
14742 if ( m==0 ) mp_print(mp, "input");
14743 else mp_print(mp, "endinput");
14746 @ @<Initiate or terminate input...@>=
14747 if ( mp->cur_mod>0 ) mp->force_eof=true;
14748 else mp_start_input(mp)
14750 @ We'll discuss the complicated parts of loop operations later. For now
14751 it suffices to know that there's a global variable called |loop_ptr|
14752 that will be |null| if no loop is in progress.
14755 { while ( token_state &&(loc==null) )
14756 mp_end_token_list(mp); /* conserve stack space */
14757 if ( mp->loop_ptr==null ) {
14758 print_err("Lost loop");
14760 help2("I'm confused; after exiting from a loop, I still seem")
14761 ("to want to repeat it. I'll try to forget the problem.");
14764 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14768 @ @<Exit a loop if the proper time has come@>=
14769 { mp_get_boolean(mp);
14770 if ( mp->internal[mp_tracing_commands]>unity )
14771 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14772 if ( mp->cur_exp==true_code ) {
14773 if ( mp->loop_ptr==null ) {
14774 print_err("No loop is in progress");
14775 @.No loop is in progress@>
14776 help1("Why say `exitif' when there's nothing to exit from?");
14777 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14779 @<Exit prematurely from an iteration@>;
14781 } else if ( mp->cur_cmd!=semicolon ) {
14782 mp_missing_err(mp, ";");
14784 help2("After `exitif <boolean exp>' I expect to see a semicolon.")
14785 ("I shall pretend that one was there."); mp_back_error(mp);
14789 @ Here we use the fact that |forever_text| is the only |token_type| that
14790 is less than |loop_text|.
14792 @<Exit prematurely...@>=
14795 if ( file_state ) {
14796 mp_end_file_reading(mp);
14798 if ( token_type<=loop_text ) p=start;
14799 mp_end_token_list(mp);
14802 if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14804 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14807 @ @<Expand the token after the next token@>=
14809 p=mp_cur_tok(mp); get_t_next;
14810 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14811 else mp_back_input(mp);
14815 @ @<Put a string into the input buffer@>=
14816 { mp_get_x_next(mp); mp_scan_primary(mp);
14817 if ( mp->cur_type!=mp_string_type ) {
14818 mp_disp_err(mp, null,"Not a string");
14820 help2("I'm going to flush this expression, since")
14821 ("scantokens should be followed by a known string.");
14822 mp_put_get_flush_error(mp, 0);
14825 if ( length(mp->cur_exp)>0 )
14826 @<Pretend we're reading a new one-line file@>;
14830 @ @<Pretend we're reading a new one-line file@>=
14831 { mp_begin_file_reading(mp); name=is_scantok;
14832 k=mp->first+length(mp->cur_exp);
14833 if ( k>=mp->max_buf_stack ) {
14834 while ( k>=mp->buf_size ) {
14835 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
14837 mp->max_buf_stack=k+1;
14839 j=mp->str_start[mp->cur_exp]; limit=k;
14840 while ( mp->first<(size_t)limit ) {
14841 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14843 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
14844 mp_flush_cur_exp(mp, 0);
14847 @ Here finally is |get_x_next|.
14849 The expression scanning routines to be considered later
14850 communicate via the global quantities |cur_type| and |cur_exp|;
14851 we must be very careful to save and restore these quantities while
14852 macros are being expanded.
14856 void mp_get_x_next (MP mp);
14858 @ @c void mp_get_x_next (MP mp) {
14859 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14861 if ( mp->cur_cmd<min_command ) {
14862 save_exp=mp_stash_cur_exp(mp);
14864 if ( mp->cur_cmd==defined_macro )
14865 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14869 } while (mp->cur_cmd<min_command);
14870 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14874 @ Now let's consider the |macro_call| procedure, which is used to start up
14875 all user-defined macros. Since the arguments to a macro might be expressions,
14876 |macro_call| is recursive.
14879 The first parameter to |macro_call| points to the reference count of the
14880 token list that defines the macro. The second parameter contains any
14881 arguments that have already been parsed (see below). The third parameter
14882 points to the symbolic token that names the macro. If the third parameter
14883 is |null|, the macro was defined by \&{vardef}, so its name can be
14884 reconstructed from the prefix and ``at'' arguments found within the
14887 What is this second parameter? It's simply a linked list of one-word items,
14888 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14889 no arguments have been scanned yet; otherwise |info(arg_list)| points to
14890 the first scanned argument, and |link(arg_list)| points to the list of
14891 further arguments (if any).
14893 Arguments of type \&{expr} are so-called capsules, which we will
14894 discuss later when we concentrate on expressions; they can be
14895 recognized easily because their |link| field is |void|. Arguments of type
14896 \&{suffix} and \&{text} are token lists without reference counts.
14898 @ After argument scanning is complete, the arguments are moved to the
14899 |param_stack|. (They can't be put on that stack any sooner, because
14900 the stack is growing and shrinking in unpredictable ways as more arguments
14901 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14902 the replacement text of the macro is placed at the top of the \MP's
14903 input stack, so that |get_t_next| will proceed to read it next.
14905 @<Declare the procedure called |macro_call|@>=
14906 @<Declare the procedure called |print_macro_name|@>
14907 @<Declare the procedure called |print_arg|@>
14908 @<Declare the procedure called |scan_text_arg|@>
14909 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14910 pointer macro_name) ;
14913 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14914 pointer macro_name) {
14915 /* invokes a user-defined control sequence */
14916 pointer r; /* current node in the macro's token list */
14917 pointer p,q; /* for list manipulation */
14918 integer n; /* the number of arguments */
14919 pointer tail = 0; /* tail of the argument list */
14920 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14921 r=link(def_ref); add_mac_ref(def_ref);
14922 if ( arg_list==null ) {
14925 @<Determine the number |n| of arguments already supplied,
14926 and set |tail| to the tail of |arg_list|@>;
14928 if ( mp->internal[mp_tracing_macros]>0 ) {
14929 @<Show the text of the macro being expanded, and the existing arguments@>;
14931 @<Scan the remaining arguments, if any; set |r| to the first token
14932 of the replacement text@>;
14933 @<Feed the arguments and replacement text to the scanner@>;
14936 @ @<Show the text of the macro...@>=
14937 mp_begin_diagnostic(mp); mp_print_ln(mp);
14938 mp_print_macro_name(mp, arg_list,macro_name);
14939 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14940 mp_show_macro(mp, def_ref,null,100000);
14941 if ( arg_list!=null ) {
14945 mp_print_arg(mp, q,n,0);
14946 incr(n); p=link(p);
14949 mp_end_diagnostic(mp, false)
14952 @ @<Declare the procedure called |print_macro_name|@>=
14953 void mp_print_macro_name (MP mp,pointer a, pointer n);
14956 void mp_print_macro_name (MP mp,pointer a, pointer n) {
14957 pointer p,q; /* they traverse the first part of |a| */
14963 mp_print_text(info(info(link(a))));
14966 while ( link(q)!=null ) q=link(q);
14967 link(q)=info(link(a));
14968 mp_show_token_list(mp, p,null,1000,0);
14974 @ @<Declare the procedure called |print_arg|@>=
14975 void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
14978 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
14979 if ( link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
14980 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
14981 else mp_print_nl(mp, "(TEXT");
14982 mp_print_int(mp, n); mp_print(mp, ")<-");
14983 if ( link(q)==mp_void ) mp_print_exp(mp, q,1);
14984 else mp_show_token_list(mp, q,null,1000,0);
14987 @ @<Determine the number |n| of arguments already supplied...@>=
14989 n=1; tail=arg_list;
14990 while ( link(tail)!=null ) {
14991 incr(n); tail=link(tail);
14995 @ @<Scan the remaining arguments, if any; set |r|...@>=
14996 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
14997 while ( info(r)>=expr_base ) {
14998 @<Scan the delimited argument represented by |info(r)|@>;
15001 if ( mp->cur_cmd==comma ) {
15002 print_err("Too many arguments to ");
15003 @.Too many arguments...@>
15004 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, ';');
15005 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
15007 mp_print(mp, "' has been inserted");
15008 help3("I'm going to assume that the comma I just read was a")
15009 ("right delimiter, and then I'll begin expanding the macro.")
15010 ("You might want to delete some tokens before continuing.");
15013 if ( info(r)!=general_macro ) {
15014 @<Scan undelimited argument(s)@>;
15018 @ At this point, the reader will find it advisable to review the explanation
15019 of token list format that was presented earlier, paying special attention to
15020 the conventions that apply only at the beginning of a macro's token list.
15022 On the other hand, the reader will have to take the expression-parsing
15023 aspects of the following program on faith; we will explain |cur_type|
15024 and |cur_exp| later. (Several things in this program depend on each other,
15025 and it's necessary to jump into the circle somewhere.)
15027 @<Scan the delimited argument represented by |info(r)|@>=
15028 if ( mp->cur_cmd!=comma ) {
15030 if ( mp->cur_cmd!=left_delimiter ) {
15031 print_err("Missing argument to ");
15032 @.Missing argument...@>
15033 mp_print_macro_name(mp, arg_list,macro_name);
15034 help3("That macro has more parameters than you thought.")
15035 ("I'll continue by pretending that each missing argument")
15036 ("is either zero or null.");
15037 if ( info(r)>=suffix_base ) {
15038 mp->cur_exp=null; mp->cur_type=mp_token_list;
15040 mp->cur_exp=0; mp->cur_type=mp_known;
15042 mp_back_error(mp); mp->cur_cmd=right_delimiter;
15045 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
15047 @<Scan the argument represented by |info(r)|@>;
15048 if ( mp->cur_cmd!=comma )
15049 @<Check that the proper right delimiter was present@>;
15051 @<Append the current expression to |arg_list|@>
15053 @ @<Check that the proper right delim...@>=
15054 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15055 if ( info(link(r))>=expr_base ) {
15056 mp_missing_err(mp, ",");
15058 help3("I've finished reading a macro argument and am about to")
15059 ("read another; the arguments weren't delimited correctly.")
15060 ("You might want to delete some tokens before continuing.");
15061 mp_back_error(mp); mp->cur_cmd=comma;
15063 mp_missing_err(mp, str(text(r_delim)));
15065 help2("I've gotten to the end of the macro parameter list.")
15066 ("You might want to delete some tokens before continuing.");
15071 @ A \&{suffix} or \&{text} parameter will have been scanned as
15072 a token list pointed to by |cur_exp|, in which case we will have
15073 |cur_type=token_list|.
15075 @<Append the current expression to |arg_list|@>=
15077 p=mp_get_avail(mp);
15078 if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
15079 else info(p)=mp_stash_cur_exp(mp);
15080 if ( mp->internal[mp_tracing_macros]>0 ) {
15081 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
15082 mp_end_diagnostic(mp, false);
15084 if ( arg_list==null ) arg_list=p;
15089 @ @<Scan the argument represented by |info(r)|@>=
15090 if ( info(r)>=text_base ) {
15091 mp_scan_text_arg(mp, l_delim,r_delim);
15094 if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
15095 else mp_scan_expression(mp);
15098 @ The parameters to |scan_text_arg| are either a pair of delimiters
15099 or zero; the latter case is for undelimited text arguments, which
15100 end with the first semicolon or \&{endgroup} or \&{end} that is not
15101 contained in a group.
15103 @<Declare the procedure called |scan_text_arg|@>=
15104 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
15107 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
15108 integer balance; /* excess of |l_delim| over |r_delim| */
15109 pointer p; /* list tail */
15110 mp->warning_info=l_delim; mp->scanner_status=absorbing;
15111 p=hold_head; balance=1; link(hold_head)=null;
15114 if ( l_delim==0 ) {
15115 @<Adjust the balance for an undelimited argument; |break| if done@>;
15117 @<Adjust the balance for a delimited argument; |break| if done@>;
15119 link(p)=mp_cur_tok(mp); p=link(p);
15121 mp->cur_exp=link(hold_head); mp->cur_type=mp_token_list;
15122 mp->scanner_status=normal;
15125 @ @<Adjust the balance for a delimited argument...@>=
15126 if ( mp->cur_cmd==right_delimiter ) {
15127 if ( mp->cur_mod==l_delim ) {
15129 if ( balance==0 ) break;
15131 } else if ( mp->cur_cmd==left_delimiter ) {
15132 if ( mp->cur_mod==r_delim ) incr(balance);
15135 @ @<Adjust the balance for an undelimited...@>=
15136 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
15137 if ( balance==1 ) { break; }
15138 else { if ( mp->cur_cmd==end_group ) decr(balance); }
15139 } else if ( mp->cur_cmd==begin_group ) {
15143 @ @<Scan undelimited argument(s)@>=
15145 if ( info(r)<text_macro ) {
15147 if ( info(r)!=suffix_macro ) {
15148 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
15152 case primary_macro:mp_scan_primary(mp); break;
15153 case secondary_macro:mp_scan_secondary(mp); break;
15154 case tertiary_macro:mp_scan_tertiary(mp); break;
15155 case expr_macro:mp_scan_expression(mp); break;
15157 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
15160 @<Scan a suffix with optional delimiters@>;
15162 case text_macro:mp_scan_text_arg(mp, 0,0); break;
15163 } /* there are no other cases */
15165 @<Append the current expression to |arg_list|@>;
15168 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
15170 mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
15171 if ( mp->internal[mp_tracing_macros]>0 ) {
15172 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
15173 mp_end_diagnostic(mp, false);
15175 if ( arg_list==null ) arg_list=p; else link(tail)=p;
15177 if ( mp->cur_cmd!=of_token ) {
15178 mp_missing_err(mp, "of"); mp_print(mp, " for ");
15180 mp_print_macro_name(mp, arg_list,macro_name);
15181 help1("I've got the first argument; will look now for the other.");
15184 mp_get_x_next(mp); mp_scan_primary(mp);
15187 @ @<Scan a suffix with optional delimiters@>=
15189 if ( mp->cur_cmd!=left_delimiter ) {
15192 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
15194 mp_scan_suffix(mp);
15195 if ( l_delim!=null ) {
15196 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15197 mp_missing_err(mp, str(text(r_delim)));
15199 help2("I've gotten to the end of the macro parameter list.")
15200 ("You might want to delete some tokens before continuing.");
15207 @ Before we put a new token list on the input stack, it is wise to clean off
15208 all token lists that have recently been depleted. Then a user macro that ends
15209 with a call to itself will not require unbounded stack space.
15211 @<Feed the arguments and replacement text to the scanner@>=
15212 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15213 if ( mp->param_ptr+n>mp->max_param_stack ) {
15214 mp->max_param_stack=mp->param_ptr+n;
15215 if ( mp->max_param_stack>mp->param_size )
15216 mp_overflow(mp, "parameter stack size",mp->param_size);
15217 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15219 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15223 mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=link(p);
15225 mp_flush_list(mp, arg_list);
15228 @ It's sometimes necessary to put a single argument onto |param_stack|.
15229 The |stack_argument| subroutine does this.
15231 @c void mp_stack_argument (MP mp,pointer p) {
15232 if ( mp->param_ptr==mp->max_param_stack ) {
15233 incr(mp->max_param_stack);
15234 if ( mp->max_param_stack>mp->param_size )
15235 mp_overflow(mp, "parameter stack size",mp->param_size);
15236 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15238 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15241 @* \[33] Conditional processing.
15242 Let's consider now the way \&{if} commands are handled.
15244 Conditions can be inside conditions, and this nesting has a stack
15245 that is independent of other stacks.
15246 Four global variables represent the top of the condition stack:
15247 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15248 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15249 the largest code of a |fi_or_else| command that is syntactically legal;
15250 and |if_line| is the line number at which the current conditional began.
15252 If no conditions are currently in progress, the condition stack has the
15253 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15254 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15255 |link| fields of the first word contain |if_limit|, |cur_if|, and
15256 |cond_ptr| at the next level, and the second word contains the
15257 corresponding |if_line|.
15259 @d if_node_size 2 /* number of words in stack entry for conditionals */
15260 @d if_line_field(A) mp->mem[(A)+1].cint
15261 @d if_code 1 /* code for \&{if} being evaluated */
15262 @d fi_code 2 /* code for \&{fi} */
15263 @d else_code 3 /* code for \&{else} */
15264 @d else_if_code 4 /* code for \&{elseif} */
15267 pointer cond_ptr; /* top of the condition stack */
15268 integer if_limit; /* upper bound on |fi_or_else| codes */
15269 small_number cur_if; /* type of conditional being worked on */
15270 integer if_line; /* line where that conditional began */
15273 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15276 mp_primitive(mp, "if",if_test,if_code);
15277 @:if_}{\&{if} primitive@>
15278 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15279 @:fi_}{\&{fi} primitive@>
15280 mp_primitive(mp, "else",fi_or_else,else_code);
15281 @:else_}{\&{else} primitive@>
15282 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15283 @:else_if_}{\&{elseif} primitive@>
15285 @ @<Cases of |print_cmd_mod|...@>=
15289 case if_code:mp_print(mp, "if"); break;
15290 case fi_code:mp_print(mp, "fi"); break;
15291 case else_code:mp_print(mp, "else"); break;
15292 default: mp_print(mp, "elseif"); break;
15296 @ Here is a procedure that ignores text until coming to an \&{elseif},
15297 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15298 nesting. After it has acted, |cur_mod| will indicate the token that
15301 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15302 makes the skipping process a bit simpler.
15305 void mp_pass_text (MP mp) {
15307 mp->scanner_status=skipping;
15308 mp->warning_info=mp_true_line(mp);
15311 if ( mp->cur_cmd<=fi_or_else ) {
15312 if ( mp->cur_cmd<fi_or_else ) {
15316 if ( mp->cur_mod==fi_code ) decr(l);
15319 @<Decrease the string reference count,
15320 if the current token is a string@>;
15323 mp->scanner_status=normal;
15326 @ @<Decrease the string reference count...@>=
15327 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15329 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15330 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15331 condition has been evaluated, a colon will be inserted.
15332 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15334 @<Push the condition stack@>=
15335 { p=mp_get_node(mp, if_node_size); link(p)=mp->cond_ptr; type(p)=mp->if_limit;
15336 name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15337 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15338 mp->cur_if=if_code;
15341 @ @<Pop the condition stack@>=
15342 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15343 mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=link(p);
15344 mp_free_node(mp, p,if_node_size);
15347 @ Here's a procedure that changes the |if_limit| code corresponding to
15348 a given value of |cond_ptr|.
15350 @c void mp_change_if_limit (MP mp,small_number l, pointer p) {
15352 if ( p==mp->cond_ptr ) {
15353 mp->if_limit=l; /* that's the easy case */
15357 if ( q==null ) mp_confusion(mp, "if");
15358 @:this can't happen if}{\quad if@>
15359 if ( link(q)==p ) {
15367 @ The user is supposed to put colons into the proper parts of conditional
15368 statements. Therefore, \MP\ has to check for their presence.
15371 void mp_check_colon (MP mp) {
15372 if ( mp->cur_cmd!=colon ) {
15373 mp_missing_err(mp, ":");
15375 help2("There should've been a colon after the condition.")
15376 ("I shall pretend that one was there.");;
15381 @ A condition is started when the |get_x_next| procedure encounters
15382 an |if_test| command; in that case |get_x_next| calls |conditional|,
15383 which is a recursive procedure.
15386 @c void mp_conditional (MP mp) {
15387 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15388 int new_if_limit; /* future value of |if_limit| */
15389 pointer p; /* temporary register */
15390 @<Push the condition stack@>;
15391 save_cond_ptr=mp->cond_ptr;
15393 mp_get_boolean(mp); new_if_limit=else_if_code;
15394 if ( mp->internal[mp_tracing_commands]>unity ) {
15395 @<Display the boolean value of |cur_exp|@>;
15398 mp_check_colon(mp);
15399 if ( mp->cur_exp==true_code ) {
15400 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15401 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15403 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15405 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15406 if ( mp->cur_mod==fi_code ) {
15407 @<Pop the condition stack@>
15408 } else if ( mp->cur_mod==else_if_code ) {
15411 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15416 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15417 \&{else}: \\{bar} \&{fi}', the first \&{else}
15418 that we come to after learning that the \&{if} is false is not the
15419 \&{else} we're looking for. Hence the following curious logic is needed.
15421 @<Skip to \&{elseif}...@>=
15424 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15425 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15429 @ @<Display the boolean value...@>=
15430 { mp_begin_diagnostic(mp);
15431 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15432 else mp_print(mp, "{false}");
15433 mp_end_diagnostic(mp, false);
15436 @ The processing of conditionals is complete except for the following
15437 code, which is actually part of |get_x_next|. It comes into play when
15438 \&{elseif}, \&{else}, or \&{fi} is scanned.
15440 @<Terminate the current conditional and skip to \&{fi}@>=
15441 if ( mp->cur_mod>mp->if_limit ) {
15442 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15443 mp_missing_err(mp, ":");
15445 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15447 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15451 help1("I'm ignoring this; it doesn't match any if.");
15455 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15456 @<Pop the condition stack@>;
15459 @* \[34] Iterations.
15460 To bring our treatment of |get_x_next| to a close, we need to consider what
15461 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15463 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15464 that are currently active. If |loop_ptr=null|, no loops are in progress;
15465 otherwise |info(loop_ptr)| points to the iterative text of the current
15466 (innermost) loop, and |link(loop_ptr)| points to the data for any other
15467 loops that enclose the current one.
15469 A loop-control node also has two other fields, called |loop_type| and
15470 |loop_list|, whose contents depend on the type of loop:
15472 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15473 points to a list of one-word nodes whose |info| fields point to the
15474 remaining argument values of a suffix list and expression list.
15476 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15479 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15480 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15481 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15484 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15485 header and |loop_list(loop_ptr)| points into the graphical object list for
15488 \yskip\noindent In the case of a progression node, the first word is not used
15489 because the link field of words in the dynamic memory area cannot be arbitrary.
15491 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15492 @d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
15493 @d loop_list(A) link(loop_list_loc((A))) /* the remaining list elements */
15494 @d loop_node_size 2 /* the number of words in a loop control node */
15495 @d progression_node_size 4 /* the number of words in a progression node */
15496 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15497 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15498 @d progression_flag (null+2)
15499 /* |loop_type| value when |loop_list| points to a progression node */
15502 pointer loop_ptr; /* top of the loop-control-node stack */
15507 @ If the expressions that define an arithmetic progression in
15508 a \&{for} loop don't have known numeric values, the |bad_for|
15509 subroutine screams at the user.
15511 @c void mp_bad_for (MP mp, const char * s) {
15512 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15513 @.Improper...replaced by 0@>
15514 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15515 help4("When you say `for x=a step b until c',")
15516 ("the initial value `a' and the step size `b'")
15517 ("and the final value `c' must have known numeric values.")
15518 ("I'm zeroing this one. Proceed, with fingers crossed.");
15519 mp_put_get_flush_error(mp, 0);
15522 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15523 has just been scanned. (This code requires slight familiarity with
15524 expression-parsing routines that we have not yet discussed; but it seems
15525 to belong in the present part of the program, even though the original author
15526 didn't write it until later. The reader may wish to come back to it.)
15528 @c void mp_begin_iteration (MP mp) {
15529 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15530 halfword n; /* hash address of the current symbol */
15531 pointer s; /* the new loop-control node */
15532 pointer p; /* substitution list for |scan_toks| */
15533 pointer q; /* link manipulation register */
15534 pointer pp; /* a new progression node */
15535 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15536 if ( m==start_forever ){
15537 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15539 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15540 info(p)=mp->cur_sym; value(p)=m;
15542 if ( mp->cur_cmd==within_token ) {
15543 @<Set up a picture iteration@>;
15545 @<Check for the |"="| or |":="| in a loop header@>;
15546 @<Scan the values to be used in the loop@>;
15549 @<Check for the presence of a colon@>;
15550 @<Scan the loop text and put it on the loop control stack@>;
15551 mp_resume_iteration(mp);
15554 @ @<Check for the |"="| or |":="| in a loop header@>=
15555 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15556 mp_missing_err(mp, "=");
15558 help3("The next thing in this loop should have been `=' or `:='.")
15559 ("But don't worry; I'll pretend that an equals sign")
15560 ("was present, and I'll look for the values next.");
15564 @ @<Check for the presence of a colon@>=
15565 if ( mp->cur_cmd!=colon ) {
15566 mp_missing_err(mp, ":");
15568 help3("The next thing in this loop should have been a `:'.")
15569 ("So I'll pretend that a colon was present;")
15570 ("everything from here to `endfor' will be iterated.");
15574 @ We append a special |frozen_repeat_loop| token in place of the
15575 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15576 at the proper time to cause the loop to be repeated.
15578 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15579 he will be foiled by the |get_symbol| routine, which keeps frozen
15580 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15581 token, so it won't be lost accidentally.)
15583 @ @<Scan the loop text...@>=
15584 q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
15585 mp->scanner_status=loop_defining; mp->warning_info=n;
15586 info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15587 link(s)=mp->loop_ptr; mp->loop_ptr=s
15589 @ @<Initialize table...@>=
15590 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15591 text(frozen_repeat_loop)=intern(" ENDFOR");
15593 @ The loop text is inserted into \MP's scanning apparatus by the
15594 |resume_iteration| routine.
15596 @c void mp_resume_iteration (MP mp) {
15597 pointer p,q; /* link registers */
15598 p=loop_type(mp->loop_ptr);
15599 if ( p==progression_flag ) {
15600 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15601 mp->cur_exp=value(p);
15602 if ( @<The arithmetic progression has ended@> ) {
15603 mp_stop_iteration(mp);
15606 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15607 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15608 } else if ( p==null ) {
15609 p=loop_list(mp->loop_ptr);
15611 mp_stop_iteration(mp);
15614 loop_list(mp->loop_ptr)=link(p); q=info(p); free_avail(p);
15615 } else if ( p==mp_void ) {
15616 mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
15618 @<Make |q| a capsule containing the next picture component from
15619 |loop_list(loop_ptr)| or |goto not_found|@>;
15621 mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
15622 mp_stack_argument(mp, q);
15623 if ( mp->internal[mp_tracing_commands]>unity ) {
15624 @<Trace the start of a loop@>;
15628 mp_stop_iteration(mp);
15631 @ @<The arithmetic progression has ended@>=
15632 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15633 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15635 @ @<Trace the start of a loop@>=
15637 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15639 if ( (q!=null)&&(link(q)==mp_void) ) mp_print_exp(mp, q,1);
15640 else mp_show_token_list(mp, q,null,50,0);
15641 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
15644 @ @<Make |q| a capsule containing the next picture component from...@>=
15645 { q=loop_list(mp->loop_ptr);
15646 if ( q==null ) goto NOT_FOUND;
15647 skip_component(q) goto NOT_FOUND;
15648 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15649 mp_init_bbox(mp, mp->cur_exp);
15650 mp->cur_type=mp_picture_type;
15651 loop_list(mp->loop_ptr)=q;
15652 q=mp_stash_cur_exp(mp);
15655 @ A level of loop control disappears when |resume_iteration| has decided
15656 not to resume, or when an \&{exitif} construction has removed the loop text
15657 from the input stack.
15659 @c void mp_stop_iteration (MP mp) {
15660 pointer p,q; /* the usual */
15661 p=loop_type(mp->loop_ptr);
15662 if ( p==progression_flag ) {
15663 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15664 } else if ( p==null ){
15665 q=loop_list(mp->loop_ptr);
15666 while ( q!=null ) {
15669 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
15670 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15672 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15675 p=q; q=link(q); free_avail(p);
15677 } else if ( p>progression_flag ) {
15678 delete_edge_ref(p);
15680 p=mp->loop_ptr; mp->loop_ptr=link(p); mp_flush_token_list(mp, info(p));
15681 mp_free_node(mp, p,loop_node_size);
15684 @ Now that we know all about loop control, we can finish up
15685 the missing portion of |begin_iteration| and we'll be done.
15687 The following code is performed after the `\.=' has been scanned in
15688 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15689 (if |m=suffix_base|).
15691 @<Scan the values to be used in the loop@>=
15692 loop_type(s)=null; q=loop_list_loc(s); link(q)=null; /* |link(q)=loop_list(s)| */
15695 if ( m!=expr_base ) {
15696 mp_scan_suffix(mp);
15698 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15700 mp_scan_expression(mp);
15701 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15702 @<Prepare for step-until construction and |break|@>;
15704 mp->cur_exp=mp_stash_cur_exp(mp);
15706 link(q)=mp_get_avail(mp); q=link(q);
15707 info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15710 } while (mp->cur_cmd==comma)
15712 @ @<Prepare for step-until construction and |break|@>=
15714 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15715 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15716 mp_get_x_next(mp); mp_scan_expression(mp);
15717 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15718 step_size(pp)=mp->cur_exp;
15719 if ( mp->cur_cmd!=until_token ) {
15720 mp_missing_err(mp, "until");
15721 @.Missing `until'@>
15722 help2("I assume you meant to say `until' after `step'.")
15723 ("So I'll look for the final value and colon next.");
15726 mp_get_x_next(mp); mp_scan_expression(mp);
15727 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15728 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15729 loop_type(s)=progression_flag;
15733 @ The last case is when we have just seen ``\&{within}'', and we need to
15734 parse a picture expression and prepare to iterate over it.
15736 @<Set up a picture iteration@>=
15737 { mp_get_x_next(mp);
15738 mp_scan_expression(mp);
15739 @<Make sure the current expression is a known picture@>;
15740 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15741 q=link(dummy_loc(mp->cur_exp));
15743 if ( is_start_or_stop(q) )
15744 if ( mp_skip_1component(mp, q)==null ) q=link(q);
15748 @ @<Make sure the current expression is a known picture@>=
15749 if ( mp->cur_type!=mp_picture_type ) {
15750 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15751 help1("When you say `for x in p', p must be a known picture.");
15752 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15753 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15756 @* \[35] File names.
15757 It's time now to fret about file names. Besides the fact that different
15758 operating systems treat files in different ways, we must cope with the
15759 fact that completely different naming conventions are used by different
15760 groups of people. The following programs show what is required for one
15761 particular operating system; similar routines for other systems are not
15762 difficult to devise.
15763 @^system dependencies@>
15765 \MP\ assumes that a file name has three parts: the name proper; its
15766 ``extension''; and a ``file area'' where it is found in an external file
15767 system. The extension of an input file is assumed to be
15768 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15769 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15770 metric files that describe characters in any fonts created by \MP; it is
15771 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15772 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15773 The file area can be arbitrary on input files, but files are usually
15774 output to the user's current area. If an input file cannot be
15775 found on the specified area, \MP\ will look for it on a special system
15776 area; this special area is intended for commonly used input files.
15778 Simple uses of \MP\ refer only to file names that have no explicit
15779 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15780 instead of `\.{input} \.{cmr10.new}'. Simple file
15781 names are best, because they make the \MP\ source files portable;
15782 whenever a file name consists entirely of letters and digits, it should be
15783 treated in the same way by all implementations of \MP. However, users
15784 need the ability to refer to other files in their environment, especially
15785 when responding to error messages concerning unopenable files; therefore
15786 we want to let them use the syntax that appears in their favorite
15789 @ \MP\ uses the same conventions that have proved to be satisfactory for
15790 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15791 @^system dependencies@>
15792 the system-independent parts of \MP\ are expressed in terms
15793 of three system-dependent
15794 procedures called |begin_name|, |more_name|, and |end_name|. In
15795 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15796 the system-independent driver program does the operations
15797 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
15799 These three procedures communicate with each other via global variables.
15800 Afterwards the file name will appear in the string pool as three strings
15801 called |cur_name|\penalty10000\hskip-.05em,
15802 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15803 |""|), unless they were explicitly specified by the user.
15805 Actually the situation is slightly more complicated, because \MP\ needs
15806 to know when the file name ends. The |more_name| routine is a function
15807 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15808 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15809 returns |false|; or, it returns |true| and $c_n$ is the last character
15810 on the current input line. In other words,
15811 |more_name| is supposed to return |true| unless it is sure that the
15812 file name has been completely scanned; and |end_name| is supposed to be able
15813 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15814 whether $|more_name|(c_n)$ returned |true| or |false|.
15817 char * cur_name; /* name of file just scanned */
15818 char * cur_area; /* file area just scanned, or \.{""} */
15819 char * cur_ext; /* file extension just scanned, or \.{""} */
15821 @ It is easier to maintain reference counts if we assign initial values.
15824 mp->cur_name=xstrdup("");
15825 mp->cur_area=xstrdup("");
15826 mp->cur_ext=xstrdup("");
15828 @ @<Dealloc variables@>=
15829 xfree(mp->cur_area);
15830 xfree(mp->cur_name);
15831 xfree(mp->cur_ext);
15833 @ The file names we shall deal with for illustrative purposes have the
15834 following structure: If the name contains `\.>' or `\.:', the file area
15835 consists of all characters up to and including the final such character;
15836 otherwise the file area is null. If the remaining file name contains
15837 `\..', the file extension consists of all such characters from the first
15838 remaining `\..' to the end, otherwise the file extension is null.
15839 @^system dependencies@>
15841 We can scan such file names easily by using two global variables that keep track
15842 of the occurrences of area and extension delimiters. Note that these variables
15843 cannot be of type |pool_pointer| because a string pool compaction could occur
15844 while scanning a file name.
15847 integer area_delimiter;
15848 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15849 integer ext_delimiter; /* the relevant `\..', if any */
15851 @ Here now is the first of the system-dependent routines for file name scanning.
15852 @^system dependencies@>
15854 The file name length is limited to |file_name_size|. That is good, because
15855 in the current configuration we cannot call |mp_do_compaction| while a name
15856 is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct
15857 offsets into |mp->str_pool|. I am not in a great hurry to fix this, because
15858 calling |str_room()| just once is more efficient anyway. TODO.
15860 @<Declare subroutines for parsing file names@>=
15861 void mp_begin_name (MP mp) {
15862 xfree(mp->cur_name);
15863 xfree(mp->cur_area);
15864 xfree(mp->cur_ext);
15865 mp->area_delimiter=-1;
15866 mp->ext_delimiter=-1;
15867 str_room(file_name_size);
15870 @ And here's the second.
15871 @^system dependencies@>
15873 @<Declare subroutines for parsing file names@>=
15874 boolean mp_more_name (MP mp, ASCII_code c) {
15878 if ( (c=='>')||(c==':') ) {
15879 mp->area_delimiter=mp->pool_ptr;
15880 mp->ext_delimiter=-1;
15881 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15882 mp->ext_delimiter=mp->pool_ptr;
15884 append_char(c); /* contribute |c| to the current string */
15890 @^system dependencies@>
15892 @d copy_pool_segment(A,B,C) {
15893 A = xmalloc(C+1,sizeof(char));
15894 strncpy(A,(char *)(mp->str_pool+B),C);
15897 @<Declare subroutines for parsing file names@>=
15898 void mp_end_name (MP mp) {
15899 pool_pointer s; /* length of area, name, and extension */
15902 s = mp->str_start[mp->str_ptr];
15903 if ( mp->area_delimiter<0 ) {
15904 mp->cur_area=xstrdup("");
15906 len = mp->area_delimiter-s;
15907 copy_pool_segment(mp->cur_area,s,len);
15910 if ( mp->ext_delimiter<0 ) {
15911 mp->cur_ext=xstrdup("");
15912 len = mp->pool_ptr-s;
15914 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(mp->pool_ptr-mp->ext_delimiter));
15915 len = mp->ext_delimiter-s;
15917 copy_pool_segment(mp->cur_name,s,len);
15918 mp->pool_ptr=s; /* don't need this partial string */
15921 @ Conversely, here is a routine that takes three strings and prints a file
15922 name that might have produced them. (The routine is system dependent, because
15923 some operating systems put the file area last instead of first.)
15924 @^system dependencies@>
15926 @<Basic printing...@>=
15927 void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15928 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15931 @ Another system-dependent routine is needed to convert three internal
15933 to the |name_of_file| value that is used to open files. The present code
15934 allows both lowercase and uppercase letters in the file name.
15935 @^system dependencies@>
15937 @d append_to_name(A) { c=(A);
15938 if ( k<file_name_size ) {
15939 mp->name_of_file[k]=xchr(c);
15944 @<Declare subroutines for parsing file names@>=
15945 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
15946 integer k; /* number of positions filled in |name_of_file| */
15947 ASCII_code c; /* character being packed */
15948 const char *j; /* a character index */
15952 for (j=a;*j;j++) { append_to_name(*j); }
15954 for (j=n;*j;j++) { append_to_name(*j); }
15956 for (j=e;*j;j++) { append_to_name(*j); }
15958 mp->name_of_file[k]=0;
15962 @ @<Internal library declarations@>=
15963 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
15965 @ A messier routine is also needed, since mem file names must be scanned
15966 before \MP's string mechanism has been initialized. We shall use the
15967 global variable |MP_mem_default| to supply the text for default system areas
15968 and extensions related to mem files.
15969 @^system dependencies@>
15971 @d mem_default_length 9 /* length of the |MP_mem_default| string */
15972 @d mem_ext_length 4 /* length of its `\.{.mem}' part */
15973 @d mem_extension ".mem" /* the extension, as a \.{WEB} constant */
15976 char *MP_mem_default;
15978 @ @<Option variables@>=
15979 char *mem_name; /* for commandline */
15981 @ @<Allocate or initialize ...@>=
15982 mp->MP_mem_default = xstrdup("plain.mem");
15983 mp->mem_name = xstrdup(opt->mem_name);
15985 @^system dependencies@>
15987 @ @<Dealloc variables@>=
15988 xfree(mp->MP_mem_default);
15989 xfree(mp->mem_name);
15991 @ @<Check the ``constant'' values for consistency@>=
15992 if ( mem_default_length>file_name_size ) mp->bad=20;
15994 @ Here is the messy routine that was just mentioned. It sets |name_of_file|
15995 from the first |n| characters of |MP_mem_default|, followed by
15996 |buffer[a..b-1]|, followed by the last |mem_ext_length| characters of
15999 We dare not give error messages here, since \MP\ calls this routine before
16000 the |error| routine is ready to roll. Instead, we simply drop excess characters,
16001 since the error will be detected in another way when a strange file name
16003 @^system dependencies@>
16005 @c void mp_pack_buffered_name (MP mp,small_number n, integer a,
16007 integer k; /* number of positions filled in |name_of_file| */
16008 ASCII_code c; /* character being packed */
16009 integer j; /* index into |buffer| or |MP_mem_default| */
16010 if ( n+b-a+1+mem_ext_length>file_name_size )
16011 b=a+file_name_size-n-1-mem_ext_length;
16013 for (j=0;j<n;j++) {
16014 append_to_name(xord((int)mp->MP_mem_default[j]));
16016 for (j=a;j<b;j++) {
16017 append_to_name(mp->buffer[j]);
16019 for (j=mem_default_length-mem_ext_length;
16020 j<mem_default_length;j++) {
16021 append_to_name(xord((int)mp->MP_mem_default[j]));
16023 mp->name_of_file[k]=0;
16027 @ Here is the only place we use |pack_buffered_name|. This part of the program
16028 becomes active when a ``virgin'' \MP\ is trying to get going, just after
16029 the preliminary initialization, or when the user is substituting another
16030 mem file by typing `\.\&' after the initial `\.{**}' prompt. The buffer
16031 contains the first line of input in |buffer[loc..(last-1)]|, where
16032 |loc<last| and |buffer[loc]<>" "|.
16035 boolean mp_open_mem_file (MP mp) ;
16038 boolean mp_open_mem_file (MP mp) {
16039 int j; /* the first space after the file name */
16040 if (mp->mem_name!=NULL) {
16041 mp->mem_file = (mp->open_file)(mp,mp->mem_name, "r", mp_filetype_memfile);
16042 if ( mp->mem_file ) return true;
16045 if ( mp->buffer[loc]=='&' ) {
16046 incr(loc); j=loc; mp->buffer[mp->last]=' ';
16047 while ( mp->buffer[j]!=' ' ) incr(j);
16048 mp_pack_buffered_name(mp, 0,loc,j); /* try first without the system file area */
16049 if ( mp_w_open_in(mp, &mp->mem_file) ) goto FOUND;
16051 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
16052 @.Sorry, I can't find...@>
16055 /* now pull out all the stops: try for the system \.{plain} file */
16056 mp_pack_buffered_name(mp, mem_default_length-mem_ext_length,0,0);
16057 if ( ! mp_w_open_in(mp, &mp->mem_file) ) {
16059 wterm_ln("I can\'t find the PLAIN mem file!\n");
16060 @.I can't find PLAIN...@>
16065 loc=j; return true;
16068 @ Operating systems often make it possible to determine the exact name (and
16069 possible version number) of a file that has been opened. The following routine,
16070 which simply makes a \MP\ string from the value of |name_of_file|, should
16071 ideally be changed to deduce the full name of file~|f|, which is the file
16072 most recently opened, if it is possible to do this.
16073 @^system dependencies@>
16076 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
16077 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
16078 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
16081 str_number mp_make_name_string (MP mp) {
16082 int k; /* index into |name_of_file| */
16083 str_room(mp->name_length);
16084 for (k=0;k<mp->name_length;k++) {
16085 append_char(xord((int)mp->name_of_file[k]));
16087 return mp_make_string(mp);
16090 @ Now let's consider the ``driver''
16091 routines by which \MP\ deals with file names
16092 in a system-independent manner. First comes a procedure that looks for a
16093 file name in the input by taking the information from the input buffer.
16094 (We can't use |get_next|, because the conversion to tokens would
16095 destroy necessary information.)
16097 This procedure doesn't allow semicolons or percent signs to be part of
16098 file names, because of other conventions of \MP.
16099 {\sl The {\logos METAFONT\/}book} doesn't
16100 use semicolons or percents immediately after file names, but some users
16101 no doubt will find it natural to do so; therefore system-dependent
16102 changes to allow such characters in file names should probably
16103 be made with reluctance, and only when an entire file name that
16104 includes special characters is ``quoted'' somehow.
16105 @^system dependencies@>
16107 @c void mp_scan_file_name (MP mp) {
16109 while ( mp->buffer[loc]==' ' ) incr(loc);
16111 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
16112 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
16118 @ Here is another version that takes its input from a string.
16120 @<Declare subroutines for parsing file names@>=
16121 void mp_str_scan_file (MP mp, str_number s) {
16122 pool_pointer p,q; /* current position and stopping point */
16124 p=mp->str_start[s]; q=str_stop(s);
16126 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
16132 @ And one that reads from a |char*|.
16134 @<Declare subroutines for parsing file names@>=
16135 void mp_ptr_scan_file (MP mp, char *s) {
16136 char *p, *q; /* current position and stopping point */
16138 p=s; q=p+strlen(s);
16140 if ( ! mp_more_name(mp, *p)) break;
16147 @ The global variable |job_name| contains the file name that was first
16148 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
16149 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
16152 boolean log_opened; /* has the transcript file been opened? */
16153 char *log_name; /* full name of the log file */
16155 @ @<Option variables@>=
16156 char *job_name; /* principal file name */
16158 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
16159 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
16160 except of course for a short time just after |job_name| has become nonzero.
16162 @<Allocate or ...@>=
16163 mp->job_name=mp_xstrdup(mp, opt->job_name);
16164 mp->log_opened=false;
16166 @ @<Dealloc variables@>=
16167 xfree(mp->job_name);
16169 @ Here is a routine that manufactures the output file names, assuming that
16170 |job_name<>0|. It ignores and changes the current settings of |cur_area|
16173 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
16176 void mp_pack_job_name (MP mp, const char *s) ;
16179 void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
16180 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
16181 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16182 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
16186 @ If some trouble arises when \MP\ tries to open a file, the following
16187 routine calls upon the user to supply another file name. Parameter~|s|
16188 is used in the error message to identify the type of file; parameter~|e|
16189 is the default extension if none is given. Upon exit from the routine,
16190 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16191 ready for another attempt at file opening.
16194 void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
16196 @ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
16197 size_t k; /* index into |buffer| */
16198 char * saved_cur_name;
16199 if ( mp->interaction==mp_scroll_mode )
16201 if (strcmp(s,"input file name")==0) {
16202 print_err("I can\'t find file `");
16203 @.I can't find file x@>
16205 print_err("I can\'t write on file `");
16207 @.I can't write on file x@>
16208 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16209 mp_print(mp, "'.");
16210 if (strcmp(e,"")==0)
16211 mp_show_context(mp);
16212 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16214 if ( mp->interaction<mp_scroll_mode )
16215 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16216 @.job aborted, file error...@>
16217 saved_cur_name = xstrdup(mp->cur_name);
16218 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16219 if (strcmp(mp->cur_ext,"")==0)
16220 mp->cur_ext=xstrdup(e);
16221 if (strlen(mp->cur_name)==0) {
16222 mp->cur_name=saved_cur_name;
16224 xfree(saved_cur_name);
16229 @ @<Scan file name in the buffer@>=
16231 mp_begin_name(mp); k=mp->first;
16232 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16234 if ( k==mp->last ) break;
16235 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16241 @ The |open_log_file| routine is used to open the transcript file and to help
16242 it catch up to what has previously been printed on the terminal.
16244 @c void mp_open_log_file (MP mp) {
16245 int old_setting; /* previous |selector| setting */
16246 int k; /* index into |months| and |buffer| */
16247 int l; /* end of first input line */
16248 integer m; /* the current month */
16249 const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16250 /* abbreviations of month names */
16251 old_setting=mp->selector;
16252 if ( mp->job_name==NULL ) {
16253 mp->job_name=xstrdup("mpout");
16255 mp_pack_job_name(mp,".log");
16256 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16257 @<Try to get a different log file name@>;
16259 mp->log_name=xstrdup(mp->name_of_file);
16260 mp->selector=log_only; mp->log_opened=true;
16261 @<Print the banner line, including the date and time@>;
16262 mp->input_stack[mp->input_ptr]=mp->cur_input;
16263 /* make sure bottom level is in memory */
16265 if (!mp->noninteractive) {
16266 mp_print_nl(mp, "**");
16267 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16268 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16269 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16271 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16274 @ @<Dealloc variables@>=
16275 xfree(mp->log_name);
16277 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16278 unable to print error messages or even to |show_context|.
16279 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16280 routine will not be invoked because |log_opened| will be false.
16282 The normal idea of |mp_batch_mode| is that nothing at all should be written
16283 on the terminal. However, in the unusual case that
16284 no log file could be opened, we make an exception and allow
16285 an explanatory message to be seen.
16287 Incidentally, the program always refers to the log file as a `\.{transcript
16288 file}', because some systems cannot use the extension `\.{.log}' for
16291 @<Try to get a different log file name@>=
16293 mp->selector=term_only;
16294 mp_prompt_file_name(mp, "transcript file name",".log");
16297 @ @<Print the banner...@>=
16300 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16301 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16302 mp_print_char(mp, ' ');
16303 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16304 for (k=3*m-3;k<3*m;k++) { wlog_chr(months[k]); }
16305 mp_print_char(mp, ' ');
16306 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16307 mp_print_char(mp, ' ');
16308 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16309 mp_print_dd(mp, m / 60); mp_print_char(mp, ':'); mp_print_dd(mp, m % 60);
16312 @ The |try_extension| function tries to open an input file determined by
16313 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16314 can't find the file in |cur_area| or the appropriate system area.
16316 @c boolean mp_try_extension (MP mp, const char *ext) {
16317 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16318 in_name=xstrdup(mp->cur_name);
16319 in_area=xstrdup(mp->cur_area);
16320 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16323 mp_pack_file_name(mp, mp->cur_name,NULL,ext);
16324 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16328 @ Let's turn now to the procedure that is used to initiate file reading
16329 when an `\.{input}' command is being processed.
16331 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16332 char *fname = NULL;
16333 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16335 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16336 if ( strlen(mp->cur_ext)==0 ) {
16337 if ( mp_try_extension(mp, ".mp") ) break;
16338 else if ( mp_try_extension(mp, "") ) break;
16339 else if ( mp_try_extension(mp, ".mf") ) break;
16340 /* |else do_nothing; | */
16341 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16344 mp_end_file_reading(mp); /* remove the level that didn't work */
16345 mp_prompt_file_name(mp, "input file name","");
16347 name=mp_a_make_name_string(mp, cur_file);
16348 fname = xstrdup(mp->name_of_file);
16349 if ( mp->job_name==NULL ) {
16350 mp->job_name=xstrdup(mp->cur_name);
16351 mp_open_log_file(mp);
16352 } /* |open_log_file| doesn't |show_context|, so |limit|
16353 and |loc| needn't be set to meaningful values yet */
16354 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16355 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
16356 mp_print_char(mp, '('); incr(mp->open_parens); mp_print(mp, fname);
16359 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16360 @<Read the first line of the new file@>;
16363 @ This code should be omitted if |a_make_name_string| returns something other
16364 than just a copy of its argument and the full file name is needed for opening
16365 \.{MPX} files or implementing the switch-to-editor option.
16366 @^system dependencies@>
16368 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16369 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16371 @ If the file is empty, it is considered to contain a single blank line,
16372 so there is no need to test the return value.
16374 @<Read the first line...@>=
16377 (void)mp_input_ln(mp, cur_file );
16378 mp_firm_up_the_line(mp);
16379 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
16382 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16383 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16384 if ( token_state ) {
16385 print_err("File names can't appear within macros");
16386 @.File names can't...@>
16387 help3("Sorry...I've converted what follows to tokens,")
16388 ("possibly garbaging the name you gave.")
16389 ("Please delete the tokens and insert the name again.");
16392 if ( file_state ) {
16393 mp_scan_file_name(mp);
16395 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16396 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16397 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16400 @ The following simple routine starts reading the \.{MPX} file associated
16401 with the current input file.
16403 @c void mp_start_mpx_input (MP mp) {
16404 char *origname = NULL; /* a copy of nameoffile */
16405 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16406 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16407 |goto not_found| if there is a problem@>;
16408 mp_begin_file_reading(mp);
16409 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16410 mp_end_file_reading(mp);
16413 name=mp_a_make_name_string(mp, cur_file);
16414 mp->mpx_name[index]=name; add_str_ref(name);
16415 @<Read the first line of the new file@>;
16419 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16423 @ This should ideally be changed to do whatever is necessary to create the
16424 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16425 of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
16426 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16427 completely different typesetting program if suitable postprocessor is
16428 available to perform the function of \.{DVItoMP}.)
16429 @^system dependencies@>
16431 @ @<Exported types@>=
16432 typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
16434 @ @<Option variables@>=
16435 mp_run_make_mpx_command run_make_mpx;
16437 @ @<Allocate or initialize ...@>=
16438 set_callback_option(run_make_mpx);
16440 @ @<Internal library declarations@>=
16441 int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16443 @ The default does nothing.
16445 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16452 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16453 |goto not_found| if there is a problem@>=
16454 origname = mp_xstrdup(mp,mp->name_of_file);
16455 *(origname+strlen(origname)-1)=0; /* drop the x */
16456 if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
16459 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16460 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16461 mp_print_nl(mp, ">> ");
16462 mp_print(mp, origname);
16463 mp_print_nl(mp, ">> ");
16464 mp_print(mp, mp->name_of_file);
16465 mp_print_nl(mp, "! Unable to make mpx file");
16466 help4("The two files given above are one of your source files")
16467 ("and an auxiliary file I need to read to find out what your")
16468 ("btex..etex blocks mean. If you don't know why I had trouble,")
16469 ("try running it manually through MPtoTeX, TeX, and DVItoMP");
16472 @ The last file-opening commands are for files accessed via the \&{readfrom}
16473 @:read_from_}{\&{readfrom} primitive@>
16474 operator and the \&{write} command. Such files are stored in separate arrays.
16475 @:write_}{\&{write} primitive@>
16477 @<Types in the outer block@>=
16478 typedef unsigned int readf_index; /* |0..max_read_files| */
16479 typedef unsigned int write_index; /* |0..max_write_files| */
16482 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16483 void ** rd_file; /* \&{readfrom} files */
16484 char ** rd_fname; /* corresponding file name or 0 if file not open */
16485 readf_index read_files; /* number of valid entries in the above arrays */
16486 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16487 void ** wr_file; /* \&{write} files */
16488 char ** wr_fname; /* corresponding file name or 0 if file not open */
16489 write_index write_files; /* number of valid entries in the above arrays */
16491 @ @<Allocate or initialize ...@>=
16492 mp->max_read_files=8;
16493 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
16494 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16495 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16497 mp->max_write_files=8;
16498 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
16499 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16500 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16504 @ This routine starts reading the file named by string~|s| without setting
16505 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16506 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16508 @c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16509 mp_ptr_scan_file(mp, s);
16511 mp_begin_file_reading(mp);
16512 if ( ! mp_a_open_in(mp, &mp->rd_file[n], (mp_filetype_text+n)) )
16514 if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
16515 (mp->close_file)(mp,mp->rd_file[n]);
16518 mp->rd_fname[n]=xstrdup(mp->name_of_file);
16521 mp_end_file_reading(mp);
16525 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16528 void mp_open_write_file (MP mp, char *s, readf_index n) ;
16530 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16531 mp_ptr_scan_file(mp, s);
16533 while ( ! mp_a_open_out(mp, &mp->wr_file[n], (mp_filetype_text+n)) )
16534 mp_prompt_file_name(mp, "file name for write output","");
16535 mp->wr_fname[n]=xstrdup(mp->name_of_file);
16539 @* \[36] Introduction to the parsing routines.
16540 We come now to the central nervous system that sparks many of \MP's activities.
16541 By evaluating expressions, from their primary constituents to ever larger
16542 subexpressions, \MP\ builds the structures that ultimately define complete
16543 pictures or fonts of type.
16545 Four mutually recursive subroutines are involved in this process: We call them
16546 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16547 and |scan_expression|.}$$
16549 Each of them is parameterless and begins with the first token to be scanned
16550 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16551 the value of the primary or secondary or tertiary or expression that was
16552 found will appear in the global variables |cur_type| and |cur_exp|. The
16553 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16556 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16557 backup mechanisms have been added in order to provide reasonable error
16561 small_number cur_type; /* the type of the expression just found */
16562 integer cur_exp; /* the value of the expression just found */
16567 @ Many different kinds of expressions are possible, so it is wise to have
16568 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16571 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16572 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16573 construction in which there was no expression before the \&{endgroup}.
16574 In this case |cur_exp| has some irrelevant value.
16577 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16581 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16583 a ring of equivalent booleans whose value has not yet been defined.
16586 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16587 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16588 includes this particular reference.
16591 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16593 a ring of equivalent strings whose value has not yet been defined.
16596 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16597 else points to any of the nodes in this pen. The pen may be polygonal or
16601 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16603 a ring of equivalent pens whose value has not yet been defined.
16606 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16607 a path; nobody else points to this particular path. The control points of
16608 the path will have been chosen.
16611 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16613 a ring of equivalent paths whose value has not yet been defined.
16616 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16617 There may be other pointers to this particular set of edges. The header node
16618 contains a reference count that includes this particular reference.
16621 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16623 a ring of equivalent pictures whose value has not yet been defined.
16626 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16627 capsule node. The |value| part of this capsule
16628 points to a transform node that contains six numeric values,
16629 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16632 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16633 capsule node. The |value| part of this capsule
16634 points to a color node that contains three numeric values,
16635 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16638 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16639 capsule node. The |value| part of this capsule
16640 points to a color node that contains four numeric values,
16641 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16644 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16645 node whose type is |mp_pair_type|. The |value| part of this capsule
16646 points to a pair node that contains two numeric values,
16647 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16650 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16653 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16654 is |dependent|. The |dep_list| field in this capsule points to the associated
16658 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16659 capsule node. The |dep_list| field in this capsule
16660 points to the associated dependency list.
16663 |cur_type=independent| means that |cur_exp| points to a capsule node
16664 whose type is |independent|. This somewhat unusual case can arise, for
16665 example, in the expression
16666 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16669 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16672 \smallskip\noindent
16673 The possible settings of |cur_type| have been listed here in increasing
16674 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16675 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16676 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16679 @ Capsules are two-word nodes that have a similar meaning
16680 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
16681 and their |type| field is one of the possibilities for |cur_type| listed above.
16682 Also |link<=void| in capsules that aren't part of a token list.
16684 The |value| field of a capsule is, in most cases, the value that
16685 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16686 However, when |cur_exp| would point to a capsule,
16687 no extra layer of indirection is present; the |value|
16688 field is what would have been called |value(cur_exp)| if it had not been
16689 encapsulated. Furthermore, if the type is |dependent| or
16690 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16691 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16692 always part of the general |dep_list| structure.
16694 The |get_x_next| routine is careful not to change the values of |cur_type|
16695 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16696 call a macro, which might parse an expression, which might execute lots of
16697 commands in a group; hence it's possible that |cur_type| might change
16698 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16699 |known| or |independent|, during the time |get_x_next| is called. The
16700 programs below are careful to stash sensitive intermediate results in
16701 capsules, so that \MP's generality doesn't cause trouble.
16703 Here's a procedure that illustrates these conventions. It takes
16704 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16705 and stashes them away in a
16706 capsule. It is not used when |cur_type=mp_token_list|.
16707 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16708 copy path lists or to update reference counts, etc.
16710 The special link |mp_void| is put on the capsule returned by
16711 |stash_cur_exp|, because this procedure is used to store macro parameters
16712 that must be easily distinguishable from token lists.
16714 @<Declare the stashing/unstashing routines@>=
16715 pointer mp_stash_cur_exp (MP mp) {
16716 pointer p; /* the capsule that will be returned */
16717 switch (mp->cur_type) {
16718 case unknown_types:
16719 case mp_transform_type:
16720 case mp_color_type:
16723 case mp_proto_dependent:
16724 case mp_independent:
16725 case mp_cmykcolor_type:
16729 p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
16730 type(p)=mp->cur_type; value(p)=mp->cur_exp;
16733 mp->cur_type=mp_vacuous; link(p)=mp_void;
16737 @ The inverse of |stash_cur_exp| is the following procedure, which
16738 deletes an unnecessary capsule and puts its contents into |cur_type|
16741 The program steps of \MP\ can be divided into two categories: those in
16742 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16743 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16744 information or not. It's important not to ignore them when they're alive,
16745 and it's important not to pay attention to them when they're dead.
16747 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16748 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16749 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16750 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16751 only when they are alive or dormant.
16753 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16754 are alive or dormant. The \\{unstash} procedure assumes that they are
16755 dead or dormant; it resuscitates them.
16757 @<Declare the stashing/unstashing...@>=
16758 void mp_unstash_cur_exp (MP mp,pointer p) ;
16761 void mp_unstash_cur_exp (MP mp,pointer p) {
16762 mp->cur_type=type(p);
16763 switch (mp->cur_type) {
16764 case unknown_types:
16765 case mp_transform_type:
16766 case mp_color_type:
16769 case mp_proto_dependent:
16770 case mp_independent:
16771 case mp_cmykcolor_type:
16775 mp->cur_exp=value(p);
16776 mp_free_node(mp, p,value_node_size);
16781 @ The following procedure prints the values of expressions in an
16782 abbreviated format. If its first parameter |p| is null, the value of
16783 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16784 containing the desired value. The second parameter controls the amount of
16785 output. If it is~0, dependency lists will be abbreviated to
16786 `\.{linearform}' unless they consist of a single term. If it is greater
16787 than~1, complicated structures (pens, pictures, and paths) will be displayed
16791 @<Declare subroutines for printing expressions@>=
16792 @<Declare the procedure called |print_dp|@>
16793 @<Declare the stashing/unstashing routines@>
16794 void mp_print_exp (MP mp,pointer p, small_number verbosity) {
16795 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16796 small_number t; /* the type of the expression */
16797 pointer q; /* a big node being displayed */
16798 integer v=0; /* the value of the expression */
16800 restore_cur_exp=false;
16802 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16805 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16806 @<Print an abbreviated value of |v| with format depending on |t|@>;
16807 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16810 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16812 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16813 case mp_boolean_type:
16814 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16816 case unknown_types: case mp_numeric_type:
16817 @<Display a variable that's been declared but not defined@>;
16819 case mp_string_type:
16820 mp_print_char(mp, '"'); mp_print_str(mp, v); mp_print_char(mp, '"');
16822 case mp_pen_type: case mp_path_type: case mp_picture_type:
16823 @<Display a complex type@>;
16825 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16826 if ( v==null ) mp_print_type(mp, t);
16827 else @<Display a big node@>;
16829 case mp_known:mp_print_scaled(mp, v); break;
16830 case mp_dependent: case mp_proto_dependent:
16831 mp_print_dp(mp, t,v,verbosity);
16833 case mp_independent:mp_print_variable_name(mp, p); break;
16834 default: mp_confusion(mp, "exp"); break;
16835 @:this can't happen exp}{\quad exp@>
16838 @ @<Display a big node@>=
16840 mp_print_char(mp, '('); q=v+mp->big_node_size[t];
16842 if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
16843 else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
16844 else mp_print_dp(mp, type(v),dep_list(v),verbosity);
16846 if ( v!=q ) mp_print_char(mp, ',');
16848 mp_print_char(mp, ')');
16851 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16852 in the log file only, unless the user has given a positive value to
16855 @<Display a complex type@>=
16856 if ( verbosity<=1 ) {
16857 mp_print_type(mp, t);
16859 if ( mp->selector==term_and_log )
16860 if ( mp->internal[mp_tracing_online]<=0 ) {
16861 mp->selector=term_only;
16862 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16863 mp->selector=term_and_log;
16866 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16867 case mp_path_type:mp_print_path(mp, v,"",false); break;
16868 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16869 } /* there are no other cases */
16872 @ @<Declare the procedure called |print_dp|@>=
16873 void mp_print_dp (MP mp,small_number t, pointer p,
16874 small_number verbosity) {
16875 pointer q; /* the node following |p| */
16877 if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16878 else mp_print(mp, "linearform");
16881 @ The displayed name of a variable in a ring will not be a capsule unless
16882 the ring consists entirely of capsules.
16884 @<Display a variable that's been declared but not defined@>=
16885 { mp_print_type(mp, t);
16887 { mp_print_char(mp, ' ');
16888 while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16889 mp_print_variable_name(mp, v);
16893 @ When errors are detected during parsing, it is often helpful to
16894 display an expression just above the error message, using |exp_err|
16895 or |disp_err| instead of |print_err|.
16897 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16899 @<Declare subroutines for printing expressions@>=
16900 void mp_disp_err (MP mp,pointer p, const char *s) {
16901 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16902 mp_print_nl(mp, ">> ");
16904 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16906 mp_print_nl(mp, "! "); mp_print(mp, s);
16911 @ If |cur_type| and |cur_exp| contain relevant information that should
16912 be recycled, we will use the following procedure, which changes |cur_type|
16913 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16914 and |cur_exp| as either alive or dormant after this has been done,
16915 because |cur_exp| will not contain a pointer value.
16917 @ @c void mp_flush_cur_exp (MP mp,scaled v) {
16918 switch (mp->cur_type) {
16919 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16920 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16921 mp_recycle_value(mp, mp->cur_exp);
16922 mp_free_node(mp, mp->cur_exp,value_node_size);
16924 case mp_string_type:
16925 delete_str_ref(mp->cur_exp); break;
16926 case mp_pen_type: case mp_path_type:
16927 mp_toss_knot_list(mp, mp->cur_exp); break;
16928 case mp_picture_type:
16929 delete_edge_ref(mp->cur_exp); break;
16933 mp->cur_type=mp_known; mp->cur_exp=v;
16936 @ There's a much more general procedure that is capable of releasing
16937 the storage associated with any two-word value packet.
16939 @<Declare the recycling subroutines@>=
16940 void mp_recycle_value (MP mp,pointer p) ;
16942 @ @c void mp_recycle_value (MP mp,pointer p) {
16943 small_number t; /* a type code */
16944 integer vv; /* another value */
16945 pointer q,r,s,pp; /* link manipulation registers */
16946 integer v=0; /* a value */
16948 if ( t<mp_dependent ) v=value(p);
16950 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
16951 case mp_numeric_type:
16953 case unknown_types:
16954 mp_ring_delete(mp, p); break;
16955 case mp_string_type:
16956 delete_str_ref(v); break;
16957 case mp_path_type: case mp_pen_type:
16958 mp_toss_knot_list(mp, v); break;
16959 case mp_picture_type:
16960 delete_edge_ref(v); break;
16961 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
16962 case mp_transform_type:
16963 @<Recycle a big node@>; break;
16964 case mp_dependent: case mp_proto_dependent:
16965 @<Recycle a dependency list@>; break;
16966 case mp_independent:
16967 @<Recycle an independent variable@>; break;
16968 case mp_token_list: case mp_structured:
16969 mp_confusion(mp, "recycle"); break;
16970 @:this can't happen recycle}{\quad recycle@>
16971 case mp_unsuffixed_macro: case mp_suffixed_macro:
16972 mp_delete_mac_ref(mp, value(p)); break;
16973 } /* there are no other cases */
16977 @ @<Recycle a big node@>=
16979 q=v+mp->big_node_size[t];
16981 q=q-2; mp_recycle_value(mp, q);
16983 mp_free_node(mp, v,mp->big_node_size[t]);
16986 @ @<Recycle a dependency list@>=
16989 while ( info(q)!=null ) q=link(q);
16990 link(prev_dep(p))=link(q);
16991 prev_dep(link(q))=prev_dep(p);
16992 link(q)=null; mp_flush_node_list(mp, dep_list(p));
16995 @ When an independent variable disappears, it simply fades away, unless
16996 something depends on it. In the latter case, a dependent variable whose
16997 coefficient of dependence is maximal will take its place.
16998 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
16999 as part of his Ph.D. thesis (Stanford University, December 1982).
17000 @^Zabala Salelles, Ignacio Andr\'es@>
17002 For example, suppose that variable $x$ is being recycled, and that the
17003 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
17004 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
17005 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
17006 we will print `\.{\#\#\# -2x=-y+a}'.
17008 There's a slight complication, however: An independent variable $x$
17009 can occur both in dependency lists and in proto-dependency lists.
17010 This makes it necessary to be careful when deciding which coefficient
17013 Furthermore, this complication is not so slight when
17014 a proto-dependent variable is chosen to become independent. For example,
17015 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
17016 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
17017 large coefficient `50'.
17019 In order to deal with these complications without wasting too much time,
17020 we shall link together the occurrences of~$x$ among all the linear
17021 dependencies, maintaining separate lists for the dependent and
17022 proto-dependent cases.
17024 @<Recycle an independent variable@>=
17026 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
17027 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
17029 while ( q!=dep_head ) {
17030 s=value_loc(q); /* now |link(s)=dep_list(q)| */
17033 if ( info(r)==null ) break;
17034 if ( info(r)!=p ) {
17037 t=type(q); link(s)=link(r); info(r)=q;
17038 if ( abs(value(r))>mp->max_c[t] ) {
17039 @<Record a new maximum coefficient of type |t|@>;
17041 link(r)=mp->max_link[t]; mp->max_link[t]=r;
17047 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
17048 @<Choose a dependent variable to take the place of the disappearing
17049 independent variable, and change all remaining dependencies
17054 @ The code for independency removal makes use of three two-word arrays.
17057 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
17058 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
17059 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
17061 @ @<Record a new maximum coefficient...@>=
17063 if ( mp->max_c[t]>0 ) {
17064 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17066 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
17069 @ @<Choose a dependent...@>=
17071 if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
17074 t=mp_proto_dependent;
17075 @<Determine the dependency list |s| to substitute for the independent
17077 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
17078 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
17079 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17081 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
17082 else { @<Substitute new proto-dependencies in place of |p|@>;}
17083 mp_flush_node_list(mp, s);
17084 if ( mp->fix_needed ) mp_fix_dependencies(mp);
17088 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
17089 and |info(s)| points to the dependent variable~|pp| of type~|t| from
17090 whose dependency list we have removed node~|s|. We must reinsert
17091 node~|s| into the dependency list, with coefficient $-1.0$, and with
17092 |pp| as the new independent variable. Since |pp| will have a larger serial
17093 number than any other variable, we can put node |s| at the head of the
17096 @<Determine the dep...@>=
17097 s=mp->max_ptr[t]; pp=info(s); v=value(s);
17098 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
17099 r=dep_list(pp); link(s)=r;
17100 while ( info(r)!=null ) r=link(r);
17101 q=link(r); link(r)=null;
17102 prev_dep(q)=prev_dep(pp); link(prev_dep(pp))=q;
17104 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
17105 if ( mp->internal[mp_tracing_equations]>0 ) {
17106 @<Show the transformed dependency@>;
17109 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
17110 by the dependency list~|s|.
17112 @<Show the transformed...@>=
17113 if ( mp_interesting(mp, p) ) {
17114 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
17115 @:]]]\#\#\#_}{\.{\#\#\#}@>
17116 if ( v>0 ) mp_print_char(mp, '-');
17117 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
17118 else vv=mp->max_c[mp_proto_dependent];
17119 if ( vv!=unity ) mp_print_scaled(mp, vv);
17120 mp_print_variable_name(mp, p);
17121 while ( value(p) % s_scale>0 ) {
17122 mp_print(mp, "*4"); value(p)=value(p)-2;
17124 if ( t==mp_dependent ) mp_print_char(mp, '='); else mp_print(mp, " = ");
17125 mp_print_dependency(mp, s,t);
17126 mp_end_diagnostic(mp, false);
17129 @ Finally, there are dependent and proto-dependent variables whose
17130 dependency lists must be brought up to date.
17132 @<Substitute new dependencies...@>=
17133 for (t=mp_dependent;t<=mp_proto_dependent;t++){
17135 while ( r!=null ) {
17137 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17138 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
17139 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
17140 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17144 @ @<Substitute new proto...@>=
17145 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
17147 while ( r!=null ) {
17149 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
17150 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
17151 mp->cur_type=mp_proto_dependent;
17152 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
17153 mp_dependent,mp_proto_dependent);
17154 type(q)=mp_proto_dependent;
17155 value(r)=mp_round_fraction(mp, value(r));
17157 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17158 mp_make_scaled(mp, value(r),-v),s,
17159 mp_proto_dependent,mp_proto_dependent);
17160 if ( dep_list(q)==mp->dep_final )
17161 mp_make_known(mp, q,mp->dep_final);
17162 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17166 @ Here are some routines that provide handy combinations of actions
17167 that are often needed during error recovery. For example,
17168 `|flush_error|' flushes the current expression, replaces it by
17169 a given value, and calls |error|.
17171 Errors often are detected after an extra token has already been scanned.
17172 The `\\{put\_get}' routines put that token back before calling |error|;
17173 then they get it back again. (Or perhaps they get another token, if
17174 the user has changed things.)
17177 void mp_flush_error (MP mp,scaled v);
17178 void mp_put_get_error (MP mp);
17179 void mp_put_get_flush_error (MP mp,scaled v) ;
17182 void mp_flush_error (MP mp,scaled v) {
17183 mp_error(mp); mp_flush_cur_exp(mp, v);
17185 void mp_put_get_error (MP mp) {
17186 mp_back_error(mp); mp_get_x_next(mp);
17188 void mp_put_get_flush_error (MP mp,scaled v) {
17189 mp_put_get_error(mp);
17190 mp_flush_cur_exp(mp, v);
17193 @ A global variable |var_flag| is set to a special command code
17194 just before \MP\ calls |scan_expression|, if the expression should be
17195 treated as a variable when this command code immediately follows. For
17196 example, |var_flag| is set to |assignment| at the beginning of a
17197 statement, because we want to know the {\sl location\/} of a variable at
17198 the left of `\.{:=}', not the {\sl value\/} of that variable.
17200 The |scan_expression| subroutine calls |scan_tertiary|,
17201 which calls |scan_secondary|, which calls |scan_primary|, which sets
17202 |var_flag:=0|. In this way each of the scanning routines ``knows''
17203 when it has been called with a special |var_flag|, but |var_flag| is
17206 A variable preceding a command that equals |var_flag| is converted to a
17207 token list rather than a value. Furthermore, an `\.{=}' sign following an
17208 expression with |var_flag=assignment| is not considered to be a relation
17209 that produces boolean expressions.
17213 int var_flag; /* command that wants a variable */
17218 @* \[37] Parsing primary expressions.
17219 The first parsing routine, |scan_primary|, is also the most complicated one,
17220 since it involves so many different cases. But each case---with one
17221 exception---is fairly simple by itself.
17223 When |scan_primary| begins, the first token of the primary to be scanned
17224 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17225 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17226 earlier. If |cur_cmd| is not between |min_primary_command| and
17227 |max_primary_command|, inclusive, a syntax error will be signaled.
17229 @<Declare the basic parsing subroutines@>=
17230 void mp_scan_primary (MP mp) {
17231 pointer p,q,r; /* for list manipulation */
17232 quarterword c; /* a primitive operation code */
17233 int my_var_flag; /* initial value of |my_var_flag| */
17234 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17235 @<Other local variables for |scan_primary|@>;
17236 my_var_flag=mp->var_flag; mp->var_flag=0;
17239 @<Supply diagnostic information, if requested@>;
17240 switch (mp->cur_cmd) {
17241 case left_delimiter:
17242 @<Scan a delimited primary@>; break;
17244 @<Scan a grouped primary@>; break;
17246 @<Scan a string constant@>; break;
17247 case numeric_token:
17248 @<Scan a primary that starts with a numeric token@>; break;
17250 @<Scan a nullary operation@>; break;
17251 case unary: case type_name: case cycle: case plus_or_minus:
17252 @<Scan a unary operation@>; break;
17253 case primary_binary:
17254 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17256 @<Convert a suffix to a string@>; break;
17257 case internal_quantity:
17258 @<Scan an internal numeric quantity@>; break;
17259 case capsule_token:
17260 mp_make_exp_copy(mp, mp->cur_mod); break;
17262 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17264 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17265 @.A primary expression...@>
17267 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17269 if ( mp->cur_cmd==left_bracket ) {
17270 if ( mp->cur_type>=mp_known ) {
17271 @<Scan a mediation construction@>;
17278 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17280 @c void mp_bad_exp (MP mp, const char * s) {
17282 print_err(s); mp_print(mp, " expression can't begin with `");
17283 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17284 mp_print_char(mp, '\'');
17285 help4("I'm afraid I need some sort of value in order to continue,")
17286 ("so I've tentatively inserted `0'. You may want to")
17287 ("delete this zero and insert something else;")
17288 ("see Chapter 27 of The METAFONTbook for an example.");
17289 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17290 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17291 mp->cur_mod=0; mp_ins_error(mp);
17292 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17293 mp->var_flag=save_flag;
17296 @ @<Supply diagnostic information, if requested@>=
17298 if ( mp->panicking ) mp_check_mem(mp, false);
17300 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17301 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17304 @ @<Scan a delimited primary@>=
17306 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17307 mp_get_x_next(mp); mp_scan_expression(mp);
17308 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17309 @<Scan the rest of a delimited set of numerics@>;
17311 mp_check_delimiter(mp, l_delim,r_delim);
17315 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17316 within a ``big node.''
17318 @c void mp_stash_in (MP mp,pointer p) {
17319 pointer q; /* temporary register */
17320 type(p)=mp->cur_type;
17321 if ( mp->cur_type==mp_known ) {
17322 value(p)=mp->cur_exp;
17324 if ( mp->cur_type==mp_independent ) {
17325 @<Stash an independent |cur_exp| into a big node@>;
17327 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17328 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17329 link(prev_dep(p))=p;
17331 mp_free_node(mp, mp->cur_exp,value_node_size);
17333 mp->cur_type=mp_vacuous;
17336 @ In rare cases the current expression can become |independent|. There
17337 may be many dependency lists pointing to such an independent capsule,
17338 so we can't simply move it into place within a big node. Instead,
17339 we copy it, then recycle it.
17341 @ @<Stash an independent |cur_exp|...@>=
17343 q=mp_single_dependency(mp, mp->cur_exp);
17344 if ( q==mp->dep_final ){
17345 type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17347 type(p)=mp_dependent; mp_new_dep(mp, p,q);
17349 mp_recycle_value(mp, mp->cur_exp);
17352 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17353 are synonymous with |x_part_loc| and |y_part_loc|.
17355 @<Scan the rest of a delimited set of numerics@>=
17357 p=mp_stash_cur_exp(mp);
17358 mp_get_x_next(mp); mp_scan_expression(mp);
17359 @<Make sure the second part of a pair or color has a numeric type@>;
17360 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
17361 if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
17362 else type(q)=mp_pair_type;
17363 mp_init_big_node(mp, q); r=value(q);
17364 mp_stash_in(mp, y_part_loc(r));
17365 mp_unstash_cur_exp(mp, p);
17366 mp_stash_in(mp, x_part_loc(r));
17367 if ( mp->cur_cmd==comma ) {
17368 @<Scan the last of a triplet of numerics@>;
17370 if ( mp->cur_cmd==comma ) {
17371 type(q)=mp_cmykcolor_type;
17372 mp_init_big_node(mp, q); t=value(q);
17373 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17374 value(cyan_part_loc(t))=value(red_part_loc(r));
17375 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17376 value(magenta_part_loc(t))=value(green_part_loc(r));
17377 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17378 value(yellow_part_loc(t))=value(blue_part_loc(r));
17379 mp_recycle_value(mp, r);
17381 @<Scan the last of a quartet of numerics@>;
17383 mp_check_delimiter(mp, l_delim,r_delim);
17384 mp->cur_type=type(q);
17388 @ @<Make sure the second part of a pair or color has a numeric type@>=
17389 if ( mp->cur_type<mp_known ) {
17390 exp_err("Nonnumeric ypart has been replaced by 0");
17391 @.Nonnumeric...replaced by 0@>
17392 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';")
17393 ("but after finding a nice `a' I found a `b' that isn't")
17394 ("of numeric type. So I've changed that part to zero.")
17395 ("(The b that I didn't like appears above the error message.)");
17396 mp_put_get_flush_error(mp, 0);
17399 @ @<Scan the last of a triplet of numerics@>=
17401 mp_get_x_next(mp); mp_scan_expression(mp);
17402 if ( mp->cur_type<mp_known ) {
17403 exp_err("Nonnumeric third part has been replaced by 0");
17404 @.Nonnumeric...replaced by 0@>
17405 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'")
17406 ("isn't of numeric type. So I've changed that part to zero.")
17407 ("(The c that I didn't like appears above the error message.)");
17408 mp_put_get_flush_error(mp, 0);
17410 mp_stash_in(mp, blue_part_loc(r));
17413 @ @<Scan the last of a quartet of numerics@>=
17415 mp_get_x_next(mp); mp_scan_expression(mp);
17416 if ( mp->cur_type<mp_known ) {
17417 exp_err("Nonnumeric blackpart has been replaced by 0");
17418 @.Nonnumeric...replaced by 0@>
17419 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")
17420 ("of numeric type. So I've changed that part to zero.")
17421 ("(The k that I didn't like appears above the error message.)");
17422 mp_put_get_flush_error(mp, 0);
17424 mp_stash_in(mp, black_part_loc(r));
17427 @ The local variable |group_line| keeps track of the line
17428 where a \&{begingroup} command occurred; this will be useful
17429 in an error message if the group doesn't actually end.
17431 @<Other local variables for |scan_primary|@>=
17432 integer group_line; /* where a group began */
17434 @ @<Scan a grouped primary@>=
17436 group_line=mp_true_line(mp);
17437 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17438 save_boundary_item(p);
17440 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17441 } while (mp->cur_cmd==semicolon);
17442 if ( mp->cur_cmd!=end_group ) {
17443 print_err("A group begun on line ");
17444 @.A group...never ended@>
17445 mp_print_int(mp, group_line);
17446 mp_print(mp, " never ended");
17447 help2("I saw a `begingroup' back there that hasn't been matched")
17448 ("by `endgroup'. So I've inserted `endgroup' now.");
17449 mp_back_error(mp); mp->cur_cmd=end_group;
17452 /* this might change |cur_type|, if independent variables are recycled */
17453 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17456 @ @<Scan a string constant@>=
17458 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17461 @ Later we'll come to procedures that perform actual operations like
17462 addition, square root, and so on; our purpose now is to do the parsing.
17463 But we might as well mention those future procedures now, so that the
17464 suspense won't be too bad:
17467 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17468 `\&{true}' or `\&{pencircle}');
17471 |do_unary(c)| applies a primitive operation to the current expression;
17474 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17475 and the current expression.
17477 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17479 @ @<Scan a unary operation@>=
17481 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17482 mp_do_unary(mp, c); goto DONE;
17485 @ A numeric token might be a primary by itself, or it might be the
17486 numerator of a fraction composed solely of numeric tokens, or it might
17487 multiply the primary that follows (provided that the primary doesn't begin
17488 with a plus sign or a minus sign). The code here uses the facts that
17489 |max_primary_command=plus_or_minus| and
17490 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17491 than unity, we try to retain higher precision when we use it in scalar
17494 @<Other local variables for |scan_primary|@>=
17495 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17497 @ @<Scan a primary that starts with a numeric token@>=
17499 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17500 if ( mp->cur_cmd!=slash ) {
17504 if ( mp->cur_cmd!=numeric_token ) {
17506 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17509 num=mp->cur_exp; denom=mp->cur_mod;
17510 if ( denom==0 ) { @<Protest division by zero@>; }
17511 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17512 check_arith; mp_get_x_next(mp);
17514 if ( mp->cur_cmd>=min_primary_command ) {
17515 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17516 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17517 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17518 mp_do_binary(mp, p,times);
17520 mp_frac_mult(mp, num,denom);
17521 mp_free_node(mp, p,value_node_size);
17528 @ @<Protest division...@>=
17530 print_err("Division by zero");
17531 @.Division by zero@>
17532 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17535 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17537 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17538 if ( mp->cur_cmd!=of_token ) {
17539 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17540 mp_print_cmd_mod(mp, primary_binary,c);
17542 help1("I've got the first argument; will look now for the other.");
17545 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17546 mp_do_binary(mp, p,c); goto DONE;
17549 @ @<Convert a suffix to a string@>=
17551 mp_get_x_next(mp); mp_scan_suffix(mp);
17552 mp->old_setting=mp->selector; mp->selector=new_string;
17553 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17554 mp_flush_token_list(mp, mp->cur_exp);
17555 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17556 mp->cur_type=mp_string_type;
17560 @ If an internal quantity appears all by itself on the left of an
17561 assignment, we return a token list of length one, containing the address
17562 of the internal quantity plus |hash_end|. (This accords with the conventions
17563 of the save stack, as described earlier.)
17565 @<Scan an internal...@>=
17568 if ( my_var_flag==assignment ) {
17570 if ( mp->cur_cmd==assignment ) {
17571 mp->cur_exp=mp_get_avail(mp);
17572 info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17577 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17580 @ The most difficult part of |scan_primary| has been saved for last, since
17581 it was necessary to build up some confidence first. We can now face the task
17582 of scanning a variable.
17584 As we scan a variable, we build a token list containing the relevant
17585 names and subscript values, simultaneously following along in the
17586 ``collective'' structure to see if we are actually dealing with a macro
17587 instead of a value.
17589 The local variables |pre_head| and |post_head| will point to the beginning
17590 of the prefix and suffix lists; |tail| will point to the end of the list
17591 that is currently growing.
17593 Another local variable, |tt|, contains partial information about the
17594 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17595 relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
17596 doesn't bother to update its information about type. And if
17597 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17599 @ @<Other local variables for |scan_primary|@>=
17600 pointer pre_head,post_head,tail;
17601 /* prefix and suffix list variables */
17602 small_number tt; /* approximation to the type of the variable-so-far */
17603 pointer t; /* a token */
17604 pointer macro_ref = 0; /* reference count for a suffixed macro */
17606 @ @<Scan a variable primary...@>=
17608 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17610 t=mp_cur_tok(mp); link(tail)=t;
17611 if ( tt!=undefined ) {
17612 @<Find the approximate type |tt| and corresponding~|q|@>;
17613 if ( tt>=mp_unsuffixed_macro ) {
17614 @<Either begin an unsuffixed macro call or
17615 prepare for a suffixed one@>;
17618 mp_get_x_next(mp); tail=t;
17619 if ( mp->cur_cmd==left_bracket ) {
17620 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17622 if ( mp->cur_cmd>max_suffix_token ) break;
17623 if ( mp->cur_cmd<min_suffix_token ) break;
17624 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17625 @<Handle unusual cases that masquerade as variables, and |goto restart|
17626 or |goto done| if appropriate;
17627 otherwise make a copy of the variable and |goto done|@>;
17630 @ @<Either begin an unsuffixed macro call or...@>=
17633 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17634 post_head=mp_get_avail(mp); tail=post_head; link(tail)=t;
17635 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17637 @<Set up unsuffixed macro call and |goto restart|@>;
17641 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17643 mp_get_x_next(mp); mp_scan_expression(mp);
17644 if ( mp->cur_cmd!=right_bracket ) {
17645 @<Put the left bracket and the expression back to be rescanned@>;
17647 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17648 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17652 @ The left bracket that we thought was introducing a subscript might have
17653 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17654 So we don't issue an error message at this point; but we do want to back up
17655 so as to avoid any embarrassment about our incorrect assumption.
17657 @<Put the left bracket and the expression back to be rescanned@>=
17659 mp_back_input(mp); /* that was the token following the current expression */
17660 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17661 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17664 @ Here's a routine that puts the current expression back to be read again.
17666 @c void mp_back_expr (MP mp) {
17667 pointer p; /* capsule token */
17668 p=mp_stash_cur_exp(mp); link(p)=null; back_list(p);
17671 @ Unknown subscripts lead to the following error message.
17673 @c void mp_bad_subscript (MP mp) {
17674 exp_err("Improper subscript has been replaced by zero");
17675 @.Improper subscript...@>
17676 help3("A bracketed subscript must have a known numeric value;")
17677 ("unfortunately, what I found was the value that appears just")
17678 ("above this error message. So I'll try a zero subscript.");
17679 mp_flush_error(mp, 0);
17682 @ Every time we call |get_x_next|, there's a chance that the variable we've
17683 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17684 into the variable structure; we need to start searching from the root each time.
17686 @<Find the approximate type |tt| and corresponding~|q|@>=
17689 p=link(pre_head); q=info(p); tt=undefined;
17690 if ( eq_type(q) % outer_tag==tag_token ) {
17692 if ( q==null ) goto DONE2;
17696 tt=type(q); goto DONE2;
17698 if ( type(q)!=mp_structured ) goto DONE2;
17699 q=link(attr_head(q)); /* the |collective_subscript| attribute */
17700 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17701 do { q=link(q); } while (! (attr_loc(q)>=info(p)));
17702 if ( attr_loc(q)>info(p) ) goto DONE2;
17710 @ How do things stand now? Well, we have scanned an entire variable name,
17711 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17712 |cur_sym| represent the token that follows. If |post_head=null|, a
17713 token list for this variable name starts at |link(pre_head)|, with all
17714 subscripts evaluated. But if |post_head<>null|, the variable turned out
17715 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17716 |post_head| is the head of a token list containing both `\.{\AT!}' and
17719 Our immediate problem is to see if this variable still exists. (Variable
17720 structures can change drastically whenever we call |get_x_next|; users
17721 aren't supposed to do this, but the fact that it is possible means that
17722 we must be cautious.)
17724 The following procedure prints an error message when a variable
17725 unexpectedly disappears. Its help message isn't quite right for
17726 our present purposes, but we'll be able to fix that up.
17729 void mp_obliterated (MP mp,pointer q) {
17730 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17731 mp_print(mp, " has been obliterated");
17732 @.Variable...obliterated@>
17733 help5("It seems you did a nasty thing---probably by accident,")
17734 ("but nevertheless you nearly hornswoggled me...")
17735 ("While I was evaluating the right-hand side of this")
17736 ("command, something happened, and the left-hand side")
17737 ("is no longer a variable! So I won't change anything.");
17740 @ If the variable does exist, we also need to check
17741 for a few other special cases before deciding that a plain old ordinary
17742 variable has, indeed, been scanned.
17744 @<Handle unusual cases that masquerade as variables...@>=
17745 if ( post_head!=null ) {
17746 @<Set up suffixed macro call and |goto restart|@>;
17748 q=link(pre_head); free_avail(pre_head);
17749 if ( mp->cur_cmd==my_var_flag ) {
17750 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17752 p=mp_find_variable(mp, q);
17754 mp_make_exp_copy(mp, p);
17756 mp_obliterated(mp, q);
17757 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17758 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17759 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17760 mp_put_get_flush_error(mp, 0);
17762 mp_flush_node_list(mp, q);
17765 @ The only complication associated with macro calling is that the prefix
17766 and ``at'' parameters must be packaged in an appropriate list of lists.
17768 @<Set up unsuffixed macro call and |goto restart|@>=
17770 p=mp_get_avail(mp); info(pre_head)=link(pre_head); link(pre_head)=p;
17771 info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17776 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17777 we don't care, because we have reserved a pointer (|macro_ref|) to its
17780 @<Set up suffixed macro call and |goto restart|@>=
17782 mp_back_input(mp); p=mp_get_avail(mp); q=link(post_head);
17783 info(pre_head)=link(pre_head); link(pre_head)=post_head;
17784 info(post_head)=q; link(post_head)=p; info(p)=link(q); link(q)=null;
17785 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17786 mp_get_x_next(mp); goto RESTART;
17789 @ Our remaining job is simply to make a copy of the value that has been
17790 found. Some cases are harder than others, but complexity arises solely
17791 because of the multiplicity of possible cases.
17793 @<Declare the procedure called |make_exp_copy|@>=
17794 @<Declare subroutines needed by |make_exp_copy|@>
17795 void mp_make_exp_copy (MP mp,pointer p) {
17796 pointer q,r,t; /* registers for list manipulation */
17798 mp->cur_type=type(p);
17799 switch (mp->cur_type) {
17800 case mp_vacuous: case mp_boolean_type: case mp_known:
17801 mp->cur_exp=value(p); break;
17802 case unknown_types:
17803 mp->cur_exp=mp_new_ring_entry(mp, p);
17805 case mp_string_type:
17806 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17808 case mp_picture_type:
17809 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17812 mp->cur_exp=copy_pen(value(p));
17815 mp->cur_exp=mp_copy_path(mp, value(p));
17817 case mp_transform_type: case mp_color_type:
17818 case mp_cmykcolor_type: case mp_pair_type:
17819 @<Copy the big node |p|@>;
17821 case mp_dependent: case mp_proto_dependent:
17822 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17824 case mp_numeric_type:
17825 new_indep(p); goto RESTART;
17827 case mp_independent:
17828 q=mp_single_dependency(mp, p);
17829 if ( q==mp->dep_final ){
17830 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
17832 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17836 mp_confusion(mp, "copy");
17837 @:this can't happen copy}{\quad copy@>
17842 @ The |encapsulate| subroutine assumes that |dep_final| is the
17843 tail of dependency list~|p|.
17845 @<Declare subroutines needed by |make_exp_copy|@>=
17846 void mp_encapsulate (MP mp,pointer p) {
17847 mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
17848 name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17851 @ The most tedious case arises when the user refers to a
17852 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17853 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17856 @<Copy the big node |p|@>=
17858 if ( value(p)==null )
17859 mp_init_big_node(mp, p);
17860 t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
17861 mp_init_big_node(mp, t);
17862 q=value(p)+mp->big_node_size[mp->cur_type];
17863 r=value(t)+mp->big_node_size[mp->cur_type];
17865 q=q-2; r=r-2; mp_install(mp, r,q);
17866 } while (q!=value(p));
17870 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17871 a big node that will be part of a capsule.
17873 @<Declare subroutines needed by |make_exp_copy|@>=
17874 void mp_install (MP mp,pointer r, pointer q) {
17875 pointer p; /* temporary register */
17876 if ( type(q)==mp_known ){
17877 value(r)=value(q); type(r)=mp_known;
17878 } else if ( type(q)==mp_independent ) {
17879 p=mp_single_dependency(mp, q);
17880 if ( p==mp->dep_final ) {
17881 type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
17883 type(r)=mp_dependent; mp_new_dep(mp, r,p);
17886 type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17890 @ Expressions of the form `\.{a[b,c]}' are converted into
17891 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17892 provided that \.a is numeric.
17894 @<Scan a mediation...@>=
17896 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17897 if ( mp->cur_cmd!=comma ) {
17898 @<Put the left bracket and the expression back...@>;
17899 mp_unstash_cur_exp(mp, p);
17901 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17902 if ( mp->cur_cmd!=right_bracket ) {
17903 mp_missing_err(mp, "]");
17905 help3("I've scanned an expression of the form `a[b,c',")
17906 ("so a right bracket should have come next.")
17907 ("I shall pretend that one was there.");
17910 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17911 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17912 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17916 @ Here is a comparatively simple routine that is used to scan the
17917 \&{suffix} parameters of a macro.
17919 @<Declare the basic parsing subroutines@>=
17920 void mp_scan_suffix (MP mp) {
17921 pointer h,t; /* head and tail of the list being built */
17922 pointer p; /* temporary register */
17923 h=mp_get_avail(mp); t=h;
17925 if ( mp->cur_cmd==left_bracket ) {
17926 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17928 if ( mp->cur_cmd==numeric_token ) {
17929 p=mp_new_num_tok(mp, mp->cur_mod);
17930 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17931 p=mp_get_avail(mp); info(p)=mp->cur_sym;
17935 link(t)=p; t=p; mp_get_x_next(mp);
17937 mp->cur_exp=link(h); free_avail(h); mp->cur_type=mp_token_list;
17940 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17942 mp_get_x_next(mp); mp_scan_expression(mp);
17943 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17944 if ( mp->cur_cmd!=right_bracket ) {
17945 mp_missing_err(mp, "]");
17947 help3("I've seen a `[' and a subscript value, in a suffix,")
17948 ("so a right bracket should have come next.")
17949 ("I shall pretend that one was there.");
17952 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
17955 @* \[38] Parsing secondary and higher expressions.
17957 After the intricacies of |scan_primary|\kern-1pt,
17958 the |scan_secondary| routine is
17959 refreshingly simple. It's not trivial, but the operations are relatively
17960 straightforward; the main difficulty is, again, that expressions and data
17961 structures might change drastically every time we call |get_x_next|, so a
17962 cautious approach is mandatory. For example, a macro defined by
17963 \&{primarydef} might have disappeared by the time its second argument has
17964 been scanned; we solve this by increasing the reference count of its token
17965 list, so that the macro can be called even after it has been clobbered.
17967 @<Declare the basic parsing subroutines@>=
17968 void mp_scan_secondary (MP mp) {
17969 pointer p; /* for list manipulation */
17970 halfword c,d; /* operation codes or modifiers */
17971 pointer mac_name; /* token defined with \&{primarydef} */
17973 if ((mp->cur_cmd<min_primary_command)||
17974 (mp->cur_cmd>max_primary_command) )
17975 mp_bad_exp(mp, "A secondary");
17976 @.A secondary expression...@>
17977 mp_scan_primary(mp);
17979 if ( mp->cur_cmd<=max_secondary_command &&
17980 mp->cur_cmd>=min_secondary_command ) {
17981 p=mp_stash_cur_exp(mp);
17982 c=mp->cur_mod; d=mp->cur_cmd;
17983 if ( d==secondary_primary_macro ) {
17984 mac_name=mp->cur_sym;
17988 mp_scan_primary(mp);
17989 if ( d!=secondary_primary_macro ) {
17990 mp_do_binary(mp, p,c);
17993 mp_binary_mac(mp, p,c,mac_name);
17994 decr(ref_count(c));
18002 @ The following procedure calls a macro that has two parameters,
18005 @c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
18006 pointer q,r; /* nodes in the parameter list */
18007 q=mp_get_avail(mp); r=mp_get_avail(mp); link(q)=r;
18008 info(q)=p; info(r)=mp_stash_cur_exp(mp);
18009 mp_macro_call(mp, c,q,n);
18012 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
18014 @<Declare the basic parsing subroutines@>=
18015 void mp_scan_tertiary (MP mp) {
18016 pointer p; /* for list manipulation */
18017 halfword c,d; /* operation codes or modifiers */
18018 pointer mac_name; /* token defined with \&{secondarydef} */
18020 if ((mp->cur_cmd<min_primary_command)||
18021 (mp->cur_cmd>max_primary_command) )
18022 mp_bad_exp(mp, "A tertiary");
18023 @.A tertiary expression...@>
18024 mp_scan_secondary(mp);
18026 if ( mp->cur_cmd<=max_tertiary_command ) {
18027 if ( mp->cur_cmd>=min_tertiary_command ) {
18028 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18029 if ( d==tertiary_secondary_macro ) {
18030 mac_name=mp->cur_sym; add_mac_ref(c);
18032 mp_get_x_next(mp); mp_scan_secondary(mp);
18033 if ( d!=tertiary_secondary_macro ) {
18034 mp_do_binary(mp, p,c);
18036 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18037 decr(ref_count(c)); mp_get_x_next(mp);
18045 @ Finally we reach the deepest level in our quartet of parsing routines.
18046 This one is much like the others; but it has an extra complication from
18047 paths, which materialize here.
18049 @d continue_path 25 /* a label inside of |scan_expression| */
18050 @d finish_path 26 /* another */
18052 @<Declare the basic parsing subroutines@>=
18053 void mp_scan_expression (MP mp) {
18054 pointer p,q,r,pp,qq; /* for list manipulation */
18055 halfword c,d; /* operation codes or modifiers */
18056 int my_var_flag; /* initial value of |var_flag| */
18057 pointer mac_name; /* token defined with \&{tertiarydef} */
18058 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
18059 scaled x,y; /* explicit coordinates or tension at a path join */
18060 int t; /* knot type following a path join */
18062 my_var_flag=mp->var_flag; mac_name=null;
18064 if ((mp->cur_cmd<min_primary_command)||
18065 (mp->cur_cmd>max_primary_command) )
18066 mp_bad_exp(mp, "An");
18067 @.An expression...@>
18068 mp_scan_tertiary(mp);
18070 if ( mp->cur_cmd<=max_expression_command )
18071 if ( mp->cur_cmd>=min_expression_command ) {
18072 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
18073 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18074 if ( d==expression_tertiary_macro ) {
18075 mac_name=mp->cur_sym; add_mac_ref(c);
18077 if ( (d<ampersand)||((d==ampersand)&&
18078 ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
18079 @<Scan a path construction operation;
18080 but |return| if |p| has the wrong type@>;
18082 mp_get_x_next(mp); mp_scan_tertiary(mp);
18083 if ( d!=expression_tertiary_macro ) {
18084 mp_do_binary(mp, p,c);
18086 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18087 decr(ref_count(c)); mp_get_x_next(mp);
18096 @ The reader should review the data structure conventions for paths before
18097 hoping to understand the next part of this code.
18099 @<Scan a path construction operation...@>=
18102 @<Convert the left operand, |p|, into a partial path ending at~|q|;
18103 but |return| if |p| doesn't have a suitable type@>;
18105 @<Determine the path join parameters;
18106 but |goto finish_path| if there's only a direction specifier@>;
18107 if ( mp->cur_cmd==cycle ) {
18108 @<Get ready to close a cycle@>;
18110 mp_scan_tertiary(mp);
18111 @<Convert the right operand, |cur_exp|,
18112 into a partial path from |pp| to~|qq|@>;
18114 @<Join the partial paths and reset |p| and |q| to the head and tail
18116 if ( mp->cur_cmd>=min_expression_command )
18117 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
18119 @<Choose control points for the path and put the result into |cur_exp|@>;
18122 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
18124 mp_unstash_cur_exp(mp, p);
18125 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
18126 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
18129 while ( link(q)!=p ) q=link(q);
18130 if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
18131 r=mp_copy_knot(mp, p); link(q)=r; q=r;
18133 left_type(p)=mp_open; right_type(q)=mp_open;
18136 @ A pair of numeric values is changed into a knot node for a one-point path
18137 when \MP\ discovers that the pair is part of a path.
18139 @c @<Declare the procedure called |known_pair|@>
18140 pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
18141 pointer q; /* the new node */
18142 q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
18143 right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; link(q)=q;
18144 mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
18148 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
18149 of the current expression, assuming that the current expression is a
18150 pair of known numerics. Unknown components are zeroed, and the
18151 current expression is flushed.
18153 @<Declare the procedure called |known_pair|@>=
18154 void mp_known_pair (MP mp) {
18155 pointer p; /* the pair node */
18156 if ( mp->cur_type!=mp_pair_type ) {
18157 exp_err("Undefined coordinates have been replaced by (0,0)");
18158 @.Undefined coordinates...@>
18159 help5("I need x and y numbers for this part of the path.")
18160 ("The value I found (see above) was no good;")
18161 ("so I'll try to keep going by using zero instead.")
18162 ("(Chapter 27 of The METAFONTbook explains that")
18163 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18164 ("you might want to type `I ??" "?' now.)");
18165 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
18167 p=value(mp->cur_exp);
18168 @<Make sure that both |x| and |y| parts of |p| are known;
18169 copy them into |cur_x| and |cur_y|@>;
18170 mp_flush_cur_exp(mp, 0);
18174 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
18175 if ( type(x_part_loc(p))==mp_known ) {
18176 mp->cur_x=value(x_part_loc(p));
18178 mp_disp_err(mp, x_part_loc(p),
18179 "Undefined x coordinate has been replaced by 0");
18180 @.Undefined coordinates...@>
18181 help5("I need a `known' x 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 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18186 ("you might want to type `I ??" "?' now.)");
18187 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18189 if ( type(y_part_loc(p))==mp_known ) {
18190 mp->cur_y=value(y_part_loc(p));
18192 mp_disp_err(mp, y_part_loc(p),
18193 "Undefined y coordinate has been replaced by 0");
18194 help5("I need a `known' y value for this part of the path.")
18195 ("The value I found (see above) was no good;")
18196 ("so I'll try to keep going by using zero instead.")
18197 ("(Chapter 27 of The METAFONTbook explains that")
18198 ("you might want to type `I ??" "?' now.)");
18199 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18202 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18204 @<Determine the path join parameters...@>=
18205 if ( mp->cur_cmd==left_brace ) {
18206 @<Put the pre-join direction information into node |q|@>;
18209 if ( d==path_join ) {
18210 @<Determine the tension and/or control points@>;
18211 } else if ( d!=ampersand ) {
18215 if ( mp->cur_cmd==left_brace ) {
18216 @<Put the post-join direction information into |x| and |t|@>;
18217 } else if ( right_type(q)!=mp_explicit ) {
18221 @ The |scan_direction| subroutine looks at the directional information
18222 that is enclosed in braces, and also scans ahead to the following character.
18223 A type code is returned, either |open| (if the direction was $(0,0)$),
18224 or |curl| (if the direction was a curl of known value |cur_exp|), or
18225 |given| (if the direction is given by the |angle| value that now
18226 appears in |cur_exp|).
18228 There's nothing difficult about this subroutine, but the program is rather
18229 lengthy because a variety of potential errors need to be nipped in the bud.
18231 @c small_number mp_scan_direction (MP mp) {
18232 int t; /* the type of information found */
18233 scaled x; /* an |x| coordinate */
18235 if ( mp->cur_cmd==curl_command ) {
18236 @<Scan a curl specification@>;
18238 @<Scan a given direction@>;
18240 if ( mp->cur_cmd!=right_brace ) {
18241 mp_missing_err(mp, "}");
18242 @.Missing `\char`\}'@>
18243 help3("I've scanned a direction spec for part of a path,")
18244 ("so a right brace should have come next.")
18245 ("I shall pretend that one was there.");
18252 @ @<Scan a curl specification@>=
18253 { mp_get_x_next(mp); mp_scan_expression(mp);
18254 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18255 exp_err("Improper curl has been replaced by 1");
18257 help1("A curl must be a known, nonnegative number.");
18258 mp_put_get_flush_error(mp, unity);
18263 @ @<Scan a given direction@>=
18264 { mp_scan_expression(mp);
18265 if ( mp->cur_type>mp_pair_type ) {
18266 @<Get given directions separated by commas@>;
18270 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18271 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18274 @ @<Get given directions separated by commas@>=
18276 if ( mp->cur_type!=mp_known ) {
18277 exp_err("Undefined x coordinate has been replaced by 0");
18278 @.Undefined coordinates...@>
18279 help5("I need a `known' x value for this part of the path.")
18280 ("The value I found (see above) was no good;")
18281 ("so I'll try to keep going by using zero instead.")
18282 ("(Chapter 27 of The METAFONTbook explains that")
18283 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18284 ("you might want to type `I ??" "?' now.)");
18285 mp_put_get_flush_error(mp, 0);
18288 if ( mp->cur_cmd!=comma ) {
18289 mp_missing_err(mp, ",");
18291 help2("I've got the x coordinate of a path direction;")
18292 ("will look for the y coordinate next.");
18295 mp_get_x_next(mp); mp_scan_expression(mp);
18296 if ( mp->cur_type!=mp_known ) {
18297 exp_err("Undefined y coordinate has been replaced by 0");
18298 help5("I need a `known' y value for this part of the path.")
18299 ("The value I found (see above) was no good;")
18300 ("so I'll try to keep going by using zero instead.")
18301 ("(Chapter 27 of The METAFONTbook explains that")
18302 ("you might want to type `I ??" "?' now.)");
18303 mp_put_get_flush_error(mp, 0);
18305 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18308 @ At this point |right_type(q)| is usually |open|, but it may have been
18309 set to some other value by a previous operation. We must maintain
18310 the value of |right_type(q)| in cases such as
18311 `\.{..\{curl2\}z\{0,0\}..}'.
18313 @<Put the pre-join...@>=
18315 t=mp_scan_direction(mp);
18316 if ( t!=mp_open ) {
18317 right_type(q)=t; right_given(q)=mp->cur_exp;
18318 if ( left_type(q)==mp_open ) {
18319 left_type(q)=t; left_given(q)=mp->cur_exp;
18320 } /* note that |left_given(q)=left_curl(q)| */
18324 @ Since |left_tension| and |left_y| share the same position in knot nodes,
18325 and since |left_given| is similarly equivalent to |left_x|, we use
18326 |x| and |y| to hold the given direction and tension information when
18327 there are no explicit control points.
18329 @<Put the post-join...@>=
18331 t=mp_scan_direction(mp);
18332 if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
18333 else t=mp_explicit; /* the direction information is superfluous */
18336 @ @<Determine the tension and/or...@>=
18339 if ( mp->cur_cmd==tension ) {
18340 @<Set explicit tensions@>;
18341 } else if ( mp->cur_cmd==controls ) {
18342 @<Set explicit control points@>;
18344 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18347 if ( mp->cur_cmd!=path_join ) {
18348 mp_missing_err(mp, "..");
18350 help1("A path join command should end with two dots.");
18357 @ @<Set explicit tensions@>=
18359 mp_get_x_next(mp); y=mp->cur_cmd;
18360 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18361 mp_scan_primary(mp);
18362 @<Make sure that the current expression is a valid tension setting@>;
18363 if ( y==at_least ) negate(mp->cur_exp);
18364 right_tension(q)=mp->cur_exp;
18365 if ( mp->cur_cmd==and_command ) {
18366 mp_get_x_next(mp); y=mp->cur_cmd;
18367 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18368 mp_scan_primary(mp);
18369 @<Make sure that the current expression is a valid tension setting@>;
18370 if ( y==at_least ) negate(mp->cur_exp);
18375 @ @d min_tension three_quarter_unit
18377 @<Make sure that the current expression is a valid tension setting@>=
18378 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18379 exp_err("Improper tension has been set to 1");
18380 @.Improper tension@>
18381 help1("The expression above should have been a number >=3/4.");
18382 mp_put_get_flush_error(mp, unity);
18385 @ @<Set explicit control points@>=
18387 right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18388 mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
18389 if ( mp->cur_cmd!=and_command ) {
18390 x=right_x(q); y=right_y(q);
18392 mp_get_x_next(mp); mp_scan_primary(mp);
18393 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18397 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18399 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18400 else pp=mp->cur_exp;
18402 while ( link(qq)!=pp ) qq=link(qq);
18403 if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18404 r=mp_copy_knot(mp, pp); link(qq)=r; qq=r;
18406 left_type(pp)=mp_open; right_type(qq)=mp_open;
18409 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18410 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18411 shouldn't have length zero.
18413 @<Get ready to close a cycle@>=
18415 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18416 if ( d==ampersand ) if ( p==q ) {
18417 d=path_join; right_tension(q)=unity; y=unity;
18421 @ @<Join the partial paths and reset |p| and |q|...@>=
18423 if ( d==ampersand ) {
18424 if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
18425 print_err("Paths don't touch; `&' will be changed to `..'");
18426 @.Paths don't touch@>
18427 help3("When you join paths `p&q', the ending point of p")
18428 ("must be exactly equal to the starting point of q.")
18429 ("So I'm going to pretend that you said `p..q' instead.");
18430 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18433 @<Plug an opening in |right_type(pp)|, if possible@>;
18434 if ( d==ampersand ) {
18435 @<Splice independent paths together@>;
18437 @<Plug an opening in |right_type(q)|, if possible@>;
18438 link(q)=pp; left_y(pp)=y;
18439 if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
18444 @ @<Plug an opening in |right_type(q)|...@>=
18445 if ( right_type(q)==mp_open ) {
18446 if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
18447 right_type(q)=left_type(q); right_given(q)=left_given(q);
18451 @ @<Plug an opening in |right_type(pp)|...@>=
18452 if ( right_type(pp)==mp_open ) {
18453 if ( (t==mp_curl)||(t==mp_given) ) {
18454 right_type(pp)=t; right_given(pp)=x;
18458 @ @<Splice independent paths together@>=
18460 if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
18461 left_type(q)=mp_curl; left_curl(q)=unity;
18463 if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
18464 right_type(pp)=mp_curl; right_curl(pp)=unity;
18466 right_type(q)=right_type(pp); link(q)=link(pp);
18467 right_x(q)=right_x(pp); right_y(q)=right_y(pp);
18468 mp_free_node(mp, pp,knot_node_size);
18469 if ( qq==pp ) qq=q;
18472 @ @<Choose control points for the path...@>=
18474 if ( d==ampersand ) p=q;
18476 left_type(p)=mp_endpoint;
18477 if ( right_type(p)==mp_open ) {
18478 right_type(p)=mp_curl; right_curl(p)=unity;
18480 right_type(q)=mp_endpoint;
18481 if ( left_type(q)==mp_open ) {
18482 left_type(q)=mp_curl; left_curl(q)=unity;
18486 mp_make_choices(mp, p);
18487 mp->cur_type=mp_path_type; mp->cur_exp=p
18489 @ Finally, we sometimes need to scan an expression whose value is
18490 supposed to be either |true_code| or |false_code|.
18492 @<Declare the basic parsing subroutines@>=
18493 void mp_get_boolean (MP mp) {
18494 mp_get_x_next(mp); mp_scan_expression(mp);
18495 if ( mp->cur_type!=mp_boolean_type ) {
18496 exp_err("Undefined condition will be treated as `false'");
18497 @.Undefined condition...@>
18498 help2("The expression shown above should have had a definite")
18499 ("true-or-false value. I'm changing it to `false'.");
18500 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18504 @* \[39] Doing the operations.
18505 The purpose of parsing is primarily to permit people to avoid piles of
18506 parentheses. But the real work is done after the structure of an expression
18507 has been recognized; that's when new expressions are generated. We
18508 turn now to the guts of \MP, which handles individual operators that
18509 have come through the parsing mechanism.
18511 We'll start with the easy ones that take no operands, then work our way
18512 up to operators with one and ultimately two arguments. In other words,
18513 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18514 that are invoked periodically by the expression scanners.
18516 First let's make sure that all of the primitive operators are in the
18517 hash table. Although |scan_primary| and its relatives made use of the
18518 \\{cmd} code for these operators, the \\{do} routines base everything
18519 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18520 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18523 mp_primitive(mp, "true",nullary,true_code);
18524 @:true_}{\&{true} primitive@>
18525 mp_primitive(mp, "false",nullary,false_code);
18526 @:false_}{\&{false} primitive@>
18527 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18528 @:null_picture_}{\&{nullpicture} primitive@>
18529 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18530 @:null_pen_}{\&{nullpen} primitive@>
18531 mp_primitive(mp, "jobname",nullary,job_name_op);
18532 @:job_name_}{\&{jobname} primitive@>
18533 mp_primitive(mp, "readstring",nullary,read_string_op);
18534 @:read_string_}{\&{readstring} primitive@>
18535 mp_primitive(mp, "pencircle",nullary,pen_circle);
18536 @:pen_circle_}{\&{pencircle} primitive@>
18537 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18538 @:normal_deviate_}{\&{normaldeviate} primitive@>
18539 mp_primitive(mp, "readfrom",unary,read_from_op);
18540 @:read_from_}{\&{readfrom} primitive@>
18541 mp_primitive(mp, "closefrom",unary,close_from_op);
18542 @:close_from_}{\&{closefrom} primitive@>
18543 mp_primitive(mp, "odd",unary,odd_op);
18544 @:odd_}{\&{odd} primitive@>
18545 mp_primitive(mp, "known",unary,known_op);
18546 @:known_}{\&{known} primitive@>
18547 mp_primitive(mp, "unknown",unary,unknown_op);
18548 @:unknown_}{\&{unknown} primitive@>
18549 mp_primitive(mp, "not",unary,not_op);
18550 @:not_}{\&{not} primitive@>
18551 mp_primitive(mp, "decimal",unary,decimal);
18552 @:decimal_}{\&{decimal} primitive@>
18553 mp_primitive(mp, "reverse",unary,reverse);
18554 @:reverse_}{\&{reverse} primitive@>
18555 mp_primitive(mp, "makepath",unary,make_path_op);
18556 @:make_path_}{\&{makepath} primitive@>
18557 mp_primitive(mp, "makepen",unary,make_pen_op);
18558 @:make_pen_}{\&{makepen} primitive@>
18559 mp_primitive(mp, "oct",unary,oct_op);
18560 @:oct_}{\&{oct} primitive@>
18561 mp_primitive(mp, "hex",unary,hex_op);
18562 @:hex_}{\&{hex} primitive@>
18563 mp_primitive(mp, "ASCII",unary,ASCII_op);
18564 @:ASCII_}{\&{ASCII} primitive@>
18565 mp_primitive(mp, "char",unary,char_op);
18566 @:char_}{\&{char} primitive@>
18567 mp_primitive(mp, "length",unary,length_op);
18568 @:length_}{\&{length} primitive@>
18569 mp_primitive(mp, "turningnumber",unary,turning_op);
18570 @:turning_number_}{\&{turningnumber} primitive@>
18571 mp_primitive(mp, "xpart",unary,x_part);
18572 @:x_part_}{\&{xpart} primitive@>
18573 mp_primitive(mp, "ypart",unary,y_part);
18574 @:y_part_}{\&{ypart} primitive@>
18575 mp_primitive(mp, "xxpart",unary,xx_part);
18576 @:xx_part_}{\&{xxpart} primitive@>
18577 mp_primitive(mp, "xypart",unary,xy_part);
18578 @:xy_part_}{\&{xypart} primitive@>
18579 mp_primitive(mp, "yxpart",unary,yx_part);
18580 @:yx_part_}{\&{yxpart} primitive@>
18581 mp_primitive(mp, "yypart",unary,yy_part);
18582 @:yy_part_}{\&{yypart} primitive@>
18583 mp_primitive(mp, "redpart",unary,red_part);
18584 @:red_part_}{\&{redpart} primitive@>
18585 mp_primitive(mp, "greenpart",unary,green_part);
18586 @:green_part_}{\&{greenpart} primitive@>
18587 mp_primitive(mp, "bluepart",unary,blue_part);
18588 @:blue_part_}{\&{bluepart} primitive@>
18589 mp_primitive(mp, "cyanpart",unary,cyan_part);
18590 @:cyan_part_}{\&{cyanpart} primitive@>
18591 mp_primitive(mp, "magentapart",unary,magenta_part);
18592 @:magenta_part_}{\&{magentapart} primitive@>
18593 mp_primitive(mp, "yellowpart",unary,yellow_part);
18594 @:yellow_part_}{\&{yellowpart} primitive@>
18595 mp_primitive(mp, "blackpart",unary,black_part);
18596 @:black_part_}{\&{blackpart} primitive@>
18597 mp_primitive(mp, "greypart",unary,grey_part);
18598 @:grey_part_}{\&{greypart} primitive@>
18599 mp_primitive(mp, "colormodel",unary,color_model_part);
18600 @:color_model_part_}{\&{colormodel} primitive@>
18601 mp_primitive(mp, "fontpart",unary,font_part);
18602 @:font_part_}{\&{fontpart} primitive@>
18603 mp_primitive(mp, "textpart",unary,text_part);
18604 @:text_part_}{\&{textpart} primitive@>
18605 mp_primitive(mp, "pathpart",unary,path_part);
18606 @:path_part_}{\&{pathpart} primitive@>
18607 mp_primitive(mp, "penpart",unary,pen_part);
18608 @:pen_part_}{\&{penpart} primitive@>
18609 mp_primitive(mp, "dashpart",unary,dash_part);
18610 @:dash_part_}{\&{dashpart} primitive@>
18611 mp_primitive(mp, "sqrt",unary,sqrt_op);
18612 @:sqrt_}{\&{sqrt} primitive@>
18613 mp_primitive(mp, "mexp",unary,m_exp_op);
18614 @:m_exp_}{\&{mexp} primitive@>
18615 mp_primitive(mp, "mlog",unary,m_log_op);
18616 @:m_log_}{\&{mlog} primitive@>
18617 mp_primitive(mp, "sind",unary,sin_d_op);
18618 @:sin_d_}{\&{sind} primitive@>
18619 mp_primitive(mp, "cosd",unary,cos_d_op);
18620 @:cos_d_}{\&{cosd} primitive@>
18621 mp_primitive(mp, "floor",unary,floor_op);
18622 @:floor_}{\&{floor} primitive@>
18623 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18624 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18625 mp_primitive(mp, "charexists",unary,char_exists_op);
18626 @:char_exists_}{\&{charexists} primitive@>
18627 mp_primitive(mp, "fontsize",unary,font_size);
18628 @:font_size_}{\&{fontsize} primitive@>
18629 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18630 @:ll_corner_}{\&{llcorner} primitive@>
18631 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18632 @:lr_corner_}{\&{lrcorner} primitive@>
18633 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18634 @:ul_corner_}{\&{ulcorner} primitive@>
18635 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18636 @:ur_corner_}{\&{urcorner} primitive@>
18637 mp_primitive(mp, "arclength",unary,arc_length);
18638 @:arc_length_}{\&{arclength} primitive@>
18639 mp_primitive(mp, "angle",unary,angle_op);
18640 @:angle_}{\&{angle} primitive@>
18641 mp_primitive(mp, "cycle",cycle,cycle_op);
18642 @:cycle_}{\&{cycle} primitive@>
18643 mp_primitive(mp, "stroked",unary,stroked_op);
18644 @:stroked_}{\&{stroked} primitive@>
18645 mp_primitive(mp, "filled",unary,filled_op);
18646 @:filled_}{\&{filled} primitive@>
18647 mp_primitive(mp, "textual",unary,textual_op);
18648 @:textual_}{\&{textual} primitive@>
18649 mp_primitive(mp, "clipped",unary,clipped_op);
18650 @:clipped_}{\&{clipped} primitive@>
18651 mp_primitive(mp, "bounded",unary,bounded_op);
18652 @:bounded_}{\&{bounded} primitive@>
18653 mp_primitive(mp, "+",plus_or_minus,plus);
18654 @:+ }{\.{+} primitive@>
18655 mp_primitive(mp, "-",plus_or_minus,minus);
18656 @:- }{\.{-} primitive@>
18657 mp_primitive(mp, "*",secondary_binary,times);
18658 @:* }{\.{*} primitive@>
18659 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18660 @:/ }{\.{/} primitive@>
18661 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18662 @:++_}{\.{++} primitive@>
18663 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18664 @:+-+_}{\.{+-+} primitive@>
18665 mp_primitive(mp, "or",tertiary_binary,or_op);
18666 @:or_}{\&{or} primitive@>
18667 mp_primitive(mp, "and",and_command,and_op);
18668 @:and_}{\&{and} primitive@>
18669 mp_primitive(mp, "<",expression_binary,less_than);
18670 @:< }{\.{<} primitive@>
18671 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18672 @:<=_}{\.{<=} primitive@>
18673 mp_primitive(mp, ">",expression_binary,greater_than);
18674 @:> }{\.{>} primitive@>
18675 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18676 @:>=_}{\.{>=} primitive@>
18677 mp_primitive(mp, "=",equals,equal_to);
18678 @:= }{\.{=} primitive@>
18679 mp_primitive(mp, "<>",expression_binary,unequal_to);
18680 @:<>_}{\.{<>} primitive@>
18681 mp_primitive(mp, "substring",primary_binary,substring_of);
18682 @:substring_}{\&{substring} primitive@>
18683 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18684 @:subpath_}{\&{subpath} primitive@>
18685 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18686 @:direction_time_}{\&{directiontime} primitive@>
18687 mp_primitive(mp, "point",primary_binary,point_of);
18688 @:point_}{\&{point} primitive@>
18689 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18690 @:precontrol_}{\&{precontrol} primitive@>
18691 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18692 @:postcontrol_}{\&{postcontrol} primitive@>
18693 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18694 @:pen_offset_}{\&{penoffset} primitive@>
18695 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18696 @:arc_time_of_}{\&{arctime} primitive@>
18697 mp_primitive(mp, "mpversion",nullary,mp_version);
18698 @:mp_verison_}{\&{mpversion} primitive@>
18699 mp_primitive(mp, "&",ampersand,concatenate);
18700 @:!!!}{\.{\&} primitive@>
18701 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18702 @:rotated_}{\&{rotated} primitive@>
18703 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18704 @:slanted_}{\&{slanted} primitive@>
18705 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18706 @:scaled_}{\&{scaled} primitive@>
18707 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18708 @:shifted_}{\&{shifted} primitive@>
18709 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18710 @:transformed_}{\&{transformed} primitive@>
18711 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18712 @:x_scaled_}{\&{xscaled} primitive@>
18713 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18714 @:y_scaled_}{\&{yscaled} primitive@>
18715 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18716 @:z_scaled_}{\&{zscaled} primitive@>
18717 mp_primitive(mp, "infont",secondary_binary,in_font);
18718 @:in_font_}{\&{infont} primitive@>
18719 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18720 @:intersection_times_}{\&{intersectiontimes} primitive@>
18721 mp_primitive(mp, "envelope",primary_binary,envelope_of);
18722 @:envelope_}{\&{envelope} primitive@>
18724 @ @<Cases of |print_cmd...@>=
18727 case primary_binary:
18728 case secondary_binary:
18729 case tertiary_binary:
18730 case expression_binary:
18732 case plus_or_minus:
18737 mp_print_op(mp, m);
18740 @ OK, let's look at the simplest \\{do} procedure first.
18742 @c @<Declare nullary action procedure@>
18743 void mp_do_nullary (MP mp,quarterword c) {
18745 if ( mp->internal[mp_tracing_commands]>two )
18746 mp_show_cmd_mod(mp, nullary,c);
18748 case true_code: case false_code:
18749 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18751 case null_picture_code:
18752 mp->cur_type=mp_picture_type;
18753 mp->cur_exp=mp_get_node(mp, edge_header_size);
18754 mp_init_edges(mp, mp->cur_exp);
18756 case null_pen_code:
18757 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18759 case normal_deviate:
18760 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18763 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18766 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18767 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18770 mp->cur_type=mp_string_type;
18771 mp->cur_exp=intern(metapost_version) ;
18773 case read_string_op:
18774 @<Read a string from the terminal@>;
18776 } /* there are no other cases */
18780 @ @<Read a string...@>=
18782 if ( mp->interaction<=mp_nonstop_mode )
18783 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18784 mp_begin_file_reading(mp); name=is_read;
18785 limit=start; prompt_input("");
18786 mp_finish_read(mp);
18789 @ @<Declare nullary action procedure@>=
18790 void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18792 str_room((int)mp->last-start);
18793 for (k=start;k<=mp->last-1;k++) {
18794 append_char(mp->buffer[k]);
18796 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18797 mp->cur_exp=mp_make_string(mp);
18800 @ Things get a bit more interesting when there's an operand. The
18801 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18803 @c @<Declare unary action procedures@>
18804 void mp_do_unary (MP mp,quarterword c) {
18805 pointer p,q,r; /* for list manipulation */
18806 integer x; /* a temporary register */
18808 if ( mp->internal[mp_tracing_commands]>two )
18809 @<Trace the current unary operation@>;
18812 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18815 @<Negate the current expression@>;
18817 @<Additional cases of unary operators@>;
18818 } /* there are no other cases */
18822 @ The |nice_pair| function returns |true| if both components of a pair
18825 @<Declare unary action procedures@>=
18826 boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18827 if ( t==mp_pair_type ) {
18829 if ( type(x_part_loc(p))==mp_known )
18830 if ( type(y_part_loc(p))==mp_known )
18836 @ The |nice_color_or_pair| function is analogous except that it also accepts
18837 fully known colors.
18839 @<Declare unary action procedures@>=
18840 boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18841 pointer q,r; /* for scanning the big node */
18842 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18846 r=q+mp->big_node_size[type(p)];
18849 if ( type(r)!=mp_known )
18856 @ @<Declare unary action...@>=
18857 void mp_print_known_or_unknown_type (MP mp,small_number t, integer v) {
18858 mp_print_char(mp, '(');
18859 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18860 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18861 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18862 mp_print_type(mp, t);
18864 mp_print_char(mp, ')');
18867 @ @<Declare unary action...@>=
18868 void mp_bad_unary (MP mp,quarterword c) {
18869 exp_err("Not implemented: "); mp_print_op(mp, c);
18870 @.Not implemented...@>
18871 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18872 help3("I'm afraid I don't know how to apply that operation to that")
18873 ("particular type. Continue, and I'll simply return the")
18874 ("argument (shown above) as the result of the operation.");
18875 mp_put_get_error(mp);
18878 @ @<Trace the current unary operation@>=
18880 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18881 mp_print_op(mp, c); mp_print_char(mp, '(');
18882 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18883 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18886 @ Negation is easy except when the current expression
18887 is of type |independent|, or when it is a pair with one or more
18888 |independent| components.
18890 It is tempting to argue that the negative of an independent variable
18891 is an independent variable, hence we don't have to do anything when
18892 negating it. The fallacy is that other dependent variables pointing
18893 to the current expression must change the sign of their
18894 coefficients if we make no change to the current expression.
18896 Instead, we work around the problem by copying the current expression
18897 and recycling it afterwards (cf.~the |stash_in| routine).
18899 @<Negate the current expression@>=
18900 switch (mp->cur_type) {
18901 case mp_color_type:
18902 case mp_cmykcolor_type:
18904 case mp_independent:
18905 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18906 if ( mp->cur_type==mp_dependent ) {
18907 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18908 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18909 p=value(mp->cur_exp);
18910 r=p+mp->big_node_size[mp->cur_type];
18913 if ( type(r)==mp_known ) negate(value(r));
18914 else mp_negate_dep_list(mp, dep_list(r));
18916 } /* if |cur_type=mp_known| then |cur_exp=0| */
18917 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18920 case mp_proto_dependent:
18921 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18924 negate(mp->cur_exp);
18927 mp_bad_unary(mp, minus);
18931 @ @<Declare unary action...@>=
18932 void mp_negate_dep_list (MP mp,pointer p) {
18935 if ( info(p)==null ) return;
18940 @ @<Additional cases of unary operators@>=
18942 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
18943 else mp->cur_exp=true_code+false_code-mp->cur_exp;
18946 @ @d three_sixty_units 23592960 /* that's |360*unity| */
18947 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
18949 @<Additional cases of unary operators@>=
18956 case uniform_deviate:
18958 case char_exists_op:
18959 if ( mp->cur_type!=mp_known ) {
18960 mp_bad_unary(mp, c);
18963 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
18964 case m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
18965 case m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
18968 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
18969 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
18970 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
18972 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
18973 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
18975 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
18976 mp->cur_type=mp_boolean_type;
18978 case char_exists_op:
18979 @<Determine if a character has been shipped out@>;
18981 } /* there are no other cases */
18985 @ @<Additional cases of unary operators@>=
18987 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
18988 p=value(mp->cur_exp);
18989 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
18990 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
18991 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
18993 mp_bad_unary(mp, angle_op);
18997 @ If the current expression is a pair, but the context wants it to
18998 be a path, we call |pair_to_path|.
19000 @<Declare unary action...@>=
19001 void mp_pair_to_path (MP mp) {
19002 mp->cur_exp=mp_new_knot(mp);
19003 mp->cur_type=mp_path_type;
19007 @d pict_color_type(A) ((link(dummy_loc(mp->cur_exp))!=null) &&
19008 (has_color(link(dummy_loc(mp->cur_exp)))) &&
19009 ((color_model(link(dummy_loc(mp->cur_exp)))==A)
19011 ((color_model(link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) &&
19012 (mp->internal[mp_default_color_model]/unity)==(A))))
19014 @<Additional cases of unary operators@>=
19017 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
19018 mp_take_part(mp, c);
19019 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19020 else mp_bad_unary(mp, c);
19026 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
19027 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19028 else mp_bad_unary(mp, c);
19033 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
19034 else if ( mp->cur_type==mp_picture_type ) {
19035 if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
19036 else mp_bad_color_part(mp, c);
19038 else mp_bad_unary(mp, c);
19044 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
19045 else if ( mp->cur_type==mp_picture_type ) {
19046 if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
19047 else mp_bad_color_part(mp, c);
19049 else mp_bad_unary(mp, c);
19052 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
19053 else if ( mp->cur_type==mp_picture_type ) {
19054 if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
19055 else mp_bad_color_part(mp, c);
19057 else mp_bad_unary(mp, c);
19059 case color_model_part:
19060 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19061 else mp_bad_unary(mp, c);
19064 @ @<Declarations@>=
19065 void mp_bad_color_part(MP mp, quarterword c);
19068 void mp_bad_color_part(MP mp, quarterword c) {
19069 pointer p; /* the big node */
19070 p=link(dummy_loc(mp->cur_exp));
19071 exp_err("Wrong picture color model: "); mp_print_op(mp, c);
19072 @.Wrong picture color model...@>
19073 if (color_model(p)==mp_grey_model)
19074 mp_print(mp, " of grey object");
19075 else if (color_model(p)==mp_cmyk_model)
19076 mp_print(mp, " of cmyk object");
19077 else if (color_model(p)==mp_rgb_model)
19078 mp_print(mp, " of rgb object");
19079 else if (color_model(p)==mp_no_model)
19080 mp_print(mp, " of marking object");
19082 mp_print(mp," of defaulted object");
19083 help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,")
19084 ("the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ")
19085 ("or the greypart of a grey object. No mixing and matching, please.");
19088 mp_flush_cur_exp(mp,unity);
19090 mp_flush_cur_exp(mp,0);
19093 @ In the following procedure, |cur_exp| points to a capsule, which points to
19094 a big node. We want to delete all but one part of the big node.
19096 @<Declare unary action...@>=
19097 void mp_take_part (MP mp,quarterword c) {
19098 pointer p; /* the big node */
19099 p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
19100 link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
19101 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
19102 mp_recycle_value(mp, temp_val);
19105 @ @<Initialize table entries...@>=
19106 name_type(temp_val)=mp_capsule;
19108 @ @<Additional cases of unary operators@>=
19114 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19115 else mp_bad_unary(mp, c);
19118 @ @<Declarations@>=
19119 void mp_scale_edges (MP mp);
19121 @ @<Declare unary action...@>=
19122 void mp_take_pict_part (MP mp,quarterword c) {
19123 pointer p; /* first graphical object in |cur_exp| */
19124 p=link(dummy_loc(mp->cur_exp));
19127 case x_part: case y_part: case xx_part:
19128 case xy_part: case yx_part: case yy_part:
19129 if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
19130 else goto NOT_FOUND;
19132 case red_part: case green_part: case blue_part:
19133 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
19134 else goto NOT_FOUND;
19136 case cyan_part: case magenta_part: case yellow_part:
19138 if ( has_color(p) ) {
19139 if ( color_model(p)==mp_uninitialized_model && c==black_part)
19140 mp_flush_cur_exp(mp, unity);
19142 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
19143 } else goto NOT_FOUND;
19146 if ( has_color(p) )
19147 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
19148 else goto NOT_FOUND;
19150 case color_model_part:
19151 if ( has_color(p) ) {
19152 if ( color_model(p)==mp_uninitialized_model )
19153 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
19155 mp_flush_cur_exp(mp, color_model(p)*unity);
19156 } else goto NOT_FOUND;
19158 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
19159 } /* all cases have been enumerated */
19163 @<Convert the current expression to a null value appropriate
19167 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
19169 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19171 mp_flush_cur_exp(mp, text_p(p));
19172 add_str_ref(mp->cur_exp);
19173 mp->cur_type=mp_string_type;
19177 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19179 mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
19180 add_str_ref(mp->cur_exp);
19181 mp->cur_type=mp_string_type;
19185 if ( type(p)==mp_text_code ) goto NOT_FOUND;
19186 else if ( is_stop(p) ) mp_confusion(mp, "pict");
19187 @:this can't happen pict}{\quad pict@>
19189 mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
19190 mp->cur_type=mp_path_type;
19194 if ( ! has_pen(p) ) goto NOT_FOUND;
19196 if ( pen_p(p)==null ) goto NOT_FOUND;
19197 else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
19198 mp->cur_type=mp_pen_type;
19203 if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
19204 else { if ( dash_p(p)==null ) goto NOT_FOUND;
19205 else { add_edge_ref(dash_p(p));
19206 mp->se_sf=dash_scale(p);
19207 mp->se_pic=dash_p(p);
19208 mp_scale_edges(mp);
19209 mp_flush_cur_exp(mp, mp->se_pic);
19210 mp->cur_type=mp_picture_type;
19215 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
19216 parameterless procedure even though it really takes two arguments and updates
19217 one of them. Hence the following globals are needed.
19220 pointer se_pic; /* edge header used and updated by |scale_edges| */
19221 scaled se_sf; /* the scale factor argument to |scale_edges| */
19223 @ @<Convert the current expression to a null value appropriate...@>=
19225 case text_part: case font_part:
19226 mp_flush_cur_exp(mp, rts(""));
19227 mp->cur_type=mp_string_type;
19230 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19231 left_type(mp->cur_exp)=mp_endpoint;
19232 right_type(mp->cur_exp)=mp_endpoint;
19233 link(mp->cur_exp)=mp->cur_exp;
19234 x_coord(mp->cur_exp)=0;
19235 y_coord(mp->cur_exp)=0;
19236 originator(mp->cur_exp)=mp_metapost_user;
19237 mp->cur_type=mp_path_type;
19240 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19241 mp->cur_type=mp_pen_type;
19244 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19245 mp_init_edges(mp, mp->cur_exp);
19246 mp->cur_type=mp_picture_type;
19249 mp_flush_cur_exp(mp, 0);
19253 @ @<Additional cases of unary...@>=
19255 if ( mp->cur_type!=mp_known ) {
19256 mp_bad_unary(mp, char_op);
19258 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19259 mp->cur_type=mp_string_type;
19260 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19264 if ( mp->cur_type!=mp_known ) {
19265 mp_bad_unary(mp, decimal);
19267 mp->old_setting=mp->selector; mp->selector=new_string;
19268 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19269 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19275 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19276 else mp_str_to_num(mp, c);
19279 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19280 else @<Find the design size of the font whose name is |cur_exp|@>;
19283 @ @<Declare unary action...@>=
19284 void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19285 integer n; /* accumulator */
19286 ASCII_code m; /* current character */
19287 pool_pointer k; /* index into |str_pool| */
19288 int b; /* radix of conversion */
19289 boolean bad_char; /* did the string contain an invalid digit? */
19290 if ( c==ASCII_op ) {
19291 if ( length(mp->cur_exp)==0 ) n=-1;
19292 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19294 if ( c==oct_op ) b=8; else b=16;
19295 n=0; bad_char=false;
19296 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19298 if ( (m>='0')&&(m<='9') ) m=m-'0';
19299 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19300 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19301 else { bad_char=true; m=0; };
19302 if ( m>=b ) { bad_char=true; m=0; };
19303 if ( n<32768 / b ) n=n*b+m; else n=32767;
19305 @<Give error messages if |bad_char| or |n>=4096|@>;
19307 mp_flush_cur_exp(mp, n*unity);
19310 @ @<Give error messages if |bad_char|...@>=
19312 exp_err("String contains illegal digits");
19313 @.String contains illegal digits@>
19315 help1("I zeroed out characters that weren't in the range 0..7.");
19317 help1("I zeroed out characters that weren't hex digits.");
19319 mp_put_get_error(mp);
19322 if ( mp->internal[mp_warning_check]>0 ) {
19323 print_err("Number too large (");
19324 mp_print_int(mp, n); mp_print_char(mp, ')');
19325 @.Number too large@>
19326 help2("I have trouble with numbers greater than 4095; watch out.")
19327 ("(Set warningcheck:=0 to suppress this message.)");
19328 mp_put_get_error(mp);
19332 @ The length operation is somewhat unusual in that it applies to a variety
19333 of different types of operands.
19335 @<Additional cases of unary...@>=
19337 switch (mp->cur_type) {
19338 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19339 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19340 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19341 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19343 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19344 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19345 value(x_part_loc(value(mp->cur_exp))),
19346 value(y_part_loc(value(mp->cur_exp)))));
19347 else mp_bad_unary(mp, c);
19352 @ @<Declare unary action...@>=
19353 scaled mp_path_length (MP mp) { /* computes the length of the current path */
19354 scaled n; /* the path length so far */
19355 pointer p; /* traverser */
19357 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
19358 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
19362 @ @<Declare unary action...@>=
19363 scaled mp_pict_length (MP mp) {
19364 /* counts interior components in picture |cur_exp| */
19365 scaled n; /* the count so far */
19366 pointer p; /* traverser */
19368 p=link(dummy_loc(mp->cur_exp));
19370 if ( is_start_or_stop(p) )
19371 if ( mp_skip_1component(mp, p)==null ) p=link(p);
19372 while ( p!=null ) {
19373 skip_component(p) return n;
19380 @ Implement |turningnumber|
19382 @<Additional cases of unary...@>=
19384 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19385 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19386 else if ( left_type(mp->cur_exp)==mp_endpoint )
19387 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19389 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19392 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19393 argument is |origin|.
19395 @<Declare unary action...@>=
19396 angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19397 if ( (! ((xpar==0) && (ypar==0))) )
19398 return mp_n_arg(mp, xpar,ypar);
19403 @ The actual turning number is (for the moment) computed in a C function
19404 that receives eight integers corresponding to the four controlling points,
19405 and returns a single angle. Besides those, we have to account for discrete
19406 moves at the actual points.
19408 @d floor(a) (a>=0 ? a : -(int)(-a))
19409 @d bezier_error (720<<20)+1
19410 @d sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19412 @d out ((double)(xo>>20))
19413 @d mid ((double)(xm>>20))
19414 @d in ((double)(xi>>20))
19415 @d divisor (256*256)
19416 @d double2angle(a) (int)floor(a*256.0*256.0*16.0)
19418 @<Declare unary action...@>=
19419 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19420 integer CX,integer CY,integer DX,integer DY);
19423 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19424 integer CX,integer CY,integer DX,integer DY) {
19426 integer deltax,deltay;
19427 double ax,ay,bx,by,cx,cy,dx,dy;
19428 angle xi = 0, xo = 0, xm = 0;
19430 ax=AX/divisor; ay=AY/divisor;
19431 bx=BX/divisor; by=BY/divisor;
19432 cx=CX/divisor; cy=CY/divisor;
19433 dx=DX/divisor; dy=DY/divisor;
19435 deltax = (BX-AX); deltay = (BY-AY);
19436 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19437 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19438 xi = mp_an_angle(mp,deltax,deltay);
19440 deltax = (CX-BX); deltay = (CY-BY);
19441 xm = mp_an_angle(mp,deltax,deltay);
19443 deltax = (DX-CX); deltay = (DY-CY);
19444 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19445 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19446 xo = mp_an_angle(mp,deltax,deltay);
19448 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19449 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19450 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19452 if ((a==0)&&(c==0)) {
19453 res = (b==0 ? 0 : (out-in));
19454 print_roots("no roots (a)");
19455 } else if ((a==0)||(c==0)) {
19456 if ((sign(b) == sign(a)) || (sign(b) == sign(c))) {
19457 res = out-in; /* ? */
19460 else if (res>180.0)
19462 print_roots("no roots (b)");
19464 res = out-in; /* ? */
19465 print_roots("one root (a)");
19467 } else if ((sign(a)*sign(c))<0) {
19468 res = out-in; /* ? */
19471 else if (res>180.0)
19473 print_roots("one root (b)");
19475 if (sign(a) == sign(b)) {
19476 res = out-in; /* ? */
19479 else if (res>180.0)
19481 print_roots("no roots (d)");
19483 if ((b*b) == (4*a*c)) {
19484 res = bezier_error;
19485 print_roots("double root"); /* cusp */
19486 } else if ((b*b) < (4*a*c)) {
19487 res = out-in; /* ? */
19488 if (res<=0.0 &&res>-180.0)
19490 else if (res>=0.0 && res<180.0)
19492 print_roots("no roots (e)");
19497 else if (res>180.0)
19499 print_roots("two roots"); /* two inflections */
19503 return double2angle(res);
19507 @d p_nextnext link(link(p))
19509 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19511 @<Declare unary action...@>=
19512 scaled mp_new_turn_cycles (MP mp,pointer c) {
19513 angle res,ang; /* the angles of intermediate results */
19514 scaled turns; /* the turn counter */
19515 pointer p; /* for running around the path */
19516 integer xp,yp; /* coordinates of next point */
19517 integer x,y; /* helper coordinates */
19518 angle in_angle,out_angle; /* helper angles */
19519 int old_setting; /* saved |selector| setting */
19523 old_setting = mp->selector; mp->selector=term_only;
19524 if ( mp->internal[mp_tracing_commands]>unity ) {
19525 mp_begin_diagnostic(mp);
19526 mp_print_nl(mp, "");
19527 mp_end_diagnostic(mp, false);
19530 xp = x_coord(p_next); yp = y_coord(p_next);
19531 ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
19532 left_x(p_next), left_y(p_next), xp, yp);
19533 if ( ang>seven_twenty_deg ) {
19534 print_err("Strange path");
19536 mp->selector=old_setting;
19540 if ( res > one_eighty_deg ) {
19541 res = res - three_sixty_deg;
19542 turns = turns + unity;
19544 if ( res <= -one_eighty_deg ) {
19545 res = res + three_sixty_deg;
19546 turns = turns - unity;
19548 /* incoming angle at next point */
19549 x = left_x(p_next); y = left_y(p_next);
19550 if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
19551 if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
19552 in_angle = mp_an_angle(mp, xp - x, yp - y);
19553 /* outgoing angle at next point */
19554 x = right_x(p_next); y = right_y(p_next);
19555 if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
19556 if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
19557 out_angle = mp_an_angle(mp, x - xp, y- yp);
19558 ang = (out_angle - in_angle);
19562 if ( res >= one_eighty_deg ) {
19563 res = res - three_sixty_deg;
19564 turns = turns + unity;
19566 if ( res <= -one_eighty_deg ) {
19567 res = res + three_sixty_deg;
19568 turns = turns - unity;
19573 mp->selector=old_setting;
19578 @ This code is based on Bogus\l{}av Jackowski's
19579 |emergency_turningnumber| macro, with some minor changes by Taco
19580 Hoekwater. The macro code looked more like this:
19582 vardef turning\_number primary p =
19583 ~~save res, ang, turns;
19585 ~~if length p <= 2:
19586 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19588 ~~~~for t = 0 upto length p-1 :
19589 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19590 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19591 ~~~~~~if angc > 180: angc := angc - 360; fi;
19592 ~~~~~~if angc < -180: angc := angc + 360; fi;
19593 ~~~~~~res := res + angc;
19598 The general idea is to calculate only the sum of the angles of
19599 straight lines between the points, of a path, not worrying about cusps
19600 or self-intersections in the segments at all. If the segment is not
19601 well-behaved, the result is not necesarily correct. But the old code
19602 was not always correct either, and worse, it sometimes failed for
19603 well-behaved paths as well. All known bugs that were triggered by the
19604 original code no longer occur with this code, and it runs roughly 3
19605 times as fast because the algorithm is much simpler.
19607 @ It is possible to overflow the return value of the |turn_cycles|
19608 function when the path is sufficiently long and winding, but I am not
19609 going to bother testing for that. In any case, it would only return
19610 the looped result value, which is not a big problem.
19612 The macro code for the repeat loop was a bit nicer to look
19613 at than the pascal code, because it could use |point -1 of p|. In
19614 pascal, the fastest way to loop around the path is not to look
19615 backward once, but forward twice. These defines help hide the trick.
19617 @d p_to link(link(p))
19621 @<Declare unary action...@>=
19622 scaled mp_turn_cycles (MP mp,pointer c) {
19623 angle res,ang; /* the angles of intermediate results */
19624 scaled turns; /* the turn counter */
19625 pointer p; /* for running around the path */
19626 res=0; turns= 0; p=c;
19628 ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
19629 y_coord(p_to) - y_coord(p_here))
19630 - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
19631 y_coord(p_here) - y_coord(p_from));
19634 if ( res >= three_sixty_deg ) {
19635 res = res - three_sixty_deg;
19636 turns = turns + unity;
19638 if ( res <= -three_sixty_deg ) {
19639 res = res + three_sixty_deg;
19640 turns = turns - unity;
19647 @ @<Declare unary action...@>=
19648 scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19650 scaled saved_t_o; /* tracing\_online saved */
19651 if ( (link(c)==c)||(link(link(c))==c) ) {
19652 if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
19657 nval = mp_new_turn_cycles(mp, c);
19658 oval = mp_turn_cycles(mp, c);
19659 if ( nval!=oval ) {
19660 saved_t_o=mp->internal[mp_tracing_online];
19661 mp->internal[mp_tracing_online]=unity;
19662 mp_begin_diagnostic(mp);
19663 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19664 " The current computed value is ");
19665 mp_print_scaled(mp, nval);
19666 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19667 mp_print_scaled(mp, oval);
19668 mp_end_diagnostic(mp, false);
19669 mp->internal[mp_tracing_online]=saved_t_o;
19675 @ @<Declare unary action...@>=
19676 scaled mp_count_turns (MP mp,pointer c) {
19677 pointer p; /* a knot in envelope spec |c| */
19678 integer t; /* total pen offset changes counted */
19681 t=t+info(p)-zero_off;
19684 return ((t / 3)*unity);
19687 @ @d type_range(A,B) {
19688 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19689 mp_flush_cur_exp(mp, true_code);
19690 else mp_flush_cur_exp(mp, false_code);
19691 mp->cur_type=mp_boolean_type;
19694 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19695 else mp_flush_cur_exp(mp, false_code);
19696 mp->cur_type=mp_boolean_type;
19699 @<Additional cases of unary operators@>=
19700 case mp_boolean_type:
19701 type_range(mp_boolean_type,mp_unknown_boolean); break;
19702 case mp_string_type:
19703 type_range(mp_string_type,mp_unknown_string); break;
19705 type_range(mp_pen_type,mp_unknown_pen); break;
19707 type_range(mp_path_type,mp_unknown_path); break;
19708 case mp_picture_type:
19709 type_range(mp_picture_type,mp_unknown_picture); break;
19710 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19712 type_test(c); break;
19713 case mp_numeric_type:
19714 type_range(mp_known,mp_independent); break;
19715 case known_op: case unknown_op:
19716 mp_test_known(mp, c); break;
19718 @ @<Declare unary action procedures@>=
19719 void mp_test_known (MP mp,quarterword c) {
19720 int b; /* is the current expression known? */
19721 pointer p,q; /* locations in a big node */
19723 switch (mp->cur_type) {
19724 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19725 case mp_pen_type: case mp_path_type: case mp_picture_type:
19729 case mp_transform_type:
19730 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19731 p=value(mp->cur_exp);
19732 q=p+mp->big_node_size[mp->cur_type];
19735 if ( type(q)!=mp_known )
19744 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19745 else mp_flush_cur_exp(mp, true_code+false_code-b);
19746 mp->cur_type=mp_boolean_type;
19749 @ @<Additional cases of unary operators@>=
19751 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19752 else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19753 else mp_flush_cur_exp(mp, false_code);
19754 mp->cur_type=mp_boolean_type;
19757 @ @<Additional cases of unary operators@>=
19759 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19760 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19761 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19764 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19766 @^data structure assumptions@>
19768 @<Additional cases of unary operators@>=
19774 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19775 else if ( link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19776 else if ( type(link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19777 mp_flush_cur_exp(mp, true_code);
19778 else mp_flush_cur_exp(mp, false_code);
19779 mp->cur_type=mp_boolean_type;
19782 @ @<Additional cases of unary operators@>=
19784 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19785 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19787 mp->cur_type=mp_pen_type;
19788 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19792 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19794 mp->cur_type=mp_path_type;
19795 mp_make_path(mp, mp->cur_exp);
19799 if ( mp->cur_type==mp_path_type ) {
19800 p=mp_htap_ypoc(mp, mp->cur_exp);
19801 if ( right_type(p)==mp_endpoint ) p=link(p);
19802 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19803 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19804 else mp_bad_unary(mp, reverse);
19807 @ The |pair_value| routine changes the current expression to a
19808 given ordered pair of values.
19810 @<Declare unary action procedures@>=
19811 void mp_pair_value (MP mp,scaled x, scaled y) {
19812 pointer p; /* a pair node */
19813 p=mp_get_node(mp, value_node_size);
19814 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19815 type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19817 type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19818 type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19821 @ @<Additional cases of unary operators@>=
19823 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19824 else mp_pair_value(mp, minx,miny);
19827 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19828 else mp_pair_value(mp, maxx,miny);
19831 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19832 else mp_pair_value(mp, minx,maxy);
19835 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19836 else mp_pair_value(mp, maxx,maxy);
19839 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19840 box of the current expression. The boolean result is |false| if the expression
19841 has the wrong type.
19843 @<Declare unary action procedures@>=
19844 boolean mp_get_cur_bbox (MP mp) {
19845 switch (mp->cur_type) {
19846 case mp_picture_type:
19847 mp_set_bbox(mp, mp->cur_exp,true);
19848 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19849 minx=0; maxx=0; miny=0; maxy=0;
19851 minx=minx_val(mp->cur_exp);
19852 maxx=maxx_val(mp->cur_exp);
19853 miny=miny_val(mp->cur_exp);
19854 maxy=maxy_val(mp->cur_exp);
19858 mp_path_bbox(mp, mp->cur_exp);
19861 mp_pen_bbox(mp, mp->cur_exp);
19869 @ @<Additional cases of unary operators@>=
19871 case close_from_op:
19872 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19873 else mp_do_read_or_close(mp,c);
19876 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19877 a line from the file or to close the file.
19879 @<Declare unary action procedures@>=
19880 void mp_do_read_or_close (MP mp,quarterword c) {
19881 readf_index n,n0; /* indices for searching |rd_fname| */
19882 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19883 call |start_read_input| and |goto found| or |not_found|@>;
19884 mp_begin_file_reading(mp);
19886 if ( mp_input_ln(mp, mp->rd_file[n] ) )
19888 mp_end_file_reading(mp);
19890 @<Record the end of file and set |cur_exp| to a dummy value@>;
19893 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19896 mp_flush_cur_exp(mp, 0);
19897 mp_finish_read(mp);
19900 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19903 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19908 fn = str(mp->cur_exp);
19909 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19912 } else if ( c==close_from_op ) {
19915 if ( n0==mp->read_files ) {
19916 if ( mp->read_files<mp->max_read_files ) {
19917 incr(mp->read_files);
19922 l = mp->max_read_files + (mp->max_read_files>>2);
19923 rd_file = xmalloc((l+1), sizeof(void *));
19924 rd_fname = xmalloc((l+1), sizeof(char *));
19925 for (k=0;k<=l;k++) {
19926 if (k<=mp->max_read_files) {
19927 rd_file[k]=mp->rd_file[k];
19928 rd_fname[k]=mp->rd_fname[k];
19934 xfree(mp->rd_file); xfree(mp->rd_fname);
19935 mp->max_read_files = l;
19936 mp->rd_file = rd_file;
19937 mp->rd_fname = rd_fname;
19941 if ( mp_start_read_input(mp,fn,n) )
19946 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19948 if ( c==close_from_op ) {
19949 (mp->close_file)(mp,mp->rd_file[n]);
19954 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19955 xfree(mp->rd_fname[n]);
19956 mp->rd_fname[n]=NULL;
19957 if ( n==mp->read_files-1 ) mp->read_files=n;
19958 if ( c==close_from_op )
19960 mp_flush_cur_exp(mp, mp->eof_line);
19961 mp->cur_type=mp_string_type
19963 @ The string denoting end-of-file is a one-byte string at position zero, by definition
19966 str_number eof_line;
19971 @ Finally, we have the operations that combine a capsule~|p|
19972 with the current expression.
19974 @d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
19976 @c @<Declare binary action procedures@>
19977 void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
19979 @<Recycle any sidestepped |independent| capsules@>;
19981 void mp_do_binary (MP mp,pointer p, quarterword c) {
19982 pointer q,r,rr; /* for list manipulation */
19983 pointer old_p,old_exp; /* capsules to recycle */
19984 integer v; /* for numeric manipulation */
19986 if ( mp->internal[mp_tracing_commands]>two ) {
19987 @<Trace the current binary operation@>;
19989 @<Sidestep |independent| cases in capsule |p|@>;
19990 @<Sidestep |independent| cases in the current expression@>;
19992 case plus: case minus:
19993 @<Add or subtract the current expression from |p|@>;
19995 @<Additional cases of binary operators@>;
19996 }; /* there are no other cases */
19997 mp_recycle_value(mp, p);
19998 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
19999 mp_finish_binary(mp, old_p, old_exp);
20002 @ @<Declare binary action...@>=
20003 void mp_bad_binary (MP mp,pointer p, quarterword c) {
20004 mp_disp_err(mp, p,"");
20005 exp_err("Not implemented: ");
20006 @.Not implemented...@>
20007 if ( c>=min_of ) mp_print_op(mp, c);
20008 mp_print_known_or_unknown_type(mp, type(p),p);
20009 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
20010 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
20011 help3("I'm afraid I don't know how to apply that operation to that")
20012 ("combination of types. Continue, and I'll return the second")
20013 ("argument (see above) as the result of the operation.");
20014 mp_put_get_error(mp);
20016 void mp_bad_envelope_pen (MP mp) {
20017 mp_disp_err(mp, null,"");
20018 exp_err("Not implemented: envelope(elliptical pen)of(path)");
20019 @.Not implemented...@>
20020 help3("I'm afraid I don't know how to apply that operation to that")
20021 ("combination of types. Continue, and I'll return the second")
20022 ("argument (see above) as the result of the operation.");
20023 mp_put_get_error(mp);
20026 @ @<Trace the current binary operation@>=
20028 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
20029 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
20030 mp_print_char(mp,')'); mp_print_op(mp,c); mp_print_char(mp,'(');
20031 mp_print_exp(mp,null,0); mp_print(mp,")}");
20032 mp_end_diagnostic(mp, false);
20035 @ Several of the binary operations are potentially complicated by the
20036 fact that |independent| values can sneak into capsules. For example,
20037 we've seen an instance of this difficulty in the unary operation
20038 of negation. In order to reduce the number of cases that need to be
20039 handled, we first change the two operands (if necessary)
20040 to rid them of |independent| components. The original operands are
20041 put into capsules called |old_p| and |old_exp|, which will be
20042 recycled after the binary operation has been safely carried out.
20044 @<Recycle any sidestepped |independent| capsules@>=
20045 if ( old_p!=null ) {
20046 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
20048 if ( old_exp!=null ) {
20049 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
20052 @ A big node is considered to be ``tarnished'' if it contains at least one
20053 independent component. We will define a simple function called `|tarnished|'
20054 that returns |null| if and only if its argument is not tarnished.
20056 @<Sidestep |independent| cases in capsule |p|@>=
20058 case mp_transform_type:
20059 case mp_color_type:
20060 case mp_cmykcolor_type:
20062 old_p=mp_tarnished(mp, p);
20064 case mp_independent: old_p=mp_void; break;
20065 default: old_p=null; break;
20067 if ( old_p!=null ) {
20068 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
20069 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
20072 @ @<Sidestep |independent| cases in the current expression@>=
20073 switch (mp->cur_type) {
20074 case mp_transform_type:
20075 case mp_color_type:
20076 case mp_cmykcolor_type:
20078 old_exp=mp_tarnished(mp, mp->cur_exp);
20080 case mp_independent:old_exp=mp_void; break;
20081 default: old_exp=null; break;
20083 if ( old_exp!=null ) {
20084 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20087 @ @<Declare binary action...@>=
20088 pointer mp_tarnished (MP mp,pointer p) {
20089 pointer q; /* beginning of the big node */
20090 pointer r; /* current position in the big node */
20091 q=value(p); r=q+mp->big_node_size[type(p)];
20094 if ( type(r)==mp_independent ) return mp_void;
20099 @ @<Add or subtract the current expression from |p|@>=
20100 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20101 mp_bad_binary(mp, p,c);
20103 if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20104 mp_add_or_subtract(mp, p,null,c);
20106 if ( mp->cur_type!=type(p) ) {
20107 mp_bad_binary(mp, p,c);
20109 q=value(p); r=value(mp->cur_exp);
20110 rr=r+mp->big_node_size[mp->cur_type];
20112 mp_add_or_subtract(mp, q,r,c);
20119 @ The first argument to |add_or_subtract| is the location of a value node
20120 in a capsule or pair node that will soon be recycled. The second argument
20121 is either a location within a pair or transform node of |cur_exp|,
20122 or it is null (which means that |cur_exp| itself should be the second
20123 argument). The third argument is either |plus| or |minus|.
20125 The sum or difference of the numeric quantities will replace the second
20126 operand. Arithmetic overflow may go undetected; users aren't supposed to
20127 be monkeying around with really big values.
20128 @^overflow in arithmetic@>
20130 @<Declare binary action...@>=
20131 @<Declare the procedure called |dep_finish|@>
20132 void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
20133 small_number s,t; /* operand types */
20134 pointer r; /* list traverser */
20135 integer v; /* second operand value */
20138 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
20141 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
20143 if ( t==mp_known ) {
20144 if ( c==minus ) negate(v);
20145 if ( type(p)==mp_known ) {
20146 v=mp_slow_add(mp, value(p),v);
20147 if ( q==null ) mp->cur_exp=v; else value(q)=v;
20150 @<Add a known value to the constant term of |dep_list(p)|@>;
20152 if ( c==minus ) mp_negate_dep_list(mp, v);
20153 @<Add operand |p| to the dependency list |v|@>;
20157 @ @<Add a known value to the constant term of |dep_list(p)|@>=
20159 while ( info(r)!=null ) r=link(r);
20160 value(r)=mp_slow_add(mp, value(r),v);
20162 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
20163 name_type(q)=mp_capsule;
20165 dep_list(q)=dep_list(p); type(q)=type(p);
20166 prev_dep(q)=prev_dep(p); link(prev_dep(p))=q;
20167 type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
20169 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
20170 nice to retain the extra accuracy of |fraction| coefficients.
20171 But we have to handle both kinds, and mixtures too.
20173 @<Add operand |p| to the dependency list |v|@>=
20174 if ( type(p)==mp_known ) {
20175 @<Add the known |value(p)| to the constant term of |v|@>;
20177 s=type(p); r=dep_list(p);
20178 if ( t==mp_dependent ) {
20179 if ( s==mp_dependent ) {
20180 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
20181 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
20182 } /* |fix_needed| will necessarily be false */
20183 t=mp_proto_dependent;
20184 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
20186 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
20187 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
20189 @<Output the answer, |v| (which might have become |known|)@>;
20192 @ @<Add the known |value(p)| to the constant term of |v|@>=
20194 while ( info(v)!=null ) v=link(v);
20195 value(v)=mp_slow_add(mp, value(p),value(v));
20198 @ @<Output the answer, |v| (which might have become |known|)@>=
20199 if ( q!=null ) mp_dep_finish(mp, v,q,t);
20200 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
20202 @ Here's the current situation: The dependency list |v| of type |t|
20203 should either be put into the current expression (if |q=null|) or
20204 into location |q| within a pair node (otherwise). The destination (|cur_exp|
20205 or |q|) formerly held a dependency list with the same
20206 final pointer as the list |v|.
20208 @<Declare the procedure called |dep_finish|@>=
20209 void mp_dep_finish (MP mp, pointer v, pointer q, small_number t) {
20210 pointer p; /* the destination */
20211 scaled vv; /* the value, if it is |known| */
20212 if ( q==null ) p=mp->cur_exp; else p=q;
20213 dep_list(p)=v; type(p)=t;
20214 if ( info(v)==null ) {
20217 mp_flush_cur_exp(mp, vv);
20219 mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
20221 } else if ( q==null ) {
20224 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20227 @ Let's turn now to the six basic relations of comparison.
20229 @<Additional cases of binary operators@>=
20230 case less_than: case less_or_equal: case greater_than:
20231 case greater_or_equal: case equal_to: case unequal_to:
20232 check_arith; /* at this point |arith_error| should be |false|? */
20233 if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20234 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20235 } else if ( mp->cur_type!=type(p) ) {
20236 mp_bad_binary(mp, p,c); goto DONE;
20237 } else if ( mp->cur_type==mp_string_type ) {
20238 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20239 } else if ((mp->cur_type==mp_unknown_string)||
20240 (mp->cur_type==mp_unknown_boolean) ) {
20241 @<Check if unknowns have been equated@>;
20242 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20243 @<Reduce comparison of big nodes to comparison of scalars@>;
20244 } else if ( mp->cur_type==mp_boolean_type ) {
20245 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20247 mp_bad_binary(mp, p,c); goto DONE;
20249 @<Compare the current expression with zero@>;
20251 mp->arith_error=false; /* ignore overflow in comparisons */
20254 @ @<Compare the current expression with zero@>=
20255 if ( mp->cur_type!=mp_known ) {
20256 if ( mp->cur_type<mp_known ) {
20257 mp_disp_err(mp, p,"");
20258 help1("The quantities shown above have not been equated.")
20260 help2("Oh dear. I can\'t decide if the expression above is positive,")
20261 ("negative, or zero. So this comparison test won't be `true'.");
20263 exp_err("Unknown relation will be considered false");
20264 @.Unknown relation...@>
20265 mp_put_get_flush_error(mp, false_code);
20268 case less_than: boolean_reset(mp->cur_exp<0); break;
20269 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20270 case greater_than: boolean_reset(mp->cur_exp>0); break;
20271 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20272 case equal_to: boolean_reset(mp->cur_exp==0); break;
20273 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20274 }; /* there are no other cases */
20276 mp->cur_type=mp_boolean_type
20278 @ When two unknown strings are in the same ring, we know that they are
20279 equal. Otherwise, we don't know whether they are equal or not, so we
20282 @<Check if unknowns have been equated@>=
20284 q=value(mp->cur_exp);
20285 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20286 if ( q==p ) mp_flush_cur_exp(mp, 0);
20289 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20291 q=value(p); r=value(mp->cur_exp);
20292 rr=r+mp->big_node_size[mp->cur_type]-2;
20293 while (1) { mp_add_or_subtract(mp, q,r,minus);
20294 if ( type(r)!=mp_known ) break;
20295 if ( value(r)!=0 ) break;
20296 if ( r==rr ) break;
20299 mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
20302 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20304 @<Additional cases of binary operators@>=
20307 if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20308 mp_bad_binary(mp, p,c);
20309 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20312 @ @<Additional cases of binary operators@>=
20314 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20315 mp_bad_binary(mp, p,times);
20316 } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
20317 @<Multiply when at least one operand is known@>;
20318 } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
20319 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20320 (type(p)>mp_pair_type)) ) {
20321 mp_hard_times(mp, p);
20324 mp_bad_binary(mp, p,times);
20328 @ @<Multiply when at least one operand is known@>=
20330 if ( type(p)==mp_known ) {
20331 v=value(p); mp_free_node(mp, p,value_node_size);
20333 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20335 if ( mp->cur_type==mp_known ) {
20336 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20337 } else if ( (mp->cur_type==mp_pair_type)||
20338 (mp->cur_type==mp_color_type)||
20339 (mp->cur_type==mp_cmykcolor_type) ) {
20340 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20342 p=p-2; mp_dep_mult(mp, p,v,true);
20343 } while (p!=value(mp->cur_exp));
20345 mp_dep_mult(mp, null,v,true);
20350 @ @<Declare binary action...@>=
20351 void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20352 pointer q; /* the dependency list being multiplied by |v| */
20353 small_number s,t; /* its type, before and after */
20356 } else if ( type(p)!=mp_known ) {
20359 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20360 else value(p)=mp_take_fraction(mp, value(p),v);
20363 t=type(q); q=dep_list(q); s=t;
20364 if ( t==mp_dependent ) if ( v_is_scaled )
20365 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20366 t=mp_proto_dependent;
20367 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20368 mp_dep_finish(mp, q,p,t);
20371 @ Here is a routine that is similar to |times|; but it is invoked only
20372 internally, when |v| is a |fraction| whose magnitude is at most~1,
20373 and when |cur_type>=mp_color_type|.
20375 @c void mp_frac_mult (MP mp,scaled n, scaled d) {
20376 /* multiplies |cur_exp| by |n/d| */
20377 pointer p; /* a pair node */
20378 pointer old_exp; /* a capsule to recycle */
20379 fraction v; /* |n/d| */
20380 if ( mp->internal[mp_tracing_commands]>two ) {
20381 @<Trace the fraction multiplication@>;
20383 switch (mp->cur_type) {
20384 case mp_transform_type:
20385 case mp_color_type:
20386 case mp_cmykcolor_type:
20388 old_exp=mp_tarnished(mp, mp->cur_exp);
20390 case mp_independent: old_exp=mp_void; break;
20391 default: old_exp=null; break;
20393 if ( old_exp!=null ) {
20394 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20396 v=mp_make_fraction(mp, n,d);
20397 if ( mp->cur_type==mp_known ) {
20398 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20399 } else if ( mp->cur_type<=mp_pair_type ) {
20400 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20403 mp_dep_mult(mp, p,v,false);
20404 } while (p!=value(mp->cur_exp));
20406 mp_dep_mult(mp, null,v,false);
20408 if ( old_exp!=null ) {
20409 mp_recycle_value(mp, old_exp);
20410 mp_free_node(mp, old_exp,value_node_size);
20414 @ @<Trace the fraction multiplication@>=
20416 mp_begin_diagnostic(mp);
20417 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,'/');
20418 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20420 mp_end_diagnostic(mp, false);
20423 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20425 @<Declare binary action procedures@>=
20426 void mp_hard_times (MP mp,pointer p) {
20427 pointer q; /* a copy of the dependent variable |p| */
20428 pointer r; /* a component of the big node for the nice color or pair */
20429 scaled v; /* the known value for |r| */
20430 if ( type(p)<=mp_pair_type ) {
20431 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20432 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20433 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20438 if ( r==value(mp->cur_exp) )
20440 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20441 mp_dep_mult(mp, r,v,true);
20443 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20444 link(prev_dep(p))=r;
20445 mp_free_node(mp, p,value_node_size);
20446 mp_dep_mult(mp, r,v,true);
20449 @ @<Additional cases of binary operators@>=
20451 if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
20452 mp_bad_binary(mp, p,over);
20454 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20456 @<Squeal about division by zero@>;
20458 if ( mp->cur_type==mp_known ) {
20459 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20460 } else if ( mp->cur_type<=mp_pair_type ) {
20461 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20463 p=p-2; mp_dep_div(mp, p,v);
20464 } while (p!=value(mp->cur_exp));
20466 mp_dep_div(mp, null,v);
20473 @ @<Declare binary action...@>=
20474 void mp_dep_div (MP mp,pointer p, scaled v) {
20475 pointer q; /* the dependency list being divided by |v| */
20476 small_number s,t; /* its type, before and after */
20477 if ( p==null ) q=mp->cur_exp;
20478 else if ( type(p)!=mp_known ) q=p;
20479 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20480 t=type(q); q=dep_list(q); s=t;
20481 if ( t==mp_dependent )
20482 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20483 t=mp_proto_dependent;
20484 q=mp_p_over_v(mp, q,v,s,t);
20485 mp_dep_finish(mp, q,p,t);
20488 @ @<Squeal about division by zero@>=
20490 exp_err("Division by zero");
20491 @.Division by zero@>
20492 help2("You're trying to divide the quantity shown above the error")
20493 ("message by zero. I'm going to divide it by one instead.");
20494 mp_put_get_error(mp);
20497 @ @<Additional cases of binary operators@>=
20500 if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
20501 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20502 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20503 } else mp_bad_binary(mp, p,c);
20506 @ The next few sections of the program deal with affine transformations
20507 of coordinate data.
20509 @<Additional cases of binary operators@>=
20510 case rotated_by: case slanted_by:
20511 case scaled_by: case shifted_by: case transformed_by:
20512 case x_scaled: case y_scaled: case z_scaled:
20513 if ( type(p)==mp_path_type ) {
20514 path_trans(c,p); binary_return;
20515 } else if ( type(p)==mp_pen_type ) {
20517 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20518 /* rounding error could destroy convexity */
20520 } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
20521 mp_big_trans(mp, p,c);
20522 } else if ( type(p)==mp_picture_type ) {
20523 mp_do_edges_trans(mp, p,c); binary_return;
20525 mp_bad_binary(mp, p,c);
20529 @ Let |c| be one of the eight transform operators. The procedure call
20530 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20531 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20532 change at all if |c=transformed_by|.)
20534 Then, if all components of the resulting transform are |known|, they are
20535 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20536 and |cur_exp| is changed to the known value zero.
20538 @<Declare binary action...@>=
20539 void mp_set_up_trans (MP mp,quarterword c) {
20540 pointer p,q,r; /* list manipulation registers */
20541 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20542 @<Put the current transform into |cur_exp|@>;
20544 @<If the current transform is entirely known, stash it in global variables;
20545 otherwise |return|@>;
20554 scaled ty; /* current transform coefficients */
20556 @ @<Put the current transform...@>=
20558 p=mp_stash_cur_exp(mp);
20559 mp->cur_exp=mp_id_transform(mp);
20560 mp->cur_type=mp_transform_type;
20561 q=value(mp->cur_exp);
20563 @<For each of the eight cases, change the relevant fields of |cur_exp|
20565 but do nothing if capsule |p| doesn't have the appropriate type@>;
20566 }; /* there are no other cases */
20567 mp_disp_err(mp, p,"Improper transformation argument");
20568 @.Improper transformation argument@>
20569 help3("The expression shown above has the wrong type,")
20570 ("so I can\'t transform anything using it.")
20571 ("Proceed, and I'll omit the transformation.");
20572 mp_put_get_error(mp);
20574 mp_recycle_value(mp, p);
20575 mp_free_node(mp, p,value_node_size);
20578 @ @<If the current transform is entirely known, ...@>=
20579 q=value(mp->cur_exp); r=q+transform_node_size;
20582 if ( type(r)!=mp_known ) return;
20584 mp->txx=value(xx_part_loc(q));
20585 mp->txy=value(xy_part_loc(q));
20586 mp->tyx=value(yx_part_loc(q));
20587 mp->tyy=value(yy_part_loc(q));
20588 mp->tx=value(x_part_loc(q));
20589 mp->ty=value(y_part_loc(q));
20590 mp_flush_cur_exp(mp, 0)
20592 @ @<For each of the eight cases...@>=
20594 if ( type(p)==mp_known )
20595 @<Install sines and cosines, then |goto done|@>;
20598 if ( type(p)>mp_pair_type ) {
20599 mp_install(mp, xy_part_loc(q),p); goto DONE;
20603 if ( type(p)>mp_pair_type ) {
20604 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20609 if ( type(p)==mp_pair_type ) {
20610 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20611 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20615 if ( type(p)>mp_pair_type ) {
20616 mp_install(mp, xx_part_loc(q),p); goto DONE;
20620 if ( type(p)>mp_pair_type ) {
20621 mp_install(mp, yy_part_loc(q),p); goto DONE;
20625 if ( type(p)==mp_pair_type )
20626 @<Install a complex multiplier, then |goto done|@>;
20628 case transformed_by:
20632 @ @<Install sines and cosines, then |goto done|@>=
20633 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20634 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20635 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20636 value(xy_part_loc(q))=-value(yx_part_loc(q));
20637 value(yy_part_loc(q))=value(xx_part_loc(q));
20641 @ @<Install a complex multiplier, then |goto done|@>=
20644 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20645 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20646 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20647 if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20648 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20649 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20653 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20654 insists that the transformation be entirely known.
20656 @<Declare binary action...@>=
20657 void mp_set_up_known_trans (MP mp,quarterword c) {
20658 mp_set_up_trans(mp, c);
20659 if ( mp->cur_type!=mp_known ) {
20660 exp_err("Transform components aren't all known");
20661 @.Transform components...@>
20662 help3("I'm unable to apply a partially specified transformation")
20663 ("except to a fully known pair or transform.")
20664 ("Proceed, and I'll omit the transformation.");
20665 mp_put_get_flush_error(mp, 0);
20666 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20667 mp->tx=0; mp->ty=0;
20671 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20672 coordinates in locations |p| and~|q|.
20674 @<Declare binary action...@>=
20675 void mp_trans (MP mp,pointer p, pointer q) {
20676 scaled v; /* the new |x| value */
20677 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20678 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20679 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20680 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20684 @ The simplest transformation procedure applies a transform to all
20685 coordinates of a path. The |path_trans(c)(p)| macro applies
20686 a transformation defined by |cur_exp| and the transform operator |c|
20689 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20690 mp_unstash_cur_exp(mp, (B));
20691 mp_do_path_trans(mp, mp->cur_exp); }
20693 @<Declare binary action...@>=
20694 void mp_do_path_trans (MP mp,pointer p) {
20695 pointer q; /* list traverser */
20698 if ( left_type(q)!=mp_endpoint )
20699 mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
20700 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20701 if ( right_type(q)!=mp_endpoint )
20702 mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
20703 @^data structure assumptions@>
20708 @ Transforming a pen is very similar, except that there are no |left_type|
20709 and |right_type| fields.
20711 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20712 mp_unstash_cur_exp(mp, (B));
20713 mp_do_pen_trans(mp, mp->cur_exp); }
20715 @<Declare binary action...@>=
20716 void mp_do_pen_trans (MP mp,pointer p) {
20717 pointer q; /* list traverser */
20718 if ( pen_is_elliptical(p) ) {
20719 mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
20720 mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
20724 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20725 @^data structure assumptions@>
20730 @ The next transformation procedure applies to edge structures. It will do
20731 any transformation, but the results may be substandard if the picture contains
20732 text that uses downloaded bitmap fonts. The binary action procedure is
20733 |do_edges_trans|, but we also need a function that just scales a picture.
20734 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20735 should be thought of as procedures that update an edge structure |h|, except
20736 that they have to return a (possibly new) structure because of the need to call
20739 @<Declare binary action...@>=
20740 pointer mp_edges_trans (MP mp, pointer h) {
20741 pointer q; /* the object being transformed */
20742 pointer r,s; /* for list manipulation */
20743 scaled sx,sy; /* saved transformation parameters */
20744 scaled sqdet; /* square root of determinant for |dash_scale| */
20745 integer sgndet; /* sign of the determinant */
20746 scaled v; /* a temporary value */
20747 h=mp_private_edges(mp, h);
20748 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20749 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20750 if ( dash_list(h)!=null_dash ) {
20751 @<Try to transform the dash list of |h|@>;
20753 @<Make the bounding box of |h| unknown if it can't be updated properly
20754 without scanning the whole structure@>;
20755 q=link(dummy_loc(h));
20756 while ( q!=null ) {
20757 @<Transform graphical object |q|@>;
20762 void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20763 mp_set_up_known_trans(mp, c);
20764 value(p)=mp_edges_trans(mp, value(p));
20765 mp_unstash_cur_exp(mp, p);
20767 void mp_scale_edges (MP mp) {
20768 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20769 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20770 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20773 @ @<Try to transform the dash list of |h|@>=
20774 if ( (mp->txy!=0)||(mp->tyx!=0)||
20775 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20776 mp_flush_dash_list(mp, h);
20778 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20779 @<Scale the dash list by |txx| and shift it by |tx|@>;
20780 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20783 @ @<Reverse the dash list of |h|@>=
20786 dash_list(h)=null_dash;
20787 while ( r!=null_dash ) {
20789 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20790 link(s)=dash_list(h);
20795 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20797 while ( r!=null_dash ) {
20798 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20799 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20803 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20804 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20805 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20806 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20807 mp_init_bbox(mp, h);
20810 if ( minx_val(h)<=maxx_val(h) ) {
20811 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20818 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20820 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20821 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20824 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20827 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20829 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20830 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20831 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20832 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20833 if ( mp->txx+mp->txy<0 ) {
20834 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20836 if ( mp->tyx+mp->tyy<0 ) {
20837 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20841 @ Now we ready for the main task of transforming the graphical objects in edge
20844 @<Transform graphical object |q|@>=
20846 case mp_fill_code: case mp_stroked_code:
20847 mp_do_path_trans(mp, path_p(q));
20848 @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20850 case mp_start_clip_code: case mp_start_bounds_code:
20851 mp_do_path_trans(mp, path_p(q));
20855 @<Transform the compact transformation starting at |r|@>;
20857 case mp_stop_clip_code: case mp_stop_bounds_code:
20859 } /* there are no other cases */
20861 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20862 The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
20863 since the \ps\ output procedures will try to compensate for the transformation
20864 we are applying to |pen_p(q)|. Since this compensation is based on the square
20865 root of the determinant, |sqdet| is the appropriate factor.
20867 @<Transform |pen_p(q)|, making sure...@>=
20868 if ( pen_p(q)!=null ) {
20869 sx=mp->tx; sy=mp->ty;
20870 mp->tx=0; mp->ty=0;
20871 mp_do_pen_trans(mp, pen_p(q));
20872 if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
20873 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20874 if ( ! pen_is_elliptical(pen_p(q)) )
20876 pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
20877 /* this unreverses the pen */
20878 mp->tx=sx; mp->ty=sy;
20881 @ This uses the fact that transformations are stored in the order
20882 |(tx,ty,txx,txy,tyx,tyy)|.
20883 @^data structure assumptions@>
20885 @<Transform the compact transformation starting at |r|@>=
20886 mp_trans(mp, r,r+1);
20887 sx=mp->tx; sy=mp->ty;
20888 mp->tx=0; mp->ty=0;
20889 mp_trans(mp, r+2,r+4);
20890 mp_trans(mp, r+3,r+5);
20891 mp->tx=sx; mp->ty=sy
20893 @ The hard cases of transformation occur when big nodes are involved,
20894 and when some of their components are unknown.
20896 @<Declare binary action...@>=
20897 @<Declare subroutines needed by |big_trans|@>
20898 void mp_big_trans (MP mp,pointer p, quarterword c) {
20899 pointer q,r,pp,qq; /* list manipulation registers */
20900 small_number s; /* size of a big node */
20901 s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
20904 if ( type(r)!=mp_known ) {
20905 @<Transform an unknown big node and |return|@>;
20908 @<Transform a known big node@>;
20909 } /* node |p| will now be recycled by |do_binary| */
20911 @ @<Transform an unknown big node and |return|@>=
20913 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20914 r=value(mp->cur_exp);
20915 if ( mp->cur_type==mp_transform_type ) {
20916 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20917 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20918 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20919 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20921 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20922 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20926 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20927 and let |q| point to a another value field. The |bilin1| procedure
20928 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20930 @<Declare subroutines needed by |big_trans|@>=
20931 void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20932 scaled u, scaled delta) {
20933 pointer r; /* list traverser */
20934 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20936 if ( type(q)==mp_known ) {
20937 delta+=mp_take_scaled(mp, value(q),u);
20939 @<Ensure that |type(p)=mp_proto_dependent|@>;
20940 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20941 mp_proto_dependent,type(q));
20944 if ( type(p)==mp_known ) {
20948 while ( info(r)!=null ) r=link(r);
20950 if ( r!=dep_list(p) ) value(r)=delta;
20951 else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
20953 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20956 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
20957 if ( type(p)!=mp_proto_dependent ) {
20958 if ( type(p)==mp_known )
20959 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
20961 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
20962 mp_proto_dependent,true);
20963 type(p)=mp_proto_dependent;
20966 @ @<Transform a known big node@>=
20967 mp_set_up_trans(mp, c);
20968 if ( mp->cur_type==mp_known ) {
20969 @<Transform known by known@>;
20971 pp=mp_stash_cur_exp(mp); qq=value(pp);
20972 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20973 if ( mp->cur_type==mp_transform_type ) {
20974 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
20975 value(xy_part_loc(q)),yx_part_loc(qq),null);
20976 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
20977 value(xx_part_loc(q)),yx_part_loc(qq),null);
20978 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
20979 value(yy_part_loc(q)),xy_part_loc(qq),null);
20980 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
20981 value(yx_part_loc(q)),xy_part_loc(qq),null);
20983 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
20984 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
20985 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
20986 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
20987 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
20990 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
20991 at |dep_final|. The following procedure adds |v| times another
20992 numeric quantity to~|p|.
20994 @<Declare subroutines needed by |big_trans|@>=
20995 void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
20996 if ( type(r)==mp_known ) {
20997 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
20999 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
21000 mp_proto_dependent,type(r));
21001 if ( mp->fix_needed ) mp_fix_dependencies(mp);
21005 @ The |bilin2| procedure is something like |bilin1|, but with known
21006 and unknown quantities reversed. Parameter |p| points to a value field
21007 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
21008 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
21009 unless it is |null| (which stands for zero). Location~|p| will be
21010 replaced by $p\cdot t+v\cdot u+q$.
21012 @<Declare subroutines needed by |big_trans|@>=
21013 void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
21014 pointer u, pointer q) {
21015 scaled vv; /* temporary storage for |value(p)| */
21016 vv=value(p); type(p)=mp_proto_dependent;
21017 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
21019 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
21020 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
21021 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
21022 if ( dep_list(p)==mp->dep_final ) {
21023 vv=value(mp->dep_final); mp_recycle_value(mp, p);
21024 type(p)=mp_known; value(p)=vv;
21028 @ @<Transform known by known@>=
21030 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
21031 if ( mp->cur_type==mp_transform_type ) {
21032 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
21033 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
21034 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
21035 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
21037 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
21038 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
21041 @ Finally, in |bilin3| everything is |known|.
21043 @<Declare subroutines needed by |big_trans|@>=
21044 void mp_bilin3 (MP mp,pointer p, scaled t,
21045 scaled v, scaled u, scaled delta) {
21047 delta+=mp_take_scaled(mp, value(p),t);
21050 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
21051 else value(p)=delta;
21054 @ @<Additional cases of binary operators@>=
21056 if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
21057 else mp_bad_binary(mp, p,concatenate);
21060 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
21061 mp_chop_string(mp, value(p));
21062 else mp_bad_binary(mp, p,substring_of);
21065 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21066 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
21067 mp_chop_path(mp, value(p));
21068 else mp_bad_binary(mp, p,subpath_of);
21071 @ @<Declare binary action...@>=
21072 void mp_cat (MP mp,pointer p) {
21073 str_number a,b; /* the strings being concatenated */
21074 pool_pointer k; /* index into |str_pool| */
21075 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
21076 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
21077 append_char(mp->str_pool[k]);
21079 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
21080 append_char(mp->str_pool[k]);
21082 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
21085 @ @<Declare binary action...@>=
21086 void mp_chop_string (MP mp,pointer p) {
21087 integer a, b; /* start and stop points */
21088 integer l; /* length of the original string */
21089 integer k; /* runs from |a| to |b| */
21090 str_number s; /* the original string */
21091 boolean reversed; /* was |a>b|? */
21092 a=mp_round_unscaled(mp, value(x_part_loc(p)));
21093 b=mp_round_unscaled(mp, value(y_part_loc(p)));
21094 if ( a<=b ) reversed=false;
21095 else { reversed=true; k=a; a=b; b=k; };
21096 s=mp->cur_exp; l=length(s);
21107 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
21108 append_char(mp->str_pool[k]);
21111 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
21112 append_char(mp->str_pool[k]);
21115 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
21118 @ @<Declare binary action...@>=
21119 void mp_chop_path (MP mp,pointer p) {
21120 pointer q; /* a knot in the original path */
21121 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
21122 scaled a,b,k,l; /* indices for chopping */
21123 boolean reversed; /* was |a>b|? */
21124 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
21125 if ( a<=b ) reversed=false;
21126 else { reversed=true; k=a; a=b; b=k; };
21127 @<Dispense with the cases |a<0| and/or |b>l|@>;
21129 while ( a>=unity ) {
21130 q=link(q); a=a-unity; b=b-unity;
21133 @<Construct a path from |pp| to |qq| of length zero@>;
21135 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
21137 left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; link(qq)=pp;
21138 mp_toss_knot_list(mp, mp->cur_exp);
21140 mp->cur_exp=link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
21146 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
21148 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21149 a=0; if ( b<0 ) b=0;
21151 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
21155 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21156 b=l; if ( a>l ) a=l;
21164 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
21166 pp=mp_copy_knot(mp, q); qq=pp;
21168 q=link(q); rr=qq; qq=mp_copy_knot(mp, q); link(rr)=qq; b=b-unity;
21171 ss=pp; pp=link(pp);
21172 mp_split_cubic(mp, ss,a*010000); pp=link(ss);
21173 mp_free_node(mp, ss,knot_node_size);
21175 b=mp_make_scaled(mp, b,unity-a); rr=pp;
21179 mp_split_cubic(mp, rr,(b+unity)*010000);
21180 mp_free_node(mp, qq,knot_node_size);
21185 @ @<Construct a path from |pp| to |qq| of length zero@>=
21187 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=link(q); };
21188 pp=mp_copy_knot(mp, q); qq=pp;
21191 @ @<Additional cases of binary operators@>=
21192 case point_of: case precontrol_of: case postcontrol_of:
21193 if ( mp->cur_type==mp_pair_type )
21194 mp_pair_to_path(mp);
21195 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21196 mp_find_point(mp, value(p),c);
21198 mp_bad_binary(mp, p,c);
21200 case pen_offset_of:
21201 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
21202 mp_set_up_offset(mp, value(p));
21204 mp_bad_binary(mp, p,pen_offset_of);
21206 case direction_time_of:
21207 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21208 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
21209 mp_set_up_direction_time(mp, value(p));
21211 mp_bad_binary(mp, p,direction_time_of);
21214 if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
21215 mp_bad_binary(mp, p,envelope_of);
21217 mp_set_up_envelope(mp, p);
21220 @ @<Declare binary action...@>=
21221 void mp_set_up_offset (MP mp,pointer p) {
21222 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
21223 mp_pair_value(mp, mp->cur_x,mp->cur_y);
21225 void mp_set_up_direction_time (MP mp,pointer p) {
21226 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
21227 value(y_part_loc(p)),mp->cur_exp));
21229 void mp_set_up_envelope (MP mp,pointer p) {
21230 small_number ljoin, lcap;
21232 pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
21233 /* TODO: accept elliptical pens for straight paths */
21234 if (pen_is_elliptical(value(p))) {
21235 mp_bad_envelope_pen(mp);
21237 mp->cur_type = mp_path_type;
21240 if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
21241 else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
21243 if ( mp->internal[mp_linecap]>unity ) lcap=2;
21244 else if ( mp->internal[mp_linecap]>0 ) lcap=1;
21246 if ( mp->internal[mp_miterlimit]<unity )
21249 miterlim=mp->internal[mp_miterlimit];
21250 mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
21251 mp->cur_type = mp_path_type;
21254 @ @<Declare binary action...@>=
21255 void mp_find_point (MP mp,scaled v, quarterword c) {
21256 pointer p; /* the path */
21257 scaled n; /* its length */
21259 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
21260 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
21263 } else if ( v<0 ) {
21264 if ( left_type(p)==mp_endpoint ) v=0;
21265 else v=n-1-((-v-1) % n);
21266 } else if ( v>n ) {
21267 if ( left_type(p)==mp_endpoint ) v=n;
21271 while ( v>=unity ) { p=link(p); v=v-unity; };
21273 @<Insert a fractional node by splitting the cubic@>;
21275 @<Set the current expression to the desired path coordinates@>;
21278 @ @<Insert a fractional node...@>=
21279 { mp_split_cubic(mp, p,v*010000); p=link(p); }
21281 @ @<Set the current expression to the desired path coordinates...@>=
21284 mp_pair_value(mp, x_coord(p),y_coord(p));
21286 case precontrol_of:
21287 if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21288 else mp_pair_value(mp, left_x(p),left_y(p));
21290 case postcontrol_of:
21291 if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21292 else mp_pair_value(mp, right_x(p),right_y(p));
21294 } /* there are no other cases */
21296 @ @<Additional cases of binary operators@>=
21298 if ( mp->cur_type==mp_pair_type )
21299 mp_pair_to_path(mp);
21300 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21301 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21303 mp_bad_binary(mp, p,c);
21306 @ @<Additional cases of bin...@>=
21308 if ( type(p)==mp_pair_type ) {
21309 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21310 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21312 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21313 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
21314 mp_path_intersection(mp, value(p),mp->cur_exp);
21315 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21317 mp_bad_binary(mp, p,intersect);
21321 @ @<Additional cases of bin...@>=
21323 if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
21324 mp_bad_binary(mp, p,in_font);
21325 else { mp_do_infont(mp, p); binary_return; }
21328 @ Function |new_text_node| owns the reference count for its second argument
21329 (the text string) but not its first (the font name).
21331 @<Declare binary action...@>=
21332 void mp_do_infont (MP mp,pointer p) {
21334 q=mp_get_node(mp, edge_header_size);
21335 mp_init_edges(mp, q);
21336 link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
21337 obj_tail(q)=link(obj_tail(q));
21338 mp_free_node(mp, p,value_node_size);
21339 mp_flush_cur_exp(mp, q);
21340 mp->cur_type=mp_picture_type;
21343 @* \[40] Statements and commands.
21344 The chief executive of \MP\ is the |do_statement| routine, which
21345 contains the master switch that causes all the various pieces of \MP\
21346 to do their things, in the right order.
21348 In a sense, this is the grand climax of the program: It applies all the
21349 tools that we have worked so hard to construct. In another sense, this is
21350 the messiest part of the program: It necessarily refers to other pieces
21351 of code all over the place, so that a person can't fully understand what is
21352 going on without paging back and forth to be reminded of conventions that
21353 are defined elsewhere. We are now at the hub of the web.
21355 The structure of |do_statement| itself is quite simple. The first token
21356 of the statement is fetched using |get_x_next|. If it can be the first
21357 token of an expression, we look for an equation, an assignment, or a
21358 title. Otherwise we use a \&{case} construction to branch at high speed to
21359 the appropriate routine for various and sundry other types of commands,
21360 each of which has an ``action procedure'' that does the necessary work.
21362 The program uses the fact that
21363 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21364 to interpret a statement that starts with, e.g., `\&{string}',
21365 as a type declaration rather than a boolean expression.
21367 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21368 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21369 if ( mp->cur_cmd>max_primary_command ) {
21370 @<Worry about bad statement@>;
21371 } else if ( mp->cur_cmd>max_statement_command ) {
21372 @<Do an equation, assignment, title, or
21373 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21375 @<Do a statement that doesn't begin with an expression@>;
21377 if ( mp->cur_cmd<semicolon )
21378 @<Flush unparsable junk that was found after the statement@>;
21382 @ @<Declarations@>=
21383 @<Declare action procedures for use by |do_statement|@>
21385 @ The only command codes |>max_primary_command| that can be present
21386 at the beginning of a statement are |semicolon| and higher; these
21387 occur when the statement is null.
21389 @<Worry about bad statement@>=
21391 if ( mp->cur_cmd<semicolon ) {
21392 print_err("A statement can't begin with `");
21393 @.A statement can't begin with x@>
21394 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, '\'');
21395 help5("I was looking for the beginning of a new statement.")
21396 ("If you just proceed without changing anything, I'll ignore")
21397 ("everything up to the next `;'. Please insert a semicolon")
21398 ("now in front of anything that you don't want me to delete.")
21399 ("(See Chapter 27 of The METAFONTbook for an example.)");
21400 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21401 mp_back_error(mp); mp_get_x_next(mp);
21405 @ The help message printed here says that everything is flushed up to
21406 a semicolon, but actually the commands |end_group| and |stop| will
21407 also terminate a statement.
21409 @<Flush unparsable junk that was found after the statement@>=
21411 print_err("Extra tokens will be flushed");
21412 @.Extra tokens will be flushed@>
21413 help6("I've just read as much of that statement as I could fathom,")
21414 ("so a semicolon should have been next. It's very puzzling...")
21415 ("but I'll try to get myself back together, by ignoring")
21416 ("everything up to the next `;'. Please insert a semicolon")
21417 ("now in front of anything that you don't want me to delete.")
21418 ("(See Chapter 27 of The METAFONTbook for an example.)");
21419 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21420 mp_back_error(mp); mp->scanner_status=flushing;
21423 @<Decrease the string reference count...@>;
21424 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21425 mp->scanner_status=normal;
21428 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21429 |cur_type=mp_vacuous| unless the statement was simply an expression;
21430 in the latter case, |cur_type| and |cur_exp| should represent that
21433 @<Do a statement that doesn't...@>=
21435 if ( mp->internal[mp_tracing_commands]>0 )
21437 switch (mp->cur_cmd ) {
21438 case type_name:mp_do_type_declaration(mp); break;
21440 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21441 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21443 @<Cases of |do_statement| that invoke particular commands@>;
21444 } /* there are no other cases */
21445 mp->cur_type=mp_vacuous;
21448 @ The most important statements begin with expressions.
21450 @<Do an equation, assignment, title, or...@>=
21452 mp->var_flag=assignment; mp_scan_expression(mp);
21453 if ( mp->cur_cmd<end_group ) {
21454 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21455 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21456 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21457 else if ( mp->cur_type!=mp_vacuous ){
21458 exp_err("Isolated expression");
21459 @.Isolated expression@>
21460 help3("I couldn't find an `=' or `:=' after the")
21461 ("expression that is shown above this error message,")
21462 ("so I guess I'll just ignore it and carry on.");
21463 mp_put_get_error(mp);
21465 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21471 if ( mp->internal[mp_tracing_titles]>0 ) {
21472 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21476 @ Equations and assignments are performed by the pair of mutually recursive
21478 routines |do_equation| and |do_assignment|. These routines are called when
21479 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21480 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21481 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21482 will be equal to the right-hand side (which will normally be equal
21483 to the left-hand side).
21485 @<Declare action procedures for use by |do_statement|@>=
21486 @<Declare the procedure called |try_eq|@>
21487 @<Declare the procedure called |make_eq|@>
21488 void mp_do_equation (MP mp) ;
21491 void mp_do_equation (MP mp) {
21492 pointer lhs; /* capsule for the left-hand side */
21493 pointer p; /* temporary register */
21494 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21495 mp->var_flag=assignment; mp_scan_expression(mp);
21496 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21497 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21498 if ( mp->internal[mp_tracing_commands]>two )
21499 @<Trace the current equation@>;
21500 if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
21501 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21502 }; /* in this case |make_eq| will change the pair to a path */
21503 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21506 @ And |do_assignment| is similar to |do_equation|:
21509 void mp_do_assignment (MP mp);
21511 @ @<Declare action procedures for use by |do_statement|@>=
21512 void mp_do_assignment (MP mp) ;
21515 void mp_do_assignment (MP mp) {
21516 pointer lhs; /* token list for the left-hand side */
21517 pointer p; /* where the left-hand value is stored */
21518 pointer q; /* temporary capsule for the right-hand value */
21519 if ( mp->cur_type!=mp_token_list ) {
21520 exp_err("Improper `:=' will be changed to `='");
21522 help2("I didn't find a variable name at the left of the `:=',")
21523 ("so I'm going to pretend that you said `=' instead.");
21524 mp_error(mp); mp_do_equation(mp);
21526 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21527 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21528 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21529 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21530 if ( mp->internal[mp_tracing_commands]>two )
21531 @<Trace the current assignment@>;
21532 if ( info(lhs)>hash_end ) {
21533 @<Assign the current expression to an internal variable@>;
21535 @<Assign the current expression to the variable |lhs|@>;
21537 mp_flush_node_list(mp, lhs);
21541 @ @<Trace the current equation@>=
21543 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21544 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21545 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21548 @ @<Trace the current assignment@>=
21550 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21551 if ( info(lhs)>hash_end )
21552 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21554 mp_show_token_list(mp, lhs,null,1000,0);
21555 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21556 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
21559 @ @<Assign the current expression to an internal variable@>=
21560 if ( mp->cur_type==mp_known ) {
21561 mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
21563 exp_err("Internal quantity `");
21564 @.Internal quantity...@>
21565 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21566 mp_print(mp, "' must receive a known value");
21567 help2("I can\'t set an internal quantity to anything but a known")
21568 ("numeric value, so I'll have to ignore this assignment.");
21569 mp_put_get_error(mp);
21572 @ @<Assign the current expression to the variable |lhs|@>=
21574 p=mp_find_variable(mp, lhs);
21576 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21577 mp_recycle_value(mp, p);
21578 type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21579 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21581 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21586 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21587 a pointer to a capsule that is to be equated to the current expression.
21589 @<Declare the procedure called |make_eq|@>=
21590 void mp_make_eq (MP mp,pointer lhs) ;
21594 @c void mp_make_eq (MP mp,pointer lhs) {
21595 small_number t; /* type of the left-hand side */
21596 pointer p,q; /* pointers inside of big nodes */
21597 integer v=0; /* value of the left-hand side */
21600 if ( t<=mp_pair_type ) v=value(lhs);
21602 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21603 is incompatible with~|t|@>;
21604 } /* all cases have been listed */
21605 @<Announce that the equation cannot be performed@>;
21607 check_arith; mp_recycle_value(mp, lhs);
21608 mp_free_node(mp, lhs,value_node_size);
21611 @ @<Announce that the equation cannot be performed@>=
21612 mp_disp_err(mp, lhs,"");
21613 exp_err("Equation cannot be performed (");
21614 @.Equation cannot be performed@>
21615 if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
21616 else mp_print(mp, "numeric");
21617 mp_print_char(mp, '=');
21618 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21619 else mp_print(mp, "numeric");
21620 mp_print_char(mp, ')');
21621 help2("I'm sorry, but I don't know how to make such things equal.")
21622 ("(See the two expressions just above the error message.)");
21623 mp_put_get_error(mp)
21625 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21626 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21627 case mp_path_type: case mp_picture_type:
21628 if ( mp->cur_type==t+unknown_tag ) {
21629 mp_nonlinear_eq(mp, v,mp->cur_exp,false);
21630 mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
21631 } else if ( mp->cur_type==t ) {
21632 @<Report redundant or inconsistent equation and |goto done|@>;
21635 case unknown_types:
21636 if ( mp->cur_type==t-unknown_tag ) {
21637 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21638 } else if ( mp->cur_type==t ) {
21639 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21640 } else if ( mp->cur_type==mp_pair_type ) {
21641 if ( t==mp_unknown_path ) {
21642 mp_pair_to_path(mp); goto RESTART;
21646 case mp_transform_type: case mp_color_type:
21647 case mp_cmykcolor_type: case mp_pair_type:
21648 if ( mp->cur_type==t ) {
21649 @<Do multiple equations and |goto done|@>;
21652 case mp_known: case mp_dependent:
21653 case mp_proto_dependent: case mp_independent:
21654 if ( mp->cur_type>=mp_known ) {
21655 mp_try_eq(mp, lhs,null); goto DONE;
21661 @ @<Report redundant or inconsistent equation and |goto done|@>=
21663 if ( mp->cur_type<=mp_string_type ) {
21664 if ( mp->cur_type==mp_string_type ) {
21665 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21668 } else if ( v!=mp->cur_exp ) {
21671 @<Exclaim about a redundant equation@>; goto DONE;
21673 print_err("Redundant or inconsistent equation");
21674 @.Redundant or inconsistent equation@>
21675 help2("An equation between already-known quantities can't help.")
21676 ("But don't worry; continue and I'll just ignore it.");
21677 mp_put_get_error(mp); goto DONE;
21679 print_err("Inconsistent equation");
21680 @.Inconsistent equation@>
21681 help2("The equation I just read contradicts what was said before.")
21682 ("But don't worry; continue and I'll just ignore it.");
21683 mp_put_get_error(mp); goto DONE;
21686 @ @<Do multiple equations and |goto done|@>=
21688 p=v+mp->big_node_size[t];
21689 q=value(mp->cur_exp)+mp->big_node_size[t];
21691 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21696 @ The first argument to |try_eq| is the location of a value node
21697 in a capsule that will soon be recycled. The second argument is
21698 either a location within a pair or transform node pointed to by
21699 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21700 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21701 but to equate the two operands.
21703 @<Declare the procedure called |try_eq|@>=
21704 void mp_try_eq (MP mp,pointer l, pointer r) ;
21707 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21708 pointer p; /* dependency list for right operand minus left operand */
21709 int t; /* the type of list |p| */
21710 pointer q; /* the constant term of |p| is here */
21711 pointer pp; /* dependency list for right operand */
21712 int tt; /* the type of list |pp| */
21713 boolean copied; /* have we copied a list that ought to be recycled? */
21714 @<Remove the left operand from its container, negate it, and
21715 put it into dependency list~|p| with constant term~|q|@>;
21716 @<Add the right operand to list |p|@>;
21717 if ( info(p)==null ) {
21718 @<Deal with redundant or inconsistent equation@>;
21720 mp_linear_eq(mp, p,t);
21721 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21722 if ( type(mp->cur_exp)==mp_known ) {
21723 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21724 mp_free_node(mp, pp,value_node_size);
21730 @ @<Remove the left operand from its container, negate it, and...@>=
21732 if ( t==mp_known ) {
21733 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21734 } else if ( t==mp_independent ) {
21735 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21738 p=dep_list(l); q=p;
21741 if ( info(q)==null ) break;
21744 link(prev_dep(l))=link(q); prev_dep(link(q))=prev_dep(l);
21748 @ @<Deal with redundant or inconsistent equation@>=
21750 if ( abs(value(p))>64 ) { /* off by .001 or more */
21751 print_err("Inconsistent equation");
21752 @.Inconsistent equation@>
21753 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21754 mp_print_char(mp, ')');
21755 help2("The equation I just read contradicts what was said before.")
21756 ("But don't worry; continue and I'll just ignore it.");
21757 mp_put_get_error(mp);
21758 } else if ( r==null ) {
21759 @<Exclaim about a redundant equation@>;
21761 mp_free_node(mp, p,dep_node_size);
21764 @ @<Add the right operand to list |p|@>=
21766 if ( mp->cur_type==mp_known ) {
21767 value(q)=value(q)+mp->cur_exp; goto DONE1;
21770 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21771 else pp=dep_list(mp->cur_exp);
21774 if ( type(r)==mp_known ) {
21775 value(q)=value(q)+value(r); goto DONE1;
21778 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21779 else pp=dep_list(r);
21782 if ( tt!=mp_independent ) copied=false;
21783 else { copied=true; tt=mp_dependent; };
21784 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21785 if ( copied ) mp_flush_node_list(mp, pp);
21788 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21789 mp->watch_coefs=false;
21791 p=mp_p_plus_q(mp, p,pp,t);
21792 } else if ( t==mp_proto_dependent ) {
21793 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21796 while ( info(q)!=null ) {
21797 value(q)=mp_round_fraction(mp, value(q)); q=link(q);
21799 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21801 mp->watch_coefs=true;
21803 @ Our next goal is to process type declarations. For this purpose it's
21804 convenient to have a procedure that scans a $\langle\,$declared
21805 variable$\,\rangle$ and returns the corresponding token list. After the
21806 following procedure has acted, the token after the declared variable
21807 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21810 @<Declare the function called |scan_declared_variable|@>=
21811 pointer mp_scan_declared_variable (MP mp) {
21812 pointer x; /* hash address of the variable's root */
21813 pointer h,t; /* head and tail of the token list to be returned */
21814 pointer l; /* hash address of left bracket */
21815 mp_get_symbol(mp); x=mp->cur_sym;
21816 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21817 h=mp_get_avail(mp); info(h)=x; t=h;
21820 if ( mp->cur_sym==0 ) break;
21821 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21822 if ( mp->cur_cmd==left_bracket ) {
21823 @<Descend past a collective subscript@>;
21828 link(t)=mp_get_avail(mp); t=link(t); info(t)=mp->cur_sym;
21830 if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
21831 if ( equiv(x)==null ) mp_new_root(mp, x);
21835 @ If the subscript isn't collective, we don't accept it as part of the
21838 @<Descend past a collective subscript@>=
21840 l=mp->cur_sym; mp_get_x_next(mp);
21841 if ( mp->cur_cmd!=right_bracket ) {
21842 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21844 mp->cur_sym=collective_subscript;
21848 @ Type declarations are introduced by the following primitive operations.
21851 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21852 @:numeric_}{\&{numeric} primitive@>
21853 mp_primitive(mp, "string",type_name,mp_string_type);
21854 @:string_}{\&{string} primitive@>
21855 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21856 @:boolean_}{\&{boolean} primitive@>
21857 mp_primitive(mp, "path",type_name,mp_path_type);
21858 @:path_}{\&{path} primitive@>
21859 mp_primitive(mp, "pen",type_name,mp_pen_type);
21860 @:pen_}{\&{pen} primitive@>
21861 mp_primitive(mp, "picture",type_name,mp_picture_type);
21862 @:picture_}{\&{picture} primitive@>
21863 mp_primitive(mp, "transform",type_name,mp_transform_type);
21864 @:transform_}{\&{transform} primitive@>
21865 mp_primitive(mp, "color",type_name,mp_color_type);
21866 @:color_}{\&{color} primitive@>
21867 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21868 @:color_}{\&{rgbcolor} primitive@>
21869 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21870 @:color_}{\&{cmykcolor} primitive@>
21871 mp_primitive(mp, "pair",type_name,mp_pair_type);
21872 @:pair_}{\&{pair} primitive@>
21874 @ @<Cases of |print_cmd...@>=
21875 case type_name: mp_print_type(mp, m); break;
21877 @ Now we are ready to handle type declarations, assuming that a
21878 |type_name| has just been scanned.
21880 @<Declare action procedures for use by |do_statement|@>=
21881 void mp_do_type_declaration (MP mp) ;
21884 void mp_do_type_declaration (MP mp) {
21885 small_number t; /* the type being declared */
21886 pointer p; /* token list for a declared variable */
21887 pointer q; /* value node for the variable */
21888 if ( mp->cur_mod>=mp_transform_type )
21891 t=mp->cur_mod+unknown_tag;
21893 p=mp_scan_declared_variable(mp);
21894 mp_flush_variable(mp, equiv(info(p)),link(p),false);
21895 q=mp_find_variable(mp, p);
21897 type(q)=t; value(q)=null;
21899 print_err("Declared variable conflicts with previous vardef");
21900 @.Declared variable conflicts...@>
21901 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")
21902 ("Proceed, and I'll ignore the illegal redeclaration.");
21903 mp_put_get_error(mp);
21905 mp_flush_list(mp, p);
21906 if ( mp->cur_cmd<comma ) {
21907 @<Flush spurious symbols after the declared variable@>;
21909 } while (! end_of_statement);
21912 @ @<Flush spurious symbols after the declared variable@>=
21914 print_err("Illegal suffix of declared variable will be flushed");
21915 @.Illegal suffix...flushed@>
21916 help5("Variables in declarations must consist entirely of")
21917 ("names and collective subscripts, e.g., `x[]a'.")
21918 ("Are you trying to use a reserved word in a variable name?")
21919 ("I'm going to discard the junk I found here,")
21920 ("up to the next comma or the end of the declaration.");
21921 if ( mp->cur_cmd==numeric_token )
21922 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21923 mp_put_get_error(mp); mp->scanner_status=flushing;
21926 @<Decrease the string reference count...@>;
21927 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21928 mp->scanner_status=normal;
21931 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21932 until coming to the end of the user's program.
21933 Each execution of |do_statement| concludes with
21934 |cur_cmd=semicolon|, |end_group|, or |stop|.
21936 @c void mp_main_control (MP mp) {
21938 mp_do_statement(mp);
21939 if ( mp->cur_cmd==end_group ) {
21940 print_err("Extra `endgroup'");
21941 @.Extra `endgroup'@>
21942 help2("I'm not currently working on a `begingroup',")
21943 ("so I had better not try to end anything.");
21944 mp_flush_error(mp, 0);
21946 } while (mp->cur_cmd!=stop);
21948 int __attribute__((noinline))
21951 if (mp->history < mp_fatal_error_stop ) {
21952 @<Install and test the non-local jump buffer@>;
21953 mp_main_control(mp); /* come to life */
21954 mp_final_cleanup(mp); /* prepare for death */
21955 mp_close_files_and_terminate(mp);
21957 return mp->history;
21959 int __attribute__((noinline))
21960 mp_execute (MP mp) {
21962 if (mp->history < mp_fatal_error_stop ) {
21963 mp->history = mp_spotless;
21964 mp->file_offset = 0;
21965 mp->term_offset = 0;
21967 @<Install and test the non-local jump buffer@>;
21968 if (mp->run_state==0) {
21971 mp_input_ln(mp,mp->term_in);
21972 mp_firm_up_the_line(mp);
21973 mp->buffer[limit]='%';
21978 mp_do_statement(mp);
21979 } while (mp->cur_cmd!=stop);
21981 return mp->history;
21983 int __attribute__((noinline))
21984 mp_finish (MP mp) {
21986 if (mp->history < mp_fatal_error_stop ) {
21987 @<Install and test the non-local jump buffer@>;
21988 mp_final_cleanup(mp); /* prepare for death */
21989 mp_close_files_and_terminate(mp);
21991 return mp->history;
21993 const char * mp_mplib_version (MP mp) {
21995 return mplib_version;
21997 const char * mp_metapost_version (MP mp) {
21999 return metapost_version;
22002 @ @<Exported function headers@>=
22003 int mp_run (MP mp);
22004 int mp_execute (MP mp);
22005 int mp_finish (MP mp);
22006 const char * mp_mplib_version (MP mp);
22007 const char * mp_metapost_version (MP mp);
22010 mp_primitive(mp, "end",stop,0);
22011 @:end_}{\&{end} primitive@>
22012 mp_primitive(mp, "dump",stop,1);
22013 @:dump_}{\&{dump} primitive@>
22015 @ @<Cases of |print_cmd...@>=
22017 if ( m==0 ) mp_print(mp, "end");
22018 else mp_print(mp, "dump");
22022 Let's turn now to statements that are classified as ``commands'' because
22023 of their imperative nature. We'll begin with simple ones, so that it
22024 will be clear how to hook command processing into the |do_statement| routine;
22025 then we'll tackle the tougher commands.
22027 Here's one of the simplest:
22029 @<Cases of |do_statement|...@>=
22030 case mp_random_seed: mp_do_random_seed(mp); break;
22032 @ @<Declare action procedures for use by |do_statement|@>=
22033 void mp_do_random_seed (MP mp) ;
22035 @ @c void mp_do_random_seed (MP mp) {
22037 if ( mp->cur_cmd!=assignment ) {
22038 mp_missing_err(mp, ":=");
22040 help1("Always say `randomseed:=<numeric expression>'.");
22043 mp_get_x_next(mp); mp_scan_expression(mp);
22044 if ( mp->cur_type!=mp_known ) {
22045 exp_err("Unknown value will be ignored");
22046 @.Unknown value...ignored@>
22047 help2("Your expression was too random for me to handle,")
22048 ("so I won't change the random seed just now.");
22049 mp_put_get_flush_error(mp, 0);
22051 @<Initialize the random seed to |cur_exp|@>;
22055 @ @<Initialize the random seed to |cur_exp|@>=
22057 mp_init_randoms(mp, mp->cur_exp);
22058 if ( mp->selector>=log_only && mp->selector<write_file) {
22059 mp->old_setting=mp->selector; mp->selector=log_only;
22060 mp_print_nl(mp, "{randomseed:=");
22061 mp_print_scaled(mp, mp->cur_exp);
22062 mp_print_char(mp, '}');
22063 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
22067 @ And here's another simple one (somewhat different in flavor):
22069 @<Cases of |do_statement|...@>=
22071 mp_print_ln(mp); mp->interaction=mp->cur_mod;
22072 @<Initialize the print |selector| based on |interaction|@>;
22073 if ( mp->log_opened ) mp->selector=mp->selector+2;
22078 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
22079 @:mp_batch_mode_}{\&{batchmode} primitive@>
22080 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
22081 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
22082 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
22083 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
22084 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
22085 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
22087 @ @<Cases of |print_cmd_mod|...@>=
22090 case mp_batch_mode: mp_print(mp, "batchmode"); break;
22091 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
22092 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
22093 default: mp_print(mp, "errorstopmode"); break;
22097 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
22099 @<Cases of |do_statement|...@>=
22100 case protection_command: mp_do_protection(mp); break;
22103 mp_primitive(mp, "inner",protection_command,0);
22104 @:inner_}{\&{inner} primitive@>
22105 mp_primitive(mp, "outer",protection_command,1);
22106 @:outer_}{\&{outer} primitive@>
22108 @ @<Cases of |print_cmd...@>=
22109 case protection_command:
22110 if ( m==0 ) mp_print(mp, "inner");
22111 else mp_print(mp, "outer");
22114 @ @<Declare action procedures for use by |do_statement|@>=
22115 void mp_do_protection (MP mp) ;
22117 @ @c void mp_do_protection (MP mp) {
22118 int m; /* 0 to unprotect, 1 to protect */
22119 halfword t; /* the |eq_type| before we change it */
22122 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
22124 if ( t>=outer_tag )
22125 eq_type(mp->cur_sym)=t-outer_tag;
22126 } else if ( t<outer_tag ) {
22127 eq_type(mp->cur_sym)=t+outer_tag;
22130 } while (mp->cur_cmd==comma);
22133 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
22134 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
22135 declaration assigns the command code |left_delimiter| to `\.{(}' and
22136 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
22137 hash address of its mate.
22139 @<Cases of |do_statement|...@>=
22140 case delimiters: mp_def_delims(mp); break;
22142 @ @<Declare action procedures for use by |do_statement|@>=
22143 void mp_def_delims (MP mp) ;
22145 @ @c void mp_def_delims (MP mp) {
22146 pointer l_delim,r_delim; /* the new delimiter pair */
22147 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
22148 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
22149 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
22150 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
22154 @ Here is a procedure that is called when \MP\ has reached a point
22155 where some right delimiter is mandatory.
22157 @<Declare the procedure called |check_delimiter|@>=
22158 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
22159 if ( mp->cur_cmd==right_delimiter )
22160 if ( mp->cur_mod==l_delim )
22162 if ( mp->cur_sym!=r_delim ) {
22163 mp_missing_err(mp, str(text(r_delim)));
22165 help2("I found no right delimiter to match a left one. So I've")
22166 ("put one in, behind the scenes; this may fix the problem.");
22169 print_err("The token `"); mp_print_text(r_delim);
22170 @.The token...delimiter@>
22171 mp_print(mp, "' is no longer a right delimiter");
22172 help3("Strange: This token has lost its former meaning!")
22173 ("I'll read it as a right delimiter this time;")
22174 ("but watch out, I'll probably miss it later.");
22179 @ The next four commands save or change the values associated with tokens.
22181 @<Cases of |do_statement|...@>=
22184 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
22185 } while (mp->cur_cmd==comma);
22187 case interim_command: mp_do_interim(mp); break;
22188 case let_command: mp_do_let(mp); break;
22189 case new_internal: mp_do_new_internal(mp); break;
22191 @ @<Declare action procedures for use by |do_statement|@>=
22192 void mp_do_statement (MP mp);
22193 void mp_do_interim (MP mp);
22195 @ @c void mp_do_interim (MP mp) {
22197 if ( mp->cur_cmd!=internal_quantity ) {
22198 print_err("The token `");
22199 @.The token...quantity@>
22200 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
22201 else mp_print_text(mp->cur_sym);
22202 mp_print(mp, "' isn't an internal quantity");
22203 help1("Something like `tracingonline' should follow `interim'.");
22206 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
22208 mp_do_statement(mp);
22211 @ The following procedure is careful not to undefine the left-hand symbol
22212 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
22214 @<Declare action procedures for use by |do_statement|@>=
22215 void mp_do_let (MP mp) ;
22217 @ @c void mp_do_let (MP mp) {
22218 pointer l; /* hash location of the left-hand symbol */
22219 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
22220 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
22221 mp_missing_err(mp, "=");
22223 help3("You should have said `let symbol = something'.")
22224 ("But don't worry; I'll pretend that an equals sign")
22225 ("was present. The next token I read will be `something'.");
22229 switch (mp->cur_cmd) {
22230 case defined_macro: case secondary_primary_macro:
22231 case tertiary_secondary_macro: case expression_tertiary_macro:
22232 add_mac_ref(mp->cur_mod);
22237 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
22238 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
22239 else equiv(l)=mp->cur_mod;
22243 @ @<Declarations@>=
22244 void mp_grow_internals (MP mp, int l);
22245 void mp_do_new_internal (MP mp) ;
22248 void mp_grow_internals (MP mp, int l) {
22252 if ( hash_end+l>max_halfword ) {
22253 mp_confusion(mp, "out of memory space"); /* can't be reached */
22255 int_name = xmalloc ((l+1),sizeof(char *));
22256 internal = xmalloc ((l+1),sizeof(scaled));
22257 for (k=0;k<=l; k++ ) {
22258 if (k<=mp->max_internal) {
22259 internal[k]=mp->internal[k];
22260 int_name[k]=mp->int_name[k];
22266 xfree(mp->internal); xfree(mp->int_name);
22267 mp->int_name = int_name;
22268 mp->internal = internal;
22269 mp->max_internal = l;
22273 void mp_do_new_internal (MP mp) {
22275 if ( mp->int_ptr==mp->max_internal ) {
22276 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal>>2)));
22278 mp_get_clear_symbol(mp); incr(mp->int_ptr);
22279 eq_type(mp->cur_sym)=internal_quantity;
22280 equiv(mp->cur_sym)=mp->int_ptr;
22281 if(mp->int_name[mp->int_ptr]!=NULL)
22282 xfree(mp->int_name[mp->int_ptr]);
22283 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
22284 mp->internal[mp->int_ptr]=0;
22286 } while (mp->cur_cmd==comma);
22289 @ @<Dealloc variables@>=
22290 for (k=0;k<=mp->max_internal;k++) {
22291 xfree(mp->int_name[k]);
22293 xfree(mp->internal);
22294 xfree(mp->int_name);
22297 @ The various `\&{show}' commands are distinguished by modifier fields
22300 @d show_token_code 0 /* show the meaning of a single token */
22301 @d show_stats_code 1 /* show current memory and string usage */
22302 @d show_code 2 /* show a list of expressions */
22303 @d show_var_code 3 /* show a variable and its descendents */
22304 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22307 mp_primitive(mp, "showtoken",show_command,show_token_code);
22308 @:show_token_}{\&{showtoken} primitive@>
22309 mp_primitive(mp, "showstats",show_command,show_stats_code);
22310 @:show_stats_}{\&{showstats} primitive@>
22311 mp_primitive(mp, "show",show_command,show_code);
22312 @:show_}{\&{show} primitive@>
22313 mp_primitive(mp, "showvariable",show_command,show_var_code);
22314 @:show_var_}{\&{showvariable} primitive@>
22315 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22316 @:show_dependencies_}{\&{showdependencies} primitive@>
22318 @ @<Cases of |print_cmd...@>=
22321 case show_token_code:mp_print(mp, "showtoken"); break;
22322 case show_stats_code:mp_print(mp, "showstats"); break;
22323 case show_code:mp_print(mp, "show"); break;
22324 case show_var_code:mp_print(mp, "showvariable"); break;
22325 default: mp_print(mp, "showdependencies"); break;
22329 @ @<Cases of |do_statement|...@>=
22330 case show_command:mp_do_show_whatever(mp); break;
22332 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22333 if it's |show_code|, complicated structures are abbreviated, otherwise
22336 @<Declare action procedures for use by |do_statement|@>=
22337 void mp_do_show (MP mp) ;
22339 @ @c void mp_do_show (MP mp) {
22341 mp_get_x_next(mp); mp_scan_expression(mp);
22342 mp_print_nl(mp, ">> ");
22344 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22345 } while (mp->cur_cmd==comma);
22348 @ @<Declare action procedures for use by |do_statement|@>=
22349 void mp_disp_token (MP mp) ;
22351 @ @c void mp_disp_token (MP mp) {
22352 mp_print_nl(mp, "> ");
22354 if ( mp->cur_sym==0 ) {
22355 @<Show a numeric or string or capsule token@>;
22357 mp_print_text(mp->cur_sym); mp_print_char(mp, '=');
22358 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22359 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22360 if ( mp->cur_cmd==defined_macro ) {
22361 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22362 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22367 @ @<Show a numeric or string or capsule token@>=
22369 if ( mp->cur_cmd==numeric_token ) {
22370 mp_print_scaled(mp, mp->cur_mod);
22371 } else if ( mp->cur_cmd==capsule_token ) {
22372 mp_print_capsule(mp,mp->cur_mod);
22374 mp_print_char(mp, '"');
22375 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, '"');
22376 delete_str_ref(mp->cur_mod);
22380 @ The following cases of |print_cmd_mod| might arise in connection
22381 with |disp_token|, although they don't necessarily correspond to
22384 @<Cases of |print_cmd_...@>=
22385 case left_delimiter:
22386 case right_delimiter:
22387 if ( c==left_delimiter ) mp_print(mp, "left");
22388 else mp_print(mp, "right");
22389 mp_print(mp, " delimiter that matches ");
22393 if ( m==null ) mp_print(mp, "tag");
22394 else mp_print(mp, "variable");
22396 case defined_macro:
22397 mp_print(mp, "macro:");
22399 case secondary_primary_macro:
22400 case tertiary_secondary_macro:
22401 case expression_tertiary_macro:
22402 mp_print_cmd_mod(mp, macro_def,c);
22403 mp_print(mp, "'d macro:");
22404 mp_print_ln(mp); mp_show_token_list(mp, link(link(m)),null,1000,0);
22407 mp_print(mp, "[repeat the loop]");
22409 case internal_quantity:
22410 mp_print(mp, mp->int_name[m]);
22413 @ @<Declare action procedures for use by |do_statement|@>=
22414 void mp_do_show_token (MP mp) ;
22416 @ @c void mp_do_show_token (MP mp) {
22418 get_t_next; mp_disp_token(mp);
22420 } while (mp->cur_cmd==comma);
22423 @ @<Declare action procedures for use by |do_statement|@>=
22424 void mp_do_show_stats (MP mp) ;
22426 @ @c void mp_do_show_stats (MP mp) {
22427 mp_print_nl(mp, "Memory usage ");
22428 @.Memory usage...@>
22429 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used);
22430 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22431 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22432 mp_print_nl(mp, "String usage ");
22433 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22434 mp_print_char(mp, '&'); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22435 mp_print(mp, " (");
22436 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, '&');
22437 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22438 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22442 @ Here's a recursive procedure that gives an abbreviated account
22443 of a variable, for use by |do_show_var|.
22445 @<Declare action procedures for use by |do_statement|@>=
22446 void mp_disp_var (MP mp,pointer p) ;
22448 @ @c void mp_disp_var (MP mp,pointer p) {
22449 pointer q; /* traverses attributes and subscripts */
22450 int n; /* amount of macro text to show */
22451 if ( type(p)==mp_structured ) {
22452 @<Descend the structure@>;
22453 } else if ( type(p)>=mp_unsuffixed_macro ) {
22454 @<Display a variable macro@>;
22455 } else if ( type(p)!=undefined ){
22456 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22457 mp_print_char(mp, '=');
22458 mp_print_exp(mp, p,0);
22462 @ @<Descend the structure@>=
22465 do { mp_disp_var(mp, q); q=link(q); } while (q!=end_attr);
22467 while ( name_type(q)==mp_subscr ) {
22468 mp_disp_var(mp, q); q=link(q);
22472 @ @<Display a variable macro@>=
22474 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22475 if ( type(p)>mp_unsuffixed_macro )
22476 mp_print(mp, "@@#"); /* |suffixed_macro| */
22477 mp_print(mp, "=macro:");
22478 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22479 else n=mp->max_print_line-mp->file_offset-15;
22480 mp_show_macro(mp, value(p),null,n);
22483 @ @<Declare action procedures for use by |do_statement|@>=
22484 void mp_do_show_var (MP mp) ;
22486 @ @c void mp_do_show_var (MP mp) {
22489 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22490 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22491 mp_disp_var(mp, mp->cur_mod); goto DONE;
22496 } while (mp->cur_cmd==comma);
22499 @ @<Declare action procedures for use by |do_statement|@>=
22500 void mp_do_show_dependencies (MP mp) ;
22502 @ @c void mp_do_show_dependencies (MP mp) {
22503 pointer p; /* link that runs through all dependencies */
22505 while ( p!=dep_head ) {
22506 if ( mp_interesting(mp, p) ) {
22507 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22508 if ( type(p)==mp_dependent ) mp_print_char(mp, '=');
22509 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22510 mp_print_dependency(mp, dep_list(p),type(p));
22513 while ( info(p)!=null ) p=link(p);
22519 @ Finally we are ready for the procedure that governs all of the
22522 @<Declare action procedures for use by |do_statement|@>=
22523 void mp_do_show_whatever (MP mp) ;
22525 @ @c void mp_do_show_whatever (MP mp) {
22526 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
22527 switch (mp->cur_mod) {
22528 case show_token_code:mp_do_show_token(mp); break;
22529 case show_stats_code:mp_do_show_stats(mp); break;
22530 case show_code:mp_do_show(mp); break;
22531 case show_var_code:mp_do_show_var(mp); break;
22532 case show_dependencies_code:mp_do_show_dependencies(mp); break;
22533 } /* there are no other cases */
22534 if ( mp->internal[mp_showstopping]>0 ){
22537 if ( mp->interaction<mp_error_stop_mode ) {
22538 help0; decr(mp->error_count);
22540 help1("This isn't an error message; I'm just showing something.");
22542 if ( mp->cur_cmd==semicolon ) mp_error(mp);
22543 else mp_put_get_error(mp);
22547 @ The `\&{addto}' command needs the following additional primitives:
22549 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
22550 @d contour_code 1 /* command modifier for `\&{contour}' */
22551 @d also_code 2 /* command modifier for `\&{also}' */
22553 @ Pre and postscripts need two new identifiers:
22555 @d with_pre_script 11
22556 @d with_post_script 13
22559 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
22560 @:double_path_}{\&{doublepath} primitive@>
22561 mp_primitive(mp, "contour",thing_to_add,contour_code);
22562 @:contour_}{\&{contour} primitive@>
22563 mp_primitive(mp, "also",thing_to_add,also_code);
22564 @:also_}{\&{also} primitive@>
22565 mp_primitive(mp, "withpen",with_option,mp_pen_type);
22566 @:with_pen_}{\&{withpen} primitive@>
22567 mp_primitive(mp, "dashed",with_option,mp_picture_type);
22568 @:dashed_}{\&{dashed} primitive@>
22569 mp_primitive(mp, "withprescript",with_option,with_pre_script);
22570 @:with_pre_script_}{\&{withprescript} primitive@>
22571 mp_primitive(mp, "withpostscript",with_option,with_post_script);
22572 @:with_post_script_}{\&{withpostscript} primitive@>
22573 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
22574 @:with_color_}{\&{withoutcolor} primitive@>
22575 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
22576 @:with_color_}{\&{withgreyscale} primitive@>
22577 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
22578 @:with_color_}{\&{withcolor} primitive@>
22579 /* \&{withrgbcolor} is an alias for \&{withcolor} */
22580 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
22581 @:with_color_}{\&{withrgbcolor} primitive@>
22582 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
22583 @:with_color_}{\&{withcmykcolor} primitive@>
22585 @ @<Cases of |print_cmd...@>=
22587 if ( m==contour_code ) mp_print(mp, "contour");
22588 else if ( m==double_path_code ) mp_print(mp, "doublepath");
22589 else mp_print(mp, "also");
22592 if ( m==mp_pen_type ) mp_print(mp, "withpen");
22593 else if ( m==with_pre_script ) mp_print(mp, "withprescript");
22594 else if ( m==with_post_script ) mp_print(mp, "withpostscript");
22595 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
22596 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
22597 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
22598 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
22599 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
22600 else mp_print(mp, "dashed");
22603 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
22604 updates the list of graphical objects starting at |p|. Each $\langle$with
22605 clause$\rangle$ updates all graphical objects whose |type| is compatible.
22606 Other objects are ignored.
22608 @<Declare action procedures for use by |do_statement|@>=
22609 void mp_scan_with_list (MP mp,pointer p) ;
22611 @ @c void mp_scan_with_list (MP mp,pointer p) {
22612 small_number t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
22613 pointer q; /* for list manipulation */
22614 int old_setting; /* saved |selector| setting */
22615 pointer k; /* for finding the near-last item in a list */
22616 str_number s; /* for string cleanup after combining */
22617 pointer cp,pp,dp,ap,bp;
22618 /* objects being updated; |void| initially; |null| to suppress update */
22619 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
22621 while ( mp->cur_cmd==with_option ){
22624 if ( t!=mp_no_model ) mp_scan_expression(mp);
22625 if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
22626 ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
22627 ((t==mp_uninitialized_model)&&
22628 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
22629 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
22630 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
22631 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
22632 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
22633 ((t==mp_pen_type)&&(mp->cur_type!=t))||
22634 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
22635 @<Complain about improper type@>;
22636 } else if ( t==mp_uninitialized_model ) {
22637 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22639 @<Transfer a color from the current expression to object~|cp|@>;
22640 mp_flush_cur_exp(mp, 0);
22641 } else if ( t==mp_rgb_model ) {
22642 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22644 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
22645 mp_flush_cur_exp(mp, 0);
22646 } else if ( t==mp_cmyk_model ) {
22647 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22649 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
22650 mp_flush_cur_exp(mp, 0);
22651 } else if ( t==mp_grey_model ) {
22652 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22654 @<Transfer a greyscale from the current expression to object~|cp|@>;
22655 mp_flush_cur_exp(mp, 0);
22656 } else if ( t==mp_no_model ) {
22657 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22659 @<Transfer a noncolor from the current expression to object~|cp|@>;
22660 } else if ( t==mp_pen_type ) {
22661 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
22663 if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
22664 pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
22666 } else if ( t==with_pre_script ) {
22669 while ( (ap!=null)&&(! has_color(ap)) )
22672 if ( pre_script(ap)!=null ) { /* build a new,combined string */
22674 old_setting=mp->selector;
22675 mp->selector=new_string;
22676 str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
22677 mp_print_str(mp, mp->cur_exp);
22678 append_char(13); /* a forced \ps\ newline */
22679 mp_print_str(mp, pre_script(ap));
22680 pre_script(ap)=mp_make_string(mp);
22682 mp->selector=old_setting;
22684 pre_script(ap)=mp->cur_exp;
22686 mp->cur_type=mp_vacuous;
22688 } else if ( t==with_post_script ) {
22692 while ( link(k)!=null ) {
22694 if ( has_color(k) ) bp=k;
22697 if ( post_script(bp)!=null ) {
22699 old_setting=mp->selector;
22700 mp->selector=new_string;
22701 str_room(length(post_script(bp))+length(mp->cur_exp)+2);
22702 mp_print_str(mp, post_script(bp));
22703 append_char(13); /* a forced \ps\ newline */
22704 mp_print_str(mp, mp->cur_exp);
22705 post_script(bp)=mp_make_string(mp);
22707 mp->selector=old_setting;
22709 post_script(bp)=mp->cur_exp;
22711 mp->cur_type=mp_vacuous;
22714 if ( dp==mp_void ) {
22715 @<Make |dp| a stroked node in list~|p|@>;
22718 if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
22719 dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
22720 dash_scale(dp)=unity;
22721 mp->cur_type=mp_vacuous;
22725 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
22729 @ @<Complain about improper type@>=
22730 { exp_err("Improper type");
22732 help2("Next time say `withpen <known pen expression>';")
22733 ("I'll ignore the bad `with' clause and look for another.");
22734 if ( t==with_pre_script )
22735 mp->help_line[1]="Next time say `withprescript <known string expression>';";
22736 else if ( t==with_post_script )
22737 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
22738 else if ( t==mp_picture_type )
22739 mp->help_line[1]="Next time say `dashed <known picture expression>';";
22740 else if ( t==mp_uninitialized_model )
22741 mp->help_line[1]="Next time say `withcolor <known color expression>';";
22742 else if ( t==mp_rgb_model )
22743 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
22744 else if ( t==mp_cmyk_model )
22745 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
22746 else if ( t==mp_grey_model )
22747 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
22748 mp_put_get_flush_error(mp, 0);
22751 @ Forcing the color to be between |0| and |unity| here guarantees that no
22752 picture will ever contain a color outside the legal range for \ps\ graphics.
22754 @<Transfer a color from the current expression to object~|cp|@>=
22755 { if ( mp->cur_type==mp_color_type )
22756 @<Transfer a rgbcolor from the current expression to object~|cp|@>
22757 else if ( mp->cur_type==mp_cmykcolor_type )
22758 @<Transfer a cmykcolor from the current expression to object~|cp|@>
22759 else if ( mp->cur_type==mp_known )
22760 @<Transfer a greyscale from the current expression to object~|cp|@>
22761 else if ( mp->cur_exp==false_code )
22762 @<Transfer a noncolor from the current expression to object~|cp|@>;
22765 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
22766 { q=value(mp->cur_exp);
22771 red_val(cp)=value(red_part_loc(q));
22772 green_val(cp)=value(green_part_loc(q));
22773 blue_val(cp)=value(blue_part_loc(q));
22774 color_model(cp)=mp_rgb_model;
22775 if ( red_val(cp)<0 ) red_val(cp)=0;
22776 if ( green_val(cp)<0 ) green_val(cp)=0;
22777 if ( blue_val(cp)<0 ) blue_val(cp)=0;
22778 if ( red_val(cp)>unity ) red_val(cp)=unity;
22779 if ( green_val(cp)>unity ) green_val(cp)=unity;
22780 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
22783 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
22784 { q=value(mp->cur_exp);
22785 cyan_val(cp)=value(cyan_part_loc(q));
22786 magenta_val(cp)=value(magenta_part_loc(q));
22787 yellow_val(cp)=value(yellow_part_loc(q));
22788 black_val(cp)=value(black_part_loc(q));
22789 color_model(cp)=mp_cmyk_model;
22790 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
22791 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
22792 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
22793 if ( black_val(cp)<0 ) black_val(cp)=0;
22794 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
22795 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
22796 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
22797 if ( black_val(cp)>unity ) black_val(cp)=unity;
22800 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
22807 color_model(cp)=mp_grey_model;
22808 if ( grey_val(cp)<0 ) grey_val(cp)=0;
22809 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
22812 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
22819 color_model(cp)=mp_no_model;
22822 @ @<Make |cp| a colored object in object list~|p|@>=
22824 while ( cp!=null ){
22825 if ( has_color(cp) ) break;
22830 @ @<Make |pp| an object in list~|p| that needs a pen@>=
22832 while ( pp!=null ) {
22833 if ( has_pen(pp) ) break;
22838 @ @<Make |dp| a stroked node in list~|p|@>=
22840 while ( dp!=null ) {
22841 if ( type(dp)==mp_stroked_code ) break;
22846 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
22847 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
22848 if ( pp>mp_void ) {
22849 @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
22851 if ( dp>mp_void ) {
22852 @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
22856 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
22858 while ( q!=null ) {
22859 if ( has_color(q) ) {
22860 red_val(q)=red_val(cp);
22861 green_val(q)=green_val(cp);
22862 blue_val(q)=blue_val(cp);
22863 black_val(q)=black_val(cp);
22864 color_model(q)=color_model(cp);
22870 @ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
22872 while ( q!=null ) {
22873 if ( has_pen(q) ) {
22874 if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
22875 pen_p(q)=copy_pen(pen_p(pp));
22881 @ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
22883 while ( q!=null ) {
22884 if ( type(q)==mp_stroked_code ) {
22885 if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
22886 dash_p(q)=dash_p(dp);
22887 dash_scale(q)=unity;
22888 if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
22894 @ One of the things we need to do when we've parsed an \&{addto} or
22895 similar command is find the header of a supposed \&{picture} variable, given
22896 a token list for that variable. Since the edge structure is about to be
22897 updated, we use |private_edges| to make sure that this is possible.
22899 @<Declare action procedures for use by |do_statement|@>=
22900 pointer mp_find_edges_var (MP mp, pointer t) ;
22902 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
22904 pointer cur_edges; /* the return value */
22905 p=mp_find_variable(mp, t); cur_edges=null;
22907 mp_obliterated(mp, t); mp_put_get_error(mp);
22908 } else if ( type(p)!=mp_picture_type ) {
22909 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
22910 @.Variable x is the wrong type@>
22911 mp_print(mp, " is the wrong type (");
22912 mp_print_type(mp, type(p)); mp_print_char(mp, ')');
22913 help2("I was looking for a \"known\" picture variable.")
22914 ("So I'll not change anything just now.");
22915 mp_put_get_error(mp);
22917 value(p)=mp_private_edges(mp, value(p));
22918 cur_edges=value(p);
22920 mp_flush_node_list(mp, t);
22924 @ @<Cases of |do_statement|...@>=
22925 case add_to_command: mp_do_add_to(mp); break;
22926 case bounds_command:mp_do_bounds(mp); break;
22929 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
22930 @:clip_}{\&{clip} primitive@>
22931 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
22932 @:set_bounds_}{\&{setbounds} primitive@>
22934 @ @<Cases of |print_cmd...@>=
22935 case bounds_command:
22936 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
22937 else mp_print(mp, "setbounds");
22940 @ The following function parses the beginning of an \&{addto} or \&{clip}
22941 command: it expects a variable name followed by a token with |cur_cmd=sep|
22942 and then an expression. The function returns the token list for the variable
22943 and stores the command modifier for the separator token in the global variable
22944 |last_add_type|. We must be careful because this variable might get overwritten
22945 any time we call |get_x_next|.
22948 quarterword last_add_type;
22949 /* command modifier that identifies the last \&{addto} command */
22951 @ @<Declare action procedures for use by |do_statement|@>=
22952 pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
22954 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
22955 pointer lhv; /* variable to add to left */
22956 quarterword add_type=0; /* value to be returned in |last_add_type| */
22958 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
22959 if ( mp->cur_type!=mp_token_list ) {
22960 @<Abandon edges command because there's no variable@>;
22962 lhv=mp->cur_exp; add_type=mp->cur_mod;
22963 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
22965 mp->last_add_type=add_type;
22969 @ @<Abandon edges command because there's no variable@>=
22970 { exp_err("Not a suitable variable");
22971 @.Not a suitable variable@>
22972 help4("At this point I needed to see the name of a picture variable.")
22973 ("(Or perhaps you have indeed presented me with one; I might")
22974 ("have missed it, if it wasn't followed by the proper token.)")
22975 ("So I'll not change anything just now.");
22976 mp_put_get_flush_error(mp, 0);
22979 @ Here is an example of how to use |start_draw_cmd|.
22981 @<Declare action procedures for use by |do_statement|@>=
22982 void mp_do_bounds (MP mp) ;
22984 @ @c void mp_do_bounds (MP mp) {
22985 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
22986 pointer p; /* for list manipulation */
22987 integer m; /* initial value of |cur_mod| */
22989 lhv=mp_start_draw_cmd(mp, to_token);
22991 lhe=mp_find_edges_var(mp, lhv);
22993 mp_flush_cur_exp(mp, 0);
22994 } else if ( mp->cur_type!=mp_path_type ) {
22995 exp_err("Improper `clip'");
22996 @.Improper `addto'@>
22997 help2("This expression should have specified a known path.")
22998 ("So I'll not change anything just now.");
22999 mp_put_get_flush_error(mp, 0);
23000 } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
23001 @<Complain about a non-cycle@>;
23003 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
23008 @ @<Complain about a non-cycle@>=
23009 { print_err("Not a cycle");
23011 help2("That contour should have ended with `..cycle' or `&cycle'.")
23012 ("So I'll not change anything just now."); mp_put_get_error(mp);
23015 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
23016 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
23017 link(p)=link(dummy_loc(lhe));
23018 link(dummy_loc(lhe))=p;
23019 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
23020 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
23021 type(p)=stop_type(m);
23022 link(obj_tail(lhe))=p;
23024 mp_init_bbox(mp, lhe);
23027 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
23028 cases to deal with.
23030 @<Declare action procedures for use by |do_statement|@>=
23031 void mp_do_add_to (MP mp) ;
23033 @ @c void mp_do_add_to (MP mp) {
23034 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23035 pointer p; /* the graphical object or list for |scan_with_list| to update */
23036 pointer e; /* an edge structure to be merged */
23037 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
23038 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
23040 if ( add_type==also_code ) {
23041 @<Make sure the current expression is a suitable picture and set |e| and |p|
23044 @<Create a graphical object |p| based on |add_type| and the current
23047 mp_scan_with_list(mp, p);
23048 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
23052 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
23053 setting |e:=null| prevents anything from being added to |lhe|.
23055 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
23058 if ( mp->cur_type!=mp_picture_type ) {
23059 exp_err("Improper `addto'");
23060 @.Improper `addto'@>
23061 help2("This expression should have specified a known picture.")
23062 ("So I'll not change anything just now."); mp_put_get_flush_error(mp, 0);
23064 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
23065 p=link(dummy_loc(e));
23069 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
23070 attempts to add to the edge structure.
23072 @<Create a graphical object |p| based on |add_type| and the current...@>=
23074 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
23075 if ( mp->cur_type!=mp_path_type ) {
23076 exp_err("Improper `addto'");
23077 @.Improper `addto'@>
23078 help2("This expression should have specified a known path.")
23079 ("So I'll not change anything just now.");
23080 mp_put_get_flush_error(mp, 0);
23081 } else if ( add_type==contour_code ) {
23082 if ( left_type(mp->cur_exp)==mp_endpoint ) {
23083 @<Complain about a non-cycle@>;
23085 p=mp_new_fill_node(mp, mp->cur_exp);
23086 mp->cur_type=mp_vacuous;
23089 p=mp_new_stroked_node(mp, mp->cur_exp);
23090 mp->cur_type=mp_vacuous;
23094 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
23095 lhe=mp_find_edges_var(mp, lhv);
23097 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
23098 if ( e!=null ) delete_edge_ref(e);
23099 } else if ( add_type==also_code ) {
23101 @<Merge |e| into |lhe| and delete |e|@>;
23105 } else if ( p!=null ) {
23106 link(obj_tail(lhe))=p;
23108 if ( add_type==double_path_code )
23109 if ( pen_p(p)==null )
23110 pen_p(p)=mp_get_pen_circle(mp, 0);
23113 @ @<Merge |e| into |lhe| and delete |e|@>=
23114 { if ( link(dummy_loc(e))!=null ) {
23115 link(obj_tail(lhe))=link(dummy_loc(e));
23116 obj_tail(lhe)=obj_tail(e);
23117 obj_tail(e)=dummy_loc(e);
23118 link(dummy_loc(e))=null;
23119 mp_flush_dash_list(mp, lhe);
23121 mp_toss_edges(mp, e);
23124 @ @<Cases of |do_statement|...@>=
23125 case ship_out_command: mp_do_ship_out(mp); break;
23127 @ @<Declare action procedures for use by |do_statement|@>=
23128 @<Declare the function called |tfm_check|@>
23129 @<Declare the \ps\ output procedures@>
23130 void mp_do_ship_out (MP mp) ;
23132 @ @c void mp_do_ship_out (MP mp) {
23133 integer c; /* the character code */
23134 mp_get_x_next(mp); mp_scan_expression(mp);
23135 if ( mp->cur_type!=mp_picture_type ) {
23136 @<Complain that it's not a known picture@>;
23138 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
23139 if ( c<0 ) c=c+256;
23140 @<Store the width information for character code~|c|@>;
23141 mp_ship_out(mp, mp->cur_exp);
23142 mp_flush_cur_exp(mp, 0);
23146 @ @<Complain that it's not a known picture@>=
23148 exp_err("Not a known picture");
23149 help1("I can only output known pictures.");
23150 mp_put_get_flush_error(mp, 0);
23153 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
23156 @<Cases of |do_statement|...@>=
23157 case every_job_command:
23158 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
23162 halfword start_sym; /* a symbolic token to insert at beginning of job */
23167 @ Finally, we have only the ``message'' commands remaining.
23170 @d err_message_code 1
23172 @d filename_template_code 3
23173 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
23174 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
23176 mp->pool_ptr = mp->pool_ptr - g;
23178 mp_print_char(mp, '0');
23181 mp_print_int(mp, (A));
23186 mp_primitive(mp, "message",message_command,message_code);
23187 @:message_}{\&{message} primitive@>
23188 mp_primitive(mp, "errmessage",message_command,err_message_code);
23189 @:err_message_}{\&{errmessage} primitive@>
23190 mp_primitive(mp, "errhelp",message_command,err_help_code);
23191 @:err_help_}{\&{errhelp} primitive@>
23192 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
23193 @:filename_template_}{\&{filenametemplate} primitive@>
23195 @ @<Cases of |print_cmd...@>=
23196 case message_command:
23197 if ( m<err_message_code ) mp_print(mp, "message");
23198 else if ( m==err_message_code ) mp_print(mp, "errmessage");
23199 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
23200 else mp_print(mp, "errhelp");
23203 @ @<Cases of |do_statement|...@>=
23204 case message_command: mp_do_message(mp); break;
23206 @ @<Declare action procedures for use by |do_statement|@>=
23207 @<Declare a procedure called |no_string_err|@>
23208 void mp_do_message (MP mp) ;
23211 @c void mp_do_message (MP mp) {
23212 int m; /* the type of message */
23213 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
23214 if ( mp->cur_type!=mp_string_type )
23215 mp_no_string_err(mp, "A message should be a known string expression.");
23219 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
23221 case err_message_code:
23222 @<Print string |cur_exp| as an error message@>;
23224 case err_help_code:
23225 @<Save string |cur_exp| as the |err_help|@>;
23227 case filename_template_code:
23228 @<Save the filename template@>;
23230 } /* there are no other cases */
23232 mp_flush_cur_exp(mp, 0);
23235 @ @<Declare a procedure called |no_string_err|@>=
23236 void mp_no_string_err (MP mp, const char *s) {
23237 exp_err("Not a string");
23240 mp_put_get_error(mp);
23243 @ The global variable |err_help| is zero when the user has most recently
23244 given an empty help string, or if none has ever been given.
23246 @<Save string |cur_exp| as the |err_help|@>=
23248 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
23249 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
23250 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
23253 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
23254 \&{errhelp}, we don't want to give a long help message each time. So we
23255 give a verbose explanation only once.
23258 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
23260 @ @<Set init...@>=mp->long_help_seen=false;
23262 @ @<Print string |cur_exp| as an error message@>=
23264 print_err(""); mp_print_str(mp, mp->cur_exp);
23265 if ( mp->err_help!=0 ) {
23266 mp->use_err_help=true;
23267 } else if ( mp->long_help_seen ) {
23268 help1("(That was another `errmessage'.)") ;
23270 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
23271 help4("This error message was generated by an `errmessage'")
23272 ("command, so I can\'t give any explicit help.")
23273 ("Pretend that you're Miss Marple: Examine all clues,")
23275 ("and deduce the truth by inspired guesses.");
23277 mp_put_get_error(mp); mp->use_err_help=false;
23280 @ @<Cases of |do_statement|...@>=
23281 case write_command: mp_do_write(mp); break;
23283 @ @<Declare action procedures for use by |do_statement|@>=
23284 void mp_do_write (MP mp) ;
23286 @ @c void mp_do_write (MP mp) {
23287 str_number t; /* the line of text to be written */
23288 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
23289 int old_setting; /* for saving |selector| during output */
23291 mp_scan_expression(mp);
23292 if ( mp->cur_type!=mp_string_type ) {
23293 mp_no_string_err(mp, "The text to be written should be a known string expression");
23294 } else if ( mp->cur_cmd!=to_token ) {
23295 print_err("Missing `to' clause");
23296 help1("A write command should end with `to <filename>'");
23297 mp_put_get_error(mp);
23299 t=mp->cur_exp; mp->cur_type=mp_vacuous;
23301 mp_scan_expression(mp);
23302 if ( mp->cur_type!=mp_string_type )
23303 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23305 @<Write |t| to the file named by |cur_exp|@>;
23309 mp_flush_cur_exp(mp, 0);
23312 @ @<Write |t| to the file named by |cur_exp|@>=
23314 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23315 |cur_exp| must be inserted@>;
23316 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23317 @<Record the end of file on |wr_file[n]|@>;
23319 old_setting=mp->selector;
23320 mp->selector=n+write_file;
23321 mp_print_str(mp, t); mp_print_ln(mp);
23322 mp->selector = old_setting;
23326 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23328 char *fn = str(mp->cur_exp);
23330 n0=mp->write_files;
23331 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23332 if ( n==0 ) { /* bottom reached */
23333 if ( n0==mp->write_files ) {
23334 if ( mp->write_files<mp->max_write_files ) {
23335 incr(mp->write_files);
23340 l = mp->max_write_files + (mp->max_write_files>>2);
23341 wr_file = xmalloc((l+1),sizeof(void *));
23342 wr_fname = xmalloc((l+1),sizeof(char *));
23343 for (k=0;k<=l;k++) {
23344 if (k<=mp->max_write_files) {
23345 wr_file[k]=mp->wr_file[k];
23346 wr_fname[k]=mp->wr_fname[k];
23352 xfree(mp->wr_file); xfree(mp->wr_fname);
23353 mp->max_write_files = l;
23354 mp->wr_file = wr_file;
23355 mp->wr_fname = wr_fname;
23359 mp_open_write_file(mp, fn ,n);
23362 if ( mp->wr_fname[n]==NULL ) n0=n;
23367 @ @<Record the end of file on |wr_file[n]|@>=
23368 { (mp->close_file)(mp,mp->wr_file[n]);
23369 xfree(mp->wr_fname[n]);
23370 if ( n==mp->write_files-1 ) mp->write_files=n;
23374 @* \[42] Writing font metric data.
23375 \TeX\ gets its knowledge about fonts from font metric files, also called
23376 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23377 but other programs know about them too. One of \MP's duties is to
23378 write \.{TFM} files so that the user's fonts can readily be
23379 applied to typesetting.
23380 @:TFM files}{\.{TFM} files@>
23381 @^font metric files@>
23383 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23384 Since the number of bytes is always a multiple of~4, we could
23385 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23386 byte interpretation. The format of \.{TFM} files was designed by
23387 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23388 @^Ramshaw, Lyle Harold@>
23389 of information in a compact but useful form.
23392 void * tfm_file; /* the font metric output goes here */
23393 char * metric_file_name; /* full name of the font metric file */
23395 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23396 integers that give the lengths of the various subsequent portions
23397 of the file. These twelve integers are, in order:
23398 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23399 |lf|&length of the entire file, in words;\cr
23400 |lh|&length of the header data, in words;\cr
23401 |bc|&smallest character code in the font;\cr
23402 |ec|&largest character code in the font;\cr
23403 |nw|&number of words in the width table;\cr
23404 |nh|&number of words in the height table;\cr
23405 |nd|&number of words in the depth table;\cr
23406 |ni|&number of words in the italic correction table;\cr
23407 |nl|&number of words in the lig/kern table;\cr
23408 |nk|&number of words in the kern table;\cr
23409 |ne|&number of words in the extensible character table;\cr
23410 |np|&number of font parameter words.\cr}}$$
23411 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23413 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23414 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23415 and as few as 0 characters (if |bc=ec+1|).
23417 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23418 16 or more bits, the most significant bytes appear first in the file.
23419 This is called BigEndian order.
23420 @^BigEndian order@>
23422 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23425 The most important data type used here is a |fix_word|, which is
23426 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23427 quantity, with the two's complement of the entire word used to represent
23428 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23429 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23430 the smallest is $-2048$. We will see below, however, that all but two of
23431 the |fix_word| values must lie between $-16$ and $+16$.
23433 @ The first data array is a block of header information, which contains
23434 general facts about the font. The header must contain at least two words,
23435 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23436 header information of use to other software routines might also be
23437 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23438 For example, 16 more words of header information are in use at the Xerox
23439 Palo Alto Research Center; the first ten specify the character coding
23440 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23441 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23442 last gives the ``face byte.''
23444 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23445 the \.{GF} output file. This helps ensure consistency between files,
23446 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23447 should match the check sums on actual fonts that are used. The actual
23448 relation between this check sum and the rest of the \.{TFM} file is not
23449 important; the check sum is simply an identification number with the
23450 property that incompatible fonts almost always have distinct check sums.
23453 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23454 font, in units of \TeX\ points. This number must be at least 1.0; it is
23455 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23456 font, i.e., a font that was designed to look best at a 10-point size,
23457 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23458 $\delta$ \.{pt}', the effect is to override the design size and replace it
23459 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23460 the font image by a factor of $\delta$ divided by the design size. {\sl
23461 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23462 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23463 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23464 since many fonts have a design size equal to one em. The other dimensions
23465 must be less than 16 design-size units in absolute value; thus,
23466 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23467 \.{TFM} file whose first byte might be something besides 0 or 255.
23470 @ Next comes the |char_info| array, which contains one |char_info_word|
23471 per character. Each word in this part of the file contains six fields
23472 packed into four bytes as follows.
23474 \yskip\hang first byte: |width_index| (8 bits)\par
23475 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23477 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23479 \hang fourth byte: |remainder| (8 bits)\par
23481 The actual width of a character is \\{width}|[width_index]|, in design-size
23482 units; this is a device for compressing information, since many characters
23483 have the same width. Since it is quite common for many characters
23484 to have the same height, depth, or italic correction, the \.{TFM} format
23485 imposes a limit of 16 different heights, 16 different depths, and
23486 64 different italic corrections.
23488 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23489 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23490 value of zero. The |width_index| should never be zero unless the
23491 character does not exist in the font, since a character is valid if and
23492 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23494 @ The |tag| field in a |char_info_word| has four values that explain how to
23495 interpret the |remainder| field.
23497 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23498 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23499 program starting at location |remainder| in the |lig_kern| array.\par
23500 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23501 characters of ascending sizes, and not the largest in the chain. The
23502 |remainder| field gives the character code of the next larger character.\par
23503 \hang|tag=3| (|ext_tag|) means that this character code represents an
23504 extensible character, i.e., a character that is built up of smaller pieces
23505 so that it can be made arbitrarily large. The pieces are specified in
23506 |exten[remainder]|.\par
23508 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23509 unless they are used in special circumstances in math formulas. For example,
23510 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23511 operation looks for both |list_tag| and |ext_tag|.
23513 @d no_tag 0 /* vanilla character */
23514 @d lig_tag 1 /* character has a ligature/kerning program */
23515 @d list_tag 2 /* character has a successor in a charlist */
23516 @d ext_tag 3 /* character is extensible */
23518 @ The |lig_kern| array contains instructions in a simple programming language
23519 that explains what to do for special letter pairs. Each word in this array is a
23520 |lig_kern_command| of four bytes.
23522 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23523 step if the byte is 128 or more, otherwise the next step is obtained by
23524 skipping this number of intervening steps.\par
23525 \hang second byte: |next_char|, ``if |next_char| follows the current character,
23526 then perform the operation and stop, otherwise continue.''\par
23527 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
23528 a kern step otherwise.\par
23529 \hang fourth byte: |remainder|.\par
23532 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
23533 between the current character and |next_char|. This amount is
23534 often negative, so that the characters are brought closer together
23535 by kerning; but it might be positive.
23537 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
23538 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
23539 |remainder| is inserted between the current character and |next_char|;
23540 then the current character is deleted if $b=0$, and |next_char| is
23541 deleted if $c=0$; then we pass over $a$~characters to reach the next
23542 current character (which may have a ligature/kerning program of its own).
23544 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
23545 the |next_char| byte is the so-called right boundary character of this font;
23546 the value of |next_char| need not lie between |bc| and~|ec|.
23547 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
23548 there is a special ligature/kerning program for a left boundary character,
23549 beginning at location |256*op_byte+remainder|.
23550 The interpretation is that \TeX\ puts implicit boundary characters
23551 before and after each consecutive string of characters from the same font.
23552 These implicit characters do not appear in the output, but they can affect
23553 ligatures and kerning.
23555 If the very first instruction of a character's |lig_kern| program has
23556 |skip_byte>128|, the program actually begins in location
23557 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
23558 arrays, because the first instruction must otherwise
23559 appear in a location |<=255|.
23561 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
23563 $$\hbox{|256*op_byte+remainder<nl|.}$$
23564 If such an instruction is encountered during
23565 normal program execution, it denotes an unconditional halt; no ligature
23566 command is performed.
23569 /* value indicating `\.{STOP}' in a lig/kern program */
23570 @d kern_flag (128) /* op code for a kern step */
23571 @d skip_byte(A) mp->lig_kern[(A)].b0
23572 @d next_char(A) mp->lig_kern[(A)].b1
23573 @d op_byte(A) mp->lig_kern[(A)].b2
23574 @d rem_byte(A) mp->lig_kern[(A)].b3
23576 @ Extensible characters are specified by an |extensible_recipe|, which
23577 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
23578 order). These bytes are the character codes of individual pieces used to
23579 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
23580 present in the built-up result. For example, an extensible vertical line is
23581 like an extensible bracket, except that the top and bottom pieces are missing.
23583 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
23584 if the piece isn't present. Then the extensible characters have the form
23585 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
23586 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
23587 The width of the extensible character is the width of $R$; and the
23588 height-plus-depth is the sum of the individual height-plus-depths of the
23589 components used, since the pieces are butted together in a vertical list.
23591 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
23592 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
23593 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
23594 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
23596 @ The final portion of a \.{TFM} file is the |param| array, which is another
23597 sequence of |fix_word| values.
23599 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
23600 to help position accents. For example, |slant=.25| means that when you go
23601 up one unit, you also go .25 units to the right. The |slant| is a pure
23602 number; it is the only |fix_word| other than the design size itself that is
23603 not scaled by the design size.
23606 \hang|param[2]=space| is the normal spacing between words in text.
23607 Note that character 040 in the font need not have anything to do with
23610 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
23612 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
23614 \hang|param[5]=x_height| is the size of one ex in the font; it is also
23615 the height of letters for which accents don't have to be raised or lowered.
23617 \hang|param[6]=quad| is the size of one em in the font.
23619 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
23623 If fewer than seven parameters are present, \TeX\ sets the missing parameters
23628 @d space_stretch_code 3
23629 @d space_shrink_code 4
23632 @d extra_space_code 7
23634 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
23635 information, and it does this all at once at the end of a job.
23636 In order to prepare for such frenetic activity, it squirrels away the
23637 necessary facts in various arrays as information becomes available.
23639 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
23640 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
23641 |tfm_ital_corr|. Other information about a character (e.g., about
23642 its ligatures or successors) is accessible via the |char_tag| and
23643 |char_remainder| arrays. Other information about the font as a whole
23644 is kept in additional arrays called |header_byte|, |lig_kern|,
23645 |kern|, |exten|, and |param|.
23647 @d max_tfm_int 32510
23648 @d undefined_label max_tfm_int /* an undefined local label */
23651 #define TFM_ITEMS 257
23653 eight_bits ec; /* smallest and largest character codes shipped out */
23654 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
23655 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
23656 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
23657 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
23658 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
23659 int char_tag[TFM_ITEMS]; /* |remainder| category */
23660 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
23661 char *header_byte; /* bytes of the \.{TFM} header */
23662 int header_last; /* last initialized \.{TFM} header byte */
23663 int header_size; /* size of the \.{TFM} header */
23664 four_quarters *lig_kern; /* the ligature/kern table */
23665 short nl; /* the number of ligature/kern steps so far */
23666 scaled *kern; /* distinct kerning amounts */
23667 short nk; /* the number of distinct kerns so far */
23668 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
23669 short ne; /* the number of extensible characters so far */
23670 scaled *param; /* \&{fontinfo} parameters */
23671 short np; /* the largest \&{fontinfo} parameter specified so far */
23672 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
23673 short skip_table[TFM_ITEMS]; /* local label status */
23674 boolean lk_started; /* has there been a lig/kern step in this command yet? */
23675 integer bchar; /* right boundary character */
23676 short bch_label; /* left boundary starting location */
23677 short ll;short lll; /* registers used for lig/kern processing */
23678 short label_loc[257]; /* lig/kern starting addresses */
23679 eight_bits label_char[257]; /* characters for |label_loc| */
23680 short label_ptr; /* highest position occupied in |label_loc| */
23682 @ @<Allocate or initialize ...@>=
23683 mp->header_last = 0; mp->header_size = 128; /* just for init */
23684 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
23685 mp->lig_kern = NULL; /* allocated when needed */
23686 mp->kern = NULL; /* allocated when needed */
23687 mp->param = NULL; /* allocated when needed */
23689 @ @<Dealloc variables@>=
23690 xfree(mp->header_byte);
23691 xfree(mp->lig_kern);
23696 for (k=0;k<= 255;k++ ) {
23697 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
23698 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
23699 mp->skip_table[k]=undefined_label;
23701 memset(mp->header_byte,0,mp->header_size);
23702 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
23703 mp->internal[mp_boundary_char]=-unity;
23704 mp->bch_label=undefined_label;
23705 mp->label_loc[0]=-1; mp->label_ptr=0;
23707 @ @<Declarations@>=
23708 scaled mp_tfm_check (MP mp,small_number m) ;
23710 @ @<Declare the function called |tfm_check|@>=
23711 scaled mp_tfm_check (MP mp,small_number m) {
23712 if ( abs(mp->internal[m])>=fraction_half ) {
23713 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
23714 @.Enormous charwd...@>
23715 @.Enormous chardp...@>
23716 @.Enormous charht...@>
23717 @.Enormous charic...@>
23718 @.Enormous designsize...@>
23719 mp_print(mp, " has been reduced");
23720 help1("Font metric dimensions must be less than 2048pt.");
23721 mp_put_get_error(mp);
23722 if ( mp->internal[m]>0 ) return (fraction_half-1);
23723 else return (1-fraction_half);
23725 return mp->internal[m];
23729 @ @<Store the width information for character code~|c|@>=
23730 if ( c<mp->bc ) mp->bc=c;
23731 if ( c>mp->ec ) mp->ec=c;
23732 mp->char_exists[c]=true;
23733 mp->tfm_width[c]=mp_tfm_check(mp, mp_char_wd);
23734 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
23735 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
23736 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
23738 @ Now let's consider \MP's special \.{TFM}-oriented commands.
23740 @<Cases of |do_statement|...@>=
23741 case tfm_command: mp_do_tfm_command(mp); break;
23743 @ @d char_list_code 0
23744 @d lig_table_code 1
23745 @d extensible_code 2
23746 @d header_byte_code 3
23747 @d font_dimen_code 4
23750 mp_primitive(mp, "charlist",tfm_command,char_list_code);
23751 @:char_list_}{\&{charlist} primitive@>
23752 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
23753 @:lig_table_}{\&{ligtable} primitive@>
23754 mp_primitive(mp, "extensible",tfm_command,extensible_code);
23755 @:extensible_}{\&{extensible} primitive@>
23756 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
23757 @:header_byte_}{\&{headerbyte} primitive@>
23758 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
23759 @:font_dimen_}{\&{fontdimen} primitive@>
23761 @ @<Cases of |print_cmd...@>=
23764 case char_list_code:mp_print(mp, "charlist"); break;
23765 case lig_table_code:mp_print(mp, "ligtable"); break;
23766 case extensible_code:mp_print(mp, "extensible"); break;
23767 case header_byte_code:mp_print(mp, "headerbyte"); break;
23768 default: mp_print(mp, "fontdimen"); break;
23772 @ @<Declare action procedures for use by |do_statement|@>=
23773 eight_bits mp_get_code (MP mp) ;
23775 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
23776 integer c; /* the code value found */
23777 mp_get_x_next(mp); mp_scan_expression(mp);
23778 if ( mp->cur_type==mp_known ) {
23779 c=mp_round_unscaled(mp, mp->cur_exp);
23780 if ( c>=0 ) if ( c<256 ) return c;
23781 } else if ( mp->cur_type==mp_string_type ) {
23782 if ( length(mp->cur_exp)==1 ) {
23783 c=mp->str_pool[mp->str_start[mp->cur_exp]];
23787 exp_err("Invalid code has been replaced by 0");
23788 @.Invalid code...@>
23789 help2("I was looking for a number between 0 and 255, or for a")
23790 ("string of length 1. Didn't find it; will use 0 instead.");
23791 mp_put_get_flush_error(mp, 0); c=0;
23795 @ @<Declare action procedures for use by |do_statement|@>=
23796 void mp_set_tag (MP mp,halfword c, small_number t, halfword r) ;
23798 @ @c void mp_set_tag (MP mp,halfword c, small_number t, halfword r) {
23799 if ( mp->char_tag[c]==no_tag ) {
23800 mp->char_tag[c]=t; mp->char_remainder[c]=r;
23802 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
23803 mp->label_char[mp->label_ptr]=c;
23806 @<Complain about a character tag conflict@>;
23810 @ @<Complain about a character tag conflict@>=
23812 print_err("Character ");
23813 if ( (c>' ')&&(c<127) ) mp_print_char(mp,c);
23814 else if ( c==256 ) mp_print(mp, "||");
23815 else { mp_print(mp, "code "); mp_print_int(mp, c); };
23816 mp_print(mp, " is already ");
23817 @.Character c is already...@>
23818 switch (mp->char_tag[c]) {
23819 case lig_tag: mp_print(mp, "in a ligtable"); break;
23820 case list_tag: mp_print(mp, "in a charlist"); break;
23821 case ext_tag: mp_print(mp, "extensible"); break;
23822 } /* there are no other cases */
23823 help2("It's not legal to label a character more than once.")
23824 ("So I'll not change anything just now.");
23825 mp_put_get_error(mp);
23828 @ @<Declare action procedures for use by |do_statement|@>=
23829 void mp_do_tfm_command (MP mp) ;
23831 @ @c void mp_do_tfm_command (MP mp) {
23832 int c,cc; /* character codes */
23833 int k; /* index into the |kern| array */
23834 int j; /* index into |header_byte| or |param| */
23835 switch (mp->cur_mod) {
23836 case char_list_code:
23838 /* we will store a list of character successors */
23839 while ( mp->cur_cmd==colon ) {
23840 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
23843 case lig_table_code:
23844 if (mp->lig_kern==NULL)
23845 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
23846 if (mp->kern==NULL)
23847 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
23848 @<Store a list of ligature/kern steps@>;
23850 case extensible_code:
23851 @<Define an extensible recipe@>;
23853 case header_byte_code:
23854 case font_dimen_code:
23855 c=mp->cur_mod; mp_get_x_next(mp);
23856 mp_scan_expression(mp);
23857 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
23858 exp_err("Improper location");
23859 @.Improper location@>
23860 help2("I was looking for a known, positive number.")
23861 ("For safety's sake I'll ignore the present command.");
23862 mp_put_get_error(mp);
23864 j=mp_round_unscaled(mp, mp->cur_exp);
23865 if ( mp->cur_cmd!=colon ) {
23866 mp_missing_err(mp, ":");
23868 help1("A colon should follow a headerbyte or fontinfo location.");
23871 if ( c==header_byte_code ) {
23872 @<Store a list of header bytes@>;
23874 if (mp->param==NULL)
23875 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
23876 @<Store a list of font dimensions@>;
23880 } /* there are no other cases */
23883 @ @<Store a list of ligature/kern steps@>=
23885 mp->lk_started=false;
23888 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
23889 @<Process a |skip_to| command and |goto done|@>;
23890 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
23891 else { mp_back_input(mp); c=mp_get_code(mp); };
23892 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
23893 @<Record a label in a lig/kern subprogram and |goto continue|@>;
23895 if ( mp->cur_cmd==lig_kern_token ) {
23896 @<Compile a ligature/kern command@>;
23898 print_err("Illegal ligtable step");
23899 @.Illegal ligtable step@>
23900 help1("I was looking for `=:' or `kern' here.");
23901 mp_back_error(mp); next_char(mp->nl)=qi(0);
23902 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
23903 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
23905 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
23907 if ( mp->cur_cmd==comma ) goto CONTINUE;
23908 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
23913 mp_primitive(mp, "=:",lig_kern_token,0);
23914 @:=:_}{\.{=:} primitive@>
23915 mp_primitive(mp, "=:|",lig_kern_token,1);
23916 @:=:/_}{\.{=:\char'174} primitive@>
23917 mp_primitive(mp, "=:|>",lig_kern_token,5);
23918 @:=:/>_}{\.{=:\char'174>} primitive@>
23919 mp_primitive(mp, "|=:",lig_kern_token,2);
23920 @:=:/_}{\.{\char'174=:} primitive@>
23921 mp_primitive(mp, "|=:>",lig_kern_token,6);
23922 @:=:/>_}{\.{\char'174=:>} primitive@>
23923 mp_primitive(mp, "|=:|",lig_kern_token,3);
23924 @:=:/_}{\.{\char'174=:\char'174} primitive@>
23925 mp_primitive(mp, "|=:|>",lig_kern_token,7);
23926 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
23927 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
23928 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
23929 mp_primitive(mp, "kern",lig_kern_token,128);
23930 @:kern_}{\&{kern} primitive@>
23932 @ @<Cases of |print_cmd...@>=
23933 case lig_kern_token:
23935 case 0:mp_print(mp, "=:"); break;
23936 case 1:mp_print(mp, "=:|"); break;
23937 case 2:mp_print(mp, "|=:"); break;
23938 case 3:mp_print(mp, "|=:|"); break;
23939 case 5:mp_print(mp, "=:|>"); break;
23940 case 6:mp_print(mp, "|=:>"); break;
23941 case 7:mp_print(mp, "|=:|>"); break;
23942 case 11:mp_print(mp, "|=:|>>"); break;
23943 default: mp_print(mp, "kern"); break;
23947 @ Local labels are implemented by maintaining the |skip_table| array,
23948 where |skip_table[c]| is either |undefined_label| or the address of the
23949 most recent lig/kern instruction that skips to local label~|c|. In the
23950 latter case, the |skip_byte| in that instruction will (temporarily)
23951 be zero if there were no prior skips to this label, or it will be the
23952 distance to the prior skip.
23954 We may need to cancel skips that span more than 127 lig/kern steps.
23956 @d cancel_skips(A) mp->ll=(A);
23958 mp->lll=qo(skip_byte(mp->ll));
23959 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
23960 } while (mp->lll!=0)
23961 @d skip_error(A) { print_err("Too far to skip");
23962 @.Too far to skip@>
23963 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
23964 mp_error(mp); cancel_skips((A));
23967 @<Process a |skip_to| command and |goto done|@>=
23970 if ( mp->nl-mp->skip_table[c]>128 ) {
23971 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
23973 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
23974 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
23975 mp->skip_table[c]=mp->nl-1; goto DONE;
23978 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
23980 if ( mp->cur_cmd==colon ) {
23981 if ( c==256 ) mp->bch_label=mp->nl;
23982 else mp_set_tag(mp, c,lig_tag,mp->nl);
23983 } else if ( mp->skip_table[c]<undefined_label ) {
23984 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
23986 mp->lll=qo(skip_byte(mp->ll));
23987 if ( mp->nl-mp->ll>128 ) {
23988 skip_error(mp->ll); goto CONTINUE;
23990 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
23991 } while (mp->lll!=0);
23996 @ @<Compile a ligature/kern...@>=
23998 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
23999 if ( mp->cur_mod<128 ) { /* ligature op */
24000 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
24002 mp_get_x_next(mp); mp_scan_expression(mp);
24003 if ( mp->cur_type!=mp_known ) {
24004 exp_err("Improper kern");
24006 help2("The amount of kern should be a known numeric value.")
24007 ("I'm zeroing this one. Proceed, with fingers crossed.");
24008 mp_put_get_flush_error(mp, 0);
24010 mp->kern[mp->nk]=mp->cur_exp;
24012 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
24014 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
24017 op_byte(mp->nl)=kern_flag+(k / 256);
24018 rem_byte(mp->nl)=qi((k % 256));
24020 mp->lk_started=true;
24023 @ @d missing_extensible_punctuation(A)
24024 { mp_missing_err(mp, (A));
24025 @.Missing `\char`\#'@>
24026 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
24029 @<Define an extensible recipe@>=
24031 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
24032 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
24033 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
24034 ext_top(mp->ne)=qi(mp_get_code(mp));
24035 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24036 ext_mid(mp->ne)=qi(mp_get_code(mp));
24037 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24038 ext_bot(mp->ne)=qi(mp_get_code(mp));
24039 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24040 ext_rep(mp->ne)=qi(mp_get_code(mp));
24044 @ The header could contain ASCII zeroes, so can't use |strdup|.
24046 @<Store a list of header bytes@>=
24048 if ( j>=mp->header_size ) {
24049 int l = mp->header_size + (mp->header_size >> 2);
24050 char *t = xmalloc(l,sizeof(char));
24052 memcpy(t,mp->header_byte,mp->header_size);
24053 xfree (mp->header_byte);
24054 mp->header_byte = t;
24055 mp->header_size = l;
24057 mp->header_byte[j]=mp_get_code(mp);
24058 incr(j); incr(mp->header_last);
24059 } while (mp->cur_cmd==comma)
24061 @ @<Store a list of font dimensions@>=
24063 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
24064 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
24065 mp_get_x_next(mp); mp_scan_expression(mp);
24066 if ( mp->cur_type!=mp_known ){
24067 exp_err("Improper font parameter");
24068 @.Improper font parameter@>
24069 help1("I'm zeroing this one. Proceed, with fingers crossed.");
24070 mp_put_get_flush_error(mp, 0);
24072 mp->param[j]=mp->cur_exp; incr(j);
24073 } while (mp->cur_cmd==comma)
24075 @ OK: We've stored all the data that is needed for the \.{TFM} file.
24076 All that remains is to output it in the correct format.
24078 An interesting problem needs to be solved in this connection, because
24079 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
24080 and 64~italic corrections. If the data has more distinct values than
24081 this, we want to meet the necessary restrictions by perturbing the
24082 given values as little as possible.
24084 \MP\ solves this problem in two steps. First the values of a given
24085 kind (widths, heights, depths, or italic corrections) are sorted;
24086 then the list of sorted values is perturbed, if necessary.
24088 The sorting operation is facilitated by having a special node of
24089 essentially infinite |value| at the end of the current list.
24091 @<Initialize table entries...@>=
24092 value(inf_val)=fraction_four;
24094 @ Straight linear insertion is good enough for sorting, since the lists
24095 are usually not terribly long. As we work on the data, the current list
24096 will start at |link(temp_head)| and end at |inf_val|; the nodes in this
24097 list will be in increasing order of their |value| fields.
24099 Given such a list, the |sort_in| function takes a value and returns a pointer
24100 to where that value can be found in the list. The value is inserted in
24101 the proper place, if necessary.
24103 At the time we need to do these operations, most of \MP's work has been
24104 completed, so we will have plenty of memory to play with. The value nodes
24105 that are allocated for sorting will never be returned to free storage.
24107 @d clear_the_list link(temp_head)=inf_val
24109 @c pointer mp_sort_in (MP mp,scaled v) {
24110 pointer p,q,r; /* list manipulation registers */
24114 if ( v<=value(q) ) break;
24117 if ( v<value(q) ) {
24118 r=mp_get_node(mp, value_node_size); value(r)=v; link(r)=q; link(p)=r;
24123 @ Now we come to the interesting part, where we reduce the list if necessary
24124 until it has the required size. The |min_cover| routine is basic to this
24125 process; it computes the minimum number~|m| such that the values of the
24126 current sorted list can be covered by |m|~intervals of width~|d|. It
24127 also sets the global value |perturbation| to the smallest value $d'>d$
24128 such that the covering found by this algorithm would be different.
24130 In particular, |min_cover(0)| returns the number of distinct values in the
24131 current list and sets |perturbation| to the minimum distance between
24134 @c integer mp_min_cover (MP mp,scaled d) {
24135 pointer p; /* runs through the current list */
24136 scaled l; /* the least element covered by the current interval */
24137 integer m; /* lower bound on the size of the minimum cover */
24138 m=0; p=link(temp_head); mp->perturbation=el_gordo;
24139 while ( p!=inf_val ){
24140 incr(m); l=value(p);
24141 do { p=link(p); } while (value(p)<=l+d);
24142 if ( value(p)-l<mp->perturbation )
24143 mp->perturbation=value(p)-l;
24149 scaled perturbation; /* quantity related to \.{TFM} rounding */
24150 integer excess; /* the list is this much too long */
24152 @ The smallest |d| such that a given list can be covered with |m| intervals
24153 is determined by the |threshold| routine, which is sort of an inverse
24154 to |min_cover|. The idea is to increase the interval size rapidly until
24155 finding the range, then to go sequentially until the exact borderline has
24158 @c scaled mp_threshold (MP mp,integer m) {
24159 scaled d; /* lower bound on the smallest interval size */
24160 mp->excess=mp_min_cover(mp, 0)-m;
24161 if ( mp->excess<=0 ) {
24165 d=mp->perturbation;
24166 } while (mp_min_cover(mp, d+d)>m);
24167 while ( mp_min_cover(mp, d)>m )
24168 d=mp->perturbation;
24173 @ The |skimp| procedure reduces the current list to at most |m| entries,
24174 by changing values if necessary. It also sets |info(p):=k| if |value(p)|
24175 is the |k|th distinct value on the resulting list, and it sets
24176 |perturbation| to the maximum amount by which a |value| field has
24177 been changed. The size of the resulting list is returned as the
24180 @c integer mp_skimp (MP mp,integer m) {
24181 scaled d; /* the size of intervals being coalesced */
24182 pointer p,q,r; /* list manipulation registers */
24183 scaled l; /* the least value in the current interval */
24184 scaled v; /* a compromise value */
24185 d=mp_threshold(mp, m); mp->perturbation=0;
24186 q=temp_head; m=0; p=link(temp_head);
24187 while ( p!=inf_val ) {
24188 incr(m); l=value(p); info(p)=m;
24189 if ( value(link(p))<=l+d ) {
24190 @<Replace an interval of values by its midpoint@>;
24197 @ @<Replace an interval...@>=
24200 p=link(p); info(p)=m;
24201 decr(mp->excess); if ( mp->excess==0 ) d=0;
24202 } while (value(link(p))<=l+d);
24203 v=l+halfp(value(p)-l);
24204 if ( value(p)-v>mp->perturbation )
24205 mp->perturbation=value(p)-v;
24208 r=link(r); value(r)=v;
24210 link(q)=p; /* remove duplicate values from the current list */
24213 @ A warning message is issued whenever something is perturbed by
24214 more than 1/16\thinspace pt.
24216 @c void mp_tfm_warning (MP mp,small_number m) {
24217 mp_print_nl(mp, "(some ");
24218 mp_print(mp, mp->int_name[m]);
24219 @.some charwds...@>
24220 @.some chardps...@>
24221 @.some charhts...@>
24222 @.some charics...@>
24223 mp_print(mp, " values had to be adjusted by as much as ");
24224 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
24227 @ Here's an example of how we use these routines.
24228 The width data needs to be perturbed only if there are 256 distinct
24229 widths, but \MP\ must check for this case even though it is
24232 An integer variable |k| will be defined when we use this code.
24233 The |dimen_head| array will contain pointers to the sorted
24234 lists of dimensions.
24236 @<Massage the \.{TFM} widths@>=
24238 for (k=mp->bc;k<=mp->ec;k++) {
24239 if ( mp->char_exists[k] )
24240 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
24242 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=link(temp_head);
24243 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
24246 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
24248 @ Heights, depths, and italic corrections are different from widths
24249 not only because their list length is more severely restricted, but
24250 also because zero values do not need to be put into the lists.
24252 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
24254 for (k=mp->bc;k<=mp->ec;k++) {
24255 if ( mp->char_exists[k] ) {
24256 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
24257 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
24260 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=link(temp_head);
24261 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
24263 for (k=mp->bc;k<=mp->ec;k++) {
24264 if ( mp->char_exists[k] ) {
24265 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
24266 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
24269 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=link(temp_head);
24270 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
24272 for (k=mp->bc;k<=mp->ec;k++) {
24273 if ( mp->char_exists[k] ) {
24274 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
24275 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
24278 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=link(temp_head);
24279 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
24281 @ @<Initialize table entries...@>=
24282 value(zero_val)=0; info(zero_val)=0;
24284 @ Bytes 5--8 of the header are set to the design size, unless the user has
24285 some crazy reason for specifying them differently.
24288 Error messages are not allowed at the time this procedure is called,
24289 so a warning is printed instead.
24291 The value of |max_tfm_dimen| is calculated so that
24292 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
24293 < \\{three\_bytes}.$$
24295 @d three_bytes 0100000000 /* $2^{24}$ */
24298 void mp_fix_design_size (MP mp) {
24299 scaled d; /* the design size */
24300 d=mp->internal[mp_design_size];
24301 if ( (d<unity)||(d>=fraction_half) ) {
24303 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24304 @.illegal design size...@>
24305 d=040000000; mp->internal[mp_design_size]=d;
24307 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24308 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24309 mp->header_byte[4]=d / 04000000;
24310 mp->header_byte[5]=(d / 4096) % 256;
24311 mp->header_byte[6]=(d / 16) % 256;
24312 mp->header_byte[7]=(d % 16)*16;
24314 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
24315 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24318 @ The |dimen_out| procedure computes a |fix_word| relative to the
24319 design size. If the data was out of range, it is corrected and the
24320 global variable |tfm_changed| is increased by~one.
24322 @c integer mp_dimen_out (MP mp,scaled x) {
24323 if ( abs(x)>mp->max_tfm_dimen ) {
24324 incr(mp->tfm_changed);
24325 if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
24327 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24332 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24333 integer tfm_changed; /* the number of data entries that were out of bounds */
24335 @ If the user has not specified any of the first four header bytes,
24336 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24337 from the |tfm_width| data relative to the design size.
24340 @c void mp_fix_check_sum (MP mp) {
24341 eight_bits k; /* runs through character codes */
24342 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24343 integer x; /* hash value used in check sum computation */
24344 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24345 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24346 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24347 mp->header_byte[0]=B1; mp->header_byte[1]=B2;
24348 mp->header_byte[2]=B3; mp->header_byte[3]=B4;
24353 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24354 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24355 for (k=mp->bc;k<=mp->ec;k++) {
24356 if ( mp->char_exists[k] ) {
24357 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24358 B1=(B1+B1+x) % 255;
24359 B2=(B2+B2+x) % 253;
24360 B3=(B3+B3+x) % 251;
24361 B4=(B4+B4+x) % 247;
24365 @ Finally we're ready to actually write the \.{TFM} information.
24366 Here are some utility routines for this purpose.
24368 @d tfm_out(A) do { /* output one byte to |tfm_file| */
24369 unsigned char s=(A);
24370 (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
24373 @c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24374 tfm_out(x / 256); tfm_out(x % 256);
24376 void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24377 if ( x>=0 ) tfm_out(x / three_bytes);
24379 x=x+010000000000; /* use two's complement for negative values */
24381 tfm_out((x / three_bytes) + 128);
24383 x=x % three_bytes; tfm_out(x / unity);
24384 x=x % unity; tfm_out(x / 0400);
24387 void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24388 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24389 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24392 @ @<Finish the \.{TFM} file@>=
24393 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24394 mp_pack_job_name(mp, ".tfm");
24395 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24396 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24397 mp->metric_file_name=xstrdup(mp->name_of_file);
24398 @<Output the subfile sizes and header bytes@>;
24399 @<Output the character information bytes, then
24400 output the dimensions themselves@>;
24401 @<Output the ligature/kern program@>;
24402 @<Output the extensible character recipes and the font metric parameters@>;
24403 if ( mp->internal[mp_tracing_stats]>0 )
24404 @<Log the subfile sizes of the \.{TFM} file@>;
24405 mp_print_nl(mp, "Font metrics written on ");
24406 mp_print(mp, mp->metric_file_name); mp_print_char(mp, '.');
24407 @.Font metrics written...@>
24408 (mp->close_file)(mp,mp->tfm_file)
24410 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24413 @<Output the subfile sizes and header bytes@>=
24415 LH=(k+3) / 4; /* this is the number of header words */
24416 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24417 @<Compute the ligature/kern program offset and implant the
24418 left boundary label@>;
24419 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24420 +lk_offset+mp->nk+mp->ne+mp->np);
24421 /* this is the total number of file words that will be output */
24422 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24423 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24424 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24425 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24426 mp_tfm_two(mp, mp->np);
24427 for (k=0;k< 4*LH;k++) {
24428 tfm_out(mp->header_byte[k]);
24431 @ @<Output the character information bytes...@>=
24432 for (k=mp->bc;k<=mp->ec;k++) {
24433 if ( ! mp->char_exists[k] ) {
24434 mp_tfm_four(mp, 0);
24436 tfm_out(info(mp->tfm_width[k])); /* the width index */
24437 tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
24438 tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24439 tfm_out(mp->char_remainder[k]);
24443 for (k=1;k<=4;k++) {
24444 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24445 while ( p!=inf_val ) {
24446 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=link(p);
24451 @ We need to output special instructions at the beginning of the
24452 |lig_kern| array in order to specify the right boundary character
24453 and/or to handle starting addresses that exceed 255. The |label_loc|
24454 and |label_char| arrays have been set up to record all the
24455 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24456 \le|label_loc|[|label_ptr]|$.
24458 @<Compute the ligature/kern program offset...@>=
24459 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24460 if ((mp->bchar<0)||(mp->bchar>255))
24461 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24462 else { mp->lk_started=true; lk_offset=1; };
24463 @<Find the minimum |lk_offset| and adjust all remainders@>;
24464 if ( mp->bch_label<undefined_label )
24465 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24466 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24467 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24468 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24471 @ @<Find the minimum |lk_offset|...@>=
24472 k=mp->label_ptr; /* pointer to the largest unallocated label */
24473 if ( mp->label_loc[k]+lk_offset>255 ) {
24474 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24476 mp->char_remainder[mp->label_char[k]]=lk_offset;
24477 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24478 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24480 incr(lk_offset); decr(k);
24481 } while (! (lk_offset+mp->label_loc[k]<256));
24482 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24484 if ( lk_offset>0 ) {
24486 mp->char_remainder[mp->label_char[k]]
24487 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24492 @ @<Output the ligature/kern program@>=
24493 for (k=0;k<= 255;k++ ) {
24494 if ( mp->skip_table[k]<undefined_label ) {
24495 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24496 @.local label l:: was missing@>
24497 cancel_skips(mp->skip_table[k]);
24500 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24501 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24503 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24504 mp->ll=mp->label_loc[mp->label_ptr];
24505 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24506 else { tfm_out(255); tfm_out(mp->bchar); };
24507 mp_tfm_two(mp, mp->ll+lk_offset);
24509 decr(mp->label_ptr);
24510 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24513 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24514 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24516 @ @<Output the extensible character recipes...@>=
24517 for (k=0;k<=mp->ne-1;k++)
24518 mp_tfm_qqqq(mp, mp->exten[k]);
24519 for (k=1;k<=mp->np;k++) {
24521 if ( abs(mp->param[1])<fraction_half ) {
24522 mp_tfm_four(mp, mp->param[1]*16);
24524 incr(mp->tfm_changed);
24525 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
24526 else mp_tfm_four(mp, -el_gordo);
24529 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
24532 if ( mp->tfm_changed>0 ) {
24533 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
24534 @.a font metric dimension...@>
24536 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
24537 @.font metric dimensions...@>
24538 mp_print(mp, " font metric dimensions");
24540 mp_print(mp, " had to be decreased)");
24543 @ @<Log the subfile sizes of the \.{TFM} file@>=
24547 if ( mp->bch_label<undefined_label ) decr(mp->nl);
24548 mp_snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
24549 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
24553 @* \[43] Reading font metric data.
24555 \MP\ isn't a typesetting program but it does need to find the bounding box
24556 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
24557 well as write them.
24562 @ All the width, height, and depth information is stored in an array called
24563 |font_info|. This array is allocated sequentially and each font is stored
24564 as a series of |char_info| words followed by the width, height, and depth
24565 tables. Since |font_name| entries are permanent, their |str_ref| values are
24566 set to |max_str_ref|.
24569 typedef unsigned int font_number; /* |0..font_max| */
24571 @ The |font_info| array is indexed via a group directory arrays.
24572 For example, the |char_info| data for character~|c| in font~|f| will be
24573 in |font_info[char_base[f]+c].qqqq|.
24576 font_number font_max; /* maximum font number for included text fonts */
24577 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
24578 memory_word *font_info; /* height, width, and depth data */
24579 char **font_enc_name; /* encoding names, if any */
24580 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
24581 int next_fmem; /* next unused entry in |font_info| */
24582 font_number last_fnum; /* last font number used so far */
24583 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
24584 char **font_name; /* name as specified in the \&{infont} command */
24585 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
24586 font_number last_ps_fnum; /* last valid |font_ps_name| index */
24587 eight_bits *font_bc;
24588 eight_bits *font_ec; /* first and last character code */
24589 int *char_base; /* base address for |char_info| */
24590 int *width_base; /* index for zeroth character width */
24591 int *height_base; /* index for zeroth character height */
24592 int *depth_base; /* index for zeroth character depth */
24593 pointer *font_sizes;
24595 @ @<Allocate or initialize ...@>=
24596 mp->font_mem_size = 10000;
24597 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
24598 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
24599 mp->font_enc_name = NULL;
24600 mp->font_ps_name_fixed = NULL;
24601 mp->font_dsize = NULL;
24602 mp->font_name = NULL;
24603 mp->font_ps_name = NULL;
24604 mp->font_bc = NULL;
24605 mp->font_ec = NULL;
24606 mp->last_fnum = null_font;
24607 mp->char_base = NULL;
24608 mp->width_base = NULL;
24609 mp->height_base = NULL;
24610 mp->depth_base = NULL;
24611 mp->font_sizes = null;
24613 @ @<Dealloc variables@>=
24614 for (k=1;k<=(int)mp->last_fnum;k++) {
24615 xfree(mp->font_enc_name[k]);
24616 xfree(mp->font_name[k]);
24617 xfree(mp->font_ps_name[k]);
24619 xfree(mp->font_info);
24620 xfree(mp->font_enc_name);
24621 xfree(mp->font_ps_name_fixed);
24622 xfree(mp->font_dsize);
24623 xfree(mp->font_name);
24624 xfree(mp->font_ps_name);
24625 xfree(mp->font_bc);
24626 xfree(mp->font_ec);
24627 xfree(mp->char_base);
24628 xfree(mp->width_base);
24629 xfree(mp->height_base);
24630 xfree(mp->depth_base);
24631 xfree(mp->font_sizes);
24635 void mp_reallocate_fonts (MP mp, font_number l) {
24637 XREALLOC(mp->font_enc_name, l, char *);
24638 XREALLOC(mp->font_ps_name_fixed, l, boolean);
24639 XREALLOC(mp->font_dsize, l, scaled);
24640 XREALLOC(mp->font_name, l, char *);
24641 XREALLOC(mp->font_ps_name, l, char *);
24642 XREALLOC(mp->font_bc, l, eight_bits);
24643 XREALLOC(mp->font_ec, l, eight_bits);
24644 XREALLOC(mp->char_base, l, int);
24645 XREALLOC(mp->width_base, l, int);
24646 XREALLOC(mp->height_base, l, int);
24647 XREALLOC(mp->depth_base, l, int);
24648 XREALLOC(mp->font_sizes, l, pointer);
24649 for (f=(mp->last_fnum+1);f<=l;f++) {
24650 mp->font_enc_name[f]=NULL;
24651 mp->font_ps_name_fixed[f] = false;
24652 mp->font_name[f]=NULL;
24653 mp->font_ps_name[f]=NULL;
24654 mp->font_sizes[f]=null;
24659 @ @<Declare |mp_reallocate| functions@>=
24660 void mp_reallocate_fonts (MP mp, font_number l);
24663 @ A |null_font| containing no characters is useful for error recovery. Its
24664 |font_name| entry starts out empty but is reset each time an erroneous font is
24665 found. This helps to cut down on the number of duplicate error messages without
24666 wasting a lot of space.
24668 @d null_font 0 /* the |font_number| for an empty font */
24670 @<Set initial...@>=
24671 mp->font_dsize[null_font]=0;
24672 mp->font_bc[null_font]=1;
24673 mp->font_ec[null_font]=0;
24674 mp->char_base[null_font]=0;
24675 mp->width_base[null_font]=0;
24676 mp->height_base[null_font]=0;
24677 mp->depth_base[null_font]=0;
24679 mp->last_fnum=null_font;
24680 mp->last_ps_fnum=null_font;
24681 mp->font_name[null_font]=(char *)"nullfont";
24682 mp->font_ps_name[null_font]=(char *)"";
24683 mp->font_ps_name_fixed[null_font] = false;
24684 mp->font_enc_name[null_font]=NULL;
24685 mp->font_sizes[null_font]=null;
24687 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
24688 the |width index|; the |b1| field contains the height
24689 index; the |b2| fields contains the depth index, and the |b3| field used only
24690 for temporary storage. (It is used to keep track of which characters occur in
24691 an edge structure that is being shipped out.)
24692 The corresponding words in the width, height, and depth tables are stored as
24693 |scaled| values in units of \ps\ points.
24695 With the macros below, the |char_info| word for character~|c| in font~|f| is
24696 |char_info(f)(c)| and the width is
24697 $$\hbox{|char_width(f)(char_info(f)(c)).sc|.}$$
24699 @d char_info_end(A) (A)].qqqq
24700 @d char_info(A) mp->font_info[mp->char_base[(A)]+char_info_end
24701 @d char_width_end(A) (A).b0].sc
24702 @d char_width(A) mp->font_info[mp->width_base[(A)]+char_width_end
24703 @d char_height_end(A) (A).b1].sc
24704 @d char_height(A) mp->font_info[mp->height_base[(A)]+char_height_end
24705 @d char_depth_end(A) (A).b2].sc
24706 @d char_depth(A) mp->font_info[mp->depth_base[(A)]+char_depth_end
24707 @d ichar_exists(A) ((A).b0>0)
24709 @ The |font_ps_name| for a built-in font should be what PostScript expects.
24710 A preliminary name is obtained here from the \.{TFM} name as given in the
24711 |fname| argument. This gets updated later from an external table if necessary.
24713 @<Declare text measuring subroutines@>=
24714 @<Declare subroutines for parsing file names@>
24715 font_number mp_read_font_info (MP mp, char *fname) {
24716 boolean file_opened; /* has |tfm_infile| been opened? */
24717 font_number n; /* the number to return */
24718 halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
24719 size_t whd_size; /* words needed for heights, widths, and depths */
24720 int i,ii; /* |font_info| indices */
24721 int jj; /* counts bytes to be ignored */
24722 scaled z; /* used to compute the design size */
24724 /* height, width, or depth as a fraction of design size times $2^{-8}$ */
24725 eight_bits h_and_d; /* height and depth indices being unpacked */
24726 unsigned char tfbyte; /* a byte read from the file */
24728 @<Open |tfm_infile| for input@>;
24729 @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
24730 otherwise |goto bad_tfm| or |goto done| as appropriate@>;
24732 @<Complain that the \.{TFM} file is bad@>;
24734 if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
24735 if ( n!=null_font ) {
24736 mp->font_ps_name[n]=mp_xstrdup(mp,fname);
24737 mp->font_name[n]=mp_xstrdup(mp,fname);
24742 @ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
24743 precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
24744 @.TFtoPL@> @.PLtoTF@>
24745 and \.{PLtoTF} can be used to debug \.{TFM} files.
24747 @<Complain that the \.{TFM} file is bad@>=
24748 print_err("Font ");
24749 mp_print(mp, fname);
24750 if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
24751 else mp_print(mp, " not usable: TFM file not found");
24752 help3("I wasn't able to read the size data for this font so this")
24753 ("`infont' operation won't produce anything. If the font name")
24754 ("is right, you might ask an expert to make a TFM file");
24756 mp->help_line[0]="is right, try asking an expert to fix the TFM file";
24759 @ @<Read data from |tfm_infile|; if there is no room, say so...@>=
24760 @<Read the \.{TFM} size fields@>;
24761 @<Use the size fields to allocate space in |font_info|@>;
24762 @<Read the \.{TFM} header@>;
24763 @<Read the character data and the width, height, and depth tables and
24766 @ A bad \.{TFM} file can be shorter than it claims to be. The code given here
24767 might try to read past the end of the file if this happens. Changes will be
24768 needed if it causes a system error to refer to |tfm_infile^| or call
24769 |get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
24770 @^system dependencies@>
24771 of |tfget| could be changed to
24772 ``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
24776 void *tfbyte_ptr = &tfbyte;
24777 (mp->read_binary_file)(mp,mp->tfm_infile,&tfbyte_ptr,&wanted);
24778 if (wanted==0) goto BAD_TFM;
24780 @d read_two(A) { (A)=tfbyte;
24781 if ( (A)>127 ) goto BAD_TFM;
24782 tfget; (A)=(A)*0400+tfbyte;
24784 @d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
24786 @<Read the \.{TFM} size fields@>=
24787 tfget; read_two(lf);
24788 tfget; read_two(tfm_lh);
24789 tfget; read_two(bc);
24790 tfget; read_two(ec);
24791 if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
24792 tfget; read_two(nw);
24793 tfget; read_two(nh);
24794 tfget; read_two(nd);
24795 whd_size=(ec+1-bc)+nw+nh+nd;
24796 if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
24799 @ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
24800 necessary to apply the |so| and |qo| macros when looking up the width of a
24801 character in the string pool. In order to ensure nonnegative |char_base|
24802 values when |bc>0|, it may be necessary to reserve a few unused |font_info|
24805 @<Use the size fields to allocate space in |font_info|@>=
24806 if ( mp->next_fmem<bc) mp->next_fmem=bc; /* ensure nonnegative |char_base| */
24807 if (mp->last_fnum==mp->font_max)
24808 mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max>>2)));
24809 while (mp->next_fmem+whd_size>=mp->font_mem_size) {
24810 size_t l = mp->font_mem_size+(mp->font_mem_size>>2);
24811 memory_word *font_info;
24812 font_info = xmalloc ((l+1),sizeof(memory_word));
24813 memset (font_info,0,sizeof(memory_word)*(l+1));
24814 memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
24815 xfree(mp->font_info);
24816 mp->font_info = font_info;
24817 mp->font_mem_size = l;
24819 incr(mp->last_fnum);
24823 mp->char_base[n]=mp->next_fmem-bc;
24824 mp->width_base[n]=mp->next_fmem+ec-bc+1;
24825 mp->height_base[n]=mp->width_base[n]+nw;
24826 mp->depth_base[n]=mp->height_base[n]+nh;
24827 mp->next_fmem=mp->next_fmem+whd_size;
24830 @ @<Read the \.{TFM} header@>=
24831 if ( tfm_lh<2 ) goto BAD_TFM;
24833 tfget; read_two(z);
24834 tfget; z=z*0400+tfbyte;
24835 tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
24836 mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
24837 /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
24838 tf_ignore(4*(tfm_lh-2))
24840 @ @<Read the character data and the width, height, and depth tables...@>=
24841 ii=mp->width_base[n];
24842 i=mp->char_base[n]+bc;
24844 tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
24845 tfget; h_and_d=tfbyte;
24846 mp->font_info[i].qqqq.b1=h_and_d / 16;
24847 mp->font_info[i].qqqq.b2=h_and_d % 16;
24851 while ( i<mp->next_fmem ) {
24852 @<Read a four byte dimension, scale it by the design size, store it in
24853 |font_info[i]|, and increment |i|@>;
24857 @ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
24858 interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
24859 we can multiply it by sixteen and think of it as a |fraction| that has been
24860 divided by sixteen. This cancels the extra scale factor contained in
24863 @<Read a four byte dimension, scale it by the design size, store it in...@>=
24866 if ( d>=0200 ) d=d-0400;
24867 tfget; d=d*0400+tfbyte;
24868 tfget; d=d*0400+tfbyte;
24869 tfget; d=d*0400+tfbyte;
24870 mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
24874 @ This function does no longer use the file name parser, because |fname| is
24875 a C string already.
24876 @<Open |tfm_infile| for input@>=
24878 mp_ptr_scan_file(mp, fname);
24879 if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); }
24880 if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
24882 mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
24883 if ( !mp->tfm_infile ) goto BAD_TFM;
24886 @ When we have a font name and we don't know whether it has been loaded yet,
24887 we scan the |font_name| array before calling |read_font_info|.
24889 @<Declare text measuring subroutines@>=
24890 font_number mp_find_font (MP mp, char *f) {
24892 for (n=0;n<=mp->last_fnum;n++) {
24893 if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
24898 n = mp_read_font_info(mp, f);
24903 @ This is an interface function for getting the width of character,
24904 as a double in ps units
24906 @c double mp_get_char_width (MP mp, char *fname, int c) {
24911 for (n=0;n<=mp->last_fnum;n++) {
24912 if (mp_xstrcmp(fname,mp->font_name[n])==0 ) {
24919 cc = char_info(f)(c);
24920 if (! ichar_exists(cc) )
24922 w = char_width(f)(cc);
24923 return w/655.35*(72.27/72);
24926 @ @<Exported function ...@>=
24927 double mp_get_char_width (MP mp, char *fname, int n);
24930 @ One simple application of |find_font| is the implementation of the |font_size|
24931 operator that gets the design size for a given font name.
24933 @<Find the design size of the font whose name is |cur_exp|@>=
24934 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
24936 @ If we discover that the font doesn't have a requested character, we omit it
24937 from the bounding box computation and expect the \ps\ interpreter to drop it.
24938 This routine issues a warning message if the user has asked for it.
24940 @<Declare text measuring subroutines@>=
24941 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
24942 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
24943 mp_begin_diagnostic(mp);
24944 if ( mp->selector==log_only ) incr(mp->selector);
24945 mp_print_nl(mp, "Missing character: There is no ");
24946 @.Missing character@>
24947 mp_print_str(mp, mp->str_pool[k]);
24948 mp_print(mp, " in font ");
24949 mp_print(mp, mp->font_name[f]); mp_print_char(mp, '!');
24950 mp_end_diagnostic(mp, false);
24954 @ The whole purpose of saving the height, width, and depth information is to be
24955 able to find the bounding box of an item of text in an edge structure. The
24956 |set_text_box| procedure takes a text node and adds this information.
24958 @<Declare text measuring subroutines@>=
24959 void mp_set_text_box (MP mp,pointer p) {
24960 font_number f; /* |font_n(p)| */
24961 ASCII_code bc,ec; /* range of valid characters for font |f| */
24962 pool_pointer k,kk; /* current character and character to stop at */
24963 four_quarters cc; /* the |char_info| for the current character */
24964 scaled h,d; /* dimensions of the current character */
24966 height_val(p)=-el_gordo;
24967 depth_val(p)=-el_gordo;
24971 kk=str_stop(text_p(p));
24972 k=mp->str_start[text_p(p)];
24974 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
24976 @<Set the height and depth to zero if the bounding box is empty@>;
24979 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
24981 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
24982 mp_lost_warning(mp, f,k);
24984 cc=char_info(f)(mp->str_pool[k]);
24985 if ( ! ichar_exists(cc) ) {
24986 mp_lost_warning(mp, f,k);
24988 width_val(p)=width_val(p)+char_width(f)(cc);
24989 h=char_height(f)(cc);
24990 d=char_depth(f)(cc);
24991 if ( h>height_val(p) ) height_val(p)=h;
24992 if ( d>depth_val(p) ) depth_val(p)=d;
24998 @ Let's hope modern compilers do comparisons correctly when the difference would
25001 @<Set the height and depth to zero if the bounding box is empty@>=
25002 if ( height_val(p)<-depth_val(p) ) {
25007 @ The new primitives fontmapfile and fontmapline.
25009 @<Declare action procedures for use by |do_statement|@>=
25010 void mp_do_mapfile (MP mp) ;
25011 void mp_do_mapline (MP mp) ;
25013 @ @c void mp_do_mapfile (MP mp) {
25014 mp_get_x_next(mp); mp_scan_expression(mp);
25015 if ( mp->cur_type!=mp_string_type ) {
25016 @<Complain about improper map operation@>;
25018 mp_map_file(mp,mp->cur_exp);
25021 void mp_do_mapline (MP mp) {
25022 mp_get_x_next(mp); mp_scan_expression(mp);
25023 if ( mp->cur_type!=mp_string_type ) {
25024 @<Complain about improper map operation@>;
25026 mp_map_line(mp,mp->cur_exp);
25030 @ @<Complain about improper map operation@>=
25032 exp_err("Unsuitable expression");
25033 help1("Only known strings can be map files or map lines.");
25034 mp_put_get_error(mp);
25037 @ To print |scaled| value to PDF output we need some subroutines to ensure
25040 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
25043 scaled one_bp; /* scaled value corresponds to 1bp */
25044 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
25045 scaled one_hundred_inch; /* scaled value corresponds to 100in */
25046 integer ten_pow[10]; /* $10^0..10^9$ */
25047 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
25050 mp->one_bp = 65782; /* 65781.76 */
25051 mp->one_hundred_bp = 6578176;
25052 mp->one_hundred_inch = 473628672;
25053 mp->ten_pow[0] = 1;
25054 for (i = 1;i<= 9; i++ ) {
25055 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
25058 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
25060 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
25064 if ( s < 0 ) { sign = -sign; s = -s; }
25065 if ( m < 0 ) { sign = -sign; m = -m; }
25067 mp_confusion(mp, "arithmetic: divided by zero");
25068 else if ( m >= (max_integer / 10) )
25069 mp_confusion(mp, "arithmetic: number too big");
25072 for (i = 1;i<=dd;i++) {
25073 q = 10*q + (10*r) / m;
25076 if ( 2*r >= m ) { incr(q); r = r - m; }
25077 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
25081 @* \[44] Shipping pictures out.
25082 The |ship_out| procedure, to be described below, is given a pointer to
25083 an edge structure. Its mission is to output a file containing the \ps\
25084 description of an edge structure.
25086 @ Each time an edge structure is shipped out we write a new \ps\ output
25087 file named according to the current \&{charcode}.
25088 @:char_code_}{\&{charcode} primitive@>
25090 This is the only backend function that remains in the main |mpost.w| file.
25091 There are just too many variable accesses needed for status reporting
25092 etcetera to make it worthwile to move the code to |psout.w|.
25094 @<Internal library declarations@>=
25095 void mp_open_output_file (MP mp) ;
25098 char *mp_set_output_file_name (MP mp, integer c) {
25099 char *ss = NULL; /* filename extension proposal */
25100 char *nn = NULL; /* temp string for str() */
25101 int old_setting; /* previous |selector| setting */
25102 pool_pointer i; /* indexes into |filename_template| */
25103 integer cc; /* a temporary integer for template building */
25104 integer f,g=0; /* field widths */
25105 if ( mp->job_name==NULL ) mp_open_log_file(mp);
25106 if ( mp->filename_template==0 ) {
25107 char *s; /* a file extension derived from |c| */
25111 @<Use |c| to compute the file extension |s|@>;
25112 mp_pack_job_name(mp, s);
25114 } else { /* initializations */
25115 str_number s, n; /* a file extension derived from |c| */
25116 old_setting=mp->selector;
25117 mp->selector=new_string;
25119 i = mp->str_start[mp->filename_template];
25120 n = rts(""); /* initialize */
25121 while ( i<str_stop(mp->filename_template) ) {
25122 if ( mp->str_pool[i]=='%' ) {
25125 if ( i<str_stop(mp->filename_template) ) {
25126 if ( mp->str_pool[i]=='j' ) {
25127 mp_print(mp, mp->job_name);
25128 } else if ( mp->str_pool[i]=='d' ) {
25129 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
25130 print_with_leading_zeroes(cc);
25131 } else if ( mp->str_pool[i]=='m' ) {
25132 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
25133 print_with_leading_zeroes(cc);
25134 } else if ( mp->str_pool[i]=='y' ) {
25135 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
25136 print_with_leading_zeroes(cc);
25137 } else if ( mp->str_pool[i]=='H' ) {
25138 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
25139 print_with_leading_zeroes(cc);
25140 } else if ( mp->str_pool[i]=='M' ) {
25141 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
25142 print_with_leading_zeroes(cc);
25143 } else if ( mp->str_pool[i]=='c' ) {
25144 if ( c<0 ) mp_print(mp, "ps");
25145 else print_with_leading_zeroes(c);
25146 } else if ( (mp->str_pool[i]>='0') &&
25147 (mp->str_pool[i]<='9') ) {
25149 f = (f*10) + mp->str_pool[i]-'0';
25152 mp_print_str(mp, mp->str_pool[i]);
25156 if ( mp->str_pool[i]=='.' )
25158 n = mp_make_string(mp);
25159 mp_print_str(mp, mp->str_pool[i]);
25163 s = mp_make_string(mp);
25164 mp->selector= old_setting;
25165 if (length(n)==0) {
25171 mp_pack_file_name(mp, nn,"",ss);
25179 char * mp_get_output_file_name (MP mp) {
25181 char *saved_name; /* saved |name_of_file| */
25182 saved_name = mp_xstrdup(mp, mp->name_of_file);
25183 junk = mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code]));
25185 mp_pack_file_name(mp, saved_name,NULL,NULL);
25187 return mp->name_of_file;
25190 void mp_open_output_file (MP mp) {
25191 char *ss; /* filename extension proposal */
25192 integer c; /* \&{charcode} rounded to the nearest integer */
25193 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25194 ss = mp_set_output_file_name(mp, c);
25195 while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
25196 mp_prompt_file_name(mp, "file name for output",ss);
25198 @<Store the true output file name if appropriate@>;
25201 @ The file extension created here could be up to five characters long in
25202 extreme cases so it may have to be shortened on some systems.
25203 @^system dependencies@>
25205 @<Use |c| to compute the file extension |s|@>=
25208 mp_snprintf(s,7,".%i",(int)c);
25211 @ The user won't want to see all the output file names so we only save the
25212 first and last ones and a count of how many there were. For this purpose
25213 files are ordered primarily by \&{charcode} and secondarily by order of
25215 @:char_code_}{\&{charcode} primitive@>
25217 @<Store the true output file name if appropriate@>=
25218 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
25219 mp->first_output_code=c;
25220 xfree(mp->first_file_name);
25221 mp->first_file_name=xstrdup(mp->name_of_file);
25223 if ( c>=mp->last_output_code ) {
25224 mp->last_output_code=c;
25225 xfree(mp->last_file_name);
25226 mp->last_file_name=xstrdup(mp->name_of_file);
25230 char * first_file_name;
25231 char * last_file_name; /* full file names */
25232 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
25233 @:char_code_}{\&{charcode} primitive@>
25234 integer total_shipped; /* total number of |ship_out| operations completed */
25237 mp->first_file_name=xstrdup("");
25238 mp->last_file_name=xstrdup("");
25239 mp->first_output_code=32768;
25240 mp->last_output_code=-32768;
25241 mp->total_shipped=0;
25243 @ @<Dealloc variables@>=
25244 xfree(mp->first_file_name);
25245 xfree(mp->last_file_name);
25247 @ @<Begin the progress report for the output of picture~|c|@>=
25248 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
25249 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
25250 mp_print_char(mp, '[');
25251 if ( c>=0 ) mp_print_int(mp, c)
25253 @ @<End progress report@>=
25254 mp_print_char(mp, ']');
25256 incr(mp->total_shipped)
25258 @ @<Explain what output files were written@>=
25259 if ( mp->total_shipped>0 ) {
25260 mp_print_nl(mp, "");
25261 mp_print_int(mp, mp->total_shipped);
25262 mp_print(mp, " output file");
25263 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
25264 mp_print(mp, " written: ");
25265 mp_print(mp, mp->first_file_name);
25266 if ( mp->total_shipped>1 ) {
25267 if ( 31+strlen(mp->first_file_name)+
25268 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
25270 mp_print(mp, " .. ");
25271 mp_print(mp, mp->last_file_name);
25275 @ @<Internal library declarations@>=
25276 boolean mp_has_font_size(MP mp, font_number f );
25279 boolean mp_has_font_size(MP mp, font_number f ) {
25280 return (mp->font_sizes[f]!=null);
25283 @ The \&{special} command saves up lines of text to be printed during the next
25284 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25287 pointer last_pending; /* the last token in a list of pending specials */
25290 mp->last_pending=spec_head;
25292 @ @<Cases of |do_statement|...@>=
25293 case special_command:
25294 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25295 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25299 @ @<Declare action procedures for use by |do_statement|@>=
25300 void mp_do_special (MP mp) ;
25302 @ @c void mp_do_special (MP mp) {
25303 mp_get_x_next(mp); mp_scan_expression(mp);
25304 if ( mp->cur_type!=mp_string_type ) {
25305 @<Complain about improper special operation@>;
25307 link(mp->last_pending)=mp_stash_cur_exp(mp);
25308 mp->last_pending=link(mp->last_pending);
25309 link(mp->last_pending)=null;
25313 @ @<Complain about improper special operation@>=
25315 exp_err("Unsuitable expression");
25316 help1("Only known strings are allowed for output as specials.");
25317 mp_put_get_error(mp);
25320 @ On the export side, we need an extra object type for special strings.
25322 @<Graphical object codes@>=
25325 @ @<Export pending specials@>=
25327 while ( p!=null ) {
25328 mp_special_object *tp;
25329 tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
25330 gr_pre_script(tp) = str(value(p));
25331 if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
25332 else gr_link(hp) = (mp_graphic_object *)tp;
25333 hp = (mp_graphic_object *)tp;
25336 mp_flush_token_list(mp, link(spec_head));
25337 link(spec_head)=null;
25338 mp->last_pending=spec_head
25340 @ We are now ready for the main output procedure. Note that the |selector|
25341 setting is saved in a global variable so that |begin_diagnostic| can access it.
25343 @<Declare the \ps\ output procedures@>=
25344 void mp_ship_out (MP mp, pointer h) ;
25346 @ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
25348 @d export_color(q,p)
25349 if ( color_model(p)==mp_uninitialized_model ) {
25350 gr_color_model(q) = (mp->internal[mp_default_color_model]>>16);
25351 gr_cyan_val(q) = 0;
25352 gr_magenta_val(q) = 0;
25353 gr_yellow_val(q) = 0;
25354 gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
25356 gr_color_model(q) = color_model(p);
25357 gr_cyan_val(q) = cyan_val(p);
25358 gr_magenta_val(q) = magenta_val(p);
25359 gr_yellow_val(q) = yellow_val(p);
25360 gr_black_val(q) = black_val(p);
25363 @d export_scripts(q,p)
25364 if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
25365 if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
25368 struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
25369 pointer p; /* the current graphical object */
25370 integer t; /* a temporary value */
25371 scaled d_width; /* the current pen width */
25372 mp_edge_object *hh; /* the first graphical object */
25373 struct mp_graphic_object *hq; /* something |hp| points to */
25374 struct mp_text_object *tt;
25375 struct mp_fill_object *tf;
25376 struct mp_stroked_object *ts;
25377 struct mp_clip_object *tc;
25378 struct mp_bounds_object *tb;
25379 struct mp_graphic_object *hp = NULL; /* the current graphical object */
25380 mp_set_bbox(mp, h, true);
25381 hh = mp_xmalloc(mp,1,sizeof(mp_edge_object));
25385 hh->_minx = minx_val(h);
25386 hh->_miny = miny_val(h);
25387 hh->_maxx = maxx_val(h);
25388 hh->_maxy = maxy_val(h);
25389 hh->_filename = mp_get_output_file_name(mp);
25390 @<Export pending specials@>;
25391 p=link(dummy_loc(h));
25392 while ( p!=null ) {
25393 hq = mp_new_graphic_object(mp,type(p));
25396 tf = (mp_fill_object *)hq;
25397 gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
25398 d_width = mp_get_pen_scale(mp, pen_p(p));
25399 if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
25400 gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
25403 pc = mp_copy_path(mp, path_p(p));
25404 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25405 gr_path_p(tf) = mp_export_knot_list(mp,pp);
25406 mp_toss_knot_list(mp, pp);
25407 pc = mp_htap_ypoc(mp, path_p(p));
25408 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25409 gr_htap_p(tf) = mp_export_knot_list(mp,pp);
25410 mp_toss_knot_list(mp, pp);
25412 export_color(tf,p) ;
25413 export_scripts(tf,p);
25414 gr_ljoin_val(tf) = ljoin_val(p);
25415 gr_miterlim_val(tf) = miterlim_val(p);
25417 case mp_stroked_code:
25418 ts = (mp_stroked_object *)hq;
25419 gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
25420 d_width = mp_get_pen_scale(mp, pen_p(p));
25421 if (pen_is_elliptical(pen_p(p))) {
25422 gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
25425 pc=mp_copy_path(mp, path_p(p));
25427 if ( left_type(pc)!=mp_endpoint ) {
25428 left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
25429 right_type(pc)=mp_endpoint;
25433 pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
25434 gr_path_p(ts) = mp_export_knot_list(mp,pc);
25435 mp_toss_knot_list(mp, pc);
25437 export_color(ts,p) ;
25438 export_scripts(ts,p);
25439 gr_ljoin_val(ts) = ljoin_val(p);
25440 gr_miterlim_val(ts) = miterlim_val(p);
25441 gr_lcap_val(ts) = lcap_val(p);
25442 gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
25445 tt = (mp_text_object *)hq;
25446 gr_text_p(tt) = str(text_p(p));
25447 gr_font_n(tt) = font_n(p);
25448 gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
25449 gr_font_dsize(tt) = mp->font_dsize[font_n(p)];
25450 export_color(tt,p) ;
25451 export_scripts(tt,p);
25452 gr_width_val(tt) = width_val(p);
25453 gr_height_val(tt) = height_val(p);
25454 gr_depth_val(tt) = depth_val(p);
25455 gr_tx_val(tt) = tx_val(p);
25456 gr_ty_val(tt) = ty_val(p);
25457 gr_txx_val(tt) = txx_val(p);
25458 gr_txy_val(tt) = txy_val(p);
25459 gr_tyx_val(tt) = tyx_val(p);
25460 gr_tyy_val(tt) = tyy_val(p);
25462 case mp_start_clip_code:
25463 tc = (mp_clip_object *)hq;
25464 gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
25466 case mp_start_bounds_code:
25467 tb = (mp_bounds_object *)hq;
25468 gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
25470 case mp_stop_clip_code:
25471 case mp_stop_bounds_code:
25472 /* nothing to do here */
25475 if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
25482 @ @<Exported function ...@>=
25483 struct mp_edge_object *mp_gr_export(MP mp, int h);
25485 @ This function is now nearly trivial.
25488 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25489 integer c; /* \&{charcode} rounded to the nearest integer */
25490 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25491 @<Begin the progress report for the output of picture~|c|@>;
25492 (mp->shipout_backend) (mp, h);
25493 @<End progress report@>;
25494 if ( mp->internal[mp_tracing_output]>0 )
25495 mp_print_edges(mp, h," (just shipped out)",true);
25498 @ @<Declarations@>=
25499 void mp_shipout_backend (MP mp, pointer h);
25502 void mp_shipout_backend (MP mp, pointer h) {
25503 mp_edge_object *hh; /* the first graphical object */
25504 hh = mp_gr_export(mp,h);
25505 mp_gr_ship_out (hh,
25506 (mp->internal[mp_prologues]>>16),
25507 (mp->internal[mp_procset]>>16));
25508 mp_gr_toss_objects(hh);
25511 @ @<Exported types@>=
25512 typedef void (*mp_backend_writer)(MP, int);
25514 @ @<Option variables@>=
25515 mp_backend_writer shipout_backend;
25517 @ @<Allocate or initialize ...@>=
25518 set_callback_option(shipout_backend);
25520 @ Now that we've finished |ship_out|, let's look at the other commands
25521 by which a user can send things to the \.{GF} file.
25523 @ @<Determine if a character has been shipped out@>=
25525 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
25526 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
25527 boolean_reset(mp->char_exists[mp->cur_exp]);
25528 mp->cur_type=mp_boolean_type;
25534 @ @<Allocate or initialize ...@>=
25535 mp_backend_initialize(mp);
25538 mp_backend_free(mp);
25541 @* \[45] Dumping and undumping the tables.
25542 After \.{INIMP} has seen a collection of macros, it
25543 can write all the necessary information on an auxiliary file so
25544 that production versions of \MP\ are able to initialize their
25545 memory at high speed. The present section of the program takes
25546 care of such output and input. We shall consider simultaneously
25547 the processes of storing and restoring,
25548 so that the inverse relation between them is clear.
25551 The global variable |mem_ident| is a string that is printed right
25552 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
25553 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
25554 for example, `\.{(mem=plain 1990.4.14)}', showing the year,
25555 month, and day that the mem file was created. We have |mem_ident=0|
25556 before \MP's tables are loaded.
25562 mp->mem_ident=NULL;
25564 @ @<Initialize table entries...@>=
25565 mp->mem_ident=xstrdup(" (INIMP)");
25567 @ @<Declare act...@>=
25568 void mp_store_mem_file (MP mp) ;
25570 @ @c void mp_store_mem_file (MP mp) {
25571 integer k; /* all-purpose index */
25572 pointer p,q; /* all-purpose pointers */
25573 integer x; /* something to dump */
25574 four_quarters w; /* four ASCII codes */
25576 @<Create the |mem_ident|, open the mem file,
25577 and inform the user that dumping has begun@>;
25578 @<Dump constants for consistency check@>;
25579 @<Dump the string pool@>;
25580 @<Dump the dynamic memory@>;
25581 @<Dump the table of equivalents and the hash table@>;
25582 @<Dump a few more things and the closing check word@>;
25583 @<Close the mem file@>;
25586 @ Corresponding to the procedure that dumps a mem file, we also have a function
25587 that reads~one~in. The function returns |false| if the dumped mem is
25588 incompatible with the present \MP\ table sizes, etc.
25590 @d off_base 6666 /* go here if the mem file is unacceptable */
25591 @d too_small(A) { wake_up_terminal;
25592 wterm_ln("---! Must increase the "); wterm((A));
25593 @.Must increase the x@>
25598 boolean mp_load_mem_file (MP mp) {
25599 integer k; /* all-purpose index */
25600 pointer p,q; /* all-purpose pointers */
25601 integer x; /* something undumped */
25602 str_number s; /* some temporary string */
25603 four_quarters w; /* four ASCII codes */
25605 @<Undump constants for consistency check@>;
25606 @<Undump the string pool@>;
25607 @<Undump the dynamic memory@>;
25608 @<Undump the table of equivalents and the hash table@>;
25609 @<Undump a few more things and the closing check word@>;
25610 return true; /* it worked! */
25613 wterm_ln("(Fatal mem file error; I'm stymied)\n");
25614 @.Fatal mem file error@>
25618 @ @<Declarations@>=
25619 boolean mp_load_mem_file (MP mp) ;
25621 @ Mem files consist of |memory_word| items, and we use the following
25622 macros to dump words of different types:
25624 @d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25625 @d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
25626 @d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25627 @d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25628 @d dump_string(A) { dump_int(strlen(A)+1);
25629 (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
25632 void * mem_file; /* for input or output of mem information */
25634 @ The inverse macros are slightly more complicated, since we need to check
25635 the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
25636 read an integer value |x| that is supposed to be in the range |a<=x<=b|.
25639 size_t wanted = sizeof(A);
25641 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25642 if (wanted!=sizeof(A)) goto OFF_BASE;
25646 size_t wanted = sizeof(A);
25648 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25649 if (wanted!=sizeof(A)) goto OFF_BASE;
25652 @d undump_wd(A) { mgetw(WW); A=WW; }
25653 @d undump_int(A) { int cint; mgeti(cint); A=cint; }
25654 @d undump_hh(A) { mgetw(WW); A=WW.hh; }
25655 @d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
25656 @d undump_strings(A,B,C) {
25657 undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
25658 @d undump(A,B,C) { undump_int(x); if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
25659 @d undump_size(A,B,C,D) { undump_int(x);
25660 if (x<(A)) goto OFF_BASE;
25661 if (x>(B)) { too_small((C)); } else { D=x;} }
25662 @d undump_string(A) do {
25668 the_string = xmalloc(XX,sizeof(char));
25669 (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
25670 A = (char *)the_string;
25671 if (the_wanted!=(size_t)XX) goto OFF_BASE;
25674 @ The next few sections of the program should make it clear how we use the
25675 dump/undump macros.
25677 @<Dump constants for consistency check@>=
25678 dump_int(mp->mem_top);
25679 dump_int(mp->hash_size);
25680 dump_int(mp->hash_prime)
25681 dump_int(mp->param_size);
25682 dump_int(mp->max_in_open);
25684 @ Sections of a \.{WEB} program that are ``commented out'' still contribute
25685 strings to the string pool; therefore \.{INIMP} and \MP\ will have
25686 the same strings. (And it is, of course, a good thing that they do.)
25690 @<Undump constants for consistency check@>=
25691 undump_int(x); mp->mem_top = x;
25692 undump_int(x); if (mp->hash_size != x) goto OFF_BASE;
25693 undump_int(x); if (mp->hash_prime != x) goto OFF_BASE;
25694 undump_int(x); if (mp->param_size != x) goto OFF_BASE;
25695 undump_int(x); if (mp->max_in_open != x) goto OFF_BASE
25697 @ We do string pool compaction to avoid dumping unused strings.
25700 w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
25701 w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
25704 @<Dump the string pool@>=
25705 mp_do_compaction(mp, mp->pool_size);
25706 dump_int(mp->pool_ptr);
25707 dump_int(mp->max_str_ptr);
25708 dump_int(mp->str_ptr);
25710 while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
25713 while ( k<=mp->max_str_ptr ) {
25714 dump_int(mp->next_str[k]); incr(k);
25718 dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
25719 if ( k==mp->str_ptr ) {
25726 while (k+4<mp->pool_ptr ) {
25727 dump_four_ASCII; k=k+4;
25729 k=mp->pool_ptr-4; dump_four_ASCII;
25730 mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
25731 mp_print(mp, " strings of total length ");
25732 mp_print_int(mp, mp->pool_ptr)
25734 @ @d undump_four_ASCII
25736 mp->str_pool[k]=qo(w.b0); mp->str_pool[k+1]=qo(w.b1);
25737 mp->str_pool[k+2]=qo(w.b2); mp->str_pool[k+3]=qo(w.b3)
25739 @<Undump the string pool@>=
25740 undump_int(mp->pool_ptr);
25741 mp_reallocate_pool(mp, mp->pool_ptr) ;
25742 undump_int(mp->max_str_ptr);
25743 mp_reallocate_strings (mp,mp->max_str_ptr) ;
25744 undump(0,mp->max_str_ptr,mp->str_ptr);
25745 undump(0,mp->max_str_ptr+1,s);
25746 for (k=0;k<=s-1;k++)
25747 mp->next_str[k]=k+1;
25748 for (k=s;k<=mp->max_str_ptr;k++)
25749 undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
25750 mp->fixed_str_use=0;
25753 undump(0,mp->pool_ptr,mp->str_start[k]);
25754 if ( k==mp->str_ptr ) break;
25755 mp->str_ref[k]=max_str_ref;
25756 incr(mp->fixed_str_use);
25757 mp->last_fixed_str=k; k=mp->next_str[k];
25760 while ( k+4<mp->pool_ptr ) {
25761 undump_four_ASCII; k=k+4;
25763 k=mp->pool_ptr-4; undump_four_ASCII;
25764 mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
25765 mp->max_pool_ptr=mp->pool_ptr;
25766 mp->strs_used_up=mp->fixed_str_use;
25767 mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
25768 mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
25769 mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
25771 @ By sorting the list of available spaces in the variable-size portion of
25772 |mem|, we are usually able to get by without having to dump very much
25773 of the dynamic memory.
25775 We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
25776 information even when it has not been gathering statistics.
25778 @<Dump the dynamic memory@>=
25779 mp_sort_avail(mp); mp->var_used=0;
25780 dump_int(mp->lo_mem_max); dump_int(mp->rover);
25781 p=0; q=mp->rover; x=0;
25783 for (k=p;k<= q+1;k++)
25784 dump_wd(mp->mem[k]);
25785 x=x+q+2-p; mp->var_used=mp->var_used+q-p;
25786 p=q+node_size(q); q=rlink(q);
25787 } while (q!=mp->rover);
25788 mp->var_used=mp->var_used+mp->lo_mem_max-p;
25789 mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
25790 for (k=p;k<= mp->lo_mem_max;k++ )
25791 dump_wd(mp->mem[k]);
25792 x=x+mp->lo_mem_max+1-p;
25793 dump_int(mp->hi_mem_min); dump_int(mp->avail);
25794 for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
25795 dump_wd(mp->mem[k]);
25796 x=x+mp->mem_end+1-mp->hi_mem_min;
25798 while ( p!=null ) {
25799 decr(mp->dyn_used); p=link(p);
25801 dump_int(mp->var_used); dump_int(mp->dyn_used);
25802 mp_print_ln(mp); mp_print_int(mp, x);
25803 mp_print(mp, " memory locations dumped; current usage is ");
25804 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used)
25806 @ @<Undump the dynamic memory@>=
25807 undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
25808 undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
25811 for (k=p;k<= q+1; k++)
25812 undump_wd(mp->mem[k]);
25814 if ( (p>mp->lo_mem_max)||((q>=rlink(q))&&(rlink(q)!=mp->rover)) )
25817 } while (q!=mp->rover);
25818 for (k=p;k<=mp->lo_mem_max;k++ )
25819 undump_wd(mp->mem[k]);
25820 undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
25821 undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
25822 mp->last_pending=spec_head;
25823 for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
25824 undump_wd(mp->mem[k]);
25825 undump_int(mp->var_used); undump_int(mp->dyn_used)
25827 @ A different scheme is used to compress the hash table, since its lower region
25828 is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
25829 words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
25830 packed for |p>=hash_used|, so the remaining entries are output in~a~block.
25832 @<Dump the table of equivalents and the hash table@>=
25833 dump_int(mp->hash_used);
25834 mp->st_count=frozen_inaccessible-1-mp->hash_used;
25835 for (p=1;p<=mp->hash_used;p++) {
25836 if ( text(p)!=0 ) {
25837 dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
25840 for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
25841 dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
25843 dump_int(mp->st_count);
25844 mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
25846 @ @<Undump the table of equivalents and the hash table@>=
25847 undump(1,frozen_inaccessible,mp->hash_used);
25850 undump(p+1,mp->hash_used,p);
25851 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
25852 } while (p!=mp->hash_used);
25853 for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
25854 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
25856 undump_int(mp->st_count)
25858 @ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
25859 to prevent them appearing again.
25861 @<Dump a few more things and the closing check word@>=
25862 dump_int(mp->max_internal);
25863 dump_int(mp->int_ptr);
25864 for (k=1;k<= mp->int_ptr;k++ ) {
25865 dump_int(mp->internal[k]);
25866 dump_string(mp->int_name[k]);
25868 dump_int(mp->start_sym);
25869 dump_int(mp->interaction);
25870 dump_string(mp->mem_ident);
25871 dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
25872 mp->internal[mp_tracing_stats]=0
25874 @ @<Undump a few more things and the closing check word@>=
25876 if (x>mp->max_internal) mp_grow_internals(mp,x);
25877 undump_int(mp->int_ptr);
25878 for (k=1;k<= mp->int_ptr;k++) {
25879 undump_int(mp->internal[k]);
25880 undump_string(mp->int_name[k]);
25882 undump(0,frozen_inaccessible,mp->start_sym);
25883 if (mp->interaction==mp_unspecified_mode) {
25884 undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
25886 undump(mp_unspecified_mode,mp_error_stop_mode,x);
25888 undump_string(mp->mem_ident);
25889 undump(1,hash_end,mp->bg_loc);
25890 undump(1,hash_end,mp->eg_loc);
25891 undump_int(mp->serial_no);
25893 if (x!=69073) goto OFF_BASE
25895 @ @<Create the |mem_ident|...@>=
25897 xfree(mp->mem_ident);
25898 mp->mem_ident = xmalloc(256,1);
25899 mp_snprintf(mp->mem_ident,256," (mem=%s %i.%i.%i)",
25901 (int)(mp_round_unscaled(mp, mp->internal[mp_year]) % 100),
25902 (int)mp_round_unscaled(mp, mp->internal[mp_month]),
25903 (int)mp_round_unscaled(mp, mp->internal[mp_day]));
25904 mp_pack_job_name(mp, mem_extension);
25905 while (! mp_w_open_out(mp, &mp->mem_file) )
25906 mp_prompt_file_name(mp, "mem file name", mem_extension);
25907 mp_print_nl(mp, "Beginning to dump on file ");
25908 @.Beginning to dump...@>
25909 mp_print(mp, mp->name_of_file);
25910 mp_print_nl(mp, mp->mem_ident);
25913 @ @<Dealloc variables@>=
25914 xfree(mp->mem_ident);
25916 @ @<Close the mem file@>=
25917 (mp->close_file)(mp,mp->mem_file)
25919 @* \[46] The main program.
25920 This is it: the part of \MP\ that executes all those procedures we have
25923 Well---almost. We haven't put the parsing subroutines into the
25924 program yet; and we'd better leave space for a few more routines that may
25925 have been forgotten.
25927 @c @<Declare the basic parsing subroutines@>
25928 @<Declare miscellaneous procedures that were declared |forward|@>
25929 @<Last-minute procedures@>
25931 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
25933 has to be run first; it initializes everything from scratch, without
25934 reading a mem file, and it has the capability of dumping a mem file.
25935 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
25937 to input a mem file in order to get started. \.{VIRMP} typically has
25938 a bit more memory capacity than \.{INIMP}, because it does not need the
25939 space consumed by the dumping/undumping routines and the numerous calls on
25942 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
25943 the best implementations therefore allow for production versions of \MP\ that
25944 not only avoid the loading routine for object code, they also have
25945 a mem file pre-loaded.
25947 @ @<Option variables@>=
25948 int ini_version; /* are we iniMP? */
25950 @ @<Set |ini_version|@>=
25951 mp->ini_version = (opt->ini_version ? true : false);
25953 @ Here we do whatever is needed to complete \MP's job gracefully on the
25954 local operating system. The code here might come into play after a fatal
25955 error; it must therefore consist entirely of ``safe'' operations that
25956 cannot produce error messages. For example, it would be a mistake to call
25957 |str_room| or |make_string| at this time, because a call on |overflow|
25958 might lead to an infinite loop.
25959 @^system dependencies@>
25961 This program doesn't bother to close the input files that may still be open.
25963 @<Last-minute...@>=
25964 void mp_close_files_and_terminate (MP mp) {
25965 integer k; /* all-purpose index */
25966 integer LH; /* the length of the \.{TFM} header, in words */
25967 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
25968 pointer p; /* runs through a list of \.{TFM} dimensions */
25969 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
25970 if ( mp->internal[mp_tracing_stats]>0 )
25971 @<Output statistics about this job@>;
25973 @<Do all the finishing work on the \.{TFM} file@>;
25974 @<Explain what output files were written@>;
25975 if ( mp->log_opened ){
25977 (mp->close_file)(mp,mp->log_file);
25978 mp->selector=mp->selector-2;
25979 if ( mp->selector==term_only ) {
25980 mp_print_nl(mp, "Transcript written on ");
25981 @.Transcript written...@>
25982 mp_print(mp, mp->log_name); mp_print_char(mp, '.');
25990 @ @<Declarations@>=
25991 void mp_close_files_and_terminate (MP mp) ;
25993 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
25994 if (mp->rd_fname!=NULL) {
25995 for (k=0;k<=(int)mp->read_files-1;k++ ) {
25996 if ( mp->rd_fname[k]!=NULL ) {
25997 (mp->close_file)(mp,mp->rd_file[k]);
25998 xfree(mp->rd_fname[k]);
26002 if (mp->wr_fname!=NULL) {
26003 for (k=0;k<=(int)mp->write_files-1;k++) {
26004 if ( mp->wr_fname[k]!=NULL ) {
26005 (mp->close_file)(mp,mp->wr_file[k]);
26006 xfree(mp->wr_fname[k]);
26012 for (k=0;k<(int)mp->max_read_files;k++ ) {
26013 if ( mp->rd_fname[k]!=NULL ) {
26014 (mp->close_file)(mp,mp->rd_file[k]);
26015 xfree(mp->rd_fname[k]);
26018 xfree(mp->rd_file);
26019 xfree(mp->rd_fname);
26020 for (k=0;k<(int)mp->max_write_files;k++) {
26021 if ( mp->wr_fname[k]!=NULL ) {
26022 (mp->close_file)(mp,mp->wr_file[k]);
26023 xfree(mp->wr_fname[k]);
26026 xfree(mp->wr_file);
26027 xfree(mp->wr_fname);
26030 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
26032 We reclaim all of the variable-size memory at this point, so that
26033 there is no chance of another memory overflow after the memory capacity
26034 has already been exceeded.
26036 @<Do all the finishing work on the \.{TFM} file@>=
26037 if ( mp->internal[mp_fontmaking]>0 ) {
26038 @<Make the dynamic memory into one big available node@>;
26039 @<Massage the \.{TFM} widths@>;
26040 mp_fix_design_size(mp); mp_fix_check_sum(mp);
26041 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
26042 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
26043 @<Finish the \.{TFM} file@>;
26046 @ @<Make the dynamic memory into one big available node@>=
26047 mp->rover=lo_mem_stat_max+1; link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26048 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26049 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26050 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
26051 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
26053 @ The present section goes directly to the log file instead of using
26054 |print| commands, because there's no need for these strings to take
26055 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26057 @<Output statistics...@>=
26058 if ( mp->log_opened ) {
26061 wlog_ln("Here is how much of MetaPost's memory you used:");
26062 @.Here is how much...@>
26063 mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26064 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26065 (int)(mp->max_strings-1-mp->init_str_use));
26067 mp_snprintf(s,128," %i string characters out of %i",
26068 (int)mp->max_pl_used-mp->init_pool_ptr,
26069 (int)mp->pool_size-mp->init_pool_ptr);
26071 mp_snprintf(s,128," %i words of memory out of %i",
26072 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26075 mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26077 mp_snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
26078 (int)mp->max_in_stack,(int)mp->int_ptr,
26079 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26080 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26082 mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26083 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26087 @ It is nice to have have some of the stats available from the API.
26089 @<Exported function ...@>=
26090 int mp_memory_usage (MP mp );
26091 int mp_hash_usage (MP mp );
26092 int mp_param_usage (MP mp );
26093 int mp_open_usage (MP mp );
26096 int mp_memory_usage (MP mp ) {
26097 return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
26099 int mp_hash_usage (MP mp ) {
26100 return (int)mp->st_count;
26102 int mp_param_usage (MP mp ) {
26103 return (int)mp->max_param_stack;
26105 int mp_open_usage (MP mp ) {
26106 return (int)mp->max_in_stack;
26109 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26112 @<Last-minute...@>=
26113 void mp_final_cleanup (MP mp) {
26114 small_number c; /* 0 for \&{end}, 1 for \&{dump} */
26116 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26117 while ( mp->input_ptr>0 ) {
26118 if ( token_state ) mp_end_token_list(mp);
26119 else mp_end_file_reading(mp);
26121 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26122 while ( mp->open_parens>0 ) {
26123 mp_print(mp, " )"); decr(mp->open_parens);
26125 while ( mp->cond_ptr!=null ) {
26126 mp_print_nl(mp, "(end occurred when ");
26127 @.end occurred...@>
26128 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26129 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26130 if ( mp->if_line!=0 ) {
26131 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26133 mp_print(mp, " was incomplete)");
26134 mp->if_line=if_line_field(mp->cond_ptr);
26135 mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=link(mp->cond_ptr);
26137 if ( mp->history!=mp_spotless )
26138 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26139 if ( mp->selector==term_and_log ) {
26140 mp->selector=term_only;
26141 mp_print_nl(mp, "(see the transcript file for additional information)");
26142 @.see the transcript file...@>
26143 mp->selector=term_and_log;
26146 if (mp->ini_version) {
26147 mp_store_mem_file(mp); return;
26149 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26150 @.dump...only by INIMP@>
26154 @ @<Declarations@>=
26155 void mp_final_cleanup (MP mp) ;
26156 void mp_init_prim (MP mp) ;
26157 void mp_init_tab (MP mp) ;
26159 @ @<Last-minute...@>=
26160 void mp_init_prim (MP mp) { /* initialize all the primitives */
26164 void mp_init_tab (MP mp) { /* initialize other tables */
26165 integer k; /* all-purpose index */
26166 @<Initialize table entries (done by \.{INIMP} only)@>;
26170 @ When we begin the following code, \MP's tables may still contain garbage;
26171 the strings might not even be present. Thus we must proceed cautiously to get
26174 But when we finish this part of the program, \MP\ is ready to call on the
26175 |main_control| routine to do its work.
26177 @<Get the first line...@>=
26179 @<Initialize the input routines@>;
26180 if ( (mp->mem_ident==NULL)||(mp->buffer[loc]=='&') ) {
26181 if ( mp->mem_ident!=NULL ) {
26182 mp_do_initialize(mp); /* erase preloaded mem */
26184 if ( ! mp_open_mem_file(mp) ) return mp_fatal_error_stop;
26185 if ( ! mp_load_mem_file(mp) ) {
26186 (mp->close_file)(mp, mp->mem_file);
26187 return mp_fatal_error_stop;
26189 (mp->close_file)(mp, mp->mem_file);
26190 while ( (loc<limit)&&(mp->buffer[loc]==' ') ) incr(loc);
26192 mp->buffer[limit]='%';
26193 mp_fix_date_and_time(mp);
26194 if (mp->random_seed==0)
26195 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
26196 mp_init_randoms(mp, mp->random_seed);
26197 @<Initialize the print |selector|...@>;
26198 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26199 mp_start_input(mp); /* \&{input} assumed */
26202 @ @<Run inimpost commands@>=
26204 mp_get_strings_started(mp);
26205 mp_init_tab(mp); /* initialize the tables */
26206 mp_init_prim(mp); /* call |primitive| for each primitive */
26207 mp->init_str_use=mp->str_ptr; mp->init_pool_ptr=mp->pool_ptr;
26208 mp->max_str_ptr=mp->str_ptr; mp->max_pool_ptr=mp->pool_ptr;
26209 mp_fix_date_and_time(mp);
26213 @* \[47] Debugging.
26214 Once \MP\ is working, you should be able to diagnose most errors with
26215 the \.{show} commands and other diagnostic features. But for the initial
26216 stages of debugging, and for the revelation of really deep mysteries, you
26217 can compile \MP\ with a few more aids. An additional routine called |debug_help|
26218 will also come into play when you type `\.D' after an error message;
26219 |debug_help| also occurs just before a fatal error causes \MP\ to succumb.
26221 @^system dependencies@>
26223 The interface to |debug_help| is primitive, but it is good enough when used
26224 with a debugger that allows you to set breakpoints and to read
26225 variables and change their values. After getting the prompt `\.{debug \#}', you
26226 type either a negative number (this exits |debug_help|), or zero (this
26227 goes to a location where you can set a breakpoint, thereby entering into
26228 dialog with the debugger), or a positive number |m| followed by
26229 an argument |n|. The meaning of |m| and |n| will be clear from the
26230 program below. (If |m=13|, there is an additional argument, |l|.)
26233 @<Last-minute...@>=
26234 void mp_debug_help (MP mp) { /* routine to display various things */
26241 mp_print_nl(mp, "debug # (-1 to exit):"); update_terminal;
26244 aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
26245 if (len) { sscanf(aline,"%i",&m); xfree(aline); }
26249 aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
26250 if (len) { sscanf(aline,"%i",&n); xfree(aline); }
26252 @<Numbered cases for |debug_help|@>;
26253 default: mp_print(mp, "?"); break;
26258 @ @<Numbered cases...@>=
26259 case 1: mp_print_word(mp, mp->mem[n]); /* display |mem[n]| in all forms */
26261 case 2: mp_print_int(mp, info(n));
26263 case 3: mp_print_int(mp, link(n));
26265 case 4: mp_print_int(mp, eq_type(n)); mp_print_char(mp, ':'); mp_print_int(mp, equiv(n));
26267 case 5: mp_print_variable_name(mp, n);
26269 case 6: mp_print_int(mp, mp->internal[n]);
26271 case 7: mp_do_show_dependencies(mp);
26273 case 9: mp_show_token_list(mp, n,null,100000,0);
26275 case 10: mp_print_str(mp, n);
26277 case 11: mp_check_mem(mp, n>0); /* check wellformedness; print new busy locations if |n>0| */
26279 case 12: mp_search_mem(mp, n); /* look for pointers to |n| */
26283 aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
26284 if (len) { sscanf(aline,"%i",&l); xfree(aline); }
26285 mp_print_cmd_mod(mp, n,l);
26287 case 14: for (k=0;k<=n;k++) mp_print_str(mp, mp->buffer[k]);
26289 case 15: mp->panicking=! mp->panicking;
26293 @ Saving the filename template
26295 @<Save the filename template@>=
26297 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26298 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26300 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26304 @* \[48] System-dependent changes.
26305 This section should be replaced, if necessary, by any special
26306 modification of the program
26307 that are necessary to make \MP\ work at a particular installation.
26308 It is usually best to design your change file so that all changes to
26309 previous sections preserve the section numbering; then everybody's version
26310 will be consistent with the published program. More extensive changes,
26311 which introduce new sections, can be inserted here; then only the index
26312 itself will get a new section number.
26313 @^system dependencies@>
26316 Here is where you can find all uses of each identifier in the program,
26317 with underlined entries pointing to where the identifier was defined.
26318 If the identifier is only one letter long, however, you get to see only
26319 the underlined entries. {\sl All references are to section numbers instead of
26322 This index also lists error messages and other aspects of the program
26323 that you might want to look up some day. For example, the entry
26324 for ``system dependencies'' lists all sections that should receive
26325 special attention from people who are installing \MP\ in a new
26326 operating environment. A list of various things that can't happen appears
26327 under ``this can't happen''.
26328 Approximately 25 sections are listed under ``inner loop''; these account
26329 for more than 60\pct! of \MP's running time, exclusive of input and output.