1 % $Id: mp.web,v 1.8 2005/08/24 10:54:02 taco Exp $
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}
17 \def\ph{\hbox{Pascal-H}}
18 \def\psqrt#1{\sqrt{\mathstrut#1}}
20 \def\pct!{{\char`\%}} % percent sign in ordinary text
21 \font\tenlogo=logo10 % font used for the METAFONT logo
23 \def\MF{{\tenlogo META}\-{\tenlogo FONT}}
24 \def\MP{{\tenlogo META}\-{\tenlogo POST}}
25 \def\[#1]{#1.} % from pascal web
26 \def\<#1>{$\langle#1\rangle$}
27 \def\section{\mathhexbox278}
28 \let\swap=\leftrightarrow
29 \def\round{\mathop{\rm round}\nolimits}
30 \mathchardef\vb="026A % synonym for `\|'
32 \def\(#1){} % this is used to make section names sort themselves better
33 \def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
35 \def\glob{15} % this should be the section number of "<Global...>"
36 \def\gglob{23, 28} % this should be the next two sections of "<Global...>"
41 This is \MP, a graphics-language processor based on D. E. Knuth's \MF.
43 The main purpose of the following program is to explain the algorithms of \MP\
44 as clearly as possible. As a result, the program will not necessarily be very
45 efficient when a particular \PASCAL\ compiler has translated it into a
46 particular machine language. However, the program has been written so that it
47 can be tuned to run efficiently in a wide variety of operating environments
48 by making comparatively few changes. Such flexibility is possible because
49 the documentation that follows is written in the \.{WEB} language, which is
50 at a higher level than \PASCAL; the preprocessing step that converts \.{WEB}
51 to \PASCAL\ is able to introduce most of the necessary refinements.
52 Semi-automatic translation to other languages is also feasible, because the
53 program below does not make extensive use of features that are peculiar to
56 A large piece of software like \MP\ has inherent complexity that cannot
57 be reduced below a certain level of difficulty, although each individual
58 part is fairly simple by itself. The \.{WEB} language is intended to make
59 the algorithms as readable as possible, by reflecting the way the
60 individual program pieces fit together and by providing the
61 cross-references that connect different parts. Detailed comments about
62 what is going on, and about why things were done in certain ways, have
63 been liberally sprinkled throughout the program. These comments explain
64 features of the implementation, but they rarely attempt to explain the
65 \MP\ language itself, since the reader is supposed to be familiar with
66 {\sl The {\logos METAFONT\/}book} as well as the manual
68 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
69 {\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
70 AT\AM T Bell Laboratories.
72 @ The present implementation is a preliminary version, but the possibilities
73 for new features are limited by the desire to remain as nearly compatible
74 with \MF\ as possible.
76 On the other hand, the \.{WEB} description can be extended without changing
77 the core of the program, and it has been designed so that such
78 extensions are not extremely difficult to make.
79 The |banner| string defined here should be changed whenever \MP\
80 undergoes any modifications, so that it will be clear which version of
81 \MP\ might be the guilty party when a problem arises.
83 @^system dependencies@>
85 @d banner "This is MetaPost, Version 1.002" /* printed when \MP\ starts */
86 @d metapost_version "1.002"
87 @d mplib_version "0.10"
88 @d version_string " (Cweb version 0.10)"
90 @ Different \PASCAL s have slightly different conventions, and the present
92 program is expressed in a version of \PASCAL\ that D. E. Knuth used for \MF.
93 Constructions that apply to
94 this particular compiler, which we shall call \ph, should help the
95 reader see how to make an appropriate interface for other systems
96 if necessary. (\ph\ is Charles Hedrick's modification of a compiler
97 @^Hedrick, Charles Locke@>
98 for the DECsystem-10 that was originally developed at the University of
99 Hamburg; cf.\ {\sl SOFTWARE---Practice \AM\ Experience \bf6} (1976),
100 29--42. The \MP\ program below is intended to be adaptable, without
101 extensive changes, to most other versions of \PASCAL\ and commonly used
102 \PASCAL-to-C translators, so it does not fully
104 use the admirable features of \ph. Indeed, a conscious effort has been
105 made here to avoid using several idiosyncratic features of standard
106 \PASCAL\ itself, so that most of the code can be translated mechanically
107 into other high-level languages. For example, the `\&{with}' and `\\{new}'
108 features are not used, nor are pointer types, set types, or enumerated
109 scalar types; there are no `\&{var}' parameters, except in the case of files;
110 there are no tag fields on variant records; there are no |real| variables;
111 no procedures are declared local to other procedures.)
113 The portions of this program that involve system-dependent code, where
114 changes might be necessary because of differences between \PASCAL\ compilers
115 and/or differences between
116 operating systems, can be identified by looking at the sections whose
117 numbers are listed under `system dependencies' in the index. Furthermore,
118 the index entries for `dirty \PASCAL' list all places where the restrictions
119 of \PASCAL\ have not been followed perfectly, for one reason or another.
120 @^system dependencies@>
123 @ The program begins with a normal \PASCAL\ program heading, whose
124 components will be filled in later, using the conventions of \.{WEB}.
126 For example, the portion of the program called `\X\glob:Global
127 variables\X' below will be replaced by a sequence of variable declarations
128 that starts in $\section\glob$ of this documentation. In this way, we are able
129 to define each individual global variable when we are prepared to
130 understand what it means; we do not have to define all of the globals at
131 once. Cross references in $\section\glob$, where it says ``See also
132 sections \gglob, \dots,'' also make it possible to look at the set of
133 all global variables, if desired. Similar remarks apply to the other
134 portions of the program heading.
136 Actually the heading shown here is not quite normal: The |program| line
137 does not mention any |output| file, because \ph\ would ask the \MP\ user
138 to specify a file name if |output| were specified here.
139 @^system dependencies@>
145 typedef struct MP_instance * MP;
147 typedef struct MP_options {
150 @<Exported function headers@>
154 typedef struct psout_data_struct * psout_data;
156 typedef signed int integer;
158 @<Types in the outer block@>;
159 @<Constants in the outer block@>
160 # ifndef LIBAVL_ALLOCATOR
161 # define LIBAVL_ALLOCATOR
162 struct libavl_allocator {
163 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
164 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
167 typedef struct MP_instance {
170 @<Internal library declarations@>
178 #include <unistd.h> /* for access() */
179 #include <time.h> /* for struct tm \& co */
181 #include "mpmp.h" /* internal header */
182 #include "mppsout.h" /* internal header */
185 @<Basic printing procedures@>
186 @<Error handling procedures@>
188 @ Here are the functions that set up the \MP\ instance.
191 @<Declare |mp_reallocate| functions@>;
192 struct MP_options *mp_options (void);
193 MP mp_new (struct MP_options *opt);
196 struct MP_options *mp_options (void) {
197 struct MP_options *opt;
198 opt = malloc(sizeof(MP_options));
200 memset (opt,0,sizeof(MP_options));
204 MP mp_new (struct MP_options *opt) {
206 mp = xmalloc(1,sizeof(MP_instance));
207 @<Set |ini_version|@>;
208 @<Setup the non-local jump buffer in |mp_new|@>;
209 @<Allocate or initialize variables@>
210 if (opt->main_memory>mp->mem_max)
211 mp_reallocate_memory(mp,opt->main_memory);
212 mp_reallocate_paths(mp,1000);
213 mp_reallocate_fonts(mp,8);
215 mp->term_out = stdout;
218 void mp_free (MP mp) {
219 int k; /* loop variable */
220 @<Dealloc variables@>
225 void mp_do_initialize ( MP mp) {
226 @<Local variables for initialization@>
227 @<Set initial values of key variables@>
229 int mp_initialize (MP mp) { /* this procedure gets things started properly */
230 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
231 @<Install and test the non-local jump buffer@>;
232 t_open_out; /* open the terminal for output */
233 @<Check the ``constant'' values...@>;
235 fprintf(stdout,"Ouch---my internal constants have been clobbered!\n"
236 "---case %i",(int)mp->bad);
240 mp_do_initialize(mp); /* erase preloaded mem */
241 if (mp->ini_version) {
242 @<Run inimpost commands@>;
244 @<Initialize the output routines@>;
245 @<Get the first line of input and prepare to start@>;
247 mp_init_map_file(mp, mp->troff_mode);
248 mp->history=mp_spotless; /* ready to go! */
249 if (mp->troff_mode) {
250 mp->internal[mp_gtroffmode]=unity;
251 mp->internal[mp_prologues]=unity;
253 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
254 mp->cur_sym=mp->start_sym; mp_back_input(mp);
260 @<Exported function headers@>=
261 extern struct MP_options *mp_options (void);
262 extern MP mp_new (struct MP_options *opt) ;
263 extern void mp_free (MP mp);
264 extern int mp_initialize (MP mp);
267 void mp_do_initialize (MP mp);
270 @ The overall \MP\ program begins with the heading just shown, after which
271 comes a bunch of procedure declarations and function declarations.
272 Finally we will get to the main program, which begins with the
273 comment `|start_here|'. If you want to skip down to the
274 main program now, you can look up `|start_here|' in the index.
275 But the author suggests that the best way to understand this program
276 is to follow pretty much the order of \MP's components as they appear in the
277 \.{WEB} description you are now reading, since the present ordering is
278 intended to combine the advantages of the ``bottom up'' and ``top down''
279 approaches to the problem of understanding a somewhat complicated system.
281 @ Some of the code below is intended to be used only when diagnosing the
282 strange behavior that sometimes occurs when \MP\ is being installed or
283 when system wizards are fooling around with \MP\ without quite knowing
284 what they are doing. Such code will not normally be compiled; it is
285 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
287 @ This program has two important variations: (1) There is a long and slow
288 version called \.{INIMP}, which does the extra calculations needed to
290 initialize \MP's internal tables; and (2)~there is a shorter and faster
291 production version, which cuts the initialization to a bare minimum.
293 Which is which is decided at runtime.
295 @ The following parameters can be changed at compile time to extend or
296 reduce \MP's capacity. They may have different values in \.{INIMP} and
297 in production versions of \MP.
299 @^system dependencies@>
302 #define file_name_size 255 /* file names shouldn't be longer than this */
303 #define bistack_size 1500 /* size of stack for bisection algorithms;
304 should probably be left at this value */
306 @ Like the preceding parameters, the following quantities can be changed
307 at compile time to extend or reduce \MP's capacity. But if they are changed,
308 it is necessary to rerun the initialization program \.{INIMP}
310 to generate new tables for the production \MP\ program.
311 One can't simply make helter-skelter changes to the following constants,
312 since certain rather complex initialization
313 numbers are computed from them.
316 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
317 int pool_size; /* maximum number of characters in strings, including all
318 error messages and help texts, and the names of all identifiers */
319 int error_line; /* width of context lines on terminal error messages */
320 int half_error_line; /* width of first lines of contexts in terminal
321 error messages; should be between 30 and |error_line-15| */
322 int max_print_line; /* width of longest text lines output; should be at least 60 */
323 int mem_max; /* greatest index in \MP's internal |mem| array;
324 must be strictly less than |max_halfword|;
325 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
326 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
327 must not be greater than |mem_max| */
328 int hash_size; /* maximum number of symbolic tokens,
329 must be less than |max_halfword-3*param_size| */
330 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
331 int param_size; /* maximum number of simultaneous macro parameters */
332 int max_in_open; /* maximum number of input files and error insertions that
333 can be going on simultaneously */
335 @ @<Option variables@>=
346 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
351 set_value(mp->error_line,opt->error_line,79);
352 set_value(mp->half_error_line,opt->half_error_line,50);
353 set_value(mp->max_print_line,opt->max_print_line,79);
356 set_value(mp->hash_size,opt->hash_size,9500);
357 set_value(mp->hash_prime,opt->hash_prime,7919);
358 set_value(mp->param_size,opt->param_size,150);
359 set_value(mp->max_in_open,opt->max_in_open,10);
362 @ In case somebody has inadvertently made bad settings of the ``constants,''
363 \MP\ checks them using a global variable called |bad|.
365 This is the first of many sections of \MP\ where global variables are
369 integer bad; /* is some ``constant'' wrong? */
371 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
372 or something similar. (We can't do that until |max_halfword| has been defined.)
374 @<Check the ``constant'' values for consistency@>=
376 if ( (mp->half_error_line<30)||(mp->half_error_line>mp->error_line-15) ) mp->bad=1;
377 if ( mp->max_print_line<60 ) mp->bad=2;
378 if ( mp->mem_top<=1100 ) mp->bad=4;
379 if (mp->hash_prime>mp->hash_size ) mp->bad=5;
381 @ Labels are given symbolic names by the following definitions, so that
382 occasional |goto| statements will be meaningful. We insert the label
383 `|exit|:' just before the `\ignorespaces|end|\unskip' of a procedure in
384 which we have used the `|return|' statement defined below; the label
385 `|restart|' is occasionally used at the very beginning of a procedure; and
386 the label `|reswitch|' is occasionally used just prior to a |case|
387 statement in which some cases change the conditions and we wish to branch
388 to the newly applicable case. Loops that are set up with the |loop|
389 construction defined below are commonly exited by going to `|done|' or to
390 `|found|' or to `|not_found|', and they are sometimes repeated by going to
391 `|continue|'. If two or more parts of a subroutine start differently but
392 end up the same, the shared code may be gathered together at
395 Incidentally, this program never declares a label that isn't actually used,
396 because some fussy \PASCAL\ compilers will complain about redundant labels.
398 @d label_exit 10 /* go here to leave a procedure */
399 @d restart 20 /* go here to start a procedure again */
400 @d reswitch 21 /* go here to start a case statement again */
401 @d continue 22 /* go here to resume a loop */
402 @d done 30 /* go here to exit a loop */
403 @d done1 31 /* like |done|, when there is more than one loop */
404 @d done2 32 /* for exiting the second loop in a long block */
405 @d done3 33 /* for exiting the third loop in a very long block */
406 @d done4 34 /* for exiting the fourth loop in an extremely long block */
407 @d done5 35 /* for exiting the fifth loop in an immense block */
408 @d done6 36 /* for exiting the sixth loop in a block */
409 @d found 40 /* go here when you've found it */
410 @d found1 41 /* like |found|, when there's more than one per routine */
411 @d found2 42 /* like |found|, when there's more than two per routine */
412 @d found3 43 /* like |found|, when there's more than three per routine */
413 @d not_found 45 /* go here when you've found nothing */
414 @d common_ending 50 /* go here when you want to merge with another branch */
416 @ Here are some macros for common programming idioms.
418 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
419 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
420 @d negate(A) (A)=-(A) /* change the sign of a variable */
421 @d double(A) (A)=(A)+(A)
424 @d do_nothing /* empty statement */
425 @d Return goto exit /* terminate a procedure call */
426 @f return nil /* \.{WEB} will henceforth say |return| instead of \\{return} */
428 @* \[2] The character set.
429 In order to make \MP\ readily portable to a wide variety of
430 computers, all of its input text is converted to an internal eight-bit
431 code that includes standard ASCII, the ``American Standard Code for
432 Information Interchange.'' This conversion is done immediately when each
433 character is read in. Conversely, characters are converted from ASCII to
434 the user's external representation just before they are output to a
438 Such an internal code is relevant to users of \MP\ only with respect to
439 the \&{char} and \&{ASCII} operations, and the comparison of strings.
441 @ Characters of text that have been converted to \MP's internal form
442 are said to be of type |ASCII_code|, which is a subrange of the integers.
445 typedef unsigned char ASCII_code; /* eight-bit numbers */
447 @ The original \PASCAL\ compiler was designed in the late 60s, when six-bit
448 character sets were common, so it did not make provision for lowercase
449 letters. Nowadays, of course, we need to deal with both capital and small
450 letters in a convenient way, especially in a program for font design;
451 so the present specification of \MP\ has been written under the assumption
452 that the \PASCAL\ compiler and run-time system permit the use of text files
453 with more than 64 distinguishable characters. More precisely, we assume that
454 the character set contains at least the letters and symbols associated
455 with ASCII codes 040 through 0176; all of these characters are now
456 available on most computer terminals.
458 Since we are dealing with more characters than were present in the first
459 \PASCAL\ compilers, we have to decide what to call the associated data
460 type. Some \PASCAL s use the original name |char| for the
461 characters in text files, even though there now are more than 64 such
462 characters, while other \PASCAL s consider |char| to be a 64-element
463 subrange of a larger data type that has some other name.
465 In order to accommodate this difference, we shall use the name |text_char|
466 to stand for the data type of the characters that are converted to and
467 from |ASCII_code| when they are input and output. We shall also assume
468 that |text_char| consists of the elements |chr(first_text_char)| through
469 |chr(last_text_char)|, inclusive. The following definitions should be
470 adjusted if necessary.
471 @^system dependencies@>
473 @d first_text_char 0 /* ordinal number of the smallest element of |text_char| */
474 @d last_text_char 255 /* ordinal number of the largest element of |text_char| */
477 typedef unsigned char text_char; /* the data type of characters in text files */
479 @ @<Local variables for init...@>=
482 @ The \MP\ processor converts between ASCII code and
483 the user's external character set by means of arrays |xord| and |xchr|
484 that are analogous to \PASCAL's |ord| and |chr| functions.
486 @d xchr(A) mp->xchr[(A)]
487 @d xord(A) mp->xord[(A)]
490 ASCII_code xord[256]; /* specifies conversion of input characters */
491 text_char xchr[256]; /* specifies conversion of output characters */
493 @ The core system assumes all 8-bit is acceptable. If it is not,
494 a change file has to alter the below section.
495 @^system dependencies@>
497 Additionally, people with extended character sets can
498 assign codes arbitrarily, giving an |xchr| equivalent to whatever
499 characters the users of \MP\ are allowed to have in their input files.
500 Appropriate changes to \MP's |char_class| table should then be made.
501 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
502 codes, called the |char_class|.) Such changes make portability of programs
503 more difficult, so they should be introduced cautiously if at all.
504 @^character set dependencies@>
505 @^system dependencies@>
508 for (i=0;i<=0377;i++) { xchr(i)=i; }
510 @ The following system-independent code makes the |xord| array contain a
511 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
512 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
513 |j| or more; hence, standard ASCII code numbers will be used instead of
514 codes below 040 in case there is a coincidence.
517 for (i=first_text_char;i<=last_text_char;i++) {
520 for (i=0200;i<=0377;i++) { xord(xchr(i))=i;}
521 for (i=0;i<=0176;i++) { xord(xchr(i))=i;}
523 @* \[3] Input and output.
524 The bane of portability is the fact that different operating systems treat
525 input and output quite differently, perhaps because computer scientists
526 have not given sufficient attention to this problem. People have felt somehow
527 that input and output are not part of ``real'' programming. Well, it is true
528 that some kinds of programming are more fun than others. With existing
529 input/output conventions being so diverse and so messy, the only sources of
530 joy in such parts of the code are the rare occasions when one can find a
531 way to make the program a little less bad than it might have been. We have
532 two choices, either to attack I/O now and get it over with, or to postpone
533 I/O until near the end. Neither prospect is very attractive, so let's
536 The basic operations we need to do are (1)~inputting and outputting of
537 text, to or from a file or the user's terminal; (2)~inputting and
538 outputting of eight-bit bytes, to or from a file; (3)~instructing the
539 operating system to initiate (``open'') or to terminate (``close'') input or
540 output from a specified file; (4)~testing whether the end of an input
541 file has been reached; (5)~display of bits on the user's screen.
542 The bit-display operation will be discussed in a later section; we shall
543 deal here only with more traditional kinds of I/O.
545 @ Finding files happens in a slightly roundabout fashion: the \MP\
546 instance object contains a field that holds a function pointer that finds a
547 file, and returns its name, or NULL. For this, it receives three
548 parameters: the non-qualified name |fname|, the intended |fopen|
549 operation type |fmode|, and the type of the file |ftype|.
551 The file types that are passed on in |ftype| can be used to
552 differentiate file searches if a library like kpathsea is used,
553 the fopen mode is passed along for the same reason.
556 typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
558 @ @<Exported types@>=
560 mp_filetype_program = 1, /* \MP\ language input */
561 mp_filetype_log, /* the log file */
562 mp_filetype_postscript, /* the postscript output */
563 mp_filetype_text, /* text files for readfrom and writeto primitives */
564 mp_filetype_memfile, /* memory dumps */
565 mp_filetype_metrics, /* TeX font metric files */
566 mp_filetype_fontmap, /* PostScript font mapping files */
567 mp_filetype_font, /* PostScript type1 font programs */
568 mp_filetype_encoding, /* PostScript font encoding files */
570 typedef char *(*mp_file_finder)(char *, char *, int);
573 mp_file_finder find_file;
575 @ @<Option variables@>=
576 mp_file_finder find_file;
578 @ The default function for finding files is |mp_find_file|. It is
579 pretty stupid: it will only find files in the current directory.
582 char *mp_find_file (char *fname, char *fmode, int ftype) {
583 if (fmode[0] != 'r' || access (fname,R_OK) || ftype)
584 return strdup(fname);
588 @ This has to be done very early on, so it is best to put it in with
589 the |mp_new| allocations
591 @d set_callback_option(A) do { mp->A = mp_##A;
592 if (opt->A!=NULL) mp->A = opt->A;
595 @<Allocate or initialize ...@>=
596 set_callback_option(find_file);
598 @ Because |mp_find_file| is used so early, it has to be in the helpers
602 char *mp_find_file (char *fname, char *fmode, int ftype) ;
604 @ The function to open files can now be very short.
607 FILE *mp_open_file(MP mp, char *fname, char *fmode, int ftype) {
608 char *s = (mp->find_file)(fname,fmode,ftype);
610 FILE *f = fopen(s, fmode);
617 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
620 char name_of_file[file_name_size+1]; /* the name of a system file */
621 int name_length;/* this many characters are actually
622 relevant in |name_of_file| (the rest are blank) */
623 boolean print_found_names; /* configuration parameter */
625 @ @<Option variables@>=
626 int print_found_names; /* configuration parameter */
628 @ If this parameter is true, the terminal and log will report the found
629 file names for input files instead of the requested ones.
630 It is off by default because it creates an extra filename lookup.
632 @<Allocate or initialize ...@>=
633 mp->print_found_names = (opt->print_found_names>0 ? true : false);
635 @ \MP's file-opening procedures return |false| if no file identified by
636 |name_of_file| could be opened.
638 The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
639 It is not used for opening a mem file for read, because that file name
643 if (mp->print_found_names) {
644 char *s = (mp->find_file)(mp->name_of_file,A,ftype);
646 *f = mp_open_file(mp,mp->name_of_file,A, ftype);
647 strncpy(mp->name_of_file,s,file_name_size);
653 *f = mp_open_file(mp,mp->name_of_file,A, ftype);
656 return (*f ? true : false)
659 boolean mp_a_open_in (MP mp, FILE **f, int ftype) {
660 /* open a text file for input */
664 boolean mp_w_open_in (MP mp, FILE **f) {
665 /* open a word file for input */
666 *f = mp_open_file(mp,mp->name_of_file,"rb",mp_filetype_memfile);
667 return (*f ? true : false);
670 boolean mp_a_open_out (MP mp, FILE **f, int ftype) {
671 /* open a text file for output */
675 boolean mp_b_open_out (MP mp, FILE **f, int ftype) {
676 /* open a binary file for output */
680 boolean mp_w_open_out (MP mp, FILE**f) {
681 /* open a word file for output */
682 int ftype = mp_filetype_memfile;
687 FILE *mp_open_file(MP mp, char *fname, char *fmode, int ftype);
689 @ Binary input and output are done with \PASCAL's ordinary |get| and |put|
690 procedures, so we don't have to make any other special arrangements for
691 binary~I/O. Text output is also easy to do with standard \PASCAL\ routines.
692 The treatment of text input is more difficult, however, because
693 of the necessary translation to |ASCII_code| values.
694 \MP's conventions should be efficient, and they should
695 blend nicely with the user's operating environment.
697 @ Input from text files is read one line at a time, using a routine called
698 |input_ln|. This function is defined in terms of global variables called
699 |buffer|, |first|, and |last| that will be described in detail later; for
700 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
701 values, and that |first| and |last| are indices into this array
702 representing the beginning and ending of a line of text.
705 size_t buf_size; /* maximum number of characters simultaneously present in
706 current lines of open files */
707 ASCII_code *buffer; /* lines of characters being read */
708 size_t first; /* the first unused position in |buffer| */
709 size_t last; /* end of the line just input to |buffer| */
710 size_t max_buf_stack; /* largest index used in |buffer| */
712 @ @<Allocate or initialize ...@>=
714 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
716 @ @<Dealloc variables@>=
720 void mp_reallocate_buffer(MP mp, size_t l) {
722 if (l>max_halfword) {
723 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
725 buffer = xmalloc((l+1),sizeof(ASCII_code));
726 memcpy(buffer,mp->buffer,(mp->buf_size+1));
728 mp->buffer = buffer ;
732 @ The |input_ln| function brings the next line of input from the specified
733 field into available positions of the buffer array and returns the value
734 |true|, unless the file has already been entirely read, in which case it
735 returns |false| and sets |last:=first|. In general, the |ASCII_code|
736 numbers that represent the next line of the file are input into
737 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
738 global variable |last| is set equal to |first| plus the length of the
739 line. Trailing blanks are removed from the line; thus, either |last=first|
740 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
743 An overflow error is given, however, if the normal actions of |input_ln|
744 would make |last>=buf_size|; this is done so that other parts of \MP\
745 can safely look at the contents of |buffer[last+1]| without overstepping
746 the bounds of the |buffer| array. Upon entry to |input_ln|, the condition
747 |first<buf_size| will always hold, so that there is always room for an
750 The variable |max_buf_stack|, which is used to keep track of how large
751 the |buf_size| parameter must be to accommodate the present job, is
752 also kept up to date by |input_ln|.
754 If the |bypass_eoln| parameter is |true|, |input_ln| will do a |get|
755 before looking at the first character of the line; this skips over
756 an |eoln| that was in |f^|. The procedure does not do a |get| when it
757 reaches the end of the line; therefore it can be used to acquire input
758 from the user's terminal as well as from ordinary text files.
760 Standard \PASCAL\ says that a file should have |eoln| immediately
761 before |eof|, but \MP\ needs only a weaker restriction: If |eof|
762 occurs in the middle of a line, the system function |eoln| should return
763 a |true| result (even though |f^| will be undefined).
766 boolean mp_input_ln (MP mp,FILE * f, boolean bypass_eoln) {
767 /* inputs the next line or returns |false| */
768 int last_nonblank; /* |last| with trailing blanks removed */
774 if (c!='\n' && c!='\r') {
778 /* input the first character of the line into |f^| */
779 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
783 last_nonblank=mp->first;
784 while (c!=EOF && c!='\n' && c!='\r') {
785 if ( mp->last>=mp->max_buf_stack ) {
786 mp->max_buf_stack=mp->last+1;
787 if ( mp->max_buf_stack==mp->buf_size ) {
788 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
791 mp->buffer[mp->last]=xord(c);
793 if ( mp->buffer[mp->last-1]!=' ' )
794 last_nonblank=mp->last;
800 mp->last=last_nonblank;
804 @ The user's terminal acts essentially like other files of text, except
805 that it is used both for input and for output. When the terminal is
806 considered an input file, the file variable is called |term_in|, and when it
807 is considered an output file the file variable is |term_out|.
808 @^system dependencies@>
811 FILE * term_in; /* the terminal as an input file */
812 FILE * term_out; /* the terminal as an output file */
814 @ Here is how to open the terminal files. In the default configuration,
815 nothing happens except that the command line (if there is one) is copied
816 to the input buffer. The variable |command_line| will be filled by the
817 |main| procedure. The copying can not be done earlier in the program
818 logic because in the |INI| version, the |buffer| is also used for primitive
821 @^system dependencies@>
823 @d t_open_out /* open the terminal for text output */
824 @d t_open_in do { /* open the terminal for text input */
825 if (mp->command_line!=NULL) {
826 mp->last = strlen(mp->command_line);
827 strncpy((char *)mp->buffer,mp->command_line,mp->last);
828 xfree(mp->command_line);
835 @ @<Option variables@>=
838 @ @<Allocate or initialize ...@>=
839 mp->command_line = opt->command_line;
841 @ Sometimes it is necessary to synchronize the input/output mixture that
842 happens on the user's terminal, and three system-dependent
843 procedures are used for this
844 purpose. The first of these, |update_terminal|, is called when we want
845 to make sure that everything we have output to the terminal so far has
846 actually left the computer's internal buffers and been sent.
847 The second, |clear_terminal|, is called when we wish to cancel any
848 input that the user may have typed ahead (since we are about to
849 issue an unexpected error message). The third, |wake_up_terminal|,
850 is supposed to revive the terminal if the user has disabled it by
851 some instruction to the operating system. The following macros show how
852 these operations can be specified in \ph:
853 @^system dependencies@>
855 @d update_terminal fflush(mp->term_out) /* empty the terminal output buffer */
856 @d clear_terminal do_nothing /* clear the terminal input buffer */
857 @d wake_up_terminal fflush(mp->term_out) /* cancel the user's cancellation of output */
859 @ We need a special routine to read the first line of \MP\ input from
860 the user's terminal. This line is different because it is read before we
861 have opened the transcript file; there is sort of a ``chicken and
862 egg'' problem here. If the user types `\.{input cmr10}' on the first
863 line, or if some macro invoked by that line does such an \.{input},
864 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
865 commands are performed during the first line of terminal input, the transcript
866 file will acquire its default name `\.{mpout.log}'. (The transcript file
867 will not contain error messages generated by the first line before the
868 first \.{input} command.)
870 The first line is even more special if we are lucky enough to have an operating
871 system that treats \MP\ differently from a run-of-the-mill \PASCAL\ object
872 program. It's nice to let the user start running a \MP\ job by typing
873 a command line like `\.{MP cmr10}'; in such a case, \MP\ will operate
874 as if the first line of input were `\.{cmr10}', i.e., the first line will
875 consist of the remainder of the command line, after the part that invoked \MP.
877 @ Different systems have different ways to get started. But regardless of
878 what conventions are adopted, the routine that initializes the terminal
879 should satisfy the following specifications:
881 \yskip\textindent{1)}It should open file |term_in| for input from the
882 terminal. (The file |term_out| will already be open for output to the
885 \textindent{2)}If the user has given a command line, this line should be
886 considered the first line of terminal input. Otherwise the
887 user should be prompted with `\.{**}', and the first line of input
888 should be whatever is typed in response.
890 \textindent{3)}The first line of input, which might or might not be a
891 command line, should appear in locations |first| to |last-1| of the
894 \textindent{4)}The global variable |loc| should be set so that the
895 character to be read next by \MP\ is in |buffer[loc]|. This
896 character should not be blank, and we should have |loc<last|.
898 \yskip\noindent(It may be necessary to prompt the user several times
899 before a non-blank line comes in. The prompt is `\.{**}' instead of the
900 later `\.*' because the meaning is slightly different: `\.{input}' need
901 not be typed immediately after~`\.{**}'.)
903 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
905 @ The following program does the required initialization
906 without retrieving a possible command line.
907 It should be clear how to modify this routine to deal with command lines,
908 if the system permits them.
909 @^system dependencies@>
912 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
919 wake_up_terminal; fprintf(mp->term_out,"**"); update_terminal;
921 if ( ! mp_input_ln(mp, mp->term_in,true) ) { /* this shouldn't happen */
922 fprintf(mp->term_out,"\n! End of file on the terminal... why?");
923 @.End of file on the terminal@>
927 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
929 if ( loc<(int)mp->last ) {
930 return true; /* return unless the line was all blank */
932 fprintf(mp->term_out,"Please type the name of your input file.\n");
937 boolean mp_init_terminal (MP mp) ;
940 @* \[4] String handling.
941 Symbolic token names and diagnostic messages are variable-length strings
942 of eight-bit characters. Since \PASCAL\ does not have a well-developed string
943 mechanism, \MP\ does all of its string processing by homegrown methods.
945 \MP\ uses strings more extensively than \MF\ does, but the necessary
946 operations can still be handled with a fairly simple data structure.
947 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
948 of the strings, and the array |str_start| contains indices of the starting
949 points of each string. Strings are referred to by integer numbers, so that
950 string number |s| comprises the characters |str_pool[j]| for
951 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
952 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
953 location. The first string number not currently in use is |str_ptr|
954 and |next_str[str_ptr]| begins a list of free string numbers. String
955 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
956 string currently being constructed.
958 String numbers 0 to 255 are reserved for strings that correspond to single
959 ASCII characters. This is in accordance with the conventions of \.{WEB},
961 which converts single-character strings into the ASCII code number of the
962 single character involved, while it converts other strings into integers
963 and builds a string pool file. Thus, when the string constant \.{"."} appears
964 in the program below, \.{WEB} converts it into the integer 46, which is the
965 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
966 into some integer greater than~255. String number 46 will presumably be the
967 single character `\..'\thinspace; but some ASCII codes have no standard visible
968 representation, and \MP\ may need to be able to print an arbitrary
969 ASCII character, so the first 256 strings are used to specify exactly what
970 should be printed for each of the 256 possibilities.
973 typedef int pool_pointer; /* for variables that point into |str_pool| */
974 typedef int str_number; /* for variables that point into |str_start| */
977 ASCII_code *str_pool; /* the characters */
978 pool_pointer *str_start; /* the starting pointers */
979 str_number *next_str; /* for linking strings in order */
980 pool_pointer pool_ptr; /* first unused position in |str_pool| */
981 str_number str_ptr; /* number of the current string being created */
982 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
983 str_number init_str_use; /* the initial number of strings in use */
984 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
985 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
987 @ @<Allocate or initialize ...@>=
988 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
989 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
990 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
992 @ @<Dealloc variables@>=
994 xfree(mp->str_start);
997 @ Most printing is done from |char *|s, but sometimes not. Here are
998 functions that convert an internal string into a |char *| for use
999 by the printing routines, and vice versa.
1001 @d str(A) mp_str(mp,A)
1002 @d rts(A) mp_rts(mp,A)
1005 int mp_xstrcmp (const char *a, const char *b);
1006 char * mp_str (MP mp, str_number s);
1009 str_number mp_rts (MP mp, char *s);
1010 str_number mp_make_string (MP mp);
1012 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1013 very good: it does not handle nesting over more than one level.
1016 int mp_xstrcmp (const char *a, const char *b) {
1017 if (a==NULL && b==NULL)
1027 char * mp_str (MP mp, str_number ss) {
1030 if (ss==mp->str_ptr) {
1034 s = xmalloc(len+1,sizeof(char));
1035 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1040 str_number mp_rts (MP mp, char *s) {
1041 int r; /* the new string */
1042 int old; /* a possible string in progress */
1046 } else if (strlen(s)==1) {
1050 str_room((integer)strlen(s));
1051 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1052 old = mp_make_string(mp);
1057 r = mp_make_string(mp);
1059 str_room(length(old));
1060 while (i<length(old)) {
1061 append_char((mp->str_start[old]+i));
1063 mp_flush_string(mp,old);
1069 @ Except for |strs_used_up|, the following string statistics are only
1070 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1074 integer strs_used_up; /* strings in use or unused but not reclaimed */
1075 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1076 integer strs_in_use; /* total number of strings actually in use */
1077 integer max_pl_used; /* maximum |pool_in_use| so far */
1078 integer max_strs_used; /* maximum |strs_in_use| so far */
1080 @ Several of the elementary string operations are performed using \.{WEB}
1081 macros instead of \PASCAL\ procedures, because many of the
1082 operations are done quite frequently and we want to avoid the
1083 overhead of procedure calls. For example, here is
1084 a simple macro that computes the length of a string.
1087 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string
1089 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1091 @ The length of the current string is called |cur_length|. If we decide that
1092 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1093 |cur_length| becomes zero.
1095 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1096 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1098 @ Strings are created by appending character codes to |str_pool|.
1099 The |append_char| macro, defined here, does not check to see if the
1100 value of |pool_ptr| has gotten too high; this test is supposed to be
1101 made before |append_char| is used.
1103 To test if there is room to append |l| more characters to |str_pool|,
1104 we shall write |str_room(l)|, which tries to make sure there is enough room
1105 by compacting the string pool if necessary. If this does not work,
1106 |do_compaction| aborts \MP\ and gives an apologetic error message.
1108 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1109 { mp->str_pool[mp->pool_ptr]=(A); incr(mp->pool_ptr);
1111 @d str_room(A) /* make sure that the pool hasn't overflowed */
1112 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1113 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1114 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1117 @ The following routine is similar to |str_room(1)| but it uses the
1118 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1119 string space is exhausted.
1121 @<Declare the procedure called |unit_str_room|@>=
1122 void mp_unit_str_room (MP mp);
1125 void mp_unit_str_room (MP mp) {
1126 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1127 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1130 @ \MP's string expressions are implemented in a brute-force way: Every
1131 new string or substring that is needed is simply copied into the string pool.
1132 Space is eventually reclaimed by a procedure called |do_compaction| with
1133 the aid of a simple system system of reference counts.
1134 @^reference counts@>
1136 The number of references to string number |s| will be |str_ref[s]|. The
1137 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1138 positive number of references; such strings will never be recycled. If
1139 a string is ever referred to more than 126 times, simultaneously, we
1140 put it in this category. Hence a single byte suffices to store each |str_ref|.
1142 @d max_str_ref 127 /* ``infinite'' number of references */
1143 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]);
1149 @ @<Allocate or initialize ...@>=
1150 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1152 @ @<Dealloc variables@>=
1155 @ Here's what we do when a string reference disappears:
1157 @d delete_str_ref(A) {
1158 if ( mp->str_ref[(A)]<max_str_ref ) {
1159 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1160 else mp_flush_string(mp, (A));
1164 @<Declare the procedure called |flush_string|@>=
1165 void mp_flush_string (MP mp,str_number s) ;
1168 @ We can't flush the first set of static strings at all, so there
1169 is no point in trying
1172 void mp_flush_string (MP mp,str_number s) {
1174 mp->pool_in_use=mp->pool_in_use-length(s);
1175 decr(mp->strs_in_use);
1176 if ( mp->next_str[s]!=mp->str_ptr ) {
1180 decr(mp->strs_used_up);
1182 mp->pool_ptr=mp->str_start[mp->str_ptr];
1186 @ C literals cannot be simply added, they need to be set so they can't
1189 @d intern(A) mp_intern(mp,(A))
1192 str_number mp_intern (MP mp, char *s) {
1195 mp->str_ref[r] = max_str_ref;
1200 str_number mp_intern (MP mp, char *s);
1203 @ Once a sequence of characters has been appended to |str_pool|, it
1204 officially becomes a string when the function |make_string| is called.
1205 This function returns the identification number of the new string as its
1208 When getting the next unused string number from the linked list, we pretend
1210 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1211 are linked sequentially even though the |next_str| entries have not been
1212 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1213 |do_compaction| is responsible for making sure of this.
1216 @<Declare the procedure called |do_compaction|@>;
1217 @<Declare the procedure called |unit_str_room|@>;
1218 str_number mp_make_string (MP mp);
1221 str_number mp_make_string (MP mp) { /* current string enters the pool */
1222 str_number s; /* the new string */
1225 mp->str_ptr=mp->next_str[s];
1226 if ( mp->str_ptr>mp->max_str_ptr ) {
1227 if ( mp->str_ptr==mp->max_strings ) {
1229 mp_do_compaction(mp, 0);
1233 if ( mp->strs_used_up!=mp->max_str_ptr ) mp_confusion(mp, "s");
1234 @:this can't happen s}{\quad \.s@>
1236 mp->max_str_ptr=mp->str_ptr;
1237 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1241 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1242 incr(mp->strs_used_up);
1243 incr(mp->strs_in_use);
1244 mp->pool_in_use=mp->pool_in_use+length(s);
1245 if ( mp->pool_in_use>mp->max_pl_used )
1246 mp->max_pl_used=mp->pool_in_use;
1247 if ( mp->strs_in_use>mp->max_strs_used )
1248 mp->max_strs_used=mp->strs_in_use;
1252 @ The most interesting string operation is string pool compaction. The idea
1253 is to recover unused space in the |str_pool| array by recopying the strings
1254 to close the gaps created when some strings become unused. All string
1255 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1256 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1257 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1258 with |needed=mp->pool_size| supresses all overflow tests.
1260 The compaction process starts with |last_fixed_str| because all lower numbered
1261 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1264 str_number last_fixed_str; /* last permanently allocated string */
1265 str_number fixed_str_use; /* number of permanently allocated strings */
1267 @ @<Declare the procedure called |do_compaction|@>=
1268 void mp_do_compaction (MP mp, pool_pointer needed) ;
1271 void mp_do_compaction (MP mp, pool_pointer needed) {
1272 str_number str_use; /* a count of strings in use */
1273 str_number r,s,t; /* strings being manipulated */
1274 pool_pointer p,q; /* destination and source for copying string characters */
1275 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1276 r=mp->last_fixed_str;
1279 while ( s!=mp->str_ptr ) {
1280 while ( mp->str_ref[s]==0 ) {
1281 @<Advance |s| and add the old |s| to the list of free string numbers;
1282 then |break| if |s=str_ptr|@>;
1284 r=s; s=mp->next_str[s];
1286 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1287 after the end of the string@>;
1289 @<Move the current string back so that it starts at |p|@>;
1290 if ( needed<mp->pool_size ) {
1291 @<Make sure that there is room for another string with |needed| characters@>;
1293 @<Account for the compaction and make sure the statistics agree with the
1295 mp->strs_used_up=str_use;
1298 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1299 t=mp->next_str[mp->last_fixed_str];
1300 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1301 incr(mp->fixed_str_use);
1302 mp->last_fixed_str=t;
1305 str_use=mp->fixed_str_use
1307 @ Because of the way |flush_string| has been written, it should never be
1308 necessary to |break| here. The extra line of code seems worthwhile to
1309 preserve the generality of |do_compaction|.
1311 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1316 mp->next_str[t]=mp->next_str[mp->str_ptr];
1317 mp->next_str[mp->str_ptr]=t;
1318 if ( s==mp->str_ptr ) break;
1321 @ The string currently starts at |str_start[r]| and ends just before
1322 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1323 to locate the next string.
1325 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1328 while ( q<mp->str_start[s] ) {
1329 mp->str_pool[p]=mp->str_pool[q];
1333 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1334 we do this, anything between them should be moved.
1336 @ @<Move the current string back so that it starts at |p|@>=
1337 q=mp->str_start[mp->str_ptr];
1338 mp->str_start[mp->str_ptr]=p;
1339 while ( q<mp->pool_ptr ) {
1340 mp->str_pool[p]=mp->str_pool[q];
1345 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1347 @<Make sure that there is room for another string with |needed| char...@>=
1348 if ( str_use>=mp->max_strings-1 )
1349 mp_reallocate_strings (mp,str_use);
1350 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1351 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1352 mp->max_pool_ptr=mp->pool_ptr+needed;
1356 void mp_reallocate_strings (MP mp, str_number str_use) ;
1357 void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1360 void mp_reallocate_strings (MP mp, str_number str_use) {
1361 while ( str_use>=mp->max_strings-1 ) {
1362 int l = mp->max_strings + (mp->max_strings>>2);
1363 XREALLOC (mp->str_ref, l, int);
1364 XREALLOC (mp->str_start, l, pool_pointer);
1365 XREALLOC (mp->next_str, l, str_number);
1366 mp->max_strings = l;
1369 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1370 while ( needed>mp->pool_size ) {
1371 int l = mp->pool_size + (mp->pool_size>>2);
1372 XREALLOC (mp->str_pool, l, ASCII_code);
1377 @ @<Account for the compaction and make sure the statistics agree with...@>=
1378 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1379 mp_confusion(mp, "string");
1380 @:this can't happen string}{\quad string@>
1381 incr(mp->pact_count);
1382 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1383 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1385 s=mp->str_ptr; t=str_use;
1386 while ( s<=mp->max_str_ptr ){
1387 if ( t>mp->max_str_ptr ) mp_confusion(mp, "\"");
1388 incr(t); s=mp->next_str[s];
1390 if ( t<=mp->max_str_ptr ) mp_confusion(mp, "\"");
1393 @ A few more global variables are needed to keep track of statistics when
1394 |stat| $\ldots$ |tats| blocks are not commented out.
1397 integer pact_count; /* number of string pool compactions so far */
1398 integer pact_chars; /* total number of characters moved during compactions */
1399 integer pact_strs; /* total number of strings moved during compactions */
1401 @ @<Initialize compaction statistics@>=
1406 @ The following subroutine compares string |s| with another string of the
1407 same length that appears in |buffer| starting at position |k|;
1408 the result is |true| if and only if the strings are equal.
1411 boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1412 /* test equality of strings */
1413 pool_pointer j; /* running index */
1415 while ( j<str_stop(s) ) {
1416 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1422 @ Here is a similar routine, but it compares two strings in the string pool,
1423 and it does not assume that they have the same length. If the first string
1424 is lexicographically greater than, less than, or equal to the second,
1425 the result is respectively positive, negative, or zero.
1428 integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1429 /* test equality of strings */
1430 pool_pointer j,k; /* running indices */
1431 integer ls,lt; /* lengths */
1432 integer l; /* length remaining to test */
1433 ls=length(s); lt=length(t);
1434 if ( ls<=lt ) l=ls; else l=lt;
1435 j=mp->str_start[s]; k=mp->str_start[t];
1437 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1438 return (mp->str_pool[j]-mp->str_pool[k]);
1445 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1446 and |str_ptr| are computed by the \.{INIMP} program, based in part
1447 on the information that \.{WEB} has output while processing \MP.
1452 void mp_get_strings_started (MP mp) {
1453 /* initializes the string pool,
1454 but returns |false| if something goes wrong */
1455 int k; /* small indices or counters */
1456 str_number g; /* a new string */
1457 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1460 mp->pool_in_use=0; mp->strs_in_use=0;
1461 mp->max_pl_used=0; mp->max_strs_used=0;
1462 @<Initialize compaction statistics@>;
1464 @<Make the first 256 strings@>;
1465 g=mp_make_string(mp); /* string 256 == "" */
1466 mp->str_ref[g]=max_str_ref;
1467 mp->last_fixed_str=mp->str_ptr-1;
1468 mp->fixed_str_use=mp->str_ptr;
1473 void mp_get_strings_started (MP mp);
1475 @ The first 256 strings will consist of a single character only.
1477 @<Make the first 256...@>=
1478 for (k=0;k<=255;k++) {
1480 g=mp_make_string(mp);
1481 mp->str_ref[g]=max_str_ref;
1484 @ The first 128 strings will contain 95 standard ASCII characters, and the
1485 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1486 unless a system-dependent change is made here. Installations that have
1487 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1488 would like string 032 to be printed as the single character 032 instead
1489 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1490 even people with an extended character set will want to represent string
1491 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1492 to produce visible strings instead of tabs or line-feeds or carriage-returns
1493 or bell-rings or characters that are treated anomalously in text files.
1495 Unprintable characters of codes 128--255 are, similarly, rendered
1496 \.{\^\^80}--\.{\^\^ff}.
1498 The boolean expression defined here should be |true| unless \MP\ internal
1499 code number~|k| corresponds to a non-troublesome visible symbol in the
1500 local character set.
1501 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1502 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1504 @^character set dependencies@>
1505 @^system dependencies@>
1507 @<Character |k| cannot be printed@>=
1510 @* \[5] On-line and off-line printing.
1511 Messages that are sent to a user's terminal and to the transcript-log file
1512 are produced by several `|print|' procedures. These procedures will
1513 direct their output to a variety of places, based on the setting of
1514 the global variable |selector|, which has the following possible
1518 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1521 \hang |log_only|, prints only on the transcript file.
1523 \hang |term_only|, prints only on the terminal.
1525 \hang |no_print|, doesn't print at all. This is used only in rare cases
1526 before the transcript file is open.
1528 \hang |ps_file_only| prints only on the \ps\ output file.
1530 \hang |pseudo|, puts output into a cyclic buffer that is used
1531 by the |show_context| routine; when we get to that routine we shall discuss
1532 the reasoning behind this curious mode.
1534 \hang |new_string|, appends the output to the current string in the
1537 \hang |>=write_file| prints on one of the files used for the \&{write}
1538 @:write_}{\&{write} primitive@>
1542 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1543 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1544 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1545 relations are not used when |selector| could be |pseudo|, |new_string|,
1546 or |ps_file_only|. We need not check for unprintable characters when
1549 Four additional global variables, |tally|, |term_offset|, |file_offset|,
1550 and |ps_offset| record the number of characters that have been printed
1551 since they were most recently cleared to zero. We use |tally| to record
1552 the length of (possibly very long) stretches of printing; |term_offset|,
1553 |file_offset|, and |ps_offset|, on the other hand, keep track of how many
1554 characters have appeared so far on the current line that has been output
1555 to the terminal, the transcript file, or the \ps\ output file, respectively.
1557 @d new_string 0 /* printing is deflected to the string pool */
1558 @d ps_file_only 1 /* printing goes to the \ps\ output file */
1559 @d pseudo 2 /* special |selector| setting for |show_context| */
1560 @d no_print 3 /* |selector| setting that makes data disappear */
1561 @d term_only 4 /* printing is destined for the terminal only */
1562 @d log_only 5 /* printing is destined for the transcript file only */
1563 @d term_and_log 6 /* normal |selector| setting */
1564 @d write_file 7 /* first write file selector */
1567 FILE * log_file; /* transcript of \MP\ session */
1568 FILE * ps_file; /* the generic font output goes here */
1569 unsigned int selector; /* where to print a message */
1570 unsigned char dig[23]; /* digits in a number being output */
1571 integer tally; /* the number of characters recently printed */
1572 unsigned int term_offset;
1573 /* the number of characters on the current terminal line */
1574 unsigned int file_offset;
1575 /* the number of characters on the current file line */
1577 /* the number of characters on the current \ps\ file line */
1578 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1579 integer trick_count; /* threshold for pseudoprinting, explained later */
1580 integer first_count; /* another variable for pseudoprinting */
1582 @ @<Allocate or initialize ...@>=
1583 memset(mp->dig,0,23);
1584 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1586 @ @<Dealloc variables@>=
1587 xfree(mp->trick_buf);
1589 @ @<Initialize the output routines@>=
1590 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0; mp->ps_offset=0;
1592 @ Macro abbreviations for output to the terminal and to the log file are
1593 defined here for convenience. Some systems need special conventions
1594 for terminal output, and it is possible to adhere to those conventions
1595 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1596 @^system dependencies@>
1598 @d wterm(A) fprintf(mp->term_out,"%s",(A))
1599 @d wterm_chr(A)fprintf(mp->term_out,"%c",(A))
1600 @d wterm_ln(A) fprintf(mp->term_out,"\n%s",(A))
1601 @d wterm_cr fprintf(mp->term_out,"\n")
1602 @d wlog(A) fprintf(mp->log_file,"%s",(A))
1603 @d wlog_chr(A) fprintf(mp->log_file,"%c",(A))
1604 @d wlog_ln(A) fprintf(mp->log_file,"\n%s",(A))
1605 @d wlog_cr fprintf(mp->log_file, "\n")
1606 @d wps(A) fprintf(mp->ps_file,"%s",(A))
1607 @d wps_chr(A) fprintf(mp->ps_file,"%c",(A))
1608 @d wps_ln(A) fprintf(mp->ps_file,,"\n%s",(A))
1609 @d wps_cr fprintf(mp->ps_file,"\n")
1611 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1612 use an array |wr_file| that will be declared later.
1614 @d mp_print_text(A) mp_print_str(mp,text((A)))
1617 void mp_print_ln (MP mp);
1618 void mp_print_visible_char (MP mp, ASCII_code s);
1619 void mp_print_char (MP mp, ASCII_code k);
1620 void mp_print (MP mp, char *s);
1621 void mp_print_str (MP mp, str_number s);
1622 void mp_print_nl (MP mp, char *s);
1623 void mp_print_two (MP mp,scaled x, scaled y) ;
1624 void mp_print_scaled (MP mp,scaled s);
1626 @ @<Basic print...@>=
1627 void mp_print_ln (MP mp) { /* prints an end-of-line */
1628 switch (mp->selector) {
1631 mp->term_offset=0; mp->file_offset=0;
1634 wlog_cr; mp->file_offset=0;
1637 wterm_cr; mp->term_offset=0;
1640 wps_cr; mp->ps_offset=0;
1647 fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1649 } /* note that |tally| is not affected */
1651 @ The |print_visible_char| procedure sends one character to the desired
1652 destination, using the |xchr| array to map it into an external character
1653 compatible with |input_ln|. (It assumes that it is always called with
1654 a visible ASCII character.) All printing comes through |print_ln| or
1655 |print_char|, which ultimately calls |print_visible_char|, hence these
1656 routines are the ones that limit lines to at most |max_print_line| characters.
1657 But we must make an exception for the \ps\ output file since it is not safe
1658 to cut up lines arbitrarily in \ps.
1660 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1661 |do_compaction| and |do_compaction| can call the error routines. Actually,
1662 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1664 @<Basic printing...@>=
1665 void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1666 switch (mp->selector) {
1668 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1669 incr(mp->term_offset); incr(mp->file_offset);
1670 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1671 wterm_cr; mp->term_offset=0;
1673 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1674 wlog_cr; mp->file_offset=0;
1678 wlog_chr(xchr(s)); incr(mp->file_offset);
1679 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1682 wterm_chr(xchr(s)); incr(mp->term_offset);
1683 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1687 wps_cr; mp->ps_offset=0;
1689 wps_chr(xchr(s)); incr(mp->ps_offset);
1695 if ( mp->tally<mp->trick_count )
1696 mp->trick_buf[mp->tally % mp->error_line]=s;
1699 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1700 mp_unit_str_room(mp);
1701 if ( mp->pool_ptr>=mp->pool_size )
1702 goto DONE; /* drop characters if string space is full */
1707 fprintf(mp->wr_file[(mp->selector-write_file)],"%c",xchr(s));
1713 @ The |print_char| procedure sends one character to the desired destination.
1714 File names and string expressions might contain |ASCII_code| values that
1715 can't be printed using |print_visible_char|. These characters will be
1716 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1717 (This procedure assumes that it is safe to bypass all checks for unprintable
1718 characters when |selector| is in the range |0..max_write_files-1| or when
1719 |selector=ps_file_only|. In the former case the user might want to write
1720 unprintable characters, and in the latter case the \ps\ printing routines
1721 check their arguments themselves before calling |print_char| or |print|.)
1723 @d print_lc_hex(A) do { l=(A);
1724 mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
1727 @<Basic printing...@>=
1728 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1729 int l; /* small index or counter */
1730 if ( mp->selector<pseudo || mp->selector>=write_file) {
1731 mp_print_visible_char(mp, k);
1732 } else if ( @<Character |k| cannot be printed@> ) {
1735 mp_print_visible_char(mp, k+0100);
1736 } else if ( k<0200 ) {
1737 mp_print_visible_char(mp, k-0100);
1739 print_lc_hex(k / 16);
1740 print_lc_hex(k % 16);
1743 mp_print_visible_char(mp, k);
1747 @ An entire string is output by calling |print|. Note that if we are outputting
1748 the single standard ASCII character \.c, we could call |print("c")|, since
1749 |"c"=99| is the number of a single-character string, as explained above. But
1750 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1751 routine when it knows that this is safe. (The present implementation
1752 assumes that it is always safe to print a visible ASCII character.)
1753 @^system dependencies@>
1756 void mp_do_print (MP mp, char *ss, unsigned int len) { /* prints string |s| */
1759 mp_print_char(mp, ss[j]); incr(j);
1765 void mp_print (MP mp, char *ss) {
1766 mp_do_print(mp, ss, strlen(ss));
1768 void mp_print_str (MP mp, str_number s) {
1769 pool_pointer j; /* current character code position */
1770 if ( (s<0)||(s>mp->max_str_ptr) ) {
1771 mp_do_print(mp,"???",3); /* this can't happen */
1775 mp_do_print(mp, (char *)(mp->str_pool+j), (str_stop(s)-j));
1779 @ Here is the very first thing that \MP\ prints: a headline that identifies
1780 the version number and base name. The |term_offset| variable is temporarily
1781 incorrect, but the discrepancy is not serious since we assume that the banner
1782 and mem identifier together will occupy at most |max_print_line|
1783 character positions.
1785 @<Initialize the output...@>=
1787 wterm (version_string);
1788 if (mp->mem_ident!=NULL)
1789 mp_print(mp,mp->mem_ident);
1793 @ The procedure |print_nl| is like |print|, but it makes sure that the
1794 string appears at the beginning of a new line.
1797 void mp_print_nl (MP mp, char *s) { /* prints string |s| at beginning of line */
1798 switch(mp->selector) {
1800 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1803 if ( mp->file_offset>0 ) mp_print_ln(mp);
1806 if ( mp->term_offset>0 ) mp_print_ln(mp);
1809 if ( mp->ps_offset>0 ) mp_print_ln(mp);
1815 } /* there are no other cases */
1819 @ An array of digits in the range |0..9| is printed by |print_the_digs|.
1822 void mp_print_the_digs (MP mp, eight_bits k) {
1823 /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */
1825 decr(k); mp_print_char(mp, '0'+mp->dig[k]);
1829 @ The following procedure, which prints out the decimal representation of a
1830 given integer |n|, has been written carefully so that it works properly
1831 if |n=0| or if |(-n)| would cause overflow. It does not apply |mod| or |div|
1832 to negative arguments, since such operations are not implemented consistently
1833 by all \PASCAL\ compilers.
1836 void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1837 integer m; /* used to negate |n| in possibly dangerous cases */
1838 int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
1840 mp_print_char(mp, '-');
1841 if ( n>-100000000 ) {
1844 m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
1848 mp->dig[0]=0; incr(n);
1853 mp->dig[k]=n % 10; n=n / 10; incr(k);
1855 mp_print_the_digs(mp, k);
1859 void mp_print_int (MP mp,integer n);
1861 @ \MP\ also makes use of a trivial procedure to print two digits. The
1862 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1865 void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1867 mp_print_char(mp, '0'+(n / 10));
1868 mp_print_char(mp, '0'+(n % 10));
1873 void mp_print_dd (MP mp,integer n);
1875 @ Here is a procedure that asks the user to type a line of input,
1876 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1877 The input is placed into locations |first| through |last-1| of the
1878 |buffer| array, and echoed on the transcript file if appropriate.
1880 This procedure is never called when |interaction<mp_scroll_mode|.
1882 @d prompt_input(A) do {
1883 wake_up_terminal; mp_print(mp, (A)); mp_term_input(mp);
1884 } while (0) /* prints a string and gets a line of input */
1887 void mp_term_input (MP mp) { /* gets a line from the terminal */
1888 size_t k; /* index into |buffer| */
1889 update_terminal; /* Now the user sees the prompt for sure */
1890 if (!mp_input_ln(mp, mp->term_in,true))
1891 mp_fatal_error(mp, "End of file on the terminal!");
1892 @.End of file on the terminal@>
1893 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1894 decr(mp->selector); /* prepare to echo the input */
1895 if ( mp->last!=mp->first ) {
1896 for (k=mp->first;k<=mp->last-1;k++) {
1897 mp_print_char(mp, mp->buffer[k]);
1901 mp->buffer[mp->last]='%';
1902 incr(mp->selector); /* restore previous status */
1905 @* \[6] Reporting errors.
1906 When something anomalous is detected, \MP\ typically does something like this:
1907 $$\vbox{\halign{#\hfil\cr
1908 |print_err("Something anomalous has been detected");|\cr
1909 |help3("This is the first line of my offer to help.")|\cr
1910 |("This is the second line. I'm trying to")|\cr
1911 |("explain the best way for you to proceed.");|\cr
1913 A two-line help message would be given using |help2|, etc.; these informal
1914 helps should use simple vocabulary that complements the words used in the
1915 official error message that was printed. (Outside the U.S.A., the help
1916 messages should preferably be translated into the local vernacular. Each
1917 line of help is at most 60 characters long, in the present implementation,
1918 so that |max_print_line| will not be exceeded.)
1920 The |print_err| procedure supplies a `\.!' before the official message,
1921 and makes sure that the terminal is awake if a stop is going to occur.
1922 The |error| procedure supplies a `\..' after the official message, then it
1923 shows the location of the error; and if |interaction=error_stop_mode|,
1924 it also enters into a dialog with the user, during which time the help
1925 message may be printed.
1926 @^system dependencies@>
1928 @ The global variable |interaction| has four settings, representing increasing
1929 amounts of user interaction:
1932 enum mp_interaction_mode {
1933 mp_unspecified_mode=0, /* extra value for command-line switch */
1934 mp_batch_mode, /* omits all stops and omits terminal output */
1935 mp_nonstop_mode, /* omits all stops */
1936 mp_scroll_mode, /* omits error stops */
1937 mp_error_stop_mode, /* stops at every opportunity to interact */
1941 int interaction; /* current level of interaction */
1943 @ @<Option variables@>=
1944 int interaction; /* current level of interaction */
1946 @ Set it here so it can be overwritten by the commandline
1948 @<Allocate or initialize ...@>=
1949 mp->interaction=opt->interaction;
1950 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
1951 mp->interaction=mp_error_stop_mode;
1952 if (mp->interaction<mp_unspecified_mode)
1953 mp->interaction=mp_batch_mode;
1957 @d print_err(A) mp_print_err(mp,(A))
1960 void mp_print_err(MP mp, char * A);
1963 void mp_print_err(MP mp, char * A) {
1964 if ( mp->interaction==mp_error_stop_mode )
1966 mp_print_nl(mp, "! ");
1972 @ \MP\ is careful not to call |error| when the print |selector| setting
1973 might be unusual. The only possible values of |selector| at the time of
1976 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
1977 and |log_file| not yet open);
1979 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
1981 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
1983 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
1985 @<Initialize the print |selector| based on |interaction|@>=
1986 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
1988 @ A global variable |deletions_allowed| is set |false| if the |get_next|
1989 routine is active when |error| is called; this ensures that |get_next|
1990 will never be called recursively.
1993 The global variable |history| records the worst level of error that
1994 has been detected. It has four possible values: |spotless|, |warning_issued|,
1995 |error_message_issued|, and |fatal_error_stop|.
1997 Another global variable, |error_count|, is increased by one when an
1998 |error| occurs without an interactive dialog, and it is reset to zero at
1999 the end of every statement. If |error_count| reaches 100, \MP\ decides
2000 that there is no point in continuing further.
2003 enum mp_history_states {
2004 mp_spotless=0, /* |history| value when nothing has been amiss yet */
2005 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
2006 mp_error_message_issued, /* |history| value when |error| has been called */
2007 mp_fatal_error_stop, /* |history| value when termination was premature */
2011 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
2012 int history; /* has the source input been clean so far? */
2013 int error_count; /* the number of scrolled errors since the last statement ended */
2015 @ The value of |history| is initially |fatal_error_stop|, but it will
2016 be changed to |spotless| if \MP\ survives the initialization process.
2018 @<Allocate or ...@>=
2019 mp->deletions_allowed=true; mp->error_count=0; /* |history| is initialized elsewhere */
2021 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2022 error procedures near the beginning of the program. But the error procedures
2023 in turn use some other procedures, which need to be declared |forward|
2024 before we get to |error| itself.
2026 It is possible for |error| to be called recursively if some error arises
2027 when |get_next| is being used to delete a token, and/or if some fatal error
2028 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2030 is never more than two levels deep.
2033 void mp_get_next (MP mp);
2034 void mp_term_input (MP mp);
2035 void mp_show_context (MP mp);
2036 void mp_begin_file_reading (MP mp);
2037 void mp_open_log_file (MP mp);
2038 void mp_clear_for_error_prompt (MP mp);
2039 void mp_debug_help (MP mp);
2040 @<Declare the procedure called |flush_string|@>
2043 void mp_normalize_selector (MP mp);
2045 @ Individual lines of help are recorded in the array |help_line|, which
2046 contains entries in positions |0..(help_ptr-1)|. They should be printed
2047 in reverse order, i.e., with |help_line[0]| appearing last.
2049 @d hlp1(A) mp->help_line[0]=(A); }
2050 @d hlp2(A) mp->help_line[1]=(A); hlp1
2051 @d hlp3(A) mp->help_line[2]=(A); hlp2
2052 @d hlp4(A) mp->help_line[3]=(A); hlp3
2053 @d hlp5(A) mp->help_line[4]=(A); hlp4
2054 @d hlp6(A) mp->help_line[5]=(A); hlp5
2055 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2056 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2057 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2058 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2059 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2060 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2061 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2064 char * help_line[6]; /* helps for the next |error| */
2065 unsigned int help_ptr; /* the number of help lines present */
2066 boolean use_err_help; /* should the |err_help| string be shown? */
2067 str_number err_help; /* a string set up by \&{errhelp} */
2068 str_number filename_template; /* a string set up by \&{filenametemplate} */
2070 @ @<Allocate or ...@>=
2071 mp->help_ptr=0; mp->use_err_help=false; mp->err_help=0; mp->filename_template=0;
2073 @ The |jump_out| procedure just cuts across all active procedure levels and
2074 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2075 whole program. It is used when there is no recovery from a particular error.
2077 The program uses a |jump_buf| to handle this, this is initialized at three
2078 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2079 of |mp_run|. Those are the only library enty points.
2081 @^system dependencies@>
2086 @ @<Install and test the non-local jump buffer@>=
2087 if (setjmp(mp->jump_buf) != 0) return mp->history;
2089 @ @<Setup the non-local jump buffer in |mp_new|@>=
2090 if (setjmp(mp->jump_buf) != 0) return NULL;
2092 @ If |mp->internal| is zero, then a crash occured during initialization,
2093 and it is not safe to run |mp_close_files_and_terminate|.
2096 void mp_jump_out (MP mp) {
2097 if(mp->internal!=NULL)
2098 mp_close_files_and_terminate(mp);
2099 longjmp(mp->jump_buf,1);
2102 @ Here now is the general |error| routine.
2105 void mp_error (MP mp) { /* completes the job of error reporting */
2106 ASCII_code c; /* what the user types */
2107 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2108 pool_pointer j; /* character position being printed */
2109 if ( mp->history<mp_error_message_issued ) mp->history=mp_error_message_issued;
2110 mp_print_char(mp, '.'); mp_show_context(mp);
2111 if ( mp->interaction==mp_error_stop_mode ) {
2112 @<Get user's advice and |return|@>;
2114 incr(mp->error_count);
2115 if ( mp->error_count==100 ) {
2116 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2117 @.That makes 100 errors...@>
2118 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2120 @<Put help message on the transcript file@>;
2122 void mp_warn (MP mp, char *msg) {
2123 int saved_selector = mp->selector;
2124 mp_normalize_selector(mp);
2125 mp_print_nl(mp,"Warning: ");
2127 mp->selector = saved_selector;
2130 @ @<Exported function ...@>=
2131 void mp_error (MP mp);
2132 void mp_warn (MP mp, char *msg);
2135 @ @<Get user's advice...@>=
2138 mp_clear_for_error_prompt(mp); prompt_input("? ");
2140 if ( mp->last==mp->first ) return;
2141 c=mp->buffer[mp->first];
2142 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2143 @<Interpret code |c| and |return| if done@>;
2146 @ It is desirable to provide an `\.E' option here that gives the user
2147 an easy way to return from \MP\ to the system editor, with the offending
2148 line ready to be edited. But such an extension requires some system
2149 wizardry, so the present implementation simply types out the name of the
2151 edited and the relevant line number.
2152 @^system dependencies@>
2155 typedef void (*mp_run_editor_command)(MP, char *, int);
2158 mp_run_editor_command run_editor;
2160 @ @<Option variables@>=
2161 mp_run_editor_command run_editor;
2163 @ @<Allocate or initialize ...@>=
2164 set_callback_option(run_editor);
2167 void mp_run_editor (MP mp, char *fname, int fline);
2169 @ @c void mp_run_editor (MP mp, char *fname, int fline) {
2170 mp_print_nl(mp, "You want to edit file ");
2171 @.You want to edit file x@>
2172 mp_print(mp, fname);
2173 mp_print(mp, " at line ");
2174 mp_print_int(mp, fline);
2175 mp->interaction=mp_scroll_mode;
2180 There is a secret `\.D' option available when the debugging routines haven't
2184 @<Interpret code |c| and |return| if done@>=
2186 case '0': case '1': case '2': case '3': case '4':
2187 case '5': case '6': case '7': case '8': case '9':
2188 if ( mp->deletions_allowed ) {
2189 @<Delete |c-"0"| tokens and |continue|@>;
2194 mp_debug_help(mp); continue;
2198 if ( mp->file_ptr>0 ){
2199 (mp->run_editor)(mp,
2200 str(mp->input_stack[mp->file_ptr].name_field),
2205 @<Print the help information and |continue|@>;
2208 @<Introduce new material from the terminal and |return|@>;
2210 case 'Q': case 'R': case 'S':
2211 @<Change the interaction level and |return|@>;
2214 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2219 @<Print the menu of available options@>
2221 @ @<Print the menu...@>=
2223 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2224 @.Type <return> to proceed...@>
2225 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2226 mp_print_nl(mp, "I to insert something, ");
2227 if ( mp->file_ptr>0 )
2228 mp_print(mp, "E to edit your file,");
2229 if ( mp->deletions_allowed )
2230 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2231 mp_print_nl(mp, "H for help, X to quit.");
2234 @ Here the author of \MP\ apologizes for making use of the numerical
2235 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2236 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2237 @^Knuth, Donald Ervin@>
2239 @<Change the interaction...@>=
2241 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2242 mp_print(mp, "OK, entering ");
2244 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2245 case 'R': mp_print(mp, "nonstopmode"); break;
2246 case 'S': mp_print(mp, "scrollmode"); break;
2247 } /* there are no other cases */
2248 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2251 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2252 contain the material inserted by the user; otherwise another prompt will
2253 be given. In order to understand this part of the program fully, you need
2254 to be familiar with \MP's input stacks.
2256 @<Introduce new material...@>=
2258 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2259 if ( mp->last>mp->first+1 ) {
2260 loc=mp->first+1; mp->buffer[mp->first]=' ';
2262 prompt_input("insert>"); loc=mp->first;
2265 mp->first=mp->last+1; mp->cur_input.limit_field=mp->last; return;
2268 @ We allow deletion of up to 99 tokens at a time.
2270 @<Delete |c-"0"| tokens...@>=
2272 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2273 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2274 c=c*10+mp->buffer[mp->first+1]-'0'*11;
2278 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2279 @<Decrease the string reference count, if the current token is a string@>;
2282 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2283 help2("I have just deleted some text, as you asked.")
2284 ("You can now delete more, or insert, or whatever.");
2285 mp_show_context(mp);
2289 @ @<Print the help info...@>=
2291 if ( mp->use_err_help ) {
2292 @<Print the string |err_help|, possibly on several lines@>;
2293 mp->use_err_help=false;
2295 if ( mp->help_ptr==0 ) {
2296 help2("Sorry, I don't know how to help in this situation.")
2297 ("Maybe you should try asking a human?");
2300 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2301 } while (mp->help_ptr!=0);
2303 help4("Sorry, I already gave what help I could...")
2304 ("Maybe you should try asking a human?")
2305 ("An error might have occurred before I noticed any problems.")
2306 ("``If all else fails, read the instructions.''");
2310 @ @<Print the string |err_help|, possibly on several lines@>=
2311 j=mp->str_start[mp->err_help];
2312 while ( j<str_stop(mp->err_help) ) {
2313 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2314 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2315 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2316 else { incr(j); mp_print_char(mp, '%'); };
2320 @ @<Put help message on the transcript file@>=
2321 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2322 if ( mp->use_err_help ) {
2323 mp_print_nl(mp, "");
2324 @<Print the string |err_help|, possibly on several lines@>;
2326 while ( mp->help_ptr>0 ){
2327 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2331 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2334 @ In anomalous cases, the print selector might be in an unknown state;
2335 the following subroutine is called to fix things just enough to keep
2336 running a bit longer.
2339 void mp_normalize_selector (MP mp) {
2340 if ( mp->log_opened ) mp->selector=term_and_log;
2341 else mp->selector=term_only;
2342 if ( mp->job_name==NULL ) mp_open_log_file(mp);
2343 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2346 @ The following procedure prints \MP's last words before dying.
2348 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2349 mp->interaction=mp_scroll_mode; /* no more interaction */
2350 if ( mp->log_opened ) mp_error(mp);
2351 /* if ( mp->interaction>mp_batch_mode ) mp_debug_help(mp); */
2352 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2356 void mp_fatal_error (MP mp, char *s) { /* prints |s|, and that's it */
2357 mp_normalize_selector(mp);
2358 print_err("Emergency stop"); help1(s); succumb;
2362 @ @<Exported function ...@>=
2363 void mp_fatal_error (MP mp, char *s);
2366 @ Here is the most dreaded error message.
2369 void mp_overflow (MP mp, char *s, integer n) { /* stop due to finiteness */
2370 mp_normalize_selector(mp);
2371 print_err("MetaPost capacity exceeded, sorry [");
2372 @.MetaPost capacity exceeded ...@>
2373 mp_print(mp, s); mp_print_char(mp, '='); mp_print_int(mp, n); mp_print_char(mp, ']');
2374 help2("If you really absolutely need more capacity,")
2375 ("you can ask a wizard to enlarge me.");
2380 void mp_overflow (MP mp, char *s, integer n);
2382 @ The program might sometime run completely amok, at which point there is
2383 no choice but to stop. If no previous error has been detected, that's bad
2384 news; a message is printed that is really intended for the \MP\
2385 maintenance person instead of the user (unless the user has been
2386 particularly diabolical). The index entries for `this can't happen' may
2387 help to pinpoint the problem.
2390 @<Internal library ...@>=
2391 void mp_confusion (MP mp,char *s);
2393 @ @<Error hand...@>=
2394 void mp_confusion (MP mp,char *s) {
2395 /* consistency check violated; |s| tells where */
2396 mp_normalize_selector(mp);
2397 if ( mp->history<mp_error_message_issued ) {
2398 print_err("This can't happen ("); mp_print(mp, s); mp_print_char(mp, ')');
2399 @.This can't happen@>
2400 help1("I'm broken. Please show this to someone who can fix can fix");
2402 print_err("I can\'t go on meeting you like this");
2403 @.I can't go on...@>
2404 help2("One of your faux pas seems to have wounded me deeply...")
2405 ("in fact, I'm barely conscious. Please fix it and try again.");
2410 @ Users occasionally want to interrupt \MP\ while it's running.
2411 If the \PASCAL\ runtime system allows this, one can implement
2412 a routine that sets the global variable |interrupt| to some nonzero value
2413 when such an interrupt is signaled. Otherwise there is probably at least
2414 a way to make |interrupt| nonzero using the \PASCAL\ debugger.
2415 @^system dependencies@>
2418 @d check_interrupt { if ( mp->interrupt!=0 )
2419 mp_pause_for_instructions(mp); }
2422 integer interrupt; /* should \MP\ pause for instructions? */
2423 boolean OK_to_interrupt; /* should interrupts be observed? */
2425 @ @<Allocate or ...@>=
2426 mp->interrupt=0; mp->OK_to_interrupt=true;
2428 @ When an interrupt has been detected, the program goes into its
2429 highest interaction level and lets the user have the full flexibility of
2430 the |error| routine. \MP\ checks for interrupts only at times when it is
2434 void mp_pause_for_instructions (MP mp) {
2435 if ( mp->OK_to_interrupt ) {
2436 mp->interaction=mp_error_stop_mode;
2437 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2439 print_err("Interruption");
2442 ("Try to insert some instructions for me (e.g.,`I show x'),")
2443 ("unless you just want to quit by typing `X'.");
2444 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2449 @ Many of \MP's error messages state that a missing token has been
2450 inserted behind the scenes. We can save string space and program space
2451 by putting this common code into a subroutine.
2454 void mp_missing_err (MP mp, char *s) {
2455 print_err("Missing `"); mp_print(mp, s); mp_print(mp, "' has been inserted");
2456 @.Missing...inserted@>
2459 @* \[7] Arithmetic with scaled numbers.
2460 The principal computations performed by \MP\ are done entirely in terms of
2461 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2462 program can be carried out in exactly the same way on a wide variety of
2463 computers, including some small ones.
2466 But \PASCAL\ does not define the |div|
2467 operation in the case of negative dividends; for example, the result of
2468 |(-2*n-1) div 2| is |-(n+1)| on some computers and |-n| on others.
2469 There are two principal types of arithmetic: ``translation-preserving,''
2470 in which the identity |(a+q*b)div b=(a div b)+q| is valid; and
2471 ``negation-preserving,'' in which |(-a)div b=-(a div b)|. This leads to
2472 two \MP s, which can produce different results, although the differences
2473 should be negligible when the language is being used properly.
2474 The \TeX\ processor has been defined carefully so that both varieties
2475 of arithmetic will produce identical output, but it would be too
2476 inefficient to constrain \MP\ in a similar way.
2478 @d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */
2480 @ One of \MP's most common operations is the calculation of
2481 $\lfloor{a+b\over2}\rfloor$,
2482 the midpoint of two given integers |a| and~|b|. The only decent way to do
2483 this in \PASCAL\ is to write `|(a+b) div 2|'; but on most machines it is
2484 far more efficient to calculate `|(a+b)| right shifted one bit'.
2486 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2487 in this program. If \MP\ is being implemented with languages that permit
2488 binary shifting, the |half| macro should be changed to make this operation
2489 as efficient as possible. Since some languages have shift operators that can
2490 only be trusted to work on positive numbers, there is also a macro |halfp|
2491 that is used only when the quantity being halved is known to be positive
2494 @d half(A) ((A) / 2)
2495 @d halfp(A) ((A) / 2)
2497 @ A single computation might use several subroutine calls, and it is
2498 desirable to avoid producing multiple error messages in case of arithmetic
2499 overflow. So the routines below set the global variable |arith_error| to |true|
2500 instead of reporting errors directly to the user.
2503 boolean arith_error; /* has arithmetic overflow occurred recently? */
2505 @ @<Allocate or ...@>=
2506 mp->arith_error=false;
2508 @ At crucial points the program will say |check_arith|, to test if
2509 an arithmetic error has been detected.
2511 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2514 void mp_clear_arith (MP mp) {
2515 print_err("Arithmetic overflow");
2516 @.Arithmetic overflow@>
2517 help4("Uh, oh. A little while ago one of the quantities that I was")
2518 ("computing got too large, so I'm afraid your answers will be")
2519 ("somewhat askew. You'll probably have to adopt different")
2520 ("tactics next time. But I shall try to carry on anyway.");
2522 mp->arith_error=false;
2525 @ Addition is not always checked to make sure that it doesn't overflow,
2526 but in places where overflow isn't too unlikely the |slow_add| routine
2529 @c integer mp_slow_add (MP mp,integer x, integer y) {
2531 if ( y<=el_gordo-x ) {
2534 mp->arith_error=true;
2537 } else if ( -y<=el_gordo+x ) {
2540 mp->arith_error=true;
2545 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2546 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2547 positions from the right end of a binary computer word.
2549 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2550 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2551 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2552 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2553 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2554 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2557 typedef integer scaled; /* this type is used for scaled integers */
2558 typedef unsigned char small_number; /* this type is self-explanatory */
2560 @ The following function is used to create a scaled integer from a given decimal
2561 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2562 given in |dig[i]|, and the calculation produces a correctly rounded result.
2565 scaled mp_round_decimals (MP mp,small_number k) {
2566 /* converts a decimal fraction */
2567 integer a = 0; /* the accumulator */
2569 a=(a+mp->dig[k]*two) / 10;
2574 @ Conversely, here is a procedure analogous to |print_int|. If the output
2575 of this procedure is subsequently read by \MP\ and converted by the
2576 |round_decimals| routine above, it turns out that the original value will
2577 be reproduced exactly. A decimal point is printed only if the value is
2578 not an integer. If there is more than one way to print the result with
2579 the optimum number of digits following the decimal point, the closest
2580 possible value is given.
2582 The invariant relation in the \&{repeat} loop is that a sequence of
2583 decimal digits yet to be printed will yield the original number if and only if
2584 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2585 We can stop if and only if $f=0$ satisfies this condition; the loop will
2586 terminate before $s$ can possibly become zero.
2588 @<Basic printing...@>=
2589 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2590 scaled delta; /* amount of allowable inaccuracy */
2592 mp_print_char(mp, '-');
2593 negate(s); /* print the sign, if negative */
2595 mp_print_int(mp, s / unity); /* print the integer part */
2599 mp_print_char(mp, '.');
2602 s=s+0100000-(delta / 2); /* round the final digit */
2603 mp_print_char(mp, '0'+(s / unity));
2610 @ We often want to print two scaled quantities in parentheses,
2611 separated by a comma.
2613 @<Basic printing...@>=
2614 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2615 mp_print_char(mp, '(');
2616 mp_print_scaled(mp, x);
2617 mp_print_char(mp, ',');
2618 mp_print_scaled(mp, y);
2619 mp_print_char(mp, ')');
2622 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2623 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2624 arithmetic with 28~significant bits of precision. A |fraction| denotes
2625 a scaled integer whose binary point is assumed to be 28 bit positions
2628 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2629 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2630 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2631 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2632 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2635 typedef integer fraction; /* this type is used for scaled fractions */
2637 @ In fact, the two sorts of scaling discussed above aren't quite
2638 sufficient; \MP\ has yet another, used internally to keep track of angles
2639 in units of $2^{-20}$ degrees.
2641 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2642 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2643 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2644 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2647 typedef integer angle; /* this type is used for scaled angles */
2649 @ The |make_fraction| routine produces the |fraction| equivalent of
2650 |p/q|, given integers |p| and~|q|; it computes the integer
2651 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2652 positive. If |p| and |q| are both of the same scaled type |t|,
2653 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2654 and it's also possible to use the subroutine ``backwards,'' using
2655 the relation |make_fraction(t,fraction)=t| between scaled types.
2657 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2658 sets |arith_error:=true|. Most of \MP's internal computations have
2659 been designed to avoid this sort of error.
2661 If this subroutine were programmed in assembly language on a typical
2662 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2663 double-precision product can often be input to a fixed-point division
2664 instruction. But when we are restricted to \PASCAL\ arithmetic it
2665 is necessary either to resort to multiple-precision maneuvering
2666 or to use a simple but slow iteration. The multiple-precision technique
2667 would be about three times faster than the code adopted here, but it
2668 would be comparatively long and tricky, involving about sixteen
2669 additional multiplications and divisions.
2671 This operation is part of \MP's ``inner loop''; indeed, it will
2672 consume nearly 10\pct! of the running time (exclusive of input and output)
2673 if the code below is left unchanged. A machine-dependent recoding
2674 will therefore make \MP\ run faster. The present implementation
2675 is highly portable, but slow; it avoids multiplication and division
2676 except in the initial stage. System wizards should be careful to
2677 replace it with a routine that is guaranteed to produce identical
2678 results in all cases.
2679 @^system dependencies@>
2681 As noted below, a few more routines should also be replaced by machine-dependent
2682 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2683 such changes aren't advisable; simplicity and robustness are
2684 preferable to trickery, unless the cost is too high.
2688 fraction mp_make_fraction (MP mp,integer p, integer q);
2689 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2691 @ If FIXPT is not defined, we need these preprocessor values
2693 @d ELGORDO 0x7fffffff
2694 @d TWEXP31 2147483648.0
2695 @d TWEXP28 268435456.0
2697 @d TWEXP_16 (1.0/65536.0)
2698 @d TWEXP_28 (1.0/268435456.0)
2702 fraction mp_make_fraction (MP mp,integer p, integer q) {
2704 integer f; /* the fraction bits, with a leading 1 bit */
2705 integer n; /* the integer part of $\vert p/q\vert$ */
2706 integer be_careful; /* disables certain compiler optimizations */
2707 boolean negative = false; /* should the result be negated? */
2709 negate(p); negative=true;
2713 if ( q==0 ) mp_confusion(mp, '/');
2715 @:this can't happen /}{\quad \./@>
2716 negate(q); negative = ! negative;
2720 mp->arith_error=true;
2721 return ( negative ? -el_gordo : el_gordo);
2723 n=(n-1)*fraction_one;
2724 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2725 return (negative ? (-(f+n)) : (f+n));
2731 if (q==0) mp_confusion(mp,'/');
2733 d = TWEXP28 * (double)p /(double)q;
2736 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
2738 if (d==i && ( ((q>0 ? -q : q)&077777)
2739 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2742 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
2744 if (d==i && ( ((q>0 ? q : -q)&077777)
2745 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2751 @ The |repeat| loop here preserves the following invariant relations
2752 between |f|, |p|, and~|q|:
2753 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2754 $p_0$ is the original value of~$p$.
2756 Notice that the computation specifies
2757 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2758 Let us hope that optimizing compilers do not miss this point; a
2759 special variable |be_careful| is used to emphasize the necessary
2760 order of computation. Optimizing compilers should keep |be_careful|
2761 in a register, not store it in memory.
2764 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2768 be_careful=p-q; p=be_careful+p;
2774 } while (f<fraction_one);
2776 if ( be_careful+p>=0 ) incr(f);
2779 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2780 given integer~|q| by a fraction~|f|. When the operands are positive, it
2781 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2784 This routine is even more ``inner loopy'' than |make_fraction|;
2785 the present implementation consumes almost 20\pct! of \MP's computation
2786 time during typical jobs, so a machine-language substitute is advisable.
2787 @^inner loop@> @^system dependencies@>
2790 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2794 integer mp_take_fraction (MP mp,integer q, fraction f) {
2795 integer p; /* the fraction so far */
2796 boolean negative; /* should the result be negated? */
2797 integer n; /* additional multiple of $q$ */
2798 integer be_careful; /* disables certain compiler optimizations */
2799 @<Reduce to the case that |f>=0| and |q>0|@>;
2800 if ( f<fraction_one ) {
2803 n=f / fraction_one; f=f % fraction_one;
2804 if ( q<=el_gordo / n ) {
2807 mp->arith_error=true; n=el_gordo;
2811 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2812 be_careful=n-el_gordo;
2813 if ( be_careful+p>0 ){
2814 mp->arith_error=true; n=el_gordo-p;
2821 integer mp_take_fraction (MP mp,integer p, fraction q) {
2824 d = (double)p * (double)q * TWEXP_28;
2828 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2829 mp->arith_error = true;
2833 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2837 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2838 mp->arith_error = true;
2842 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2848 @ @<Reduce to the case that |f>=0| and |q>0|@>=
2852 negate( f); negative=true;
2855 negate(q); negative=! negative;
2858 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2859 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2860 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2863 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2864 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2865 if ( q<fraction_four ) {
2867 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2872 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2878 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2879 analogous to |take_fraction| but with a different scaling.
2880 Given positive operands, |take_scaled|
2881 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2883 Once again it is a good idea to use a machine-language replacement if
2884 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2885 when the Computer Modern fonts are being generated.
2890 integer mp_take_scaled (MP mp,integer q, scaled f) {
2891 integer p; /* the fraction so far */
2892 boolean negative; /* should the result be negated? */
2893 integer n; /* additional multiple of $q$ */
2894 integer be_careful; /* disables certain compiler optimizations */
2895 @<Reduce to the case that |f>=0| and |q>0|@>;
2899 n=f / unity; f=f % unity;
2900 if ( q<=el_gordo / n ) {
2903 mp->arith_error=true; n=el_gordo;
2907 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2908 be_careful=n-el_gordo;
2909 if ( be_careful+p>0 ) {
2910 mp->arith_error=true; n=el_gordo-p;
2912 return ( negative ?(-(n+p)) :(n+p));
2914 integer mp_take_scaled (MP mp,integer p, scaled q) {
2917 d = (double)p * (double)q * TWEXP_16;
2921 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2922 mp->arith_error = true;
2926 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2930 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2931 mp->arith_error = true;
2935 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2941 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
2942 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
2944 if ( q<fraction_four ) {
2946 p = (odd(f) ? halfp(p+q) : halfp(p));
2951 p = (odd(f) ? p+halfp(q-p) : halfp(p));
2956 @ For completeness, there's also |make_scaled|, which computes a
2957 quotient as a |scaled| number instead of as a |fraction|.
2958 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
2959 operands are positive. \ (This procedure is not used especially often,
2960 so it is not part of \MP's inner loop.)
2962 @<Internal library ...@>=
2963 scaled mp_make_scaled (MP mp,integer p, integer q) ;
2966 scaled mp_make_scaled (MP mp,integer p, integer q) {
2968 integer f; /* the fraction bits, with a leading 1 bit */
2969 integer n; /* the integer part of $\vert p/q\vert$ */
2970 boolean negative; /* should the result be negated? */
2971 integer be_careful; /* disables certain compiler optimizations */
2972 if ( p>=0 ) negative=false;
2973 else { negate(p); negative=true; };
2976 if ( q==0 ) mp_confusion(mp, "/");
2977 @:this can't happen /}{\quad \./@>
2979 negate(q); negative=! negative;
2983 mp->arith_error=true;
2984 return (negative ? (-el_gordo) : el_gordo);
2987 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
2988 return ( negative ? (-(f+n)) :(f+n));
2994 if (q==0) mp_confusion(mp,"/");
2996 d = TWEXP16 * (double)p /(double)q;
2999 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
3001 if (d==i && ( ((q>0 ? -q : q)&077777)
3002 * (((i&037777)<<1)-1) & 04000)!=0) --i;
3005 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
3007 if (d==i && ( ((q>0 ? q : -q)&077777)
3008 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
3014 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
3017 be_careful=p-q; p=be_careful+p;
3018 if ( p>=0 ) f=f+f+1;
3019 else { f+=f; p=p+q; };
3022 if ( be_careful+p>=0 ) incr(f)
3024 @ Here is a typical example of how the routines above can be used.
3025 It computes the function
3026 $${1\over3\tau}f(\theta,\phi)=
3027 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3028 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3029 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3030 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3031 fudge factor for placing the first control point of a curve that starts
3032 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3033 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3035 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3036 (It's a sum of eight terms whose absolute values can be bounded using
3037 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3038 is positive; and since the tension $\tau$ is constrained to be at least
3039 $3\over4$, the numerator is less than $16\over3$. The denominator is
3040 nonnegative and at most~6. Hence the fixed-point calculations below
3041 are guaranteed to stay within the bounds of a 32-bit computer word.
3043 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3044 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3045 $\sin\phi$, and $\cos\phi$, respectively.
3048 fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3049 fraction cf, scaled t) {
3050 integer acc,num,denom; /* registers for intermediate calculations */
3051 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3052 acc=mp_take_fraction(mp, acc,ct-cf);
3053 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3054 /* $2^{28}\sqrt2\approx379625062.497$ */
3055 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3056 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3057 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3058 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3059 /* |make_scaled(fraction,scaled)=fraction| */
3060 if ( num / 4>=denom )
3061 return fraction_four;
3063 return mp_make_fraction(mp, num, denom);
3066 @ The following somewhat different subroutine tests rigorously if $ab$ is
3067 greater than, equal to, or less than~$cd$,
3068 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3069 The result is $+1$, 0, or~$-1$ in the three respective cases.
3071 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3074 integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3075 integer q,r; /* temporary registers */
3076 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3078 q = a / d; r = c / b;
3080 return ( q>r ? 1 : -1);
3081 q = a % d; r = c % b;
3084 if ( q==0 ) return -1;
3086 } /* now |a>d>0| and |c>b>0| */
3089 @ @<Reduce to the case that |a...@>=
3090 if ( a<0 ) { negate(a); negate(b); };
3091 if ( c<0 ) { negate(c); negate(d); };
3094 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3098 return ( a==0 ? 0 : -1);
3099 q=a; a=c; c=q; q=-b; b=-d; d=q;
3100 } else if ( b<=0 ) {
3101 if ( b<0 ) if ( a>0 ) return -1;
3102 return (c==0 ? 0 : -1);
3105 @ We conclude this set of elementary routines with some simple rounding
3106 and truncation operations.
3108 @<Internal library declarations@>=
3109 #define mp_floor_scaled(M,i) ((i)&(-65536))
3110 #define mp_round_unscaled(M,i) (((i>>15)+1)>>1)
3111 #define mp_round_fraction(M,i) (((i>>11)+1)>>1)
3114 @* \[8] Algebraic and transcendental functions.
3115 \MP\ computes all of the necessary special functions from scratch, without
3116 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3118 @ To get the square root of a |scaled| number |x|, we want to calculate
3119 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3120 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3121 determines $s$ by an iterative method that maintains the invariant
3122 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3123 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3124 might, however, be zero at the start of the first iteration.
3127 scaled mp_square_rt (MP mp,scaled x) ;
3130 scaled mp_square_rt (MP mp,scaled x) {
3131 small_number k; /* iteration control counter */
3132 integer y,q; /* registers for intermediate calculations */
3134 @<Handle square root of zero or negative argument@>;
3137 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3140 if ( x<fraction_four ) y=0;
3141 else { x=x-fraction_four; y=1; };
3143 @<Decrease |k| by 1, maintaining the invariant
3144 relations between |x|, |y|, and~|q|@>;
3150 @ @<Handle square root of zero...@>=
3153 print_err("Square root of ");
3154 @.Square root...replaced by 0@>
3155 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3156 help2("Since I don't take square roots of negative numbers,")
3157 ("I'm zeroing this one. Proceed, with fingers crossed.");
3163 @ @<Decrease |k| by 1, maintaining...@>=
3165 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3166 x=x-fraction_four; incr(y);
3168 x+=x; y=y+y-q; q+=q;
3169 if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
3170 if ( y>q ){ y=y-q; q=q+2; }
3171 else if ( y<=0 ) { q=q-2; y=y+q; };
3174 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3175 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3176 @^Moler, Cleve Barry@>
3177 @^Morrison, Donald Ross@>
3178 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3179 in such a way that their Pythagorean sum remains invariant, while the
3180 smaller argument decreases.
3182 @<Internal library ...@>=
3183 integer mp_pyth_add (MP mp,integer a, integer b);
3187 integer mp_pyth_add (MP mp,integer a, integer b) {
3188 fraction r; /* register used to transform |a| and |b| */
3189 boolean big; /* is the result dangerously near $2^{31}$? */
3191 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3193 if ( a<fraction_two ) {
3196 a=a / 4; b=b / 4; big=true;
3197 }; /* we reduced the precision to avoid arithmetic overflow */
3198 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3200 if ( a<fraction_two ) {
3203 mp->arith_error=true; a=el_gordo;
3210 @ The key idea here is to reflect the vector $(a,b)$ about the
3211 line through $(a,b/2)$.
3213 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3215 r=mp_make_fraction(mp, b,a);
3216 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3218 r=mp_make_fraction(mp, r,fraction_four+r);
3219 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3223 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3224 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3227 integer mp_pyth_sub (MP mp,integer a, integer b) {
3228 fraction r; /* register used to transform |a| and |b| */
3229 boolean big; /* is the input dangerously near $2^{31}$? */
3232 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3234 if ( a<fraction_four ) {
3237 a=halfp(a); b=halfp(b); big=true;
3239 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3240 if ( big ) double(a);
3245 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3247 r=mp_make_fraction(mp, b,a);
3248 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3250 r=mp_make_fraction(mp, r,fraction_four-r);
3251 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3254 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3257 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3258 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3259 mp_print(mp, " has been replaced by 0");
3261 help2("Since I don't take square roots of negative numbers,")
3262 ("I'm zeroing this one. Proceed, with fingers crossed.");
3268 @ The subroutines for logarithm and exponential involve two tables.
3269 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3270 a bit more calculation, which the author claims to have done correctly:
3271 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3272 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3275 @d two_to_the(A) (1<<(A))
3278 static const integer spec_log[29] = { 0, /* special logarithms */
3279 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3280 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3281 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3283 @ @<Local variables for initialization@>=
3284 integer k; /* all-purpose loop index */
3287 @ Here is the routine that calculates $2^8$ times the natural logarithm
3288 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3289 when |x| is a given positive integer.
3291 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3292 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3293 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3294 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3295 during the calculation, and sixteen auxiliary bits to extend |y| are
3296 kept in~|z| during the initial argument reduction. (We add
3297 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3298 not become negative; also, the actual amount subtracted from~|y| is~96,
3299 not~100, because we want to add~4 for rounding before the final division by~8.)
3302 scaled mp_m_log (MP mp,scaled x) {
3303 integer y,z; /* auxiliary registers */
3304 integer k; /* iteration counter */
3306 @<Handle non-positive logarithm@>;
3308 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3309 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3310 while ( x<fraction_four ) {
3311 double(x); y-=93032639; z-=48782;
3312 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3313 y=y+(z / unity); k=2;
3314 while ( x>fraction_four+4 ) {
3315 @<Increase |k| until |x| can be multiplied by a
3316 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3322 @ @<Increase |k| until |x| can...@>=
3324 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3325 while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
3326 y+=spec_log[k]; x-=z;
3329 @ @<Handle non-positive logarithm@>=
3331 print_err("Logarithm of ");
3332 @.Logarithm...replaced by 0@>
3333 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3334 help2("Since I don't take logs of non-positive numbers,")
3335 ("I'm zeroing this one. Proceed, with fingers crossed.");
3340 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3341 when |x| is |scaled|. The result is an integer approximation to
3342 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3345 scaled mp_m_exp (MP mp,scaled x) {
3346 small_number k; /* loop control index */
3347 integer y,z; /* auxiliary registers */
3348 if ( x>174436200 ) {
3349 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3350 mp->arith_error=true;
3352 } else if ( x<-197694359 ) {
3353 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3357 z=-8*x; y=04000000; /* $y=2^{20}$ */
3359 if ( x<=127919879 ) {
3361 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3363 z=8*(174436200-x); /* |z| is always nonnegative */
3367 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3369 return ((y+8) / 16);
3375 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3376 to multiplying |y| by $1-2^{-k}$.
3378 A subtle point (which had to be checked) was that if $x=127919879$, the
3379 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3380 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3381 and by~16 when |k=27|.
3383 @<Multiply |y| by...@>=
3386 while ( z>=spec_log[k] ) {
3388 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3393 @ The trigonometric subroutines use an auxiliary table such that
3394 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3395 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3398 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3399 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3400 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3402 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3403 returns the |angle| whose tangent points in the direction $(x,y)$.
3404 This subroutine first determines the correct octant, then solves the
3405 problem for |0<=y<=x|, then converts the result appropriately to
3406 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3407 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3408 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3410 The octants are represented in a ``Gray code,'' since that turns out
3411 to be computationally simplest.
3417 @d second_octant (first_octant+switch_x_and_y)
3418 @d third_octant (first_octant+switch_x_and_y+negate_x)
3419 @d fourth_octant (first_octant+negate_x)
3420 @d fifth_octant (first_octant+negate_x+negate_y)
3421 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3422 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3423 @d eighth_octant (first_octant+negate_y)
3426 angle mp_n_arg (MP mp,integer x, integer y) {
3427 angle z; /* auxiliary register */
3428 integer t; /* temporary storage */
3429 small_number k; /* loop counter */
3430 int octant; /* octant code */
3432 octant=first_octant;
3434 negate(x); octant=first_octant+negate_x;
3437 negate(y); octant=octant+negate_y;
3440 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3443 @<Handle undefined arg@>;
3445 @<Set variable |z| to the arg of $(x,y)$@>;
3446 @<Return an appropriate answer based on |z| and |octant|@>;
3450 @ @<Handle undefined arg@>=
3452 print_err("angle(0,0) is taken as zero");
3453 @.angle(0,0)...zero@>
3454 help2("The `angle' between two identical points is undefined.")
3455 ("I'm zeroing this one. Proceed, with fingers crossed.");
3460 @ @<Return an appropriate answer...@>=
3462 case first_octant: return z;
3463 case second_octant: return (ninety_deg-z);
3464 case third_octant: return (ninety_deg+z);
3465 case fourth_octant: return (one_eighty_deg-z);
3466 case fifth_octant: return (z-one_eighty_deg);
3467 case sixth_octant: return (-z-ninety_deg);
3468 case seventh_octant: return (z-ninety_deg);
3469 case eighth_octant: return (-z);
3470 }; /* there are no other cases */
3473 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3474 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3477 @<Set variable |z| to the arg...@>=
3478 while ( x>=fraction_two ) {
3479 x=halfp(x); y=halfp(y);
3483 while ( x<fraction_one ) {
3486 @<Increase |z| to the arg of $(x,y)$@>;
3489 @ During the calculations of this section, variables |x| and~|y|
3490 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3491 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3492 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3493 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3494 coordinates whose angle has decreased by~$\phi$; in the special case
3495 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3496 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3497 @^Meggitt, John E.@>
3498 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3500 The initial value of |x| will be multiplied by at most
3501 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3502 there is no chance of integer overflow.
3504 @<Increase |z|...@>=
3509 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3514 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3517 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3518 and cosine of that angle. The results of this routine are
3519 stored in global integer variables |n_sin| and |n_cos|.
3522 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3524 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3525 the purpose of |n_sin_cos(z)| is to set
3526 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3527 for some rather large number~|r|. The maximum of |x| and |y|
3528 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3529 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3532 void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3534 small_number k; /* loop control variable */
3535 int q; /* specifies the quadrant */
3536 fraction r; /* magnitude of |(x,y)| */
3537 integer x,y,t; /* temporary registers */
3538 while ( z<0 ) z=z+three_sixty_deg;
3539 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3540 q=z / forty_five_deg; z=z % forty_five_deg;
3541 x=fraction_one; y=x;
3542 if ( ! odd(q) ) z=forty_five_deg-z;
3543 @<Subtract angle |z| from |(x,y)|@>;
3544 @<Convert |(x,y)| to the octant determined by~|q|@>;
3545 r=mp_pyth_add(mp, x,y);
3546 mp->n_cos=mp_make_fraction(mp, x,r);
3547 mp->n_sin=mp_make_fraction(mp, y,r);
3550 @ In this case the octants are numbered sequentially.
3552 @<Convert |(x,...@>=
3555 case 1: t=x; x=y; y=t; break;
3556 case 2: t=x; x=-y; y=t; break;
3557 case 3: negate(x); break;
3558 case 4: negate(x); negate(y); break;
3559 case 5: t=x; x=-y; y=-t; break;
3560 case 6: t=x; x=y; y=-t; break;
3561 case 7: negate(y); break;
3562 } /* there are no other cases */
3564 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3565 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3566 that this loop is guaranteed to terminate before the (nonexistent) value
3567 |spec_atan[27]| would be required.
3569 @<Subtract angle |z|...@>=
3572 if ( z>=spec_atan[k] ) {
3573 z=z-spec_atan[k]; t=x;
3574 x=t+y / two_to_the(k);
3575 y=y-t / two_to_the(k);
3579 if ( y<0 ) y=0 /* this precaution may never be needed */
3581 @ And now let's complete our collection of numeric utility routines
3582 by considering random number generation.
3583 \MP\ generates pseudo-random numbers with the additive scheme recommended
3584 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3585 results are random fractions between 0 and |fraction_one-1|, inclusive.
3587 There's an auxiliary array |randoms| that contains 55 pseudo-random
3588 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3589 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3590 The global variable |j_random| tells which element has most recently
3592 The global variable |sys_random_seed| was introduced in version 0.9,
3593 for the sole reason of stressing the fact that the initial value of the
3594 random seed is system-dependant. The pascal code below will initialize
3595 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3596 is not good enough on modern fast machines that are capable of running
3597 multiple MetaPost processes within the same second.
3598 @^system dependencies@>
3601 fraction randoms[55]; /* the last 55 random values generated */
3602 int j_random; /* the number of unused |randoms| */
3603 scaled sys_random_seed; /* the default random seed */
3605 @ @<Exported types@>=
3606 typedef int (*mp_get_random_seed_command)(MP mp);
3609 mp_get_random_seed_command get_random_seed;
3611 @ @<Option variables@>=
3612 mp_get_random_seed_command get_random_seed;
3614 @ @<Allocate or initialize ...@>=
3615 set_callback_option(get_random_seed);
3617 @ @<Internal library declarations@>=
3618 int mp_get_random_seed (MP mp);
3621 int mp_get_random_seed (MP mp) {
3622 return (mp->internal[mp_time] / unity)+mp->internal[mp_day];
3625 @ To consume a random fraction, the program below will say `|next_random|'
3626 and then it will fetch |randoms[j_random]|.
3628 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3629 else decr(mp->j_random); }
3632 void mp_new_randoms (MP mp) {
3633 int k; /* index into |randoms| */
3634 fraction x; /* accumulator */
3635 for (k=0;k<=23;k++) {
3636 x=mp->randoms[k]-mp->randoms[k+31];
3637 if ( x<0 ) x=x+fraction_one;
3640 for (k=24;k<= 54;k++){
3641 x=mp->randoms[k]-mp->randoms[k-24];
3642 if ( x<0 ) x=x+fraction_one;
3649 void mp_init_randoms (MP mp,scaled seed);
3651 @ To initialize the |randoms| table, we call the following routine.
3654 void mp_init_randoms (MP mp,scaled seed) {
3655 fraction j,jj,k; /* more or less random integers */
3656 int i; /* index into |randoms| */
3658 while ( j>=fraction_one ) j=halfp(j);
3660 for (i=0;i<=54;i++ ){
3662 if ( k<0 ) k=k+fraction_one;
3663 mp->randoms[(i*21)% 55]=j;
3667 mp_new_randoms(mp); /* ``warm up'' the array */
3670 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3671 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3673 Note that the call of |take_fraction| will produce the values 0 and~|x|
3674 with about half the probability that it will produce any other particular
3675 values between 0 and~|x|, because it rounds its answers.
3678 scaled mp_unif_rand (MP mp,scaled x) {
3679 scaled y; /* trial value */
3680 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3681 if ( y==abs(x) ) return 0;
3682 else if ( x>0 ) return y;
3686 @ Finally, a normal deviate with mean zero and unit standard deviation
3687 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3688 {\sl The Art of Computer Programming\/}).
3691 scaled mp_norm_rand (MP mp) {
3692 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3696 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3697 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3698 next_random; u=mp->randoms[mp->j_random];
3699 } while (abs(x)>=u);
3700 x=mp_make_fraction(mp, x,u);
3701 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3702 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3706 @* \[9] Packed data.
3707 In order to make efficient use of storage space, \MP\ bases its major data
3708 structures on a |memory_word|, which contains either a (signed) integer,
3709 possibly scaled, or a small number of fields that are one half or one
3710 quarter of the size used for storing integers.
3712 If |x| is a variable of type |memory_word|, it contains up to four
3713 fields that can be referred to as follows:
3714 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3715 |x|&.|int|&(an |integer|)\cr
3716 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3717 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3718 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3720 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3721 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3722 This is somewhat cumbersome to write, and not very readable either, but
3723 macros will be used to make the notation shorter and more transparent.
3724 The code below gives a formal definition of |memory_word| and
3725 its subsidiary types, using packed variant records. \MP\ makes no
3726 assumptions about the relative positions of the fields within a word.
3728 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3729 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3731 @ Here are the inequalities that the quarterword and halfword values
3732 must satisfy (or rather, the inequalities that they mustn't satisfy):
3734 @<Check the ``constant''...@>=
3735 if (mp->ini_version) {
3736 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3738 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3740 if ( max_quarterword<255 ) mp->bad=9;
3741 if ( max_halfword<65535 ) mp->bad=10;
3742 if ( max_quarterword>max_halfword ) mp->bad=11;
3743 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3744 if ( mp->max_strings>max_halfword ) mp->bad=13;
3746 @ The macros |qi| and |qo| are used for input to and output
3747 from quarterwords. These are legacy macros.
3748 @^system dependencies@>
3750 @d qo(A) (A) /* to read eight bits from a quarterword */
3751 @d qi(A) (A) /* to store eight bits in a quarterword */
3753 @ The reader should study the following definitions closely:
3754 @^system dependencies@>
3756 @d sc cint /* |scaled| data is equivalent to |integer| */
3759 typedef short quarterword; /* 1/4 of a word */
3760 typedef int halfword; /* 1/2 of a word */
3765 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3772 quarterword B2, B3, B0, B1;
3787 @ When debugging, we may want to print a |memory_word| without knowing
3788 what type it is; so we print it in all modes.
3789 @^dirty \PASCAL@>@^debugging@>
3792 void mp_print_word (MP mp,memory_word w) {
3793 /* prints |w| in all ways */
3794 mp_print_int(mp, w.cint); mp_print_char(mp, ' ');
3795 mp_print_scaled(mp, w.sc); mp_print_char(mp, ' ');
3796 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3797 mp_print_int(mp, w.hh.lh); mp_print_char(mp, '=');
3798 mp_print_int(mp, w.hh.b0); mp_print_char(mp, ':');
3799 mp_print_int(mp, w.hh.b1); mp_print_char(mp, ';');
3800 mp_print_int(mp, w.hh.rh); mp_print_char(mp, ' ');
3801 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, ':');
3802 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, ':');
3803 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, ':');
3804 mp_print_int(mp, w.qqqq.b3);
3808 @* \[10] Dynamic memory allocation.
3810 The \MP\ system does nearly all of its own memory allocation, so that it
3811 can readily be transported into environments that do not have automatic
3812 facilities for strings, garbage collection, etc., and so that it can be in
3813 control of what error messages the user receives. The dynamic storage
3814 requirements of \MP\ are handled by providing a large array |mem| in
3815 which consecutive blocks of words are used as nodes by the \MP\ routines.
3817 Pointer variables are indices into this array, or into another array
3818 called |eqtb| that will be explained later. A pointer variable might
3819 also be a special flag that lies outside the bounds of |mem|, so we
3820 allow pointers to assume any |halfword| value. The minimum memory
3821 index represents a null pointer.
3823 @d null 0 /* the null pointer */
3824 @d mp_void (null+1) /* a null pointer different from |null| */
3828 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3830 @ The |mem| array is divided into two regions that are allocated separately,
3831 but the dividing line between these two regions is not fixed; they grow
3832 together until finding their ``natural'' size in a particular job.
3833 Locations less than or equal to |lo_mem_max| are used for storing
3834 variable-length records consisting of two or more words each. This region
3835 is maintained using an algorithm similar to the one described in exercise
3836 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3837 appears in the allocated nodes; the program is responsible for knowing the
3838 relevant size when a node is freed. Locations greater than or equal to
3839 |hi_mem_min| are used for storing one-word records; a conventional
3840 \.{AVAIL} stack is used for allocation in this region.
3842 Locations of |mem| between |0| and |mem_top| may be dumped as part
3843 of preloaded format files, by the \.{INIMP} preprocessor.
3845 Production versions of \MP\ may extend the memory at the top end in order to
3846 provide more space; these locations, between |mem_top| and |mem_max|,
3847 are always used for single-word nodes.
3849 The key pointers that govern |mem| allocation have a prescribed order:
3850 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3853 memory_word *mem; /* the big dynamic storage area */
3854 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3855 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3859 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3860 @d xrealloc(P,A,B) mp_xrealloc(mp,P,A,B)
3861 @d xmalloc(A,B) mp_xmalloc(mp,A,B)
3862 @d xstrdup(A) mp_xstrdup(mp,A)
3863 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3865 @<Declare helpers@>=
3866 void mp_xfree (void *x);
3867 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3868 void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3869 char *mp_xstrdup(MP mp, const char *s);
3871 @ The |max_size_test| guards against overflow, on the assumption that
3872 |size_t| is at least 31bits wide.
3874 @d max_size_test 0x7FFFFFFF
3877 void mp_xfree (void *x) {
3878 if (x!=NULL) free(x);
3880 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3882 if ((max_size_test/size)<nmem) {
3883 fprintf(stderr,"Memory size overflow!\n");
3884 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3886 w = realloc (p,(nmem*size));
3888 fprintf(stderr,"Out of memory!\n");
3889 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3893 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
3895 if ((max_size_test/size)<nmem) {
3896 fprintf(stderr,"Memory size overflow!\n");
3897 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3899 w = malloc (nmem*size);
3901 fprintf(stderr,"Out of memory!\n");
3902 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3906 char *mp_xstrdup(MP mp, const char *s) {
3912 fprintf(stderr,"Out of memory!\n");
3913 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3920 @<Allocate or initialize ...@>=
3921 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
3922 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
3924 @ @<Dealloc variables@>=
3927 @ Users who wish to study the memory requirements of particular applications can
3928 can use optional special features that keep track of current and
3929 maximum memory usage. When code between the delimiters |stat| $\ldots$
3930 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
3931 report these statistics when |mp_tracing_stats| is positive.
3934 integer var_used; integer dyn_used; /* how much memory is in use */
3936 @ Let's consider the one-word memory region first, since it's the
3937 simplest. The pointer variable |mem_end| holds the highest-numbered location
3938 of |mem| that has ever been used. The free locations of |mem| that
3939 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
3940 |two_halves|, and we write |info(p)| and |link(p)| for the |lh|
3941 and |rh| fields of |mem[p]| when it is of this type. The single-word
3942 free locations form a linked list
3943 $$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
3944 terminated by |null|.
3946 @d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
3947 @d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
3950 pointer avail; /* head of the list of available one-word nodes */
3951 pointer mem_end; /* the last one-word node used in |mem| */
3953 @ If one-word memory is exhausted, it might mean that the user has forgotten
3954 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
3955 later that try to help pinpoint the trouble.
3958 @<Declare the procedure called |show_token_list|@>;
3959 @<Declare the procedure called |runaway|@>
3961 @ The function |get_avail| returns a pointer to a new one-word node whose
3962 |link| field is null. However, \MP\ will halt if there is no more room left.
3966 pointer mp_get_avail (MP mp) { /* single-word node allocation */
3967 pointer p; /* the new node being got */
3968 p=mp->avail; /* get top location in the |avail| stack */
3970 mp->avail=link(mp->avail); /* and pop it off */
3971 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
3972 incr(mp->mem_end); p=mp->mem_end;
3974 decr(mp->hi_mem_min); p=mp->hi_mem_min;
3975 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
3976 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
3977 mp_overflow(mp, "main memory size",mp->mem_max);
3978 /* quit; all one-word nodes are busy */
3979 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
3982 link(p)=null; /* provide an oft-desired initialization of the new node */
3983 incr(mp->dyn_used);/* maintain statistics */
3987 @ Conversely, a one-word node is recycled by calling |free_avail|.
3989 @d free_avail(A) /* single-word node liberation */
3990 { link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
3992 @ There's also a |fast_get_avail| routine, which saves the procedure-call
3993 overhead at the expense of extra programming. This macro is used in
3994 the places that would otherwise account for the most calls of |get_avail|.
3997 @d fast_get_avail(A) {
3998 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
3999 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4000 else { mp->avail=link((A)); link((A))=null; incr(mp->dyn_used); }
4003 @ The available-space list that keeps track of the variable-size portion
4004 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4005 pointed to by the roving pointer |rover|.
4007 Each empty node has size 2 or more; the first word contains the special
4008 value |max_halfword| in its |link| field and the size in its |info| field;
4009 the second word contains the two pointers for double linking.
4011 Each nonempty node also has size 2 or more. Its first word is of type
4012 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4013 Otherwise there is complete flexibility with respect to the contents
4014 of its other fields and its other words.
4016 (We require |mem_max<max_halfword| because terrible things can happen
4017 when |max_halfword| appears in the |link| field of a nonempty node.)
4019 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4020 @d is_empty(A) (link((A))==empty_flag) /* tests for empty node */
4021 @d node_size info /* the size field in empty variable-size nodes */
4022 @d llink(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
4023 @d rlink(A) link((A)+1) /* right link in doubly-linked list of empty nodes */
4026 pointer rover; /* points to some node in the list of empties */
4028 @ A call to |get_node| with argument |s| returns a pointer to a new node
4029 of size~|s|, which must be 2~or more. The |link| field of the first word
4030 of this new node is set to null. An overflow stop occurs if no suitable
4033 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4034 areas and returns the value |max_halfword|.
4037 pointer mp_get_node (MP mp,integer s) ;
4040 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4041 pointer p; /* the node currently under inspection */
4042 pointer q; /* the node physically after node |p| */
4043 integer r; /* the newly allocated node, or a candidate for this honor */
4044 integer t,tt; /* temporary registers */
4047 p=mp->rover; /* start at some free node in the ring */
4049 @<Try to allocate within node |p| and its physical successors,
4050 and |goto found| if allocation was possible@>;
4051 p=rlink(p); /* move to the next node in the ring */
4052 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4053 if ( s==010000000000 ) {
4054 return max_halfword;
4056 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4057 if ( mp->lo_mem_max+2<=max_halfword ) {
4058 @<Grow more variable-size memory and |goto restart|@>;
4061 mp_overflow(mp, "main memory size",mp->mem_max);
4062 /* sorry, nothing satisfactory is left */
4063 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4065 link(r)=null; /* this node is now nonempty */
4066 mp->var_used=mp->var_used+s; /* maintain usage statistics */
4070 @ The lower part of |mem| grows by 1000 words at a time, unless
4071 we are very close to going under. When it grows, we simply link
4072 a new node into the available-space list. This method of controlled
4073 growth helps to keep the |mem| usage consecutive when \MP\ is
4074 implemented on ``virtual memory'' systems.
4077 @<Grow more variable-size memory and |goto restart|@>=
4079 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4080 t=mp->lo_mem_max+1000;
4082 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4083 /* |lo_mem_max+2<=t<hi_mem_min| */
4085 if ( t>max_halfword ) t=max_halfword;
4086 p=llink(mp->rover); q=mp->lo_mem_max; rlink(p)=q; llink(mp->rover)=q;
4087 rlink(q)=mp->rover; llink(q)=p; link(q)=empty_flag; node_size(q)=t-mp->lo_mem_max;
4088 mp->lo_mem_max=t; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4093 @ @<Try to allocate...@>=
4094 q=p+node_size(p); /* find the physical successor */
4095 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4096 t=rlink(q); tt=llink(q);
4098 if ( q==mp->rover ) mp->rover=t;
4099 llink(t)=tt; rlink(tt)=t;
4104 @<Allocate from the top of node |p| and |goto found|@>;
4107 if ( rlink(p)!=p ) {
4108 @<Allocate entire node |p| and |goto found|@>;
4111 node_size(p)=q-p /* reset the size in case it grew */
4113 @ @<Allocate from the top...@>=
4115 node_size(p)=r-p; /* store the remaining size */
4116 mp->rover=p; /* start searching here next time */
4120 @ Here we delete node |p| from the ring, and let |rover| rove around.
4122 @<Allocate entire...@>=
4124 mp->rover=rlink(p); t=llink(p);
4125 llink(mp->rover)=t; rlink(t)=mp->rover;
4129 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4130 the operation |free_node(p,s)| will make its words available, by inserting
4131 |p| as a new empty node just before where |rover| now points.
4134 void mp_free_node (MP mp, pointer p, halfword s) ;
4137 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4139 pointer q; /* |llink(rover)| */
4140 node_size(p)=s; link(p)=empty_flag;
4142 q=llink(mp->rover); llink(p)=q; rlink(p)=mp->rover; /* set both links */
4143 llink(mp->rover)=p; rlink(q)=p; /* insert |p| into the ring */
4144 mp->var_used=mp->var_used-s; /* maintain statistics */
4147 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4148 available space list. The list is probably very short at such times, so a
4149 simple insertion sort is used. The smallest available location will be
4150 pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
4153 void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4155 pointer p,q,r; /* indices into |mem| */
4156 pointer old_rover; /* initial |rover| setting */
4157 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4158 p=rlink(mp->rover); rlink(mp->rover)=max_halfword; old_rover=mp->rover;
4159 while ( p!=old_rover ) {
4160 @<Sort |p| into the list starting at |rover|
4161 and advance |p| to |rlink(p)|@>;
4164 while ( rlink(p)!=max_halfword ) {
4165 llink(rlink(p))=p; p=rlink(p);
4167 rlink(p)=mp->rover; llink(mp->rover)=p;
4170 @ The following |while| loop is guaranteed to
4171 terminate, since the list that starts at
4172 |rover| ends with |max_halfword| during the sorting procedure.
4175 if ( p<mp->rover ) {
4176 q=p; p=rlink(q); rlink(q)=mp->rover; mp->rover=q;
4179 while ( rlink(q)<p ) q=rlink(q);
4180 r=rlink(p); rlink(p)=rlink(q); rlink(q)=p; p=r;
4183 @* \[11] Memory layout.
4184 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4185 more efficient than dynamic allocation when we can get away with it. For
4186 example, locations |0| to |1| are always used to store a
4187 two-word dummy token whose second word is zero.
4188 The following macro definitions accomplish the static allocation by giving
4189 symbolic names to the fixed positions. Static variable-size nodes appear
4190 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4191 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4193 @d null_dash (2) /* the first two words are reserved for a null value */
4194 @d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4195 @d zero_val (dep_head+2) /* two words for a permanently zero value */
4196 @d temp_val (zero_val+2) /* two words for a temporary value node */
4197 @d end_attr temp_val /* we use |end_attr+2| only */
4198 @d inf_val (end_attr+2) /* and |inf_val+1| only */
4199 @d test_pen (inf_val+2)
4200 /* nine words for a pen used when testing the turning number */
4201 @d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
4202 @d lo_mem_stat_max (bad_vardef+1) /* largest statically
4203 allocated word in the variable-size |mem| */
4205 @d sentinel mp->mem_top /* end of sorted lists */
4206 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4207 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4208 @d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4209 @d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4210 the one-word |mem| */
4212 @ The following code gets the dynamic part of |mem| off to a good start,
4213 when \MP\ is initializing itself the slow way.
4215 @<Initialize table entries (done by \.{INIMP} only)@>=
4216 @^data structure assumptions@>
4217 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4218 link(mp->rover)=empty_flag;
4219 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4220 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
4221 mp->lo_mem_max=mp->rover+1000; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4222 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4223 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4225 mp->avail=null; mp->mem_end=mp->mem_top;
4226 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4227 mp->var_used=lo_mem_stat_max+1;
4228 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4229 @<Initialize a pen at |test_pen| so that it fits in nine words@>;
4231 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4232 nodes that starts at a given position, until coming to |sentinel| or a
4233 pointer that is not in the one-word region. Another procedure,
4234 |flush_node_list|, frees an entire linked list of one-word and two-word
4235 nodes, until coming to a |null| pointer.
4239 void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4240 pointer q,r; /* list traversers */
4241 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4246 if ( r<mp->hi_mem_min ) break;
4247 } while (r!=sentinel);
4248 /* now |q| is the last node on the list */
4249 link(q)=mp->avail; mp->avail=p;
4253 void mp_flush_node_list (MP mp,pointer p) {
4254 pointer q; /* the node being recycled */
4257 if ( q<mp->hi_mem_min )
4258 mp_free_node(mp, q,2);
4264 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4265 For example, some pointers might be wrong, or some ``dead'' nodes might not
4266 have been freed when the last reference to them disappeared. Procedures
4267 |check_mem| and |search_mem| are available to help diagnose such
4268 problems. These procedures make use of two arrays called |free| and
4269 |was_free| that are present only if \MP's debugging routines have
4270 been included. (You may want to decrease the size of |mem| while you
4274 Because |boolean|s are typedef-d as ints, it is better to use
4275 unsigned chars here.
4278 unsigned char *free; /* free cells */
4279 unsigned char *was_free; /* previously free cells */
4280 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4281 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4282 boolean panicking; /* do we want to check memory constantly? */
4284 @ @<Allocate or initialize ...@>=
4285 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4286 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4288 @ @<Dealloc variables@>=
4290 xfree(mp->was_free);
4292 @ @<Allocate or ...@>=
4293 mp->was_mem_end=0; /* indicate that everything was previously free */
4294 mp->was_lo_max=0; mp->was_hi_min=mp->mem_max;
4295 mp->panicking=false;
4297 @ @<Declare |mp_reallocate| functions@>=
4298 void mp_reallocate_memory(MP mp, int l) ;
4301 void mp_reallocate_memory(MP mp, int l) {
4302 XREALLOC(mp->free, l, unsigned char);
4303 XREALLOC(mp->was_free, l, unsigned char);
4305 int newarea = l-mp->mem_max;
4306 XREALLOC(mp->mem, l, memory_word);
4307 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4309 XREALLOC(mp->mem, l, memory_word);
4310 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4313 if (mp->ini_version)
4319 @ Procedure |check_mem| makes sure that the available space lists of
4320 |mem| are well formed, and it optionally prints out all locations
4321 that are reserved now but were free the last time this procedure was called.
4324 void mp_check_mem (MP mp,boolean print_locs ) {
4325 pointer p,q,r; /* current locations of interest in |mem| */
4326 boolean clobbered; /* is something amiss? */
4327 for (p=0;p<=mp->lo_mem_max;p++) {
4328 mp->free[p]=false; /* you can probably do this faster */
4330 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4331 mp->free[p]=false; /* ditto */
4333 @<Check single-word |avail| list@>;
4334 @<Check variable-size |avail| list@>;
4335 @<Check flags of unavailable nodes@>;
4336 @<Check the list of linear dependencies@>;
4338 @<Print newly busy locations@>;
4340 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4341 mp->was_mem_end=mp->mem_end;
4342 mp->was_lo_max=mp->lo_mem_max;
4343 mp->was_hi_min=mp->hi_mem_min;
4346 @ @<Check single-word...@>=
4347 p=mp->avail; q=null; clobbered=false;
4349 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4350 else if ( mp->free[p] ) clobbered=true;
4352 mp_print_nl(mp, "AVAIL list clobbered at ");
4353 @.AVAIL list clobbered...@>
4354 mp_print_int(mp, q); break;
4356 mp->free[p]=true; q=p; p=link(q);
4359 @ @<Check variable-size...@>=
4360 p=mp->rover; q=null; clobbered=false;
4362 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4363 else if ( (rlink(p)>=mp->lo_mem_max)||(rlink(p)<0) ) clobbered=true;
4364 else if ( !(is_empty(p))||(node_size(p)<2)||
4365 (p+node_size(p)>mp->lo_mem_max)|| (llink(rlink(p))!=p) ) clobbered=true;
4367 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4368 @.Double-AVAIL list clobbered...@>
4369 mp_print_int(mp, q); break;
4371 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4372 if ( mp->free[q] ) {
4373 mp_print_nl(mp, "Doubly free location at ");
4374 @.Doubly free location...@>
4375 mp_print_int(mp, q); break;
4380 } while (p!=mp->rover)
4383 @ @<Check flags...@>=
4385 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4386 if ( is_empty(p) ) {
4387 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4390 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
4391 while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
4394 @ @<Print newly busy...@>=
4396 @<Do intialization required before printing new busy locations@>;
4397 mp_print_nl(mp, "New busy locs:");
4399 for (p=0;p<= mp->lo_mem_max;p++ ) {
4400 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4401 @<Indicate that |p| is a new busy location@>;
4404 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4405 if ( ! mp->free[p] &&
4406 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4407 @<Indicate that |p| is a new busy location@>;
4410 @<Finish printing new busy locations@>;
4413 @ There might be many new busy locations so we are careful to print contiguous
4414 blocks compactly. During this operation |q| is the last new busy location and
4415 |r| is the start of the block containing |q|.
4417 @<Indicate that |p| is a new busy location@>=
4421 mp_print(mp, ".."); mp_print_int(mp, q);
4423 mp_print_char(mp, ' '); mp_print_int(mp, p);
4429 @ @<Do intialization required before printing new busy locations@>=
4430 q=mp->mem_max; r=mp->mem_max
4432 @ @<Finish printing new busy locations@>=
4434 mp_print(mp, ".."); mp_print_int(mp, q);
4437 @ The |search_mem| procedure attempts to answer the question ``Who points
4438 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4439 that might not be of type |two_halves|. Strictly speaking, this is
4441 undefined in \PASCAL, and it can lead to ``false drops'' (words that seem to
4442 point to |p| purely by coincidence). But for debugging purposes, we want
4443 to rule out the places that do {\sl not\/} point to |p|, so a few false
4444 drops are tolerable.
4447 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4448 integer q; /* current position being searched */
4449 for (q=0;q<=mp->lo_mem_max;q++) {
4451 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4454 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4457 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4459 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4462 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4465 @<Search |eqtb| for equivalents equal to |p|@>;
4468 @* \[12] The command codes.
4469 Before we can go much further, we need to define symbolic names for the internal
4470 code numbers that represent the various commands obeyed by \MP. These codes
4471 are somewhat arbitrary, but not completely so. For example,
4472 some codes have been made adjacent so that |case| statements in the
4473 program need not consider cases that are widely spaced, or so that |case|
4474 statements can be replaced by |if| statements. A command can begin an
4475 expression if and only if its code lies between |min_primary_command| and
4476 |max_primary_command|, inclusive. The first token of a statement that doesn't
4477 begin with an expression has a command code between |min_command| and
4478 |max_statement_command|, inclusive. Anything less than |min_command| is
4479 eliminated during macro expansions, and anything no more than |max_pre_command|
4480 is eliminated when expanding \TeX\ material. Ranges such as
4481 |min_secondary_command..max_secondary_command| are used when parsing
4482 expressions, but the relative ordering within such a range is generally not
4485 The ordering of the highest-numbered commands
4486 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4487 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4488 for the smallest two commands. The ordering is also important in the ranges
4489 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4491 At any rate, here is the list, for future reference.
4493 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4494 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4495 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4496 @d max_pre_command mpx_break
4497 @d if_test 4 /* conditional text (\&{if}) */
4498 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi} */
4499 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4500 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4501 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4502 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4503 @d relax 10 /* do nothing (\.{\char`\\}) */
4504 @d scan_tokens 11 /* put a string into the input buffer */
4505 @d expand_after 12 /* look ahead one token */
4506 @d defined_macro 13 /* a macro defined by the user */
4507 @d min_command (defined_macro+1)
4508 @d save_command 14 /* save a list of tokens (\&{save}) */
4509 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4510 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4511 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4512 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4513 @d ship_out_command 19 /* output a character (\&{shipout}) */
4514 @d add_to_command 20 /* add to edges (\&{addto}) */
4515 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4516 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4517 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4518 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4519 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4520 @d random_seed 26 /* initialize random number generator (\&{randomseed}) */
4521 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4522 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4523 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4524 @d special_command 30 /* output special info (\&{special})
4525 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4526 @d write_command 31 /* write text to a file (\&{write}) */
4527 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc. */
4528 @d max_statement_command type_name
4529 @d min_primary_command type_name
4530 @d left_delimiter 33 /* the left delimiter of a matching pair */
4531 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4532 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4533 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4534 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4535 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4536 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4537 @d capsule_token 40 /* a value that has been put into a token list */
4538 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4539 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4540 @d min_suffix_token internal_quantity
4541 @d tag_token 43 /* a symbolic token without a primitive meaning */
4542 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4543 @d max_suffix_token numeric_token
4544 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4545 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4546 @d min_tertiary_command plus_or_minus
4547 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4548 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4549 @d max_tertiary_command tertiary_binary
4550 @d left_brace 48 /* the operator `\.{\char`\{}' */
4551 @d min_expression_command left_brace
4552 @d path_join 49 /* the operator `\.{..}' */
4553 @d ampersand 50 /* the operator `\.\&' */
4554 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4555 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4556 @d equals 53 /* the operator `\.=' */
4557 @d max_expression_command equals
4558 @d and_command 54 /* the operator `\&{and}' */
4559 @d min_secondary_command and_command
4560 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4561 @d slash 56 /* the operator `\./' */
4562 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4563 @d max_secondary_command secondary_binary
4564 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4565 @d controls 59 /* specify control points explicitly (\&{controls}) */
4566 @d tension 60 /* specify tension between knots (\&{tension}) */
4567 @d at_least 61 /* bounded tension value (\&{atleast}) */
4568 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4569 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4570 @d right_delimiter 64 /* the right delimiter of a matching pair */
4571 @d left_bracket 65 /* the operator `\.[' */
4572 @d right_bracket 66 /* the operator `\.]' */
4573 @d right_brace 67 /* the operator `\.{\char`\}}' */
4574 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4576 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4577 @d of_token 70 /* the operator `\&{of}' */
4578 @d to_token 71 /* the operator `\&{to}' */
4579 @d step_token 72 /* the operator `\&{step}' */
4580 @d until_token 73 /* the operator `\&{until}' */
4581 @d within_token 74 /* the operator `\&{within}' */
4582 @d lig_kern_token 75
4583 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}, etc. */
4584 @d assignment 76 /* the operator `\.{:=}' */
4585 @d skip_to 77 /* the operation `\&{skipto}' */
4586 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4587 @d double_colon 79 /* the operator `\.{::}' */
4588 @d colon 80 /* the operator `\.:' */
4590 @d comma 81 /* the operator `\.,', must be |colon+1| */
4591 @d end_of_statement (mp->cur_cmd>comma)
4592 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4593 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4594 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4595 @d max_command_code stop
4596 @d outer_tag (max_command_code+1) /* protection code added to command code */
4599 typedef int command_code;
4601 @ Variables and capsules in \MP\ have a variety of ``types,''
4602 distinguished by the code numbers defined here. These numbers are also
4603 not completely arbitrary. Things that get expanded must have types
4604 |>mp_independent|; a type remaining after expansion is numeric if and only if
4605 its code number is at least |numeric_type|; objects containing numeric
4606 parts must have types between |transform_type| and |pair_type|;
4607 all other types must be smaller than |transform_type|; and among the types
4608 that are not unknown or vacuous, the smallest two must be |boolean_type|
4609 and |string_type| in that order.
4611 @d undefined 0 /* no type has been declared */
4612 @d unknown_tag 1 /* this constant is added to certain type codes below */
4613 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4614 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4617 enum mp_variable_type {
4618 mp_vacuous=1, /* no expression was present */
4619 mp_boolean_type, /* \&{boolean} with a known value */
4621 mp_string_type, /* \&{string} with a known value */
4623 mp_pen_type, /* \&{pen} with a known value */
4625 mp_path_type, /* \&{path} with a known value */
4627 mp_picture_type, /* \&{picture} with a known value */
4629 mp_transform_type, /* \&{transform} variable or capsule */
4630 mp_color_type, /* \&{color} variable or capsule */
4631 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4632 mp_pair_type, /* \&{pair} variable or capsule */
4633 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4634 mp_known, /* \&{numeric} with a known value */
4635 mp_dependent, /* a linear combination with |fraction| coefficients */
4636 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4637 mp_independent, /* \&{numeric} with unknown value */
4638 mp_token_list, /* variable name or suffix argument or text argument */
4639 mp_structured, /* variable with subscripts and attributes */
4640 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4641 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4645 void mp_print_type (MP mp,small_number t) ;
4647 @ @<Basic printing procedures@>=
4648 void mp_print_type (MP mp,small_number t) {
4650 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4651 case mp_boolean_type:mp_print(mp, "boolean"); break;
4652 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4653 case mp_string_type:mp_print(mp, "string"); break;
4654 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4655 case mp_pen_type:mp_print(mp, "pen"); break;
4656 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4657 case mp_path_type:mp_print(mp, "path"); break;
4658 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4659 case mp_picture_type:mp_print(mp, "picture"); break;
4660 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4661 case mp_transform_type:mp_print(mp, "transform"); break;
4662 case mp_color_type:mp_print(mp, "color"); break;
4663 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4664 case mp_pair_type:mp_print(mp, "pair"); break;
4665 case mp_known:mp_print(mp, "known numeric"); break;
4666 case mp_dependent:mp_print(mp, "dependent"); break;
4667 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4668 case mp_numeric_type:mp_print(mp, "numeric"); break;
4669 case mp_independent:mp_print(mp, "independent"); break;
4670 case mp_token_list:mp_print(mp, "token list"); break;
4671 case mp_structured:mp_print(mp, "mp_structured"); break;
4672 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4673 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4674 default: mp_print(mp, "undefined"); break;
4678 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4679 as well as a |type|. The possibilities for |name_type| are defined
4680 here; they will be explained in more detail later.
4684 mp_root=0, /* |name_type| at the top level of a variable */
4685 mp_saved_root, /* same, when the variable has been saved */
4686 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4687 mp_subscr, /* |name_type| in a subscript node */
4688 mp_attr, /* |name_type| in an attribute node */
4689 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4690 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4691 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4692 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4693 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4694 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4695 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4696 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4697 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4698 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4699 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4700 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4701 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4702 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4703 mp_capsule, /* |name_type| in stashed-away subexpressions */
4704 mp_token /* |name_type| in a numeric token or string token */
4707 @ Primitive operations that produce values have a secondary identification
4708 code in addition to their command code; it's something like genera and species.
4709 For example, `\.*' has the command code |primary_binary|, and its
4710 secondary identification is |times|. The secondary codes start at 30 so that
4711 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4712 are used as operators as well as type identifications. The relative values
4713 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4714 and |filled_op..bounded_op|. The restrictions are that
4715 |and_op-false_code=or_op-true_code|, that the ordering of
4716 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4717 and the ordering of |filled_op..bounded_op| must match that of the code
4718 values they test for.
4720 @d true_code 30 /* operation code for \.{true} */
4721 @d false_code 31 /* operation code for \.{false} */
4722 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4723 @d null_pen_code 33 /* operation code for \.{nullpen} */
4724 @d job_name_op 34 /* operation code for \.{jobname} */
4725 @d read_string_op 35 /* operation code for \.{readstring} */
4726 @d pen_circle 36 /* operation code for \.{pencircle} */
4727 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4728 @d read_from_op 38 /* operation code for \.{readfrom} */
4729 @d close_from_op 39 /* operation code for \.{closefrom} */
4730 @d odd_op 40 /* operation code for \.{odd} */
4731 @d known_op 41 /* operation code for \.{known} */
4732 @d unknown_op 42 /* operation code for \.{unknown} */
4733 @d not_op 43 /* operation code for \.{not} */
4734 @d decimal 44 /* operation code for \.{decimal} */
4735 @d reverse 45 /* operation code for \.{reverse} */
4736 @d make_path_op 46 /* operation code for \.{makepath} */
4737 @d make_pen_op 47 /* operation code for \.{makepen} */
4738 @d oct_op 48 /* operation code for \.{oct} */
4739 @d hex_op 49 /* operation code for \.{hex} */
4740 @d ASCII_op 50 /* operation code for \.{ASCII} */
4741 @d char_op 51 /* operation code for \.{char} */
4742 @d length_op 52 /* operation code for \.{length} */
4743 @d turning_op 53 /* operation code for \.{turningnumber} */
4744 @d color_model_part 54 /* operation code for \.{colormodel} */
4745 @d x_part 55 /* operation code for \.{xpart} */
4746 @d y_part 56 /* operation code for \.{ypart} */
4747 @d xx_part 57 /* operation code for \.{xxpart} */
4748 @d xy_part 58 /* operation code for \.{xypart} */
4749 @d yx_part 59 /* operation code for \.{yxpart} */
4750 @d yy_part 60 /* operation code for \.{yypart} */
4751 @d red_part 61 /* operation code for \.{redpart} */
4752 @d green_part 62 /* operation code for \.{greenpart} */
4753 @d blue_part 63 /* operation code for \.{bluepart} */
4754 @d cyan_part 64 /* operation code for \.{cyanpart} */
4755 @d magenta_part 65 /* operation code for \.{magentapart} */
4756 @d yellow_part 66 /* operation code for \.{yellowpart} */
4757 @d black_part 67 /* operation code for \.{blackpart} */
4758 @d grey_part 68 /* operation code for \.{greypart} */
4759 @d font_part 69 /* operation code for \.{fontpart} */
4760 @d text_part 70 /* operation code for \.{textpart} */
4761 @d path_part 71 /* operation code for \.{pathpart} */
4762 @d pen_part 72 /* operation code for \.{penpart} */
4763 @d dash_part 73 /* operation code for \.{dashpart} */
4764 @d sqrt_op 74 /* operation code for \.{sqrt} */
4765 @d m_exp_op 75 /* operation code for \.{mexp} */
4766 @d m_log_op 76 /* operation code for \.{mlog} */
4767 @d sin_d_op 77 /* operation code for \.{sind} */
4768 @d cos_d_op 78 /* operation code for \.{cosd} */
4769 @d floor_op 79 /* operation code for \.{floor} */
4770 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4771 @d char_exists_op 81 /* operation code for \.{charexists} */
4772 @d font_size 82 /* operation code for \.{fontsize} */
4773 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4774 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4775 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4776 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4777 @d arc_length 87 /* operation code for \.{arclength} */
4778 @d angle_op 88 /* operation code for \.{angle} */
4779 @d cycle_op 89 /* operation code for \.{cycle} */
4780 @d filled_op 90 /* operation code for \.{filled} */
4781 @d stroked_op 91 /* operation code for \.{stroked} */
4782 @d textual_op 92 /* operation code for \.{textual} */
4783 @d clipped_op 93 /* operation code for \.{clipped} */
4784 @d bounded_op 94 /* operation code for \.{bounded} */
4785 @d plus 95 /* operation code for \.+ */
4786 @d minus 96 /* operation code for \.- */
4787 @d times 97 /* operation code for \.* */
4788 @d over 98 /* operation code for \./ */
4789 @d pythag_add 99 /* operation code for \.{++} */
4790 @d pythag_sub 100 /* operation code for \.{+-+} */
4791 @d or_op 101 /* operation code for \.{or} */
4792 @d and_op 102 /* operation code for \.{and} */
4793 @d less_than 103 /* operation code for \.< */
4794 @d less_or_equal 104 /* operation code for \.{<=} */
4795 @d greater_than 105 /* operation code for \.> */
4796 @d greater_or_equal 106 /* operation code for \.{>=} */
4797 @d equal_to 107 /* operation code for \.= */
4798 @d unequal_to 108 /* operation code for \.{<>} */
4799 @d concatenate 109 /* operation code for \.\& */
4800 @d rotated_by 110 /* operation code for \.{rotated} */
4801 @d slanted_by 111 /* operation code for \.{slanted} */
4802 @d scaled_by 112 /* operation code for \.{scaled} */
4803 @d shifted_by 113 /* operation code for \.{shifted} */
4804 @d transformed_by 114 /* operation code for \.{transformed} */
4805 @d x_scaled 115 /* operation code for \.{xscaled} */
4806 @d y_scaled 116 /* operation code for \.{yscaled} */
4807 @d z_scaled 117 /* operation code for \.{zscaled} */
4808 @d in_font 118 /* operation code for \.{infont} */
4809 @d intersect 119 /* operation code for \.{intersectiontimes} */
4810 @d double_dot 120 /* operation code for improper \.{..} */
4811 @d substring_of 121 /* operation code for \.{substring} */
4812 @d min_of substring_of
4813 @d subpath_of 122 /* operation code for \.{subpath} */
4814 @d direction_time_of 123 /* operation code for \.{directiontime} */
4815 @d point_of 124 /* operation code for \.{point} */
4816 @d precontrol_of 125 /* operation code for \.{precontrol} */
4817 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4818 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4819 @d arc_time_of 128 /* operation code for \.{arctime} */
4820 @d mp_version 129 /* operation code for \.{mpversion} */
4822 @c void mp_print_op (MP mp,quarterword c) {
4823 if (c<=mp_numeric_type ) {
4824 mp_print_type(mp, c);
4827 case true_code:mp_print(mp, "true"); break;
4828 case false_code:mp_print(mp, "false"); break;
4829 case null_picture_code:mp_print(mp, "nullpicture"); break;
4830 case null_pen_code:mp_print(mp, "nullpen"); break;
4831 case job_name_op:mp_print(mp, "jobname"); break;
4832 case read_string_op:mp_print(mp, "readstring"); break;
4833 case pen_circle:mp_print(mp, "pencircle"); break;
4834 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4835 case read_from_op:mp_print(mp, "readfrom"); break;
4836 case close_from_op:mp_print(mp, "closefrom"); break;
4837 case odd_op:mp_print(mp, "odd"); break;
4838 case known_op:mp_print(mp, "known"); break;
4839 case unknown_op:mp_print(mp, "unknown"); break;
4840 case not_op:mp_print(mp, "not"); break;
4841 case decimal:mp_print(mp, "decimal"); break;
4842 case reverse:mp_print(mp, "reverse"); break;
4843 case make_path_op:mp_print(mp, "makepath"); break;
4844 case make_pen_op:mp_print(mp, "makepen"); break;
4845 case oct_op:mp_print(mp, "oct"); break;
4846 case hex_op:mp_print(mp, "hex"); break;
4847 case ASCII_op:mp_print(mp, "ASCII"); break;
4848 case char_op:mp_print(mp, "char"); break;
4849 case length_op:mp_print(mp, "length"); break;
4850 case turning_op:mp_print(mp, "turningnumber"); break;
4851 case x_part:mp_print(mp, "xpart"); break;
4852 case y_part:mp_print(mp, "ypart"); break;
4853 case xx_part:mp_print(mp, "xxpart"); break;
4854 case xy_part:mp_print(mp, "xypart"); break;
4855 case yx_part:mp_print(mp, "yxpart"); break;
4856 case yy_part:mp_print(mp, "yypart"); break;
4857 case red_part:mp_print(mp, "redpart"); break;
4858 case green_part:mp_print(mp, "greenpart"); break;
4859 case blue_part:mp_print(mp, "bluepart"); break;
4860 case cyan_part:mp_print(mp, "cyanpart"); break;
4861 case magenta_part:mp_print(mp, "magentapart"); break;
4862 case yellow_part:mp_print(mp, "yellowpart"); break;
4863 case black_part:mp_print(mp, "blackpart"); break;
4864 case grey_part:mp_print(mp, "greypart"); break;
4865 case color_model_part:mp_print(mp, "colormodel"); break;
4866 case font_part:mp_print(mp, "fontpart"); break;
4867 case text_part:mp_print(mp, "textpart"); break;
4868 case path_part:mp_print(mp, "pathpart"); break;
4869 case pen_part:mp_print(mp, "penpart"); break;
4870 case dash_part:mp_print(mp, "dashpart"); break;
4871 case sqrt_op:mp_print(mp, "sqrt"); break;
4872 case m_exp_op:mp_print(mp, "mexp"); break;
4873 case m_log_op:mp_print(mp, "mlog"); break;
4874 case sin_d_op:mp_print(mp, "sind"); break;
4875 case cos_d_op:mp_print(mp, "cosd"); break;
4876 case floor_op:mp_print(mp, "floor"); break;
4877 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4878 case char_exists_op:mp_print(mp, "charexists"); break;
4879 case font_size:mp_print(mp, "fontsize"); break;
4880 case ll_corner_op:mp_print(mp, "llcorner"); break;
4881 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4882 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4883 case ur_corner_op:mp_print(mp, "urcorner"); break;
4884 case arc_length:mp_print(mp, "arclength"); break;
4885 case angle_op:mp_print(mp, "angle"); break;
4886 case cycle_op:mp_print(mp, "cycle"); break;
4887 case filled_op:mp_print(mp, "filled"); break;
4888 case stroked_op:mp_print(mp, "stroked"); break;
4889 case textual_op:mp_print(mp, "textual"); break;
4890 case clipped_op:mp_print(mp, "clipped"); break;
4891 case bounded_op:mp_print(mp, "bounded"); break;
4892 case plus:mp_print_char(mp, '+'); break;
4893 case minus:mp_print_char(mp, '-'); break;
4894 case times:mp_print_char(mp, '*'); break;
4895 case over:mp_print_char(mp, '/'); break;
4896 case pythag_add:mp_print(mp, "++"); break;
4897 case pythag_sub:mp_print(mp, "+-+"); break;
4898 case or_op:mp_print(mp, "or"); break;
4899 case and_op:mp_print(mp, "and"); break;
4900 case less_than:mp_print_char(mp, '<'); break;
4901 case less_or_equal:mp_print(mp, "<="); break;
4902 case greater_than:mp_print_char(mp, '>'); break;
4903 case greater_or_equal:mp_print(mp, ">="); break;
4904 case equal_to:mp_print_char(mp, '='); break;
4905 case unequal_to:mp_print(mp, "<>"); break;
4906 case concatenate:mp_print(mp, "&"); break;
4907 case rotated_by:mp_print(mp, "rotated"); break;
4908 case slanted_by:mp_print(mp, "slanted"); break;
4909 case scaled_by:mp_print(mp, "scaled"); break;
4910 case shifted_by:mp_print(mp, "shifted"); break;
4911 case transformed_by:mp_print(mp, "transformed"); break;
4912 case x_scaled:mp_print(mp, "xscaled"); break;
4913 case y_scaled:mp_print(mp, "yscaled"); break;
4914 case z_scaled:mp_print(mp, "zscaled"); break;
4915 case in_font:mp_print(mp, "infont"); break;
4916 case intersect:mp_print(mp, "intersectiontimes"); break;
4917 case substring_of:mp_print(mp, "substring"); break;
4918 case subpath_of:mp_print(mp, "subpath"); break;
4919 case direction_time_of:mp_print(mp, "directiontime"); break;
4920 case point_of:mp_print(mp, "point"); break;
4921 case precontrol_of:mp_print(mp, "precontrol"); break;
4922 case postcontrol_of:mp_print(mp, "postcontrol"); break;
4923 case pen_offset_of:mp_print(mp, "penoffset"); break;
4924 case arc_time_of:mp_print(mp, "arctime"); break;
4925 case mp_version:mp_print(mp, "mpversion"); break;
4926 default: mp_print(mp, ".."); break;
4931 @ \MP\ also has a bunch of internal parameters that a user might want to
4932 fuss with. Every such parameter has an identifying code number, defined here.
4935 enum mp_given_internal {
4936 mp_tracing_titles=1, /* show titles online when they appear */
4937 mp_tracing_equations, /* show each variable when it becomes known */
4938 mp_tracing_capsules, /* show capsules too */
4939 mp_tracing_choices, /* show the control points chosen for paths */
4940 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
4941 mp_tracing_commands, /* show commands and operations before they are performed */
4942 mp_tracing_restores, /* show when a variable or internal is restored */
4943 mp_tracing_macros, /* show macros before they are expanded */
4944 mp_tracing_output, /* show digitized edges as they are output */
4945 mp_tracing_stats, /* show memory usage at end of job */
4946 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
4947 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
4948 mp_year, /* the current year (e.g., 1984) */
4949 mp_month, /* the current month (e.g, 3 $\equiv$ March) */
4950 mp_day, /* the current day of the month */
4951 mp_time, /* the number of minutes past midnight when this job started */
4952 mp_char_code, /* the number of the next character to be output */
4953 mp_char_ext, /* the extension code of the next character to be output */
4954 mp_char_wd, /* the width of the next character to be output */
4955 mp_char_ht, /* the height of the next character to be output */
4956 mp_char_dp, /* the depth of the next character to be output */
4957 mp_char_ic, /* the italic correction of the next character to be output */
4958 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
4959 mp_pausing, /* positive to display lines on the terminal before they are read */
4960 mp_showstopping, /* positive to stop after each \&{show} command */
4961 mp_fontmaking, /* positive if font metric output is to be produced */
4962 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
4963 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
4964 mp_miterlimit, /* controls miter length as in \ps */
4965 mp_warning_check, /* controls error message when variable value is large */
4966 mp_boundary_char, /* the right boundary character for ligatures */
4967 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
4968 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
4969 mp_default_color_model, /* the default color model for unspecified items */
4970 mp_restore_clip_color,
4971 mp_procset, /* wether or not create PostScript command shortcuts */
4972 mp_gtroffmode, /* whether the user specified |-troff| on the command line */
4977 @d max_given_internal mp_gtroffmode
4980 scaled *internal; /* the values of internal quantities */
4981 char **int_name; /* their names */
4982 int int_ptr; /* the maximum internal quantity defined so far */
4983 int max_internal; /* current maximum number of internal quantities */
4986 @ @<Option variables@>=
4989 @ @<Allocate or initialize ...@>=
4990 mp->max_internal=2*max_given_internal;
4991 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
4992 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
4993 mp->troff_mode=(opt->troff_mode>0 ? true : false);
4995 @ @<Exported function ...@>=
4996 int mp_troff_mode(MP mp);
4999 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5001 @ @<Set initial ...@>=
5002 for (k=0;k<= mp->max_internal; k++ ) {
5004 mp->int_name[k]=NULL;
5006 mp->int_ptr=max_given_internal;
5008 @ The symbolic names for internal quantities are put into \MP's hash table
5009 by using a routine called |primitive|, which will be defined later. Let us
5010 enter them now, so that we don't have to list all those names again
5013 @<Put each of \MP's primitives into the hash table@>=
5014 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5015 @:tracingtitles_}{\&{tracingtitles} primitive@>
5016 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5017 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5018 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5019 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5020 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5021 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5022 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5023 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5024 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5025 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5026 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5027 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5028 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5029 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5030 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5031 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5032 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5033 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5034 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5035 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5036 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5037 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5038 mp_primitive(mp, "year",internal_quantity,mp_year);
5039 @:mp_year_}{\&{year} primitive@>
5040 mp_primitive(mp, "month",internal_quantity,mp_month);
5041 @:mp_month_}{\&{month} primitive@>
5042 mp_primitive(mp, "day",internal_quantity,mp_day);
5043 @:mp_day_}{\&{day} primitive@>
5044 mp_primitive(mp, "time",internal_quantity,mp_time);
5045 @:time_}{\&{time} primitive@>
5046 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5047 @:mp_char_code_}{\&{charcode} primitive@>
5048 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5049 @:mp_char_ext_}{\&{charext} primitive@>
5050 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5051 @:mp_char_wd_}{\&{charwd} primitive@>
5052 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5053 @:mp_char_ht_}{\&{charht} primitive@>
5054 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5055 @:mp_char_dp_}{\&{chardp} primitive@>
5056 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5057 @:mp_char_ic_}{\&{charic} primitive@>
5058 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5059 @:mp_design_size_}{\&{designsize} primitive@>
5060 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5061 @:mp_pausing_}{\&{pausing} primitive@>
5062 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5063 @:mp_showstopping_}{\&{showstopping} primitive@>
5064 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5065 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5066 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5067 @:mp_linejoin_}{\&{linejoin} primitive@>
5068 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5069 @:mp_linecap_}{\&{linecap} primitive@>
5070 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5071 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5072 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5073 @:mp_warning_check_}{\&{warningcheck} primitive@>
5074 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5075 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5076 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5077 @:mp_prologues_}{\&{prologues} primitive@>
5078 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5079 @:mp_true_corners_}{\&{truecorners} primitive@>
5080 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5081 @:mp_procset_}{\&{mpprocset} primitive@>
5082 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5083 @:troffmode_}{\&{troffmode} primitive@>
5084 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5085 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5086 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5087 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5089 @ Colors can be specified in four color models. In the special
5090 case of |no_model|, MetaPost does not output any color operator to
5091 the postscript output.
5093 Note: these values are passed directly on to |with_option|. This only
5094 works because the other possible values passed to |with_option| are
5095 8 and 10 respectively (from |with_pen| and |with_picture|).
5097 There is a first state, that is only used for |gs_colormodel|. It flags
5098 the fact that there has not been any kind of color specification by
5099 the user so far in the game.
5102 enum mp_color_model {
5107 mp_uninitialized_model=9,
5111 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5112 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5113 mp->internal[mp_restore_clip_color]=unity;
5115 @ Well, we do have to list the names one more time, for use in symbolic
5118 @<Initialize table...@>=
5119 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5120 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5121 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5122 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5123 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5124 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5125 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5126 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5127 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5128 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5129 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5130 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5131 mp->int_name[mp_year]=xstrdup("year");
5132 mp->int_name[mp_month]=xstrdup("month");
5133 mp->int_name[mp_day]=xstrdup("day");
5134 mp->int_name[mp_time]=xstrdup("time");
5135 mp->int_name[mp_char_code]=xstrdup("charcode");
5136 mp->int_name[mp_char_ext]=xstrdup("charext");
5137 mp->int_name[mp_char_wd]=xstrdup("charwd");
5138 mp->int_name[mp_char_ht]=xstrdup("charht");
5139 mp->int_name[mp_char_dp]=xstrdup("chardp");
5140 mp->int_name[mp_char_ic]=xstrdup("charic");
5141 mp->int_name[mp_design_size]=xstrdup("designsize");
5142 mp->int_name[mp_pausing]=xstrdup("pausing");
5143 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5144 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5145 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5146 mp->int_name[mp_linecap]=xstrdup("linecap");
5147 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5148 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5149 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5150 mp->int_name[mp_prologues]=xstrdup("prologues");
5151 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5152 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5153 mp->int_name[mp_procset]=xstrdup("mpprocset");
5154 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5155 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5157 @ The following procedure, which is called just before \MP\ initializes its
5158 input and output, establishes the initial values of the date and time.
5159 @^system dependencies@>
5161 Note that the values are |scaled| integers. Hence \MP\ can no longer
5162 be used after the year 32767.
5165 void mp_fix_date_and_time (MP mp) {
5166 time_t clock = time ((time_t *) 0);
5167 struct tm *tmptr = localtime (&clock);
5168 mp->internal[mp_time]=
5169 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5170 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5171 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5172 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5176 void mp_fix_date_and_time (MP mp) ;
5178 @ \MP\ is occasionally supposed to print diagnostic information that
5179 goes only into the transcript file, unless |mp_tracing_online| is positive.
5180 Now that we have defined |mp_tracing_online| we can define
5181 two routines that adjust the destination of print commands:
5184 void mp_begin_diagnostic (MP mp) ;
5185 void mp_end_diagnostic (MP mp,boolean blank_line);
5186 void mp_print_diagnostic (MP mp, char *s, char *t, boolean nuline) ;
5188 @ @<Basic printing...@>=
5189 @<Declare a function called |true_line|@>;
5190 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5191 mp->old_setting=mp->selector;
5192 if ( mp->selector==ps_file_only ) mp->selector=mp->non_ps_setting;
5193 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5195 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5199 void mp_end_diagnostic (MP mp,boolean blank_line) {
5200 /* restore proper conditions after tracing */
5201 mp_print_nl(mp, "");
5202 if ( blank_line ) mp_print_ln(mp);
5203 mp->selector=mp->old_setting;
5206 @ The global variable |non_ps_setting| is initialized when it is time to print
5210 unsigned int old_setting;
5211 unsigned int non_ps_setting;
5213 @ We will occasionally use |begin_diagnostic| in connection with line-number
5214 printing, as follows. (The parameter |s| is typically |"Path"| or
5215 |"Cycle spec"|, etc.)
5217 @<Basic printing...@>=
5218 void mp_print_diagnostic (MP mp, char *s, char *t, boolean nuline) {
5219 mp_begin_diagnostic(mp);
5220 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5221 mp_print(mp, " at line ");
5222 mp_print_int(mp, mp_true_line(mp));
5223 mp_print(mp, t); mp_print_char(mp, ':');
5226 @ The 256 |ASCII_code| characters are grouped into classes by means of
5227 the |char_class| table. Individual class numbers have no semantic
5228 or syntactic significance, except in a few instances defined here.
5229 There's also |max_class|, which can be used as a basis for additional
5230 class numbers in nonstandard extensions of \MP.
5232 @d digit_class 0 /* the class number of \.{0123456789} */
5233 @d period_class 1 /* the class number of `\..' */
5234 @d space_class 2 /* the class number of spaces and nonstandard characters */
5235 @d percent_class 3 /* the class number of `\.\%' */
5236 @d string_class 4 /* the class number of `\."' */
5237 @d right_paren_class 8 /* the class number of `\.)' */
5238 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5239 @d letter_class 9 /* letters and the underline character */
5240 @d left_bracket_class 17 /* `\.[' */
5241 @d right_bracket_class 18 /* `\.]' */
5242 @d invalid_class 20 /* bad character in the input */
5243 @d max_class 20 /* the largest class number */
5246 int char_class[256]; /* the class numbers */
5248 @ If changes are made to accommodate non-ASCII character sets, they should
5249 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5250 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5251 @^system dependencies@>
5253 @<Set initial ...@>=
5254 for (k='0';k<='9';k++)
5255 mp->char_class[k]=digit_class;
5256 mp->char_class['.']=period_class;
5257 mp->char_class[' ']=space_class;
5258 mp->char_class['%']=percent_class;
5259 mp->char_class['"']=string_class;
5260 mp->char_class[',']=5;
5261 mp->char_class[';']=6;
5262 mp->char_class['(']=7;
5263 mp->char_class[')']=right_paren_class;
5264 for (k='A';k<= 'Z';k++ )
5265 mp->char_class[k]=letter_class;
5266 for (k='a';k<='z';k++)
5267 mp->char_class[k]=letter_class;
5268 mp->char_class['_']=letter_class;
5269 mp->char_class['<']=10;
5270 mp->char_class['=']=10;
5271 mp->char_class['>']=10;
5272 mp->char_class[':']=10;
5273 mp->char_class['|']=10;
5274 mp->char_class['`']=11;
5275 mp->char_class['\'']=11;
5276 mp->char_class['+']=12;
5277 mp->char_class['-']=12;
5278 mp->char_class['/']=13;
5279 mp->char_class['*']=13;
5280 mp->char_class['\\']=13;
5281 mp->char_class['!']=14;
5282 mp->char_class['?']=14;
5283 mp->char_class['#']=15;
5284 mp->char_class['&']=15;
5285 mp->char_class['@@']=15;
5286 mp->char_class['$']=15;
5287 mp->char_class['^']=16;
5288 mp->char_class['~']=16;
5289 mp->char_class['[']=left_bracket_class;
5290 mp->char_class[']']=right_bracket_class;
5291 mp->char_class['{']=19;
5292 mp->char_class['}']=19;
5294 mp->char_class[k]=invalid_class;
5295 mp->char_class['\t']=space_class;
5296 mp->char_class['\f']=space_class;
5297 for (k=127;k<=255;k++)
5298 mp->char_class[k]=invalid_class;
5300 @* \[13] The hash table.
5301 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5302 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5303 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5304 table, it is never removed.
5306 The actual sequence of characters forming a symbolic token is
5307 stored in the |str_pool| array together with all the other strings. An
5308 auxiliary array |hash| consists of items with two halfword fields per
5309 word. The first of these, called |next(p)|, points to the next identifier
5310 belonging to the same coalesced list as the identifier corresponding to~|p|;
5311 and the other, called |text(p)|, points to the |str_start| entry for
5312 |p|'s identifier. If position~|p| of the hash table is empty, we have
5313 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5314 hash list, we have |next(p)=0|.
5316 An auxiliary pointer variable called |hash_used| is maintained in such a
5317 way that all locations |p>=hash_used| are nonempty. The global variable
5318 |st_count| tells how many symbolic tokens have been defined, if statistics
5321 The first 256 locations of |hash| are reserved for symbols of length one.
5323 There's a parallel array called |eqtb| that contains the current equivalent
5324 values of each symbolic token. The entries of this array consist of
5325 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5326 piece of information that qualifies the |eq_type|).
5328 @d next(A) mp->hash[(A)].lh /* link for coalesced lists */
5329 @d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5330 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5331 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5332 @d hash_base 257 /* hashing actually starts here */
5333 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5336 pointer hash_used; /* allocation pointer for |hash| */
5337 integer st_count; /* total number of known identifiers */
5339 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5340 since they are used in error recovery.
5342 @d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
5343 @d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5344 @d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5345 @d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5346 @d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5347 @d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5348 @d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5349 @d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5350 @d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5351 @d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5352 @d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5353 @d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5354 @d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5355 @d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5356 @d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5357 @d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5358 @d hash_end (hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5361 two_halves *hash; /* the hash table */
5362 two_halves *eqtb; /* the equivalents */
5364 @ @<Allocate or initialize ...@>=
5365 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5366 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5368 @ @<Dealloc variables@>=
5373 next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5374 for (k=2;k<=hash_end;k++) {
5375 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5378 @ @<Initialize table entries...@>=
5379 mp->hash_used=frozen_inaccessible; /* nothing is used */
5381 text(frozen_bad_vardef)=intern("a bad variable");
5382 text(frozen_etex)=intern("etex");
5383 text(frozen_mpx_break)=intern("mpxbreak");
5384 text(frozen_fi)=intern("fi");
5385 text(frozen_end_group)=intern("endgroup");
5386 text(frozen_end_def)=intern("enddef");
5387 text(frozen_end_for)=intern("endfor");
5388 text(frozen_semicolon)=intern(";");
5389 text(frozen_colon)=intern(":");
5390 text(frozen_slash)=intern("/");
5391 text(frozen_left_bracket)=intern("[");
5392 text(frozen_right_delimiter)=intern(")");
5393 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5394 eq_type(frozen_right_delimiter)=right_delimiter;
5396 @ @<Check the ``constant'' values...@>=
5397 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5399 @ Here is the subroutine that searches the hash table for an identifier
5400 that matches a given string of length~|l| appearing in |buffer[j..
5401 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5402 will always be found, and the corresponding hash table address
5406 pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5407 integer h; /* hash code */
5408 pointer p; /* index in |hash| array */
5409 pointer k; /* index in |buffer| array */
5411 @<Treat special case of length 1 and |break|@>;
5413 @<Compute the hash code |h|@>;
5414 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5416 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5419 @<Insert a new symbolic token after |p|, then
5420 make |p| point to it and |break|@>;
5427 @ @<Treat special case of length 1...@>=
5428 p=mp->buffer[j]+1; text(p)=p-1; return p;
5431 @ @<Insert a new symbolic...@>=
5436 mp_overflow(mp, "hash size",mp->hash_size);
5437 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5438 decr(mp->hash_used);
5439 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5440 next(p)=mp->hash_used;
5444 for (k=j;k<=j+l-1;k++) {
5445 append_char(mp->buffer[k]);
5447 text(p)=mp_make_string(mp);
5448 mp->str_ref[text(p)]=max_str_ref;
5454 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5455 should be a prime number. The theory of hashing tells us to expect fewer
5456 than two table probes, on the average, when the search is successful.
5457 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5458 @^Vitter, Jeffrey Scott@>
5460 @<Compute the hash code |h|@>=
5462 for (k=j+1;k<=j+l-1;k++){
5463 h=h+h+mp->buffer[k];
5464 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5467 @ @<Search |eqtb| for equivalents equal to |p|@>=
5468 for (q=1;q<=hash_end;q++) {
5469 if ( equiv(q)==p ) {
5470 mp_print_nl(mp, "EQUIV(");
5471 mp_print_int(mp, q);
5472 mp_print_char(mp, ')');
5476 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5477 table, together with their command code (which will be the |eq_type|)
5478 and an operand (which will be the |equiv|). The |primitive| procedure
5479 does this, in a way that no \MP\ user can. The global value |cur_sym|
5480 contains the new |eqtb| pointer after |primitive| has acted.
5483 void mp_primitive (MP mp, char *ss, halfword c, halfword o) {
5484 pool_pointer k; /* index into |str_pool| */
5485 small_number j; /* index into |buffer| */
5486 small_number l; /* length of the string */
5489 k=mp->str_start[s]; l=str_stop(s)-k;
5490 /* we will move |s| into the (empty) |buffer| */
5491 for (j=0;j<=l-1;j++) {
5492 mp->buffer[j]=mp->str_pool[k+j];
5494 mp->cur_sym=mp_id_lookup(mp, 0,l);
5495 if ( s>=256 ) { /* we don't want to have the string twice */
5496 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5498 eq_type(mp->cur_sym)=c;
5499 equiv(mp->cur_sym)=o;
5503 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5504 by their |eq_type| alone. These primitives are loaded into the hash table
5507 @<Put each of \MP's primitives into the hash table@>=
5508 mp_primitive(mp, "..",path_join,0);
5509 @:.._}{\.{..} primitive@>
5510 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5511 @:[ }{\.{[} primitive@>
5512 mp_primitive(mp, "]",right_bracket,0);
5513 @:] }{\.{]} primitive@>
5514 mp_primitive(mp, "}",right_brace,0);
5515 @:]]}{\.{\char`\}} primitive@>
5516 mp_primitive(mp, "{",left_brace,0);
5517 @:][}{\.{\char`\{} primitive@>
5518 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5519 @:: }{\.{:} primitive@>
5520 mp_primitive(mp, "::",double_colon,0);
5521 @::: }{\.{::} primitive@>
5522 mp_primitive(mp, "||:",bchar_label,0);
5523 @:::: }{\.{\char'174\char'174:} primitive@>
5524 mp_primitive(mp, ":=",assignment,0);
5525 @::=_}{\.{:=} primitive@>
5526 mp_primitive(mp, ",",comma,0);
5527 @:, }{\., primitive@>
5528 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5529 @:; }{\.; primitive@>
5530 mp_primitive(mp, "\\",relax,0);
5531 @:]]\\}{\.{\char`\\} primitive@>
5533 mp_primitive(mp, "addto",add_to_command,0);
5534 @:add_to_}{\&{addto} primitive@>
5535 mp_primitive(mp, "atleast",at_least,0);
5536 @:at_least_}{\&{atleast} primitive@>
5537 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5538 @:begin_group_}{\&{begingroup} primitive@>
5539 mp_primitive(mp, "controls",controls,0);
5540 @:controls_}{\&{controls} primitive@>
5541 mp_primitive(mp, "curl",curl_command,0);
5542 @:curl_}{\&{curl} primitive@>
5543 mp_primitive(mp, "delimiters",delimiters,0);
5544 @:delimiters_}{\&{delimiters} primitive@>
5545 mp_primitive(mp, "endgroup",end_group,0);
5546 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5547 @:endgroup_}{\&{endgroup} primitive@>
5548 mp_primitive(mp, "everyjob",every_job_command,0);
5549 @:every_job_}{\&{everyjob} primitive@>
5550 mp_primitive(mp, "exitif",exit_test,0);
5551 @:exit_if_}{\&{exitif} primitive@>
5552 mp_primitive(mp, "expandafter",expand_after,0);
5553 @:expand_after_}{\&{expandafter} primitive@>
5554 mp_primitive(mp, "interim",interim_command,0);
5555 @:interim_}{\&{interim} primitive@>
5556 mp_primitive(mp, "let",let_command,0);
5557 @:let_}{\&{let} primitive@>
5558 mp_primitive(mp, "newinternal",new_internal,0);
5559 @:new_internal_}{\&{newinternal} primitive@>
5560 mp_primitive(mp, "of",of_token,0);
5561 @:of_}{\&{of} primitive@>
5562 mp_primitive(mp, "randomseed",random_seed,0);
5563 @:random_seed_}{\&{randomseed} primitive@>
5564 mp_primitive(mp, "save",save_command,0);
5565 @:save_}{\&{save} primitive@>
5566 mp_primitive(mp, "scantokens",scan_tokens,0);
5567 @:scan_tokens_}{\&{scantokens} primitive@>
5568 mp_primitive(mp, "shipout",ship_out_command,0);
5569 @:ship_out_}{\&{shipout} primitive@>
5570 mp_primitive(mp, "skipto",skip_to,0);
5571 @:skip_to_}{\&{skipto} primitive@>
5572 mp_primitive(mp, "special",special_command,0);
5573 @:special}{\&{special} primitive@>
5574 mp_primitive(mp, "fontmapfile",special_command,1);
5575 @:fontmapfile}{\&{fontmapfile} primitive@>
5576 mp_primitive(mp, "fontmapline",special_command,2);
5577 @:fontmapline}{\&{fontmapline} primitive@>
5578 mp_primitive(mp, "step",step_token,0);
5579 @:step_}{\&{step} primitive@>
5580 mp_primitive(mp, "str",str_op,0);
5581 @:str_}{\&{str} primitive@>
5582 mp_primitive(mp, "tension",tension,0);
5583 @:tension_}{\&{tension} primitive@>
5584 mp_primitive(mp, "to",to_token,0);
5585 @:to_}{\&{to} primitive@>
5586 mp_primitive(mp, "until",until_token,0);
5587 @:until_}{\&{until} primitive@>
5588 mp_primitive(mp, "within",within_token,0);
5589 @:within_}{\&{within} primitive@>
5590 mp_primitive(mp, "write",write_command,0);
5591 @:write_}{\&{write} primitive@>
5593 @ Each primitive has a corresponding inverse, so that it is possible to
5594 display the cryptic numeric contents of |eqtb| in symbolic form.
5595 Every call of |primitive| in this program is therefore accompanied by some
5596 straightforward code that forms part of the |print_cmd_mod| routine
5599 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5600 case add_to_command:mp_print(mp, "addto"); break;
5601 case assignment:mp_print(mp, ":="); break;
5602 case at_least:mp_print(mp, "atleast"); break;
5603 case bchar_label:mp_print(mp, "||:"); break;
5604 case begin_group:mp_print(mp, "begingroup"); break;
5605 case colon:mp_print(mp, ":"); break;
5606 case comma:mp_print(mp, ","); break;
5607 case controls:mp_print(mp, "controls"); break;
5608 case curl_command:mp_print(mp, "curl"); break;
5609 case delimiters:mp_print(mp, "delimiters"); break;
5610 case double_colon:mp_print(mp, "::"); break;
5611 case end_group:mp_print(mp, "endgroup"); break;
5612 case every_job_command:mp_print(mp, "everyjob"); break;
5613 case exit_test:mp_print(mp, "exitif"); break;
5614 case expand_after:mp_print(mp, "expandafter"); break;
5615 case interim_command:mp_print(mp, "interim"); break;
5616 case left_brace:mp_print(mp, "{"); break;
5617 case left_bracket:mp_print(mp, "["); break;
5618 case let_command:mp_print(mp, "let"); break;
5619 case new_internal:mp_print(mp, "newinternal"); break;
5620 case of_token:mp_print(mp, "of"); break;
5621 case path_join:mp_print(mp, ".."); break;
5622 case random_seed:mp_print(mp, "randomseed"); break;
5623 case relax:mp_print_char(mp, '\\'); break;
5624 case right_brace:mp_print(mp, "}"); break;
5625 case right_bracket:mp_print(mp, "]"); break;
5626 case save_command:mp_print(mp, "save"); break;
5627 case scan_tokens:mp_print(mp, "scantokens"); break;
5628 case semicolon:mp_print(mp, ";"); break;
5629 case ship_out_command:mp_print(mp, "shipout"); break;
5630 case skip_to:mp_print(mp, "skipto"); break;
5631 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5632 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5633 mp_print(mp, "special"); break;
5634 case step_token:mp_print(mp, "step"); break;
5635 case str_op:mp_print(mp, "str"); break;
5636 case tension:mp_print(mp, "tension"); break;
5637 case to_token:mp_print(mp, "to"); break;
5638 case until_token:mp_print(mp, "until"); break;
5639 case within_token:mp_print(mp, "within"); break;
5640 case write_command:mp_print(mp, "write"); break;
5642 @ We will deal with the other primitives later, at some point in the program
5643 where their |eq_type| and |equiv| values are more meaningful. For example,
5644 the primitives for macro definitions will be loaded when we consider the
5645 routines that define macros.
5646 It is easy to find where each particular
5647 primitive was treated by looking in the index at the end; for example, the
5648 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5650 @* \[14] Token lists.
5651 A \MP\ token is either symbolic or numeric or a string, or it denotes
5652 a macro parameter or capsule; so there are five corresponding ways to encode it
5654 internally: (1)~A symbolic token whose hash code is~|p|
5655 is represented by the number |p|, in the |info| field of a single-word
5656 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5657 represented in a two-word node of~|mem|; the |type| field is |known|,
5658 the |name_type| field is |token|, and the |value| field holds~|v|.
5659 The fact that this token appears in a two-word node rather than a
5660 one-word node is, of course, clear from the node address.
5661 (3)~A string token is also represented in a two-word node; the |type|
5662 field is |mp_string_type|, the |name_type| field is |token|, and the
5663 |value| field holds the corresponding |str_number|. (4)~Capsules have
5664 |name_type=capsule|, and their |type| and |value| fields represent
5665 arbitrary values (in ways to be explained later). (5)~Macro parameters
5666 are like symbolic tokens in that they appear in |info| fields of
5667 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5668 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5669 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5670 Actual values of these parameters are kept in a separate stack, as we will
5671 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5672 of course, chosen so that there will be no confusion between symbolic
5673 tokens and parameters of various types.
5676 the `\\{type}' field of a node has nothing to do with ``type'' in a
5677 printer's sense. It's curious that the same word is used in such different ways.
5679 @d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5680 @d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5681 @d token_node_size 2 /* the number of words in a large token node */
5682 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5683 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5684 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5685 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5686 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5688 @<Check the ``constant''...@>=
5689 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5691 @ We have set aside a two word node beginning at |null| so that we can have
5692 |value(null)=0|. We will make use of this coincidence later.
5694 @<Initialize table entries...@>=
5695 link(null)=null; value(null)=0;
5697 @ A numeric token is created by the following trivial routine.
5700 pointer mp_new_num_tok (MP mp,scaled v) {
5701 pointer p; /* the new node */
5702 p=mp_get_node(mp, token_node_size); value(p)=v;
5703 type(p)=mp_known; name_type(p)=mp_token;
5707 @ A token list is a singly linked list of nodes in |mem|, where
5708 each node contains a token and a link. Here's a subroutine that gets rid
5709 of a token list when it is no longer needed.
5712 void mp_token_recycle (MP mp);
5715 @c void mp_flush_token_list (MP mp,pointer p) {
5716 pointer q; /* the node being recycled */
5719 if ( q>=mp->hi_mem_min ) {
5723 case mp_vacuous: case mp_boolean_type: case mp_known:
5725 case mp_string_type:
5726 delete_str_ref(value(q));
5728 case unknown_types: case mp_pen_type: case mp_path_type:
5729 case mp_picture_type: case mp_pair_type: case mp_color_type:
5730 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5731 case mp_proto_dependent: case mp_independent:
5732 mp->g_pointer=q; mp_token_recycle(mp);
5734 default: mp_confusion(mp, "token");
5735 @:this can't happen token}{\quad token@>
5737 mp_free_node(mp, q,token_node_size);
5742 @ The procedure |show_token_list|, which prints a symbolic form of
5743 the token list that starts at a given node |p|, illustrates these
5744 conventions. The token list being displayed should not begin with a reference
5745 count. However, the procedure is intended to be fairly robust, so that if the
5746 memory links are awry or if |p| is not really a pointer to a token list,
5747 almost nothing catastrophic can happen.
5749 An additional parameter |q| is also given; this parameter is either null
5750 or it points to a node in the token list where a certain magic computation
5751 takes place that will be explained later. (Basically, |q| is non-null when
5752 we are printing the two-line context information at the time of an error
5753 message; |q| marks the place corresponding to where the second line
5756 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5757 of printing exceeds a given limit~|l|; the length of printing upon entry is
5758 assumed to be a given amount called |null_tally|. (Note that
5759 |show_token_list| sometimes uses itself recursively to print
5760 variable names within a capsule.)
5763 Unusual entries are printed in the form of all-caps tokens
5764 preceded by a space, e.g., `\.{\char`\ BAD}'.
5767 void mp_print_capsule (MP mp);
5769 @ @<Declare the procedure called |show_token_list|@>=
5770 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5771 integer null_tally) ;
5774 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5775 integer null_tally) {
5776 small_number class,c; /* the |char_class| of previous and new tokens */
5777 integer r,v; /* temporary registers */
5778 class=percent_class;
5779 mp->tally=null_tally;
5780 while ( (p!=null) && (mp->tally<l) ) {
5782 @<Do magic computation@>;
5783 @<Display token |p| and set |c| to its class;
5784 but |return| if there are problems@>;
5788 mp_print(mp, " ETC.");
5793 @ @<Display token |p| and set |c| to its class...@>=
5794 c=letter_class; /* the default */
5795 if ( (p<0)||(p>mp->mem_end) ) {
5796 mp_print(mp, " CLOBBERED"); return;
5799 if ( p<mp->hi_mem_min ) {
5800 @<Display two-word token@>;
5803 if ( r>=expr_base ) {
5804 @<Display a parameter token@>;
5808 @<Display a collective subscript@>
5810 mp_print(mp, " IMPOSSIBLE");
5815 if ( (r<0)||(r>mp->max_str_ptr) ) {
5816 mp_print(mp, " NONEXISTENT");
5819 @<Print string |r| as a symbolic token
5820 and set |c| to its class@>;
5826 @ @<Display two-word token@>=
5827 if ( name_type(p)==mp_token ) {
5828 if ( type(p)==mp_known ) {
5829 @<Display a numeric token@>;
5830 } else if ( type(p)!=mp_string_type ) {
5831 mp_print(mp, " BAD");
5834 mp_print_char(mp, '"'); mp_print_str(mp, value(p)); mp_print_char(mp, '"');
5837 } else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
5838 mp_print(mp, " BAD");
5840 mp->g_pointer=p; mp_print_capsule(mp); c=right_paren_class;
5843 @ @<Display a numeric token@>=
5844 if ( class==digit_class )
5845 mp_print_char(mp, ' ');
5848 if ( class==left_bracket_class )
5849 mp_print_char(mp, ' ');
5850 mp_print_char(mp, '['); mp_print_scaled(mp, v); mp_print_char(mp, ']');
5851 c=right_bracket_class;
5853 mp_print_scaled(mp, v); c=digit_class;
5857 @ Strictly speaking, a genuine token will never have |info(p)=0|.
5858 But we will see later (in the |print_variable_name| routine) that
5859 it is convenient to let |info(p)=0| stand for `\.{[]}'.
5861 @<Display a collective subscript@>=
5863 if ( class==left_bracket_class )
5864 mp_print_char(mp, ' ');
5865 mp_print(mp, "[]"); c=right_bracket_class;
5868 @ @<Display a parameter token@>=
5870 if ( r<suffix_base ) {
5871 mp_print(mp, "(EXPR"); r=r-(expr_base);
5873 } else if ( r<text_base ) {
5874 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5877 mp_print(mp, "(TEXT"); r=r-(text_base);
5880 mp_print_int(mp, r); mp_print_char(mp, ')'); c=right_paren_class;
5884 @ @<Print string |r| as a symbolic token...@>=
5886 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5889 case letter_class:mp_print_char(mp, '.'); break;
5890 case isolated_classes: break;
5891 default: mp_print_char(mp, ' '); break;
5894 mp_print_str(mp, r);
5897 @ The following procedures have been declared |forward| with no parameters,
5898 because the author dislikes \PASCAL's convention about |forward| procedures
5899 with parameters. It was necessary to do something, because |show_token_list|
5900 is recursive (although the recursion is limited to one level), and because
5901 |flush_token_list| is syntactically (but not semantically) recursive.
5904 @<Declare miscellaneous procedures that were declared |forward|@>=
5905 void mp_print_capsule (MP mp) {
5906 mp_print_char(mp, '('); mp_print_exp(mp, mp->g_pointer,0); mp_print_char(mp, ')');
5909 void mp_token_recycle (MP mp) {
5910 mp_recycle_value(mp, mp->g_pointer);
5914 pointer g_pointer; /* (global) parameter to the |forward| procedures */
5916 @ Macro definitions are kept in \MP's memory in the form of token lists
5917 that have a few extra one-word nodes at the beginning.
5919 The first node contains a reference count that is used to tell when the
5920 list is no longer needed. To emphasize the fact that a reference count is
5921 present, we shall refer to the |info| field of this special node as the
5923 @^reference counts@>
5925 The next node or nodes after the reference count serve to describe the
5926 formal parameters. They either contain a code word that specifies all
5927 of the parameters, or they contain zero or more parameter tokens followed
5928 by the code `|general_macro|'.
5931 /* reference count preceding a macro definition or picture header */
5932 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
5933 @d general_macro 0 /* preface to a macro defined with a parameter list */
5934 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
5935 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
5936 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
5937 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
5938 @d of_macro 5 /* preface to a macro with
5939 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
5940 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
5941 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
5944 void mp_delete_mac_ref (MP mp,pointer p) {
5945 /* |p| points to the reference count of a macro list that is
5946 losing one reference */
5947 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
5948 else decr(ref_count(p));
5951 @ The following subroutine displays a macro, given a pointer to its
5955 @<Declare the procedure called |print_cmd_mod|@>;
5956 void mp_show_macro (MP mp, pointer p, integer q, integer l) {
5957 pointer r; /* temporary storage */
5958 p=link(p); /* bypass the reference count */
5959 while ( info(p)>text_macro ){
5960 r=link(p); link(p)=null;
5961 mp_show_token_list(mp, p,null,l,0); link(p)=r; p=r;
5962 if ( l>0 ) l=l-mp->tally; else return;
5963 } /* control printing of `\.{ETC.}' */
5967 case general_macro:mp_print(mp, "->"); break;
5969 case primary_macro: case secondary_macro: case tertiary_macro:
5970 mp_print_char(mp, '<');
5971 mp_print_cmd_mod(mp, param_type,info(p));
5972 mp_print(mp, ">->");
5974 case expr_macro:mp_print(mp, "<expr>->"); break;
5975 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
5976 case suffix_macro:mp_print(mp, "<suffix>->"); break;
5977 case text_macro:mp_print(mp, "<text>->"); break;
5978 } /* there are no other cases */
5979 mp_show_token_list(mp, link(p),q,l-mp->tally,0);
5982 @* \[15] Data structures for variables.
5983 The variables of \MP\ programs can be simple, like `\.x', or they can
5984 combine the structural properties of arrays and records, like `\.{x20a.b}'.
5985 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
5986 example, `\.{boolean} \.{x20a.b}'. It's time for us to study how such
5987 things are represented inside of the computer.
5989 Each variable value occupies two consecutive words, either in a two-word
5990 node called a value node, or as a two-word subfield of a larger node. One
5991 of those two words is called the |value| field; it is an integer,
5992 containing either a |scaled| numeric value or the representation of some
5993 other type of quantity. (It might also be subdivided into halfwords, in
5994 which case it is referred to by other names instead of |value|.) The other
5995 word is broken into subfields called |type|, |name_type|, and |link|. The
5996 |type| field is a quarterword that specifies the variable's type, and
5997 |name_type| is a quarterword from which \MP\ can reconstruct the
5998 variable's name (sometimes by using the |link| field as well). Thus, only
5999 1.25 words are actually devoted to the value itself; the other
6000 three-quarters of a word are overhead, but they aren't wasted because they
6001 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6003 In this section we shall be concerned only with the structural aspects of
6004 variables, not their values. Later parts of the program will change the
6005 |type| and |value| fields, but we shall treat those fields as black boxes
6006 whose contents should not be touched.
6008 However, if the |type| field is |mp_structured|, there is no |value| field,
6009 and the second word is broken into two pointer fields called |attr_head|
6010 and |subscr_head|. Those fields point to additional nodes that
6011 contain structural information, as we shall see.
6013 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6014 @d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
6015 @d subscr_head(A) link(subscr_head_loc((A))) /* pointer to subscript info */
6016 @d value_node_size 2 /* the number of words in a value node */
6018 @ An attribute node is three words long. Two of these words contain |type|
6019 and |value| fields as described above, and the third word contains
6020 additional information: There is an |attr_loc| field, which contains the
6021 hash address of the token that names this attribute; and there's also a
6022 |parent| field, which points to the value node of |mp_structured| type at the
6023 next higher level (i.e., at the level to which this attribute is
6024 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6025 |link| field points to the next attribute with the same parent; these are
6026 arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
6027 final attribute node links to the constant |end_attr|, whose |attr_loc|
6028 field is greater than any legal hash address. The |attr_head| in the
6029 parent points to a node whose |name_type| is |mp_structured_root|; this
6030 node represents the null attribute, i.e., the variable that is relevant
6031 when no attributes are attached to the parent. The |attr_head| node is either
6032 a value node, a subscript node, or an attribute node, depending on what
6033 the parent would be if it were not structured; but the subscript and
6034 attribute fields are ignored, so it effectively contains only the data of
6035 a value node. The |link| field in this special node points to an attribute
6036 node whose |attr_loc| field is zero; the latter node represents a collective
6037 subscript `\.{[]}' attached to the parent, and its |link| field points to
6038 the first non-special attribute node (or to |end_attr| if there are none).
6040 A subscript node likewise occupies three words, with |type| and |value| fields
6041 plus extra information; its |name_type| is |subscr|. In this case the
6042 third word is called the |subscript| field, which is a |scaled| integer.
6043 The |link| field points to the subscript node with the next larger
6044 subscript, if any; otherwise the |link| points to the attribute node
6045 for collective subscripts at this level. We have seen that the latter node
6046 contains an upward pointer, so that the parent can be deduced.
6048 The |name_type| in a parent-less value node is |root|, and the |link|
6049 is the hash address of the token that names this value.
6051 In other words, variables have a hierarchical structure that includes
6052 enough threads running around so that the program is able to move easily
6053 between siblings, parents, and children. An example should be helpful:
6054 (The reader is advised to draw a picture while reading the following
6055 description, since that will help to firm up the ideas.)
6056 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6057 and `\.{x20b}' have been mentioned in a user's program, where
6058 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6059 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6060 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6061 node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=mp_structured|,
6062 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6063 node and |r| to a subscript node. (Are you still following this? Use
6064 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6065 |type(q)| and |value(q)|; furthermore
6066 |name_type(q)=mp_structured_root| and |link(q)=q1|, where |q1| points
6067 to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
6068 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6069 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6070 |qq| is a value node with |type(qq)=mp_numeric_type| (assuming that \.{x5} is
6071 numeric, because |qq| represents `\.{x[]}' with no further attributes),
6072 |name_type(qq)=mp_structured_root|, and
6073 |link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6074 an attribute node representing `\.{x[][]}', which has never yet
6075 occurred; its |type| field is |undefined|, and its |value| field is
6076 undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6077 |parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
6078 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6079 |parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
6080 (Maybe colored lines will help untangle your picture.)
6081 Node |r| is a subscript node with |type| and |value|
6082 representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
6083 and |link(r)=r1| is another subscript node. To complete the picture,
6084 see if you can guess what |link(r1)| is; give up? It's~|q1|.
6085 Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
6086 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6087 and we finish things off with three more nodes
6088 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6089 with a larger sheet of paper.) The value of variable \.{x20b}
6090 appears in node~|qqq2|, as you can well imagine.
6092 If the example in the previous paragraph doesn't make things crystal
6093 clear, a glance at some of the simpler subroutines below will reveal how
6094 things work out in practice.
6096 The only really unusual thing about these conventions is the use of
6097 collective subscript attributes. The idea is to avoid repeating a lot of
6098 type information when many elements of an array are identical macros
6099 (for which distinct values need not be stored) or when they don't have
6100 all of the possible attributes. Branches of the structure below collective
6101 subscript attributes do not carry actual values except for macro identifiers;
6102 branches of the structure below subscript nodes do not carry significant
6103 information in their collective subscript attributes.
6105 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6106 @d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
6107 @d parent(A) link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6108 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6109 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6110 @d attr_node_size 3 /* the number of words in an attribute node */
6111 @d subscr_node_size 3 /* the number of words in a subscript node */
6112 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6114 @<Initialize table...@>=
6115 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6117 @ Variables of type \&{pair} will have values that point to four-word
6118 nodes containing two numeric values. The first of these values has
6119 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6120 the |link| in the first points back to the node whose |value| points
6121 to this four-word node.
6123 Variables of type \&{transform} are similar, but in this case their
6124 |value| points to a 12-word node containing six values, identified by
6125 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6126 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6127 Finally, variables of type \&{color} have three values in six words
6128 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6130 When an entire structured variable is saved, the |root| indication
6131 is temporarily replaced by |saved_root|.
6133 Some variables have no name; they just are used for temporary storage
6134 while expressions are being evaluated. We call them {\sl capsules}.
6136 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6137 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6138 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6139 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6140 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6141 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6142 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6143 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6144 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6145 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6146 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6147 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6148 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6149 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6151 @d pair_node_size 4 /* the number of words in a pair node */
6152 @d transform_node_size 12 /* the number of words in a transform node */
6153 @d color_node_size 6 /* the number of words in a color node */
6154 @d cmykcolor_node_size 8 /* the number of words in a color node */
6157 small_number big_node_size[mp_pair_type+1];
6158 small_number sector0[mp_pair_type+1];
6159 small_number sector_offset[mp_black_part_sector+1];
6161 @ The |sector0| array gives for each big node type, |name_type| values
6162 for its first subfield; the |sector_offset| array gives for each
6163 |name_type| value, the offset from the first subfield in words;
6164 and the |big_node_size| array gives the size in words for each type of
6168 mp->big_node_size[mp_transform_type]=transform_node_size;
6169 mp->big_node_size[mp_pair_type]=pair_node_size;
6170 mp->big_node_size[mp_color_type]=color_node_size;
6171 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6172 mp->sector0[mp_transform_type]=mp_x_part_sector;
6173 mp->sector0[mp_pair_type]=mp_x_part_sector;
6174 mp->sector0[mp_color_type]=mp_red_part_sector;
6175 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6176 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6177 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6179 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6180 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6182 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6183 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6186 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6187 procedure call |init_big_node(p)| will allocate a pair or transform node
6188 for~|p|. The individual parts of such nodes are initially of type
6192 void mp_init_big_node (MP mp,pointer p) {
6193 pointer q; /* the new node */
6194 small_number s; /* its size */
6195 s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
6198 @<Make variable |q+s| newly independent@>;
6199 name_type(q+s)=halfp(s)+mp->sector0[type(p)];
6202 link(q)=p; value(p)=q;
6205 @ The |id_transform| function creates a capsule for the
6206 identity transformation.
6209 pointer mp_id_transform (MP mp) {
6210 pointer p,q,r; /* list manipulation registers */
6211 p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
6212 name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6213 r=q+transform_node_size;
6216 type(r)=mp_known; value(r)=0;
6218 value(xx_part_loc(q))=unity;
6219 value(yy_part_loc(q))=unity;
6223 @ Tokens are of type |tag_token| when they first appear, but they point
6224 to |null| until they are first used as the root of a variable.
6225 The following subroutine establishes the root node on such grand occasions.
6228 void mp_new_root (MP mp,pointer x) {
6229 pointer p; /* the new node */
6230 p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
6231 link(p)=x; equiv(x)=p;
6234 @ These conventions for variable representation are illustrated by the
6235 |print_variable_name| routine, which displays the full name of a
6236 variable given only a pointer to its two-word value packet.
6239 void mp_print_variable_name (MP mp, pointer p);
6242 void mp_print_variable_name (MP mp, pointer p) {
6243 pointer q; /* a token list that will name the variable's suffix */
6244 pointer r; /* temporary for token list creation */
6245 while ( name_type(p)>=mp_x_part_sector ) {
6246 @<Preface the output with a part specifier; |return| in the
6247 case of a capsule@>;
6250 while ( name_type(p)>mp_saved_root ) {
6251 @<Ascend one level, pushing a token onto list |q|
6252 and replacing |p| by its parent@>;
6254 r=mp_get_avail(mp); info(r)=link(p); link(r)=q;
6255 if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6257 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6258 mp_flush_token_list(mp, r);
6261 @ @<Ascend one level, pushing a token onto list |q|...@>=
6263 if ( name_type(p)==mp_subscr ) {
6264 r=mp_new_num_tok(mp, subscript(p));
6267 } while (name_type(p)!=mp_attr);
6268 } else if ( name_type(p)==mp_structured_root ) {
6269 p=link(p); goto FOUND;
6271 if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6272 @:this can't happen var}{\quad var@>
6273 r=mp_get_avail(mp); info(r)=attr_loc(p);
6280 @ @<Preface the output with a part specifier...@>=
6281 { switch (name_type(p)) {
6282 case mp_x_part_sector: mp_print_char(mp, 'x'); break;
6283 case mp_y_part_sector: mp_print_char(mp, 'y'); break;
6284 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6285 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6286 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6287 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6288 case mp_red_part_sector: mp_print(mp, "red"); break;
6289 case mp_green_part_sector: mp_print(mp, "green"); break;
6290 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6291 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6292 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6293 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6294 case mp_black_part_sector: mp_print(mp, "black"); break;
6295 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6297 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6300 } /* there are no other cases */
6301 mp_print(mp, "part ");
6302 p=link(p-mp->sector_offset[name_type(p)]);
6305 @ The |interesting| function returns |true| if a given variable is not
6306 in a capsule, or if the user wants to trace capsules.
6309 boolean mp_interesting (MP mp,pointer p) {
6310 small_number t; /* a |name_type| */
6311 if ( mp->internal[mp_tracing_capsules]>0 ) {
6315 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6316 t=name_type(link(p-mp->sector_offset[t]));
6317 return (t!=mp_capsule);
6321 @ Now here is a subroutine that converts an unstructured type into an
6322 equivalent structured type, by inserting a |mp_structured| node that is
6323 capable of growing. This operation is done only when |name_type(p)=root|,
6324 |subscr|, or |attr|.
6326 The procedure returns a pointer to the new node that has taken node~|p|'s
6327 place in the structure. Node~|p| itself does not move, nor are its
6328 |value| or |type| fields changed in any way.
6331 pointer mp_new_structure (MP mp,pointer p) {
6332 pointer q,r=0; /* list manipulation registers */
6333 switch (name_type(p)) {
6335 q=link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6338 @<Link a new subscript node |r| in place of node |p|@>;
6341 @<Link a new attribute node |r| in place of node |p|@>;
6344 mp_confusion(mp, "struct");
6345 @:this can't happen struct}{\quad struct@>
6348 link(r)=link(p); type(r)=mp_structured; name_type(r)=name_type(p);
6349 attr_head(r)=p; name_type(p)=mp_structured_root;
6350 q=mp_get_node(mp, attr_node_size); link(p)=q; subscr_head(r)=q;
6351 parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; link(q)=end_attr;
6352 attr_loc(q)=collective_subscript;
6356 @ @<Link a new subscript node |r| in place of node |p|@>=
6361 } while (name_type(q)!=mp_attr);
6362 q=parent(q); r=subscr_head_loc(q); /* |link(r)=subscr_head(q)| */
6366 r=mp_get_node(mp, subscr_node_size);
6367 link(q)=r; subscript(r)=subscript(p);
6370 @ If the attribute is |collective_subscript|, there are two pointers to
6371 node~|p|, so we must change both of them.
6373 @<Link a new attribute node |r| in place of node |p|@>=
6375 q=parent(p); r=attr_head(q);
6379 r=mp_get_node(mp, attr_node_size); link(q)=r;
6380 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6381 if ( attr_loc(p)==collective_subscript ) {
6382 q=subscr_head_loc(parent(p));
6383 while ( link(q)!=p ) q=link(q);
6388 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6389 list of suffixes; it returns a pointer to the corresponding two-word
6390 value. For example, if |t| points to token \.x followed by a numeric
6391 token containing the value~7, |find_variable| finds where the value of
6392 \.{x7} is stored in memory. This may seem a simple task, and it
6393 usually is, except when \.{x7} has never been referenced before.
6394 Indeed, \.x may never have even been subscripted before; complexities
6395 arise with respect to updating the collective subscript information.
6397 If a macro type is detected anywhere along path~|t|, or if the first
6398 item on |t| isn't a |tag_token|, the value |null| is returned.
6399 Otherwise |p| will be a non-null pointer to a node such that
6400 |undefined<type(p)<mp_structured|.
6402 @d abort_find { return null; }
6405 pointer mp_find_variable (MP mp,pointer t) {
6406 pointer p,q,r,s; /* nodes in the ``value'' line */
6407 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6408 integer n; /* subscript or attribute */
6409 memory_word save_word; /* temporary storage for a word of |mem| */
6411 p=info(t); t=link(t);
6412 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6413 if ( equiv(p)==null ) mp_new_root(mp, p);
6416 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6417 if ( t<mp->hi_mem_min ) {
6418 @<Descend one level for the subscript |value(t)|@>
6420 @<Descend one level for the attribute |info(t)|@>;
6424 if ( type(pp)>=mp_structured ) {
6425 if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6427 if ( type(p)==mp_structured ) p=attr_head(p);
6428 if ( type(p)==undefined ) {
6429 if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
6430 type(p)=type(pp); value(p)=null;
6435 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6436 |pp|~stays in the collective line while |p|~goes through actual subscript
6439 @<Make sure that both nodes |p| and |pp|...@>=
6440 if ( type(pp)!=mp_structured ) {
6441 if ( type(pp)>mp_structured ) abort_find;
6442 ss=mp_new_structure(mp, pp);
6445 }; /* now |type(pp)=mp_structured| */
6446 if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6447 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6449 @ We want this part of the program to be reasonably fast, in case there are
6451 lots of subscripts at the same level of the data structure. Therefore
6452 we store an ``infinite'' value in the word that appears at the end of the
6453 subscript list, even though that word isn't part of a subscript node.
6455 @<Descend one level for the subscript |value(t)|@>=
6458 pp=link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6459 q=link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6460 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |link(s)=subscr_head(p)| */
6463 } while (n>subscript(s));
6464 if ( n==subscript(s) ) {
6467 p=mp_get_node(mp, subscr_node_size); link(r)=p; link(p)=s;
6468 subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
6470 mp->mem[subscript_loc(q)]=save_word;
6473 @ @<Descend one level for the attribute |info(t)|@>=
6479 } while (n>attr_loc(ss));
6480 if ( n<attr_loc(ss) ) {
6481 qq=mp_get_node(mp, attr_node_size); link(rr)=qq; link(qq)=ss;
6482 attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
6483 parent(qq)=pp; ss=qq;
6488 pp=ss; s=attr_head(p);
6491 } while (n>attr_loc(s));
6492 if ( n==attr_loc(s) ) {
6495 q=mp_get_node(mp, attr_node_size); link(r)=q; link(q)=s;
6496 attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
6502 @ Variables lose their former values when they appear in a type declaration,
6503 or when they are defined to be macros or \&{let} equal to something else.
6504 A subroutine will be defined later that recycles the storage associated
6505 with any particular |type| or |value|; our goal now is to study a higher
6506 level process called |flush_variable|, which selectively frees parts of a
6509 This routine has some complexity because of examples such as
6510 `\hbox{\tt numeric x[]a[]b}'
6511 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6512 `\hbox{\tt vardef x[]a[]=...}'
6513 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6514 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6515 to handle such examples is to use recursion; so that's what we~do.
6518 Parameter |p| points to the root information of the variable;
6519 parameter |t| points to a list of one-word nodes that represent
6520 suffixes, with |info=collective_subscript| for subscripts.
6523 @<Declare subroutines for printing expressions@>
6524 @<Declare basic dependency-list subroutines@>
6525 @<Declare the recycling subroutines@>
6526 void mp_flush_cur_exp (MP mp,scaled v) ;
6527 @<Declare the procedure called |flush_below_variable|@>
6530 void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6531 pointer q,r; /* list manipulation */
6532 halfword n; /* attribute to match */
6534 if ( type(p)!=mp_structured ) return;
6535 n=info(t); t=link(t);
6536 if ( n==collective_subscript ) {
6537 r=subscr_head_loc(p); q=link(r); /* |q=subscr_head(p)| */
6538 while ( name_type(q)==mp_subscr ){
6539 mp_flush_variable(mp, q,t,discard_suffixes);
6541 if ( type(q)==mp_structured ) r=q;
6542 else { link(r)=link(q); mp_free_node(mp, q,subscr_node_size); }
6552 } while (attr_loc(p)<n);
6553 if ( attr_loc(p)!=n ) return;
6555 if ( discard_suffixes ) {
6556 mp_flush_below_variable(mp, p);
6558 if ( type(p)==mp_structured ) p=attr_head(p);
6559 mp_recycle_value(mp, p);
6563 @ The next procedure is simpler; it wipes out everything but |p| itself,
6564 which becomes undefined.
6566 @<Declare the procedure called |flush_below_variable|@>=
6567 void mp_flush_below_variable (MP mp, pointer p);
6570 void mp_flush_below_variable (MP mp,pointer p) {
6571 pointer q,r; /* list manipulation registers */
6572 if ( type(p)!=mp_structured ) {
6573 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6576 while ( name_type(q)==mp_subscr ) {
6577 mp_flush_below_variable(mp, q); r=q; q=link(q);
6578 mp_free_node(mp, r,subscr_node_size);
6580 r=attr_head(p); q=link(r); mp_recycle_value(mp, r);
6581 if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6582 else mp_free_node(mp, r,subscr_node_size);
6583 /* we assume that |subscr_node_size=attr_node_size| */
6585 mp_flush_below_variable(mp, q); r=q; q=link(q); mp_free_node(mp, r,attr_node_size);
6586 } while (q!=end_attr);
6591 @ Just before assigning a new value to a variable, we will recycle the
6592 old value and make the old value undefined. The |und_type| routine
6593 determines what type of undefined value should be given, based on
6594 the current type before recycling.
6597 small_number mp_und_type (MP mp,pointer p) {
6599 case undefined: case mp_vacuous:
6601 case mp_boolean_type: case mp_unknown_boolean:
6602 return mp_unknown_boolean;
6603 case mp_string_type: case mp_unknown_string:
6604 return mp_unknown_string;
6605 case mp_pen_type: case mp_unknown_pen:
6606 return mp_unknown_pen;
6607 case mp_path_type: case mp_unknown_path:
6608 return mp_unknown_path;
6609 case mp_picture_type: case mp_unknown_picture:
6610 return mp_unknown_picture;
6611 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6612 case mp_pair_type: case mp_numeric_type:
6614 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6615 return mp_numeric_type;
6616 } /* there are no other cases */
6620 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6621 of a symbolic token. It must remove any variable structure or macro
6622 definition that is currently attached to that symbol. If the |saving|
6623 parameter is true, a subsidiary structure is saved instead of destroyed.
6626 void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6627 pointer q; /* |equiv(p)| */
6629 switch (eq_type(p) % outer_tag) {
6631 case secondary_primary_macro:
6632 case tertiary_secondary_macro:
6633 case expression_tertiary_macro:
6634 if ( ! saving ) mp_delete_mac_ref(mp, q);
6639 name_type(q)=mp_saved_root;
6641 mp_flush_below_variable(mp, q); mp_free_node(mp,q,value_node_size);
6648 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6651 @* \[16] Saving and restoring equivalents.
6652 The nested structure given by \&{begingroup} and \&{endgroup}
6653 allows |eqtb| entries to be saved and restored, so that temporary changes
6654 can be made without difficulty. When the user requests a current value to
6655 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6656 \&{endgroup} ultimately causes the old values to be removed from the save
6657 stack and put back in their former places.
6659 The save stack is a linked list containing three kinds of entries,
6660 distinguished by their |info| fields. If |p| points to a saved item,
6664 |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6665 such an item to the save stack and each \&{endgroup} cuts back the stack
6666 until the most recent such entry has been removed.
6669 |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6670 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6671 commands or suitable \&{interim} commands.
6674 |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6675 integer to be restored to internal parameter number~|q|. Such entries
6676 are generated by \&{interim} commands.
6679 The global variable |save_ptr| points to the top item on the save stack.
6681 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6682 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6683 @d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
6684 link((A))=mp->save_ptr; mp->save_ptr=(A);
6688 pointer save_ptr; /* the most recently saved item */
6690 @ @<Set init...@>=mp->save_ptr=null;
6692 @ The |save_variable| routine is given a hash address |q|; it salts this
6693 address in the save stack, together with its current equivalent,
6694 then makes token~|q| behave as though it were brand new.
6696 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6697 things from the stack when the program is not inside a group, so there's
6698 no point in wasting the space.
6700 @c void mp_save_variable (MP mp,pointer q) {
6701 pointer p; /* temporary register */
6702 if ( mp->save_ptr!=null ){
6703 p=mp_get_node(mp, save_node_size); info(p)=q; link(p)=mp->save_ptr;
6704 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6706 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6709 @ Similarly, |save_internal| is given the location |q| of an internal
6710 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6713 @c void mp_save_internal (MP mp,halfword q) {
6714 pointer p; /* new item for the save stack */
6715 if ( mp->save_ptr!=null ){
6716 p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
6717 link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6721 @ At the end of a group, the |unsave| routine restores all of the saved
6722 equivalents in reverse order. This routine will be called only when there
6723 is at least one boundary item on the save stack.
6726 void mp_unsave (MP mp) {
6727 pointer q; /* index to saved item */
6728 pointer p; /* temporary register */
6729 while ( info(mp->save_ptr)!=0 ) {
6730 q=info(mp->save_ptr);
6732 if ( mp->internal[mp_tracing_restores]>0 ) {
6733 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6734 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, '=');
6735 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, '}');
6736 mp_end_diagnostic(mp, false);
6738 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6740 if ( mp->internal[mp_tracing_restores]>0 ) {
6741 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6742 mp_print_text(q); mp_print_char(mp, '}');
6743 mp_end_diagnostic(mp, false);
6745 mp_clear_symbol(mp, q,false);
6746 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6747 if ( eq_type(q) % outer_tag==tag_token ) {
6749 if ( p!=null ) name_type(p)=mp_root;
6752 p=link(mp->save_ptr);
6753 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6755 p=link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6758 @* \[17] Data structures for paths.
6759 When a \MP\ user specifies a path, \MP\ will create a list of knots
6760 and control points for the associated cubic spline curves. If the
6761 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6762 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6763 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6764 @:Bezier}{B\'ezier, Pierre Etienne@>
6765 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6766 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6769 There is a 8-word node for each knot $z_k$, containing one word of
6770 control information and six words for the |x| and |y| coordinates of
6771 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6772 |left_type| and |right_type| fields, which each occupy a quarter of
6773 the first word in the node; they specify properties of the curve as it
6774 enters and leaves the knot. There's also a halfword |link| field,
6775 which points to the following knot, and a final supplementary word (of
6776 which only a quarter is used).
6778 If the path is a closed contour, knots 0 and |n| are identical;
6779 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6780 is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
6781 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6782 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6784 @d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6785 @d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6786 @d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6787 @d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6788 @d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6789 @d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6790 @d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6791 @d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6792 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6793 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6794 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6795 @d left_coord(A) mp->mem[(A)+2].sc
6796 /* coordinate of previous control point given |x_loc| or |y_loc| */
6797 @d right_coord(A) mp->mem[(A)+4].sc
6798 /* coordinate of next control point given |x_loc| or |y_loc| */
6799 @d knot_node_size 8 /* number of words in a knot node */
6803 mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
6804 mp_explicit, /* |left_type| or |right_type| when control points are known */
6805 mp_given, /* |left_type| or |right_type| when a direction is given */
6806 mp_curl, /* |left_type| or |right_type| when a curl is desired */
6807 mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
6811 @ Before the B\'ezier control points have been calculated, the memory
6812 space they will ultimately occupy is taken up by information that can be
6813 used to compute them. There are four cases:
6816 \textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
6817 the knot in the same direction it entered; \MP\ will figure out a
6821 \textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
6822 knot in a direction depending on the angle at which it enters the next
6823 knot and on the curl parameter stored in |right_curl|.
6826 \textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
6827 knot in a nonzero direction stored as an |angle| in |right_given|.
6830 \textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
6831 point for leaving this knot has already been computed; it is in the
6832 |right_x| and |right_y| fields.
6835 The rules for |left_type| are similar, but they refer to the curve entering
6836 the knot, and to \\{left} fields instead of \\{right} fields.
6838 Non-|explicit| control points will be chosen based on ``tension'' parameters
6839 in the |left_tension| and |right_tension| fields. The
6840 `\&{atleast}' option is represented by negative tension values.
6841 @:at_least_}{\&{atleast} primitive@>
6843 For example, the \MP\ path specification
6844 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6846 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6848 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6849 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6850 |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
6852 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6853 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6854 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6855 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6856 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6857 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6858 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6859 Of course, this example is more complicated than anything a normal user
6862 These types must satisfy certain restrictions because of the form of \MP's
6864 (i)~|open| type never appears in the same node together with |endpoint|,
6866 (ii)~The |right_type| of a node is |explicit| if and only if the
6867 |left_type| of the following node is |explicit|.
6868 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6870 @d left_curl left_x /* curl information when entering this knot */
6871 @d left_given left_x /* given direction when entering this knot */
6872 @d left_tension left_y /* tension information when entering this knot */
6873 @d right_curl right_x /* curl information when leaving this knot */
6874 @d right_given right_x /* given direction when leaving this knot */
6875 @d right_tension right_y /* tension information when leaving this knot */
6877 @ Knots can be user-supplied, or they can be created by program code,
6878 like the |split_cubic| function, or |copy_path|. The distinction is
6879 needed for the cleanup routine that runs after |split_cubic|, because
6880 it should only delete knots it has previously inserted, and never
6881 anything that was user-supplied. In order to be able to differentiate
6882 one knot from another, we will set |originator(p):=mp_metapost_user| when
6883 it appeared in the actual metapost program, and
6884 |originator(p):=mp_program_code| in all other cases.
6886 @d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6890 mp_program_code=0, /* not created by a user */
6891 mp_metapost_user, /* created by a user */
6894 @ Here is a routine that prints a given knot list
6895 in symbolic form. It illustrates the conventions discussed above,
6896 and checks for anomalies that might arise while \MP\ is being debugged.
6898 @<Declare subroutines for printing expressions@>=
6899 void mp_pr_path (MP mp,pointer h);
6902 void mp_pr_path (MP mp,pointer h) {
6903 pointer p,q; /* for list traversal */
6907 if ( (p==null)||(q==null) ) {
6908 mp_print_nl(mp, "???"); return; /* this won't happen */
6911 @<Print information for adjacent knots |p| and |q|@>;
6914 if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
6915 @<Print two dots, followed by |given| or |curl| if present@>;
6918 if ( left_type(h)!=mp_endpoint )
6919 mp_print(mp, "cycle");
6922 @ @<Print information for adjacent knots...@>=
6923 mp_print_two(mp, x_coord(p),y_coord(p));
6924 switch (right_type(p)) {
6926 if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
6928 if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
6932 @<Print control points between |p| and |q|, then |goto done1|@>;
6935 @<Print information for a curve that begins |open|@>;
6939 @<Print information for a curve that begins |curl| or |given|@>;
6942 mp_print(mp, "???"); /* can't happen */
6946 if ( left_type(q)<=mp_explicit ) {
6947 mp_print(mp, "..control?"); /* can't happen */
6949 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
6950 @<Print tension between |p| and |q|@>;
6953 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
6954 were |scaled|, the magnitude of a |given| direction vector will be~4096.
6956 @<Print two dots...@>=
6958 mp_print_nl(mp, " ..");
6959 if ( left_type(p)==mp_given ) {
6960 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, '{');
6961 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
6962 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, '}');
6963 } else if ( left_type(p)==mp_curl ){
6964 mp_print(mp, "{curl ");
6965 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, '}');
6969 @ @<Print tension between |p| and |q|@>=
6971 mp_print(mp, "..tension ");
6972 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
6973 mp_print_scaled(mp, abs(right_tension(p)));
6974 if ( right_tension(p)!=left_tension(q) ){
6975 mp_print(mp, " and ");
6976 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
6977 mp_print_scaled(mp, abs(left_tension(q)));
6981 @ @<Print control points between |p| and |q|, then |goto done1|@>=
6983 mp_print(mp, "..controls ");
6984 mp_print_two(mp, right_x(p),right_y(p));
6985 mp_print(mp, " and ");
6986 if ( left_type(q)!=mp_explicit ) {
6987 mp_print(mp, "??"); /* can't happen */
6990 mp_print_two(mp, left_x(q),left_y(q));
6995 @ @<Print information for a curve that begins |open|@>=
6996 if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
6997 mp_print(mp, "{open?}"); /* can't happen */
7001 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7002 \MP's default curl is present.
7004 The code here uses the fact that |left_curl==left_given| and
7005 |right_curl==right_given|.
7007 @<Print information for a curve that begins |curl|...@>=
7009 if ( left_type(p)==mp_open )
7010 mp_print(mp, "??"); /* can't happen */
7012 if ( right_type(p)==mp_curl ) {
7013 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7015 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, '{');
7016 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7017 mp_print_scaled(mp, mp->n_sin);
7019 mp_print_char(mp, '}');
7022 @ It is convenient to have another version of |pr_path| that prints the path
7023 as a diagnostic message.
7025 @<Declare subroutines for printing expressions@>=
7026 void mp_print_path (MP mp,pointer h, char *s, boolean nuline) {
7027 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7030 mp_end_diagnostic(mp, true);
7033 @ If we want to duplicate a knot node, we can say |copy_knot|:
7036 pointer mp_copy_knot (MP mp,pointer p) {
7037 pointer q; /* the copy */
7038 int k; /* runs through the words of a knot node */
7039 q=mp_get_node(mp, knot_node_size);
7040 for (k=0;k<knot_node_size;k++) {
7041 mp->mem[q+k]=mp->mem[p+k];
7043 originator(q)=originator(p);
7047 @ The |copy_path| routine makes a clone of a given path.
7050 pointer mp_copy_path (MP mp, pointer p) {
7051 pointer q,pp,qq; /* for list manipulation */
7052 q=mp_copy_knot(mp, p);
7055 link(qq)=mp_copy_knot(mp, pp);
7063 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7064 returns a pointer to the first node of the copy, if the path is a cycle,
7065 but to the final node of a non-cyclic copy. The global
7066 variable |path_tail| will point to the final node of the original path;
7067 this trick makes it easier to implement `\&{doublepath}'.
7069 All node types are assumed to be |endpoint| or |explicit| only.
7072 pointer mp_htap_ypoc (MP mp,pointer p) {
7073 pointer q,pp,qq,rr; /* for list manipulation */
7074 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7077 right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
7078 x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
7079 right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
7080 left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
7081 originator(qq)=originator(pp);
7082 if ( link(pp)==p ) {
7083 link(q)=qq; mp->path_tail=pp; return q;
7085 rr=mp_get_node(mp, knot_node_size); link(rr)=qq; qq=rr; pp=link(pp);
7090 pointer path_tail; /* the node that links to the beginning of a path */
7092 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7093 calling the following subroutine.
7095 @<Declare the recycling subroutines@>=
7096 void mp_toss_knot_list (MP mp,pointer p) ;
7099 void mp_toss_knot_list (MP mp,pointer p) {
7100 pointer q; /* the node being freed */
7101 pointer r; /* the next node */
7105 mp_free_node(mp, q,knot_node_size); q=r;
7109 @* \[18] Choosing control points.
7110 Now we must actually delve into one of \MP's more difficult routines,
7111 the |make_choices| procedure that chooses angles and control points for
7112 the splines of a curve when the user has not specified them explicitly.
7113 The parameter to |make_choices| points to a list of knots and
7114 path information, as described above.
7116 A path decomposes into independent segments at ``breakpoint'' knots,
7117 which are knots whose left and right angles are both prespecified in
7118 some way (i.e., their |left_type| and |right_type| aren't both open).
7121 @<Declare the procedure called |solve_choices|@>;
7122 void mp_make_choices (MP mp,pointer knots) {
7123 pointer h; /* the first breakpoint */
7124 pointer p,q; /* consecutive breakpoints being processed */
7125 @<Other local variables for |make_choices|@>;
7126 check_arith; /* make sure that |arith_error=false| */
7127 if ( mp->internal[mp_tracing_choices]>0 )
7128 mp_print_path(mp, knots,", before choices",true);
7129 @<If consecutive knots are equal, join them explicitly@>;
7130 @<Find the first breakpoint, |h|, on the path;
7131 insert an artificial breakpoint if the path is an unbroken cycle@>;
7134 @<Fill in the control points between |p| and the next breakpoint,
7135 then advance |p| to that breakpoint@>;
7137 if ( mp->internal[mp_tracing_choices]>0 )
7138 mp_print_path(mp, knots,", after choices",true);
7139 if ( mp->arith_error ) {
7140 @<Report an unexpected problem during the choice-making@>;
7144 @ @<Report an unexpected problem during the choice...@>=
7146 print_err("Some number got too big");
7147 @.Some number got too big@>
7148 help2("The path that I just computed is out of range.")
7149 ("So it will probably look funny. Proceed, for a laugh.");
7150 mp_put_get_error(mp); mp->arith_error=false;
7153 @ Two knots in a row with the same coordinates will always be joined
7154 by an explicit ``curve'' whose control points are identical with the
7157 @<If consecutive knots are equal, join them explicitly@>=
7161 if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
7162 right_type(p)=mp_explicit;
7163 if ( left_type(p)==mp_open ) {
7164 left_type(p)=mp_curl; left_curl(p)=unity;
7166 left_type(q)=mp_explicit;
7167 if ( right_type(q)==mp_open ) {
7168 right_type(q)=mp_curl; right_curl(q)=unity;
7170 right_x(p)=x_coord(p); left_x(q)=x_coord(p);
7171 right_y(p)=y_coord(p); left_y(q)=y_coord(p);
7176 @ If there are no breakpoints, it is necessary to compute the direction
7177 angles around an entire cycle. In this case the |left_type| of the first
7178 node is temporarily changed to |end_cycle|.
7180 @<Find the first breakpoint, |h|, on the path...@>=
7183 if ( left_type(h)!=mp_open ) break;
7184 if ( right_type(h)!=mp_open ) break;
7187 left_type(h)=mp_end_cycle; break;
7191 @ If |right_type(p)<given| and |q=link(p)|, we must have
7192 |right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
7194 @<Fill in the control points between |p| and the next breakpoint...@>=
7196 if ( right_type(p)>=mp_given ) {
7197 while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=link(q);
7198 @<Fill in the control information between
7199 consecutive breakpoints |p| and |q|@>;
7200 } else if ( right_type(p)==mp_endpoint ) {
7201 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7205 @ This step makes it possible to transform an explicitly computed path without
7206 checking the |left_type| and |right_type| fields.
7208 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7210 right_x(p)=x_coord(p); right_y(p)=y_coord(p);
7211 left_x(q)=x_coord(q); left_y(q)=y_coord(q);
7214 @ Before we can go further into the way choices are made, we need to
7215 consider the underlying theory. The basic ideas implemented in |make_choices|
7216 are due to John Hobby, who introduced the notion of ``mock curvature''
7217 @^Hobby, John Douglas@>
7218 at a knot. Angles are chosen so that they preserve mock curvature when
7219 a knot is passed, and this has been found to produce excellent results.
7221 It is convenient to introduce some notations that simplify the necessary
7222 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7223 between knots |k| and |k+1|; and let
7224 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7225 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7226 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7227 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7228 $$\eqalign{z_k^+&=z_k+
7229 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7231 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7232 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7233 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7234 corresponding ``offset angles.'' These angles satisfy the condition
7235 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7236 whenever the curve leaves an intermediate knot~|k| in the direction that
7239 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7240 the curve at its beginning and ending points. This means that
7241 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7242 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7243 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7244 z\k^-,z\k^{\phantom+};t)$
7247 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7248 \qquad{\rm and}\qquad
7249 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7250 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7252 approximation to this true curvature that arises in the limit for
7253 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7254 The standard velocity function satisfies
7255 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7256 hence the mock curvatures are respectively
7257 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7258 \qquad{\rm and}\qquad
7259 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7261 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7262 determines $\phi_k$ when $\theta_k$ is known, so the task of
7263 angle selection is essentially to choose appropriate values for each
7264 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7265 from $(**)$, we obtain a system of linear equations of the form
7266 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7268 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7269 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7270 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7271 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7272 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7273 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7274 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7275 hence they have a unique solution. Moreover, in most cases the tensions
7276 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7277 solution numerically stable, and there is an exponential damping
7278 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7279 a factor of~$O(2^{-j})$.
7281 @ However, we still must consider the angles at the starting and ending
7282 knots of a non-cyclic path. These angles might be given explicitly, or
7283 they might be specified implicitly in terms of an amount of ``curl.''
7285 Let's assume that angles need to be determined for a non-cyclic path
7286 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7287 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7288 have been given for $0<k<n$, and it will be convenient to introduce
7289 equations of the same form for $k=0$ and $k=n$, where
7290 $$A_0=B_0=C_n=D_n=0.$$
7291 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7292 define $C_0=0$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7293 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7294 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7295 mock curvature at $z_1$; i.e.,
7296 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7297 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7298 This equation simplifies to
7299 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7300 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7301 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7302 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7303 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7304 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7305 hence the linear equations remain nonsingular.
7307 Similar considerations apply at the right end, when the final angle $\phi_n$
7308 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7309 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7311 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7312 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7313 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7315 When |make_choices| chooses angles, it must compute the coefficients of
7316 these linear equations, then solve the equations. To compute the coefficients,
7317 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7318 When the equations are solved, the chosen directions $\theta_k$ are put
7319 back into the form of control points by essentially computing sines and
7322 @ OK, we are ready to make the hard choices of |make_choices|.
7323 Most of the work is relegated to an auxiliary procedure
7324 called |solve_choices|, which has been introduced to keep
7325 |make_choices| from being extremely long.
7327 @<Fill in the control information between...@>=
7328 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7329 set $n$ to the length of the path@>;
7330 @<Remove |open| types at the breakpoints@>;
7331 mp_solve_choices(mp, p,q,n)
7333 @ It's convenient to precompute quantities that will be needed several
7334 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7335 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7336 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7337 and $z\k-z_k$ will be stored in |psi[k]|.
7340 int path_size; /* maximum number of knots between breakpoints of a path */
7343 scaled *delta; /* knot differences */
7344 angle *psi; /* turning angles */
7346 @ @<Allocate or initialize ...@>=
7352 @ @<Dealloc variables@>=
7358 @ @<Other local variables for |make_choices|@>=
7359 int k,n; /* current and final knot numbers */
7360 pointer s,t; /* registers for list traversal */
7361 scaled delx,dely; /* directions where |open| meets |explicit| */
7362 fraction sine,cosine; /* trig functions of various angles */
7364 @ @<Calculate the turning angles...@>=
7367 k=0; s=p; n=mp->path_size;
7370 mp->delta_x[k]=x_coord(t)-x_coord(s);
7371 mp->delta_y[k]=y_coord(t)-y_coord(s);
7372 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7374 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7375 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7376 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7377 mp_take_fraction(mp, mp->delta_y[k],sine),
7378 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7379 mp_take_fraction(mp, mp->delta_x[k],sine));
7382 if ( k==mp->path_size ) {
7383 mp_reallocate_paths(mp, mp->path_size+(mp->path_size>>2));
7384 goto RESTART; /* retry, loop size has changed */
7387 } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
7388 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7391 @ When we get to this point of the code, |right_type(p)| is either
7392 |given| or |curl| or |open|. If it is |open|, we must have
7393 |left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
7394 case, the |open| type is converted to |given|; however, if the
7395 velocity coming into this knot is zero, the |open| type is
7396 converted to a |curl|, since we don't know the incoming direction.
7398 Similarly, |left_type(q)| is either |given| or |curl| or |open| or
7399 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7401 @<Remove |open| types at the breakpoints@>=
7402 if ( left_type(q)==mp_open ) {
7403 delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
7404 if ( (delx==0)&&(dely==0) ) {
7405 left_type(q)=mp_curl; left_curl(q)=unity;
7407 left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7410 if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
7411 delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
7412 if ( (delx==0)&&(dely==0) ) {
7413 right_type(p)=mp_curl; right_curl(p)=unity;
7415 right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7419 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7420 and exactly one of the breakpoints involves a curl. The simplest case occurs
7421 when |n=1| and there is a curl at both breakpoints; then we simply draw
7424 But before coding up the simple cases, we might as well face the general case,
7425 since we must deal with it sooner or later, and since the general case
7426 is likely to give some insight into the way simple cases can be handled best.
7428 When there is no cycle, the linear equations to be solved form a tridiagonal
7429 system, and we can apply the standard technique of Gaussian elimination
7430 to convert that system to a sequence of equations of the form
7431 $$\theta_0+u_0\theta_1=v_0,\quad
7432 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7433 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7435 It is possible to do this diagonalization while generating the equations.
7436 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7437 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7439 The procedure is slightly more complex when there is a cycle, but the
7440 basic idea will be nearly the same. In the cyclic case the right-hand
7441 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7442 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7443 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7444 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7445 eliminate the $w$'s from the system, after which the solution can be
7448 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7449 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7450 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7451 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7454 angle *theta; /* values of $\theta_k$ */
7455 fraction *uu; /* values of $u_k$ */
7456 angle *vv; /* values of $v_k$ */
7457 fraction *ww; /* values of $w_k$ */
7459 @ @<Allocate or initialize ...@>=
7465 @ @<Dealloc variables@>=
7471 @ @<Declare |mp_reallocate| functions@>=
7472 void mp_reallocate_paths (MP mp, int l);
7475 void mp_reallocate_paths (MP mp, int l) {
7476 XREALLOC (mp->delta_x, l, scaled);
7477 XREALLOC (mp->delta_y, l, scaled);
7478 XREALLOC (mp->delta, l, scaled);
7479 XREALLOC (mp->psi, l, angle);
7480 XREALLOC (mp->theta, l, angle);
7481 XREALLOC (mp->uu, l, fraction);
7482 XREALLOC (mp->vv, l, angle);
7483 XREALLOC (mp->ww, l, fraction);
7487 @ Our immediate problem is to get the ball rolling by setting up the
7488 first equation or by realizing that no equations are needed, and to fit
7489 this initialization into a framework suitable for the overall computation.
7491 @<Declare the procedure called |solve_choices|@>=
7492 @<Declare subroutines needed by |solve_choices|@>;
7493 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7494 int k; /* current knot number */
7495 pointer r,s,t; /* registers for list traversal */
7496 @<Other local variables for |solve_choices|@>;
7501 @<Get the linear equations started; or |return|
7502 with the control points in place, if linear equations
7505 switch (left_type(s)) {
7506 case mp_end_cycle: case mp_open:
7507 @<Set up equation to match mock curvatures
7508 at $z_k$; then |goto found| with $\theta_n$
7509 adjusted to equal $\theta_0$, if a cycle has ended@>;
7512 @<Set up equation for a curl at $\theta_n$
7516 @<Calculate the given value of $\theta_n$
7519 } /* there are no other cases */
7524 @<Finish choosing angles and assigning control points@>;
7527 @ On the first time through the loop, we have |k=0| and |r| is not yet
7528 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7530 @<Get the linear equations started...@>=
7531 switch (right_type(s)) {
7533 if ( left_type(t)==mp_given ) {
7534 @<Reduce to simple case of two givens and |return|@>
7536 @<Set up the equation for a given value of $\theta_0$@>;
7540 if ( left_type(t)==mp_curl ) {
7541 @<Reduce to simple case of straight line and |return|@>
7543 @<Set up the equation for a curl at $\theta_0$@>;
7547 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7548 /* this begins a cycle */
7550 } /* there are no other cases */
7552 @ The general equation that specifies equality of mock curvature at $z_k$ is
7553 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7554 as derived above. We want to combine this with the already-derived equation
7555 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7557 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7559 $$(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}
7560 -A_kw_{k-1}\theta_0$$
7561 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7562 fixed-point arithmetic, avoiding the chance of overflow while retaining
7565 The calculations will be performed in several registers that
7566 provide temporary storage for intermediate quantities.
7568 @<Other local variables for |solve_choices|@>=
7569 fraction aa,bb,cc,ff,acc; /* temporary registers */
7570 scaled dd,ee; /* likewise, but |scaled| */
7571 scaled lt,rt; /* tension values */
7573 @ @<Set up equation to match mock curvatures...@>=
7574 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7575 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7576 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7577 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7578 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7579 @<Calculate the values of $v_k$ and $w_k$@>;
7580 if ( left_type(s)==mp_end_cycle ) {
7581 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7585 @ Since tension values are never less than 3/4, the values |aa| and
7586 |bb| computed here are never more than 4/5.
7588 @<Calculate the values $\\{aa}=...@>=
7589 if ( abs(right_tension(r))==unity) {
7590 aa=fraction_half; dd=2*mp->delta[k];
7592 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7593 dd=mp_take_fraction(mp, mp->delta[k],
7594 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7596 if ( abs(left_tension(t))==unity ){
7597 bb=fraction_half; ee=2*mp->delta[k-1];
7599 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7600 ee=mp_take_fraction(mp, mp->delta[k-1],
7601 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7603 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7605 @ The ratio to be calculated in this step can be written in the form
7606 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7607 \\{cc}\cdot\\{dd},$$
7608 because of the quantities just calculated. The values of |dd| and |ee|
7609 will not be needed after this step has been performed.
7611 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7612 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7613 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7615 ff=mp_make_fraction(mp, lt,rt);
7616 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7617 dd=mp_take_fraction(mp, dd,ff);
7619 ff=mp_make_fraction(mp, rt,lt);
7620 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7621 ee=mp_take_fraction(mp, ee,ff);
7624 ff=mp_make_fraction(mp, ee,ee+dd)
7626 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7627 equation was specified by a curl. In that case we must use a special
7628 method of computation to prevent overflow.
7630 Fortunately, the calculations turn out to be even simpler in this ``hard''
7631 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7632 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7634 @<Calculate the values of $v_k$ and $w_k$@>=
7635 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7636 if ( right_type(r)==mp_curl ) {
7638 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7640 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7641 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7642 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7643 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7644 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7645 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7646 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7649 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7650 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7651 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7652 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7655 The idea in the following code is to observe that
7656 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7657 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7658 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7659 so we can solve for $\theta_n=\theta_0$.
7661 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7663 aa=0; bb=fraction_one; /* we have |k=n| */
7666 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7667 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7668 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7669 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7670 mp->theta[n]=aa; mp->vv[0]=aa;
7671 for (k=1;k<=n-1;k++) {
7672 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7677 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7678 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7680 @<Calculate the given value of $\theta_n$...@>=
7682 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7683 reduce_angle(mp->theta[n]);
7687 @ @<Set up the equation for a given value of $\theta_0$@>=
7689 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7690 reduce_angle(mp->vv[0]);
7691 mp->uu[0]=0; mp->ww[0]=0;
7694 @ @<Set up the equation for a curl at $\theta_0$@>=
7695 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7696 if ( (rt==unity)&&(lt==unity) )
7697 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7699 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7700 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7703 @ @<Set up equation for a curl at $\theta_n$...@>=
7704 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7705 if ( (rt==unity)&&(lt==unity) )
7706 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7708 ff=mp_curl_ratio(mp, cc,lt,rt);
7709 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7710 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7714 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7715 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7716 a somewhat tedious program to calculate
7717 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7718 \alpha^3\gamma+(3-\beta)\beta^2},$$
7719 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7720 is necessary only if the curl and tension are both large.)
7721 The values of $\alpha$ and $\beta$ will be at most~4/3.
7723 @<Declare subroutines needed by |solve_choices|@>=
7724 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7726 fraction alpha,beta,num,denom,ff; /* registers */
7727 alpha=mp_make_fraction(mp, unity,a_tension);
7728 beta=mp_make_fraction(mp, unity,b_tension);
7729 if ( alpha<=beta ) {
7730 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7731 gamma=mp_take_fraction(mp, gamma,ff);
7732 beta=beta / 010000; /* convert |fraction| to |scaled| */
7733 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7734 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7736 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7737 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7738 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7739 /* $1365\approx 2^{12}/3$ */
7740 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7742 if ( num>=denom+denom+denom+denom ) return fraction_four;
7743 else return mp_make_fraction(mp, num,denom);
7746 @ We're in the home stretch now.
7748 @<Finish choosing angles and assigning control points@>=
7749 for (k=n-1;k>=0;k--) {
7750 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7755 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7756 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7757 mp_set_controls(mp, s,t,k);
7761 @ The |set_controls| routine actually puts the control points into
7762 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7763 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7764 $\cos\phi$ needed in this calculation.
7770 fraction cf; /* sines and cosines */
7772 @ @<Declare subroutines needed by |solve_choices|@>=
7773 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7774 fraction rr,ss; /* velocities, divided by thrice the tension */
7775 scaled lt,rt; /* tensions */
7776 fraction sine; /* $\sin(\theta+\phi)$ */
7777 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7778 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7779 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7780 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7781 @<Decrease the velocities,
7782 if necessary, to stay inside the bounding triangle@>;
7784 right_x(p)=x_coord(p)+mp_take_fraction(mp,
7785 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7786 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7787 right_y(p)=y_coord(p)+mp_take_fraction(mp,
7788 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7789 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7790 left_x(q)=x_coord(q)-mp_take_fraction(mp,
7791 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7792 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7793 left_y(q)=y_coord(q)-mp_take_fraction(mp,
7794 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7795 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7796 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7799 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7800 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7801 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7802 there is no ``bounding triangle.''
7803 @:at_least_}{\&{atleast} primitive@>
7805 @<Decrease the velocities, if necessary...@>=
7806 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7807 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7808 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7810 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7811 if ( right_tension(p)<0 )
7812 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7813 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7814 if ( left_tension(q)<0 )
7815 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7816 ss=mp_make_fraction(mp, abs(mp->st),sine);
7820 @ Only the simple cases remain to be handled.
7822 @<Reduce to simple case of two givens and |return|@>=
7824 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7825 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7826 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7827 mp_set_controls(mp, p,q,0); return;
7830 @ @<Reduce to simple case of straight line and |return|@>=
7832 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7833 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7835 if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
7836 else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
7837 if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
7838 else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
7840 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7841 right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7842 right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7845 if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
7846 else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
7847 if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
7848 else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
7850 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7851 left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7852 left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7857 @* \[19] Measuring paths.
7858 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7859 allow the user to measure the bounding box of anything that can go into a
7860 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7861 by just finding the bounding box of the knots and the control points. We
7862 need a more accurate version of the bounding box, but we can still use the
7863 easy estimate to save time by focusing on the interesting parts of the path.
7865 @ Computing an accurate bounding box involves a theme that will come up again
7866 and again. Given a Bernshte{\u\i}n polynomial
7867 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
7868 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
7869 we can conveniently bisect its range as follows:
7872 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
7875 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
7876 |0<=k<n-j|, for |0<=j<n|.
7880 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
7881 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
7882 This formula gives us the coefficients of polynomials to use over the ranges
7883 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
7885 @ Now here's a subroutine that's handy for all sorts of path computations:
7886 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
7887 returns the unique |fraction| value |t| between 0 and~1 at which
7888 $B(a,b,c;t)$ changes from positive to negative, or returns
7889 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
7890 is already negative at |t=0|), |crossing_point| returns the value zero.
7892 @d no_crossing { return (fraction_one+1); }
7893 @d one_crossing { return fraction_one; }
7894 @d zero_crossing { return 0; }
7895 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
7897 @c fraction mp_do_crossing_point (integer a, integer b, integer c) {
7898 integer d; /* recursive counter */
7899 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
7900 if ( a<0 ) zero_crossing;
7903 if ( c>0 ) { no_crossing; }
7904 else if ( (a==0)&&(b==0) ) { no_crossing;}
7905 else { one_crossing; }
7907 if ( a==0 ) zero_crossing;
7908 } else if ( a==0 ) {
7909 if ( b<=0 ) zero_crossing;
7911 @<Use bisection to find the crossing point, if one exists@>;
7914 @ The general bisection method is quite simple when $n=2$, hence
7915 |crossing_point| does not take much time. At each stage in the
7916 recursion we have a subinterval defined by |l| and~|j| such that
7917 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
7918 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
7920 It is convenient for purposes of calculation to combine the values
7921 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
7922 of bisection then corresponds simply to doubling $d$ and possibly
7923 adding~1. Furthermore it proves to be convenient to modify
7924 our previous conventions for bisection slightly, maintaining the
7925 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
7926 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
7927 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
7929 The following code maintains the invariant relations
7930 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
7931 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
7932 it has been constructed in such a way that no arithmetic overflow
7933 will occur if the inputs satisfy
7934 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
7936 @<Use bisection to find the crossing point...@>=
7937 d=1; x0=a; x1=a-b; x2=b-c;
7948 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
7952 } while (d<fraction_one);
7953 return (d-fraction_one)
7955 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
7956 a cubic corresponding to the |fraction| value~|t|.
7958 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
7959 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
7961 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
7963 @c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
7964 scaled x1,x2,x3; /* intermediate values */
7965 x1=t_of_the_way(knot_coord(p),right_coord(p));
7966 x2=t_of_the_way(right_coord(p),left_coord(q));
7967 x3=t_of_the_way(left_coord(q),knot_coord(q));
7968 x1=t_of_the_way(x1,x2);
7969 x2=t_of_the_way(x2,x3);
7970 return t_of_the_way(x1,x2);
7973 @ The actual bounding box information is stored in global variables.
7974 Since it is convenient to address the $x$ and $y$ information
7975 separately, we define arrays indexed by |x_code..y_code| and use
7976 macros to give them more convenient names.
7980 mp_x_code=0, /* index for |minx| and |maxx| */
7981 mp_y_code /* index for |miny| and |maxy| */
7985 @d minx mp->bbmin[mp_x_code]
7986 @d maxx mp->bbmax[mp_x_code]
7987 @d miny mp->bbmin[mp_y_code]
7988 @d maxy mp->bbmax[mp_y_code]
7991 scaled bbmin[mp_y_code+1];
7992 scaled bbmax[mp_y_code+1];
7993 /* the result of procedures that compute bounding box information */
7995 @ Now we're ready for the key part of the bounding box computation.
7996 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
7997 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
7998 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8000 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8001 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8002 The |c| parameter is |x_code| or |y_code|.
8004 @c void mp_bound_cubic (MP mp,pointer p, pointer q, small_number c) {
8005 boolean wavy; /* whether we need to look for extremes */
8006 scaled del1,del2,del3,del,dmax; /* proportional to the control
8007 points of a quadratic derived from a cubic */
8008 fraction t,tt; /* where a quadratic crosses zero */
8009 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8011 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8012 @<Check the control points against the bounding box and set |wavy:=true|
8013 if any of them lie outside@>;
8015 del1=right_coord(p)-knot_coord(p);
8016 del2=left_coord(q)-right_coord(p);
8017 del3=knot_coord(q)-left_coord(q);
8018 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8019 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8021 negate(del1); negate(del2); negate(del3);
8023 t=mp_crossing_point(mp, del1,del2,del3);
8024 if ( t<fraction_one ) {
8025 @<Test the extremes of the cubic against the bounding box@>;
8030 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8031 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8032 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8034 @ @<Check the control points against the bounding box and set...@>=
8036 if ( mp->bbmin[c]<=right_coord(p) )
8037 if ( right_coord(p)<=mp->bbmax[c] )
8038 if ( mp->bbmin[c]<=left_coord(q) )
8039 if ( left_coord(q)<=mp->bbmax[c] )
8042 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8043 section. We just set |del=0| in that case.
8045 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8046 if ( del1!=0 ) del=del1;
8047 else if ( del2!=0 ) del=del2;
8051 if ( abs(del2)>dmax ) dmax=abs(del2);
8052 if ( abs(del3)>dmax ) dmax=abs(del3);
8053 while ( dmax<fraction_half ) {
8054 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8058 @ Since |crossing_point| has tried to choose |t| so that
8059 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8060 slope, the value of |del2| computed below should not be positive.
8061 But rounding error could make it slightly positive in which case we
8062 must cut it to zero to avoid confusion.
8064 @<Test the extremes of the cubic against the bounding box@>=
8066 x=mp_eval_cubic(mp, p,q,t);
8067 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8068 del2=t_of_the_way(del2,del3);
8069 /* now |0,del2,del3| represent the derivative on the remaining interval */
8070 if ( del2>0 ) del2=0;
8071 tt=mp_crossing_point(mp, 0,-del2,-del3);
8072 if ( tt<fraction_one ) {
8073 @<Test the second extreme against the bounding box@>;
8077 @ @<Test the second extreme against the bounding box@>=
8079 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8080 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8083 @ Finding the bounding box of a path is basically a matter of applying
8084 |bound_cubic| twice for each pair of adjacent knots.
8086 @c void mp_path_bbox (MP mp,pointer h) {
8087 pointer p,q; /* a pair of adjacent knots */
8088 minx=x_coord(h); miny=y_coord(h);
8089 maxx=minx; maxy=miny;
8092 if ( right_type(p)==mp_endpoint ) return;
8094 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8095 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8100 @ Another important way to measure a path is to find its arc length. This
8101 is best done by using the general bisection algorithm to subdivide the path
8102 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8105 Since the arc length is the integral with respect to time of the magnitude of
8106 the velocity, it is natural to use Simpson's rule for the approximation.
8108 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8109 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8110 for the arc length of a path of length~1. For a cubic spline
8111 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8112 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8114 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8116 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8117 is the result of the bisection algorithm.
8119 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8120 This could be done via the theoretical error bound for Simpson's rule,
8122 but this is impractical because it requires an estimate of the fourth
8123 derivative of the quantity being integrated. It is much easier to just perform
8124 a bisection step and see how much the arc length estimate changes. Since the
8125 error for Simpson's rule is proportional to the fourth power of the sample
8126 spacing, the remaining error is typically about $1\over16$ of the amount of
8127 the change. We say ``typically'' because the error has a pseudo-random behavior
8128 that could cause the two estimates to agree when each contain large errors.
8130 To protect against disasters such as undetected cusps, the bisection process
8131 should always continue until all the $dz_i$ vectors belong to a single
8132 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8133 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8134 If such a spline happens to produce an erroneous arc length estimate that
8135 is little changed by bisection, the amount of the error is likely to be fairly
8136 small. We will try to arrange things so that freak accidents of this type do
8137 not destroy the inverse relationship between the \&{arclength} and
8138 \&{arctime} operations.
8139 @:arclength_}{\&{arclength} primitive@>
8140 @:arctime_}{\&{arctime} primitive@>
8142 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8144 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8145 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8146 returns the time when the arc length reaches |a_goal| if there is such a time.
8147 Thus the return value is either an arc length less than |a_goal| or, if the
8148 arc length would be at least |a_goal|, it returns a time value decreased by
8149 |two|. This allows the caller to use the sign of the result to distinguish
8150 between arc lengths and time values. On certain types of overflow, it is
8151 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8152 Otherwise, the result is always less than |a_goal|.
8154 Rather than halving the control point coordinates on each recursive call to
8155 |arc_test|, it is better to keep them proportional to velocity on the original
8156 curve and halve the results instead. This means that recursive calls can
8157 potentially use larger error tolerances in their arc length estimates. How
8158 much larger depends on to what extent the errors behave as though they are
8159 independent of each other. To save computing time, we use optimistic assumptions
8160 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8163 In addition to the tolerance parameter, |arc_test| should also have parameters
8164 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8165 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8166 and they are needed in different instances of |arc_test|.
8168 @c @t\4@>@<Declare subroutines needed by |arc_test|@>;
8169 scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8170 scaled dx2, scaled dy2, scaled v0, scaled v02,
8171 scaled v2, scaled a_goal, scaled tol) {
8172 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8173 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8175 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8176 scaled arc; /* best arc length estimate before recursion */
8177 @<Other local variables in |arc_test|@>;
8178 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8180 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8181 set |arc_test| and |return|@>;
8182 @<Test if the control points are confined to one quadrant or rotating them
8183 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8184 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8185 if ( arc < a_goal ) {
8188 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8189 that time minus |two|@>;
8192 @<Use one or two recursive calls to compute the |arc_test| function@>;
8196 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8197 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8198 |make_fraction| in this inner loop.
8201 @<Use one or two recursive calls to compute the |arc_test| function@>=
8203 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8204 large as possible@>;
8205 tol = tol + halfp(tol);
8206 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8207 halfp(v02), a_new, tol);
8209 return (-halfp(two-a));
8211 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8212 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8213 halfp(v02), v022, v2, a_new, tol);
8215 return (-halfp(-b) - half_unit);
8217 return (a + half(b-a));
8221 @ @<Other local variables in |arc_test|@>=
8222 scaled a,b; /* results of recursive calls */
8223 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8225 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8226 a_aux = el_gordo - a_goal;
8227 if ( a_goal > a_aux ) {
8228 a_aux = a_goal - a_aux;
8231 a_new = a_goal + a_goal;
8235 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8236 to force the additions and subtractions to be done in an order that avoids
8239 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8242 a_new = a_new + a_aux;
8245 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8246 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8247 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8248 this bound. Note that recursive calls will maintain this invariant.
8250 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8251 dx01 = half(dx0 + dx1);
8252 dx12 = half(dx1 + dx2);
8253 dx02 = half(dx01 + dx12);
8254 dy01 = half(dy0 + dy1);
8255 dy12 = half(dy1 + dy2);
8256 dy02 = half(dy01 + dy12)
8258 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8259 |a_goal=el_gordo| is guaranteed to yield the arc length.
8261 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8262 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8263 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8265 arc1 = v002 + half(halfp(v0+tmp) - v002);
8266 arc = v022 + half(halfp(v2+tmp) - v022);
8267 if ( (arc < el_gordo-arc1) ) {
8270 mp->arith_error = true;
8271 if ( a_goal==el_gordo ) return (el_gordo);
8275 @ @<Other local variables in |arc_test|@>=
8276 scaled tmp, tmp2; /* all purpose temporary registers */
8277 scaled arc1; /* arc length estimate for the first half */
8279 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8280 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8281 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8283 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8284 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8286 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8287 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8289 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8290 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8293 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8295 it is appropriate to use the same approximation to decide when the integral
8296 reaches the intermediate value |a_goal|. At this point
8298 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8299 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8300 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8301 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8302 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8306 $$ {\vb\dot B(t)\vb\over 3} \approx
8307 \cases{B\left(\hbox{|v0|},
8308 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8309 {1\over 2}\hbox{|v02|}; 2t \right)&
8310 if $t\le{1\over 2}$\cr
8311 B\left({1\over 2}\hbox{|v02|},
8312 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8313 \hbox{|v2|}; 2t-1 \right)&
8314 if $t\ge{1\over 2}$.\cr}
8317 We can integrate $\vb\dot B(t)\vb$ by using
8318 $$\int 3B(a,b,c;\tau)\,dt =
8319 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8322 This construction allows us to find the time when the arc length reaches
8323 |a_goal| by solving a cubic equation of the form
8324 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8325 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8326 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8327 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8328 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8329 $\tau$ given $a$, $b$, $c$, and $x$.
8331 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8333 tmp = (v02 + 2) / 4;
8334 if ( a_goal<=arc1 ) {
8337 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8340 return ((half_unit - two) +
8341 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8345 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8346 $$ B(0, a, a+b, a+b+c; t) = x. $$
8347 This routine is based on |crossing_point| but is simplified by the
8348 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8349 If rounding error causes this condition to be violated slightly, we just ignore
8350 it and proceed with binary search. This finds a time when the function value
8351 reaches |x| and the slope is positive.
8353 @<Declare subroutines needed by |arc_test|@>=
8354 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8355 scaled ab, bc, ac; /* bisection results */
8356 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8357 integer xx; /* temporary for updating |x| */
8358 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8359 @:this can't happen rising?}{\quad rising?@>
8362 } else if ( x >= a+b+c ) {
8366 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8370 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8371 xx = x - a - ab - ac;
8372 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8373 else { x = x + xx; a=ac; b=mp->bc; t = t+1; };
8374 } while (t < unity);
8379 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8384 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8386 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8387 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8394 @ It is convenient to have a simpler interface to |arc_test| that requires no
8395 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8396 length less than |fraction_four|.
8398 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8400 @c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8401 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8402 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8403 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8404 v0 = mp_pyth_add(mp, dx0,dy0);
8405 v1 = mp_pyth_add(mp, dx1,dy1);
8406 v2 = mp_pyth_add(mp, dx2,dy2);
8407 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8408 mp->arith_error = true;
8409 if ( a_goal==el_gordo ) return el_gordo;
8412 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8413 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8414 v0, v02, v2, a_goal, arc_tol));
8418 @ Now it is easy to find the arc length of an entire path.
8420 @c scaled mp_get_arc_length (MP mp,pointer h) {
8421 pointer p,q; /* for traversing the path */
8422 scaled a,a_tot; /* current and total arc lengths */
8425 while ( right_type(p)!=mp_endpoint ){
8427 a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8428 left_x(q)-right_x(p), left_y(q)-right_y(p),
8429 x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
8430 a_tot = mp_slow_add(mp, a, a_tot);
8431 if ( q==h ) break; else p=q;
8437 @ The inverse operation of finding the time on a path~|h| when the arc length
8438 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8439 is required to handle very large times or negative times on cyclic paths. For
8440 non-cyclic paths, |arc0| values that are negative or too large cause
8441 |get_arc_time| to return 0 or the length of path~|h|.
8443 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8444 time value greater than the length of the path. Since it could be much greater,
8445 we must be prepared to compute the arc length of path~|h| and divide this into
8446 |arc0| to find how many multiples of the length of path~|h| to add.
8448 @c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8449 pointer p,q; /* for traversing the path */
8450 scaled t_tot; /* accumulator for the result */
8451 scaled t; /* the result of |do_arc_test| */
8452 scaled arc; /* portion of |arc0| not used up so far */
8453 integer n; /* number of extra times to go around the cycle */
8455 @<Deal with a negative |arc0| value and |return|@>;
8457 if ( arc0==el_gordo ) decr(arc0);
8461 while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
8463 t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8464 left_x(q)-right_x(p), left_y(q)-right_y(p),
8465 x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
8466 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8468 @<Update |t_tot| and |arc| to avoid going around the cyclic
8469 path too many times but set |arith_error:=true| and |goto done| on
8478 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8479 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8480 else { t_tot = t_tot + unity; arc = arc - t; }
8482 @ @<Deal with a negative |arc0| value and |return|@>=
8484 if ( left_type(h)==mp_endpoint ) {
8487 p = mp_htap_ypoc(mp, h);
8488 t_tot = -mp_get_arc_time(mp, p, -arc0);
8489 mp_toss_knot_list(mp, p);
8495 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8497 n = arc / (arc0 - arc);
8498 arc = arc - n*(arc0 - arc);
8499 if ( t_tot > el_gordo / (n+1) ) {
8500 mp->arith_error = true;
8504 t_tot = (n + 1)*t_tot;
8507 @* \[20] Data structures for pens.
8508 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8509 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8510 @:stroke}{\&{stroke} command@>
8511 converted into an area fill as described in the next part of this program.
8512 The mathematics behind this process is based on simple aspects of the theory
8513 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8514 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8515 Foundations of Computer Science {\bf 24} (1983), 100--111].
8517 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8518 @:makepen_}{\&{makepen} primitive@>
8519 This path representation is almost sufficient for our purposes except that
8520 a pen path should always be a convex polygon with the vertices in
8521 counter-clockwise order.
8522 Since we will need to scan pen polygons both forward and backward, a pen
8523 should be represented as a doubly linked ring of knot nodes. There is
8524 room for the extra back pointer because we do not need the
8525 |left_type| or |right_type| fields. In fact, we don't need the |left_x|,
8526 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
8527 so that certain procedures can operate on both pens and paths. In particular,
8528 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8531 /* this replaces the |left_type| and |right_type| fields in a pen knot */
8533 @ The |make_pen| procedure turns a path into a pen by initializing
8534 the |knil| pointers and making sure the knots form a convex polygon.
8535 Thus each cubic in the given path becomes a straight line and the control
8536 points are ignored. If the path is not cyclic, the ends are connected by a
8539 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8541 @c @<Declare a function called |convex_hull|@>;
8542 pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8543 pointer p,q; /* two consecutive knots */
8550 h=mp_convex_hull(mp, h);
8551 @<Make sure |h| isn't confused with an elliptical pen@>;
8556 @ The only information required about an elliptical pen is the overall
8557 transformation that has been applied to the original \&{pencircle}.
8558 @:pencircle_}{\&{pencircle} primitive@>
8559 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8560 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8561 knot node and transformed as if it were a path.
8563 @d pen_is_elliptical(A) ((A)==link((A)))
8565 @c pointer mp_get_pen_circle (MP mp,scaled diam) {
8566 pointer h; /* the knot node to return */
8567 h=mp_get_node(mp, knot_node_size);
8568 link(h)=h; knil(h)=h;
8569 originator(h)=mp_program_code;
8570 x_coord(h)=0; y_coord(h)=0;
8571 left_x(h)=diam; left_y(h)=0;
8572 right_x(h)=0; right_y(h)=diam;
8576 @ If the polygon being returned by |make_pen| has only one vertex, it will
8577 be interpreted as an elliptical pen. This is no problem since a degenerate
8578 polygon can equally well be thought of as a degenerate ellipse. We need only
8579 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
8581 @<Make sure |h| isn't confused with an elliptical pen@>=
8582 if ( pen_is_elliptical( h) ){
8583 left_x(h)=x_coord(h); left_y(h)=y_coord(h);
8584 right_x(h)=x_coord(h); right_y(h)=y_coord(h);
8587 @ We have to cheat a little here but most operations on pens only use
8588 the first three words in each knot node.
8589 @^data structure assumptions@>
8591 @<Initialize a pen at |test_pen| so that it fits in nine words@>=
8592 x_coord(test_pen)=-half_unit;
8593 y_coord(test_pen)=0;
8594 x_coord(test_pen+3)=half_unit;
8595 y_coord(test_pen+3)=0;
8596 x_coord(test_pen+6)=0;
8597 y_coord(test_pen+6)=unity;
8598 link(test_pen)=test_pen+3;
8599 link(test_pen+3)=test_pen+6;
8600 link(test_pen+6)=test_pen;
8601 knil(test_pen)=test_pen+6;
8602 knil(test_pen+3)=test_pen;
8603 knil(test_pen+6)=test_pen+3
8605 @ Printing a polygonal pen is very much like printing a path
8607 @<Declare subroutines for printing expressions@>=
8608 void mp_pr_pen (MP mp,pointer h) {
8609 pointer p,q; /* for list traversal */
8610 if ( pen_is_elliptical(h) ) {
8611 @<Print the elliptical pen |h|@>;
8615 mp_print_two(mp, x_coord(p),y_coord(p));
8616 mp_print_nl(mp, " .. ");
8617 @<Advance |p| making sure the links are OK and |return| if there is
8620 mp_print(mp, "cycle");
8624 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8626 if ( (q==null) || (knil(q)!=p) ) {
8627 mp_print_nl(mp, "???"); return; /* this won't happen */
8632 @ @<Print the elliptical pen |h|@>=
8634 mp_print(mp, "pencircle transformed (");
8635 mp_print_scaled(mp, x_coord(h));
8636 mp_print_char(mp, ',');
8637 mp_print_scaled(mp, y_coord(h));
8638 mp_print_char(mp, ',');
8639 mp_print_scaled(mp, left_x(h)-x_coord(h));
8640 mp_print_char(mp, ',');
8641 mp_print_scaled(mp, right_x(h)-x_coord(h));
8642 mp_print_char(mp, ',');
8643 mp_print_scaled(mp, left_y(h)-y_coord(h));
8644 mp_print_char(mp, ',');
8645 mp_print_scaled(mp, right_y(h)-y_coord(h));
8646 mp_print_char(mp, ')');
8649 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8652 @<Declare subroutines for printing expressions@>=
8653 void mp_print_pen (MP mp,pointer h, char *s, boolean nuline) {
8654 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8657 mp_end_diagnostic(mp, true);
8660 @ Making a polygonal pen into a path involves restoring the |left_type| and
8661 |right_type| fields and setting the control points so as to make a polygonal
8665 void mp_make_path (MP mp,pointer h) {
8666 pointer p; /* for traversing the knot list */
8667 small_number k; /* a loop counter */
8668 @<Other local variables in |make_path|@>;
8669 if ( pen_is_elliptical(h) ) {
8670 @<Make the elliptical pen |h| into a path@>;
8674 left_type(p)=mp_explicit;
8675 right_type(p)=mp_explicit;
8676 @<copy the coordinates of knot |p| into its control points@>;
8682 @ @<copy the coordinates of knot |p| into its control points@>=
8683 left_x(p)=x_coord(p);
8684 left_y(p)=y_coord(p);
8685 right_x(p)=x_coord(p);
8686 right_y(p)=y_coord(p)
8688 @ We need an eight knot path to get a good approximation to an ellipse.
8690 @<Make the elliptical pen |h| into a path@>=
8692 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8694 for (k=0;k<=7;k++ ) {
8695 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8696 transforming it appropriately@>;
8697 if ( k==7 ) link(p)=h; else link(p)=mp_get_node(mp, knot_node_size);
8702 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8703 center_x=x_coord(h);
8704 center_y=y_coord(h);
8705 width_x=left_x(h)-center_x;
8706 width_y=left_y(h)-center_y;
8707 height_x=right_x(h)-center_x;
8708 height_y=right_y(h)-center_y
8710 @ @<Other local variables in |make_path|@>=
8711 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8712 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8713 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8714 scaled dx,dy; /* the vector from knot |p| to its right control point */
8716 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8718 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8719 find the point $k/8$ of the way around the circle and the direction vector
8722 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8724 x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8725 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8726 y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8727 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8728 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8729 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8730 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8731 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8732 right_x(p)=x_coord(p)+dx;
8733 right_y(p)=y_coord(p)+dy;
8734 left_x(p)=x_coord(p)-dx;
8735 left_y(p)=y_coord(p)-dy;
8736 left_type(p)=mp_explicit;
8737 right_type(p)=mp_explicit;
8738 originator(p)=mp_program_code
8741 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8742 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8744 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8745 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8746 function for $\theta=\phi=22.5^\circ$. This comes out to be
8747 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8748 \approx 0.132608244919772.
8752 mp->half_cos[0]=fraction_half;
8753 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8755 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8756 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8758 for (k=3;k<= 4;k++ ) {
8759 mp->half_cos[k]=-mp->half_cos[4-k];
8760 mp->d_cos[k]=-mp->d_cos[4-k];
8762 for (k=5;k<= 7;k++ ) {
8763 mp->half_cos[k]=mp->half_cos[8-k];
8764 mp->d_cos[k]=mp->d_cos[8-k];
8767 @ The |convex_hull| function forces a pen polygon to be convex when it is
8768 returned by |make_pen| and after any subsequent transformation where rounding
8769 error might allow the convexity to be lost.
8770 The convex hull algorithm used here is described by F.~P. Preparata and
8771 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8773 @<Declare a function called |convex_hull|@>=
8774 @<Declare a procedure called |move_knot|@>;
8775 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8776 pointer l,r; /* the leftmost and rightmost knots */
8777 pointer p,q; /* knots being scanned */
8778 pointer s; /* the starting point for an upcoming scan */
8779 scaled dx,dy; /* a temporary pointer */
8780 if ( pen_is_elliptical(h) ) {
8783 @<Set |l| to the leftmost knot in polygon~|h|@>;
8784 @<Set |r| to the rightmost knot in polygon~|h|@>;
8787 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8788 move them past~|r|@>;
8789 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8790 move them past~|l|@>;
8791 @<Sort the path from |l| to |r| by increasing $x$@>;
8792 @<Sort the path from |r| to |l| by decreasing $x$@>;
8795 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8801 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8803 @<Set |l| to the leftmost knot in polygon~|h|@>=
8807 if ( x_coord(p)<=x_coord(l) )
8808 if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
8813 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8817 if ( x_coord(p)>=x_coord(r) )
8818 if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
8823 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8824 dx=x_coord(r)-x_coord(l);
8825 dy=y_coord(r)-y_coord(l);
8829 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
8830 mp_move_knot(mp, p, r);
8834 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8837 @ @<Declare a procedure called |move_knot|@>=
8838 void mp_move_knot (MP mp,pointer p, pointer q) {
8839 link(knil(p))=link(p);
8840 knil(link(p))=knil(p);
8847 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8851 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
8852 mp_move_knot(mp, p,l);
8856 @ The list is likely to be in order already so we just do linear insertions.
8857 Secondary comparisons on $y$ ensure that the sort is consistent with the
8858 choice of |l| and |r|.
8860 @<Sort the path from |l| to |r| by increasing $x$@>=
8864 while ( x_coord(q)>x_coord(p) ) q=knil(q);
8865 while ( x_coord(q)==x_coord(p) ) {
8866 if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
8868 if ( q==knil(p) ) p=link(p);
8869 else { p=link(p); mp_move_knot(mp, knil(p),q); };
8872 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
8876 while ( x_coord(q)<x_coord(p) ) q=knil(q);
8877 while ( x_coord(q)==x_coord(p) ) {
8878 if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
8880 if ( q==knil(p) ) p=link(p);
8881 else { p=link(p); mp_move_knot(mp, knil(p),q); };
8884 @ The condition involving |ab_vs_cd| tests if there is not a left turn
8885 at knot |q|. There usually will be a left turn so we streamline the case
8886 where the |then| clause is not executed.
8888 @<Do a Gramm scan and remove vertices where there...@>=
8892 dx=x_coord(q)-x_coord(p);
8893 dy=y_coord(q)-y_coord(p);
8897 if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
8898 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
8903 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
8906 mp_free_node(mp, p,knot_node_size);
8907 link(s)=q; knil(q)=s;
8909 else { p=knil(s); q=s; };
8912 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
8913 offset associated with the given direction |(x,y)|. If two different offsets
8914 apply, it chooses one of them.
8917 void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
8918 pointer p,q; /* consecutive knots */
8920 /* the transformation matrix for an elliptical pen */
8921 fraction xx,yy; /* untransformed offset for an elliptical pen */
8922 fraction d; /* a temporary register */
8923 if ( pen_is_elliptical(h) ) {
8924 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
8929 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
8932 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
8933 mp->cur_x=x_coord(p);
8934 mp->cur_y=y_coord(p);
8940 scaled cur_y; /* all-purpose return value registers */
8942 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
8943 if ( (x==0) && (y==0) ) {
8944 mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
8946 @<Find the non-constant part of the transformation for |h|@>;
8947 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
8950 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
8951 untransformed version of |(x,y)|@>;
8952 mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
8953 mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
8956 @ @<Find the non-constant part of the transformation for |h|@>=
8957 wx=left_x(h)-x_coord(h);
8958 wy=left_y(h)-y_coord(h);
8959 hx=right_x(h)-x_coord(h);
8960 hy=right_y(h)-y_coord(h)
8962 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
8963 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
8964 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
8965 d=mp_pyth_add(mp, xx,yy);
8967 xx=half(mp_make_fraction(mp, xx,d));
8968 yy=half(mp_make_fraction(mp, yy,d));
8971 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
8972 But we can handle that case by just calling |find_offset| twice. The answer
8973 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
8976 void mp_pen_bbox (MP mp,pointer h) {
8977 pointer p; /* for scanning the knot list */
8978 if ( pen_is_elliptical(h) ) {
8979 @<Find the bounding box of an elliptical pen@>;
8981 minx=x_coord(h); maxx=minx;
8982 miny=y_coord(h); maxy=miny;
8985 if ( x_coord(p)<minx ) minx=x_coord(p);
8986 if ( y_coord(p)<miny ) miny=y_coord(p);
8987 if ( x_coord(p)>maxx ) maxx=x_coord(p);
8988 if ( y_coord(p)>maxy ) maxy=y_coord(p);
8994 @ @<Find the bounding box of an elliptical pen@>=
8996 mp_find_offset(mp, 0,fraction_one,h);
8998 minx=2*x_coord(h)-mp->cur_x;
8999 mp_find_offset(mp, -fraction_one,0,h);
9001 miny=2*y_coord(h)-mp->cur_y;
9004 @* \[21] Edge structures.
9005 Now we come to \MP's internal scheme for representing pictures.
9006 The representation is very different from \MF's edge structures
9007 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9008 images. However, the basic idea is somewhat similar in that shapes
9009 are represented via their boundaries.
9011 The main purpose of edge structures is to keep track of graphical objects
9012 until it is time to translate them into \ps. Since \MP\ does not need to
9013 know anything about an edge structure other than how to translate it into
9014 \ps\ and how to find its bounding box, edge structures can be just linked
9015 lists of graphical objects. \MP\ has no easy way to determine whether
9016 two such objects overlap, but it suffices to draw the first one first and
9017 let the second one overwrite it if necessary.
9020 enum mp_graphical_object_code {
9021 @<Graphical object codes@>
9024 @ Let's consider the types of graphical objects one at a time.
9025 First of all, a filled contour is represented by a eight-word node. The first
9026 word contains |type| and |link| fields, and the next six words contain a
9027 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9028 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9029 give the relevant information.
9031 @d path_p(A) link((A)+1)
9032 /* a pointer to the path that needs filling */
9033 @d pen_p(A) info((A)+1)
9034 /* a pointer to the pen to fill or stroke with */
9035 @d color_model(A) type((A)+2) /* the color model */
9036 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9037 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9038 @d obj_grey_loc obj_red_loc /* the location for the color */
9039 @d red_val(A) mp->mem[(A)+3].sc
9040 /* the red component of the color in the range $0\ldots1$ */
9043 @d green_val(A) mp->mem[(A)+4].sc
9044 /* the green component of the color in the range $0\ldots1$ */
9045 @d magenta_val green_val
9046 @d blue_val(A) mp->mem[(A)+5].sc
9047 /* the blue component of the color in the range $0\ldots1$ */
9048 @d yellow_val blue_val
9049 @d black_val(A) mp->mem[(A)+6].sc
9050 /* the blue component of the color in the range $0\ldots1$ */
9051 @d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
9052 @:mp_linejoin_}{\&{linejoin} primitive@>
9053 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9054 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9055 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9056 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9057 @d pre_script(A) mp->mem[(A)+8].hh.lh
9058 @d post_script(A) mp->mem[(A)+8].hh.rh
9061 @ @<Graphical object codes@>=
9065 pointer mp_new_fill_node (MP mp,pointer p) {
9066 /* make a fill node for cyclic path |p| and color black */
9067 pointer t; /* the new node */
9068 t=mp_get_node(mp, fill_node_size);
9069 type(t)=mp_fill_code;
9071 pen_p(t)=null; /* |null| means don't use a pen */
9076 color_model(t)=mp_uninitialized_model;
9078 post_script(t)=null;
9079 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9083 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9084 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9085 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9086 else ljoin_val(t)=0;
9087 if ( mp->internal[mp_miterlimit]<unity )
9088 miterlim_val(t)=unity;
9090 miterlim_val(t)=mp->internal[mp_miterlimit]
9092 @ A stroked path is represented by an eight-word node that is like a filled
9093 contour node except that it contains the current \&{linecap} value, a scale
9094 factor for the dash pattern, and a pointer that is non-null if the stroke
9095 is to be dashed. The purpose of the scale factor is to allow a picture to
9096 be transformed without touching the picture that |dash_p| points to.
9098 @d dash_p(A) link((A)+9)
9099 /* a pointer to the edge structure that gives the dash pattern */
9100 @d lcap_val(A) type((A)+9)
9101 /* the value of \&{linecap} */
9102 @:mp_linecap_}{\&{linecap} primitive@>
9103 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9104 @d stroked_node_size 11
9106 @ @<Graphical object codes@>=
9110 pointer mp_new_stroked_node (MP mp,pointer p) {
9111 /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
9112 pointer t; /* the new node */
9113 t=mp_get_node(mp, stroked_node_size);
9114 type(t)=mp_stroked_code;
9115 path_p(t)=p; pen_p(t)=null;
9117 dash_scale(t)=unity;
9122 color_model(t)=mp_uninitialized_model;
9124 post_script(t)=null;
9125 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9126 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9127 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9132 @ When a dashed line is computed in a transformed coordinate system, the dash
9133 lengths get scaled like the pen shape and we need to compensate for this. Since
9134 there is no unique scale factor for an arbitrary transformation, we use the
9135 the square root of the determinant. The properties of the determinant make it
9136 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9137 except for the initialization of the scale factor |s|. The factor of 64 is
9138 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9139 to counteract the effect of |take_fraction|.
9141 @<Declare subroutines needed by |print_edges|@>=
9142 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9143 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9144 integer s; /* amount by which the result of |square_rt| needs to be scaled */
9145 @<Initialize |maxabs|@>;
9147 while ( (maxabs<fraction_one) && (s>1) ){
9148 a+=a; b+=b; c+=c; d+=d;
9149 maxabs+=maxabs; s=halfp(s);
9151 return s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)));
9154 scaled mp_get_pen_scale (MP mp,pointer p) {
9155 return mp_sqrt_det(mp,
9156 left_x(p)-x_coord(p), right_x(p)-x_coord(p),
9157 left_y(p)-y_coord(p), right_y(p)-y_coord(p));
9160 @ @<Internal library ...@>=
9161 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9164 @ @<Initialize |maxabs|@>=
9166 if ( abs(b)>maxabs ) maxabs=abs(b);
9167 if ( abs(c)>maxabs ) maxabs=abs(c);
9168 if ( abs(d)>maxabs ) maxabs=abs(d)
9170 @ When a picture contains text, this is represented by a fourteen-word node
9171 where the color information and |type| and |link| fields are augmented by
9172 additional fields that describe the text and how it is transformed.
9173 The |path_p| and |pen_p| pointers are replaced by a number that identifies
9174 the font and a string number that gives the text to be displayed.
9175 The |width|, |height|, and |depth| fields
9176 give the dimensions of the text at its design size, and the remaining six
9177 words give a transformation to be applied to the text. The |new_text_node|
9178 function initializes everything to default values so that the text comes out
9179 black with its reference point at the origin.
9181 @d text_p(A) link((A)+1) /* a string pointer for the text to display */
9182 @d font_n(A) info((A)+1) /* the font number */
9183 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9184 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9185 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9186 @d text_tx_loc(A) ((A)+11)
9187 /* the first of six locations for transformation parameters */
9188 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9189 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9190 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9191 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9192 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9193 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9194 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9195 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9196 @d text_node_size 17
9198 @ @<Graphical object codes@>=
9201 @ @c @<Declare text measuring subroutines@>;
9202 pointer mp_new_text_node (MP mp,char *f,str_number s) {
9203 /* make a text node for font |f| and text string |s| */
9204 pointer t; /* the new node */
9205 t=mp_get_node(mp, text_node_size);
9206 type(t)=mp_text_code;
9208 font_n(t)=mp_find_font(mp, f); /* this identifies the font */
9213 color_model(t)=mp_uninitialized_model;
9215 post_script(t)=null;
9216 tx_val(t)=0; ty_val(t)=0;
9217 txx_val(t)=unity; txy_val(t)=0;
9218 tyx_val(t)=0; tyy_val(t)=unity;
9219 mp_set_text_box(mp, t); /* this finds the bounding box */
9223 @ The last two types of graphical objects that can occur in an edge structure
9224 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9225 @:set_bounds_}{\&{setbounds} primitive@>
9226 to implement because we must keep track of exactly what is being clipped or
9227 bounded when pictures get merged together. For this reason, each clipping or
9228 \&{setbounds} operation is represented by a pair of nodes: first comes a
9229 two-word node whose |path_p| gives the relevant path, then there is the list
9230 of objects to clip or bound followed by a two-word node whose second word is
9233 Using at least two words for each graphical object node allows them all to be
9234 allocated and deallocated similarly with a global array |gr_object_size| to
9235 give the size in words for each object type.
9237 @d start_clip_size 2
9238 @d start_bounds_size 2
9239 @d stop_clip_size 2 /* the second word is not used here */
9240 @d stop_bounds_size 2 /* the second word is not used here */
9242 @d stop_type(A) ((A)+2)
9243 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9244 @d has_color(A) (type((A))<mp_start_clip_code)
9245 /* does a graphical object have color fields? */
9246 @d has_pen(A) (type((A))<mp_text_code)
9247 /* does a graphical object have a |pen_p| field? */
9248 @d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
9249 @d is_stop(A) (type((A))>=mp_stop_clip_code)
9251 @ @<Graphical object codes@>=
9252 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9253 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9254 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9255 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9259 pointer mp_new_bounds_node (MP mp,pointer p, small_number c) {
9260 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9261 pointer t; /* the new node */
9262 t=mp_get_node(mp, mp->gr_object_size[c]);
9268 @ We need an array to keep track of the sizes of graphical objects.
9271 small_number gr_object_size[mp_stop_bounds_code+1];
9274 mp->gr_object_size[mp_fill_code]=fill_node_size;
9275 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9276 mp->gr_object_size[mp_text_code]=text_node_size;
9277 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9278 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9279 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9280 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9282 @ All the essential information in an edge structure is encoded as a linked list
9283 of graphical objects as we have just seen, but it is helpful to add some
9284 redundant information. A single edge structure might be used as a dash pattern
9285 many times, and it would be nice to avoid scanning the same structure
9286 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9287 has a header that gives a list of dashes in a sorted order designed for rapid
9288 translation into \ps.
9290 Each dash is represented by a three-word node containing the initial and final
9291 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9292 the dash node with the next higher $x$-coordinates and the final link points
9293 to a special location called |null_dash|. (There should be no overlap between
9294 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9295 the period of repetition, this needs to be stored in the edge header along
9296 with a pointer to the list of dash nodes.
9298 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9299 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9302 /* in an edge header this points to the first dash node */
9303 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9305 @ It is also convenient for an edge header to contain the bounding
9306 box information needed by the \&{llcorner} and \&{urcorner} operators
9307 so that this does not have to be recomputed unnecessarily. This is done by
9308 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9309 how far the bounding box computation has gotten. Thus if the user asks for
9310 the bounding box and then adds some more text to the picture before asking
9311 for more bounding box information, the second computation need only look at
9312 the additional text.
9314 When the bounding box has not been computed, the |bblast| pointer points
9315 to a dummy link at the head of the graphical object list while the |minx_val|
9316 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9317 fields contain |-el_gordo|.
9319 Since the bounding box of pictures containing objects of type
9320 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9321 @:mp_true_corners_}{\&{truecorners} primitive@>
9322 data might not be valid for all values of this parameter. Hence, the |bbtype|
9323 field is needed to keep track of this.
9325 @d minx_val(A) mp->mem[(A)+2].sc
9326 @d miny_val(A) mp->mem[(A)+3].sc
9327 @d maxx_val(A) mp->mem[(A)+4].sc
9328 @d maxy_val(A) mp->mem[(A)+5].sc
9329 @d bblast(A) link((A)+6) /* last item considered in bounding box computation */
9330 @d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9331 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9333 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9335 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9337 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9340 void mp_init_bbox (MP mp,pointer h) {
9341 /* Initialize the bounding box information in edge structure |h| */
9342 bblast(h)=dummy_loc(h);
9343 bbtype(h)=no_bounds;
9344 minx_val(h)=el_gordo;
9345 miny_val(h)=el_gordo;
9346 maxx_val(h)=-el_gordo;
9347 maxy_val(h)=-el_gordo;
9350 @ The only other entries in an edge header are a reference count in the first
9351 word and a pointer to the tail of the object list in the last word.
9353 @d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
9354 @d edge_header_size 8
9357 void mp_init_edges (MP mp,pointer h) {
9358 /* initialize an edge header to null values */
9359 dash_list(h)=null_dash;
9360 obj_tail(h)=dummy_loc(h);
9361 link(dummy_loc(h))=null;
9363 mp_init_bbox(mp, h);
9366 @ Here is how edge structures are deleted. The process can be recursive because
9367 of the need to dereference edge structures that are used as dash patterns.
9370 @d add_edge_ref(A) incr(ref_count((A)))
9371 @d delete_edge_ref(A) { if ( ref_count((A))==null ) mp_toss_edges(mp, (A));
9372 else decr(ref_count((A))); }
9374 @<Declare the recycling subroutines@>=
9375 void mp_flush_dash_list (MP mp,pointer h);
9376 pointer mp_toss_gr_object (MP mp,pointer p) ;
9377 void mp_toss_edges (MP mp,pointer h) ;
9379 @ @c void mp_toss_edges (MP mp,pointer h) {
9380 pointer p,q; /* pointers that scan the list being recycled */
9381 pointer r; /* an edge structure that object |p| refers to */
9382 mp_flush_dash_list(mp, h);
9383 q=link(dummy_loc(h));
9384 while ( (q!=null) ) {
9386 r=mp_toss_gr_object(mp, p);
9387 if ( r!=null ) delete_edge_ref(r);
9389 mp_free_node(mp, h,edge_header_size);
9391 void mp_flush_dash_list (MP mp,pointer h) {
9392 pointer p,q; /* pointers that scan the list being recycled */
9394 while ( q!=null_dash ) {
9396 mp_free_node(mp, p,dash_node_size);
9398 dash_list(h)=null_dash;
9400 pointer mp_toss_gr_object (MP mp,pointer p) {
9401 /* returns an edge structure that needs to be dereferenced */
9402 pointer e; /* the edge structure to return */
9404 @<Prepare to recycle graphical object |p|@>;
9405 mp_free_node(mp, p,mp->gr_object_size[type(p)]);
9409 @ @<Prepare to recycle graphical object |p|@>=
9412 mp_toss_knot_list(mp, path_p(p));
9413 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9414 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9415 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9417 case mp_stroked_code:
9418 mp_toss_knot_list(mp, path_p(p));
9419 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9420 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9421 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9425 delete_str_ref(text_p(p));
9426 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9427 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9429 case mp_start_clip_code:
9430 case mp_start_bounds_code:
9431 mp_toss_knot_list(mp, path_p(p));
9433 case mp_stop_clip_code:
9434 case mp_stop_bounds_code:
9436 } /* there are no other cases */
9438 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9439 to be done before making a significant change to an edge structure. Much of
9440 the work is done in a separate routine |copy_objects| that copies a list of
9441 graphical objects into a new edge header.
9443 @c @<Declare a function called |copy_objects|@>;
9444 pointer mp_private_edges (MP mp,pointer h) {
9445 /* make a private copy of the edge structure headed by |h| */
9446 pointer hh; /* the edge header for the new copy */
9447 pointer p,pp; /* pointers for copying the dash list */
9448 if ( ref_count(h)==null ) {
9452 hh=mp_copy_objects(mp, link(dummy_loc(h)),null);
9453 @<Copy the dash list from |h| to |hh|@>;
9454 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9455 point into the new object list@>;
9460 @ Here we use the fact that |dash_list(hh)=link(hh)|.
9461 @^data structure assumptions@>
9463 @<Copy the dash list from |h| to |hh|@>=
9464 pp=hh; p=dash_list(h);
9465 while ( (p!=null_dash) ) {
9466 link(pp)=mp_get_node(mp, dash_node_size);
9468 start_x(pp)=start_x(p);
9469 stop_x(pp)=stop_x(p);
9473 dash_y(hh)=dash_y(h)
9475 @ @<Copy the bounding box information from |h| to |hh|...@>=
9476 minx_val(hh)=minx_val(h);
9477 miny_val(hh)=miny_val(h);
9478 maxx_val(hh)=maxx_val(h);
9479 maxy_val(hh)=maxy_val(h);
9480 bbtype(hh)=bbtype(h);
9481 p=dummy_loc(h); pp=dummy_loc(hh);
9482 while ((p!=bblast(h)) ) {
9483 if ( p==null ) mp_confusion(mp, "bblast");
9484 @:this can't happen bblast}{\quad bblast@>
9485 p=link(p); pp=link(pp);
9489 @ Here is the promised routine for copying graphical objects into a new edge
9490 structure. It starts copying at object~|p| and stops just before object~|q|.
9491 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9492 structure requires further initialization by |init_bbox|.
9494 @<Declare a function called |copy_objects|@>=
9495 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9496 pointer hh; /* the new edge header */
9497 pointer pp; /* the last newly copied object */
9498 small_number k; /* temporary register */
9499 hh=mp_get_node(mp, edge_header_size);
9500 dash_list(hh)=null_dash;
9504 @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9511 @ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9512 { k=mp->gr_object_size[type(p)];
9513 link(pp)=mp_get_node(mp, k);
9515 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9516 @<Fix anything in graphical object |pp| that should differ from the
9517 corresponding field in |p|@>;
9521 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9523 case mp_start_clip_code:
9524 case mp_start_bounds_code:
9525 path_p(pp)=mp_copy_path(mp, path_p(p));
9528 path_p(pp)=mp_copy_path(mp, path_p(p));
9529 if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
9531 case mp_stroked_code:
9532 path_p(pp)=mp_copy_path(mp, path_p(p));
9533 pen_p(pp)=copy_pen(pen_p(p));
9534 if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
9537 add_str_ref(text_p(pp));
9539 case mp_stop_clip_code:
9540 case mp_stop_bounds_code:
9542 } /* there are no other cases */
9544 @ Here is one way to find an acceptable value for the second argument to
9545 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9546 skips past one picture component, where a ``picture component'' is a single
9547 graphical object, or a start bounds or start clip object and everything up
9548 through the matching stop bounds or stop clip object. The macro version avoids
9549 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9550 unless |p| points to a stop bounds or stop clip node, in which case it executes
9553 @d skip_component(A)
9554 if ( ! is_start_or_stop((A)) ) (A)=link((A));
9555 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9559 pointer mp_skip_1component (MP mp,pointer p) {
9560 integer lev; /* current nesting level */
9563 if ( is_start_or_stop(p) ) {
9564 if ( is_stop(p) ) decr(lev); else incr(lev);
9571 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9573 @<Declare subroutines for printing expressions@>=
9574 @<Declare subroutines needed by |print_edges|@>;
9575 void mp_print_edges (MP mp,pointer h, char *s, boolean nuline) {
9576 pointer p; /* a graphical object to be printed */
9577 pointer hh,pp; /* temporary pointers */
9578 scaled scf; /* a scale factor for the dash pattern */
9579 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9580 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9582 while ( link(p)!=null ) {
9586 @<Cases for printing graphical object node |p|@>;
9588 mp_print(mp, "[unknown object type!]");
9592 mp_print_nl(mp, "End edges");
9593 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9595 mp_end_diagnostic(mp, true);
9598 @ @<Cases for printing graphical object node |p|@>=
9600 mp_print(mp, "Filled contour ");
9601 mp_print_obj_color(mp, p);
9602 mp_print_char(mp, ':'); mp_print_ln(mp);
9603 mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
9604 if ( (pen_p(p)!=null) ) {
9605 @<Print join type for graphical object |p|@>;
9606 mp_print(mp, " with pen"); mp_print_ln(mp);
9607 mp_pr_pen(mp, pen_p(p));
9611 @ @<Print join type for graphical object |p|@>=
9612 switch (ljoin_val(p)) {
9614 mp_print(mp, "mitered joins limited ");
9615 mp_print_scaled(mp, miterlim_val(p));
9618 mp_print(mp, "round joins");
9621 mp_print(mp, "beveled joins");
9624 mp_print(mp, "?? joins");
9629 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9631 @<Print join and cap types for stroked node |p|@>=
9632 switch (lcap_val(p)) {
9633 case 0:mp_print(mp, "butt"); break;
9634 case 1:mp_print(mp, "round"); break;
9635 case 2:mp_print(mp, "square"); break;
9636 default: mp_print(mp, "??"); break;
9639 mp_print(mp, " ends, ");
9640 @<Print join type for graphical object |p|@>
9642 @ Here is a routine that prints the color of a graphical object if it isn't
9643 black (the default color).
9645 @<Declare subroutines needed by |print_edges|@>=
9646 @<Declare a procedure called |print_compact_node|@>;
9647 void mp_print_obj_color (MP mp,pointer p) {
9648 if ( color_model(p)==mp_grey_model ) {
9649 if ( grey_val(p)>0 ) {
9650 mp_print(mp, "greyed ");
9651 mp_print_compact_node(mp, obj_grey_loc(p),1);
9653 } else if ( color_model(p)==mp_cmyk_model ) {
9654 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9655 (yellow_val(p)>0) || (black_val(p)>0) ) {
9656 mp_print(mp, "processcolored ");
9657 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9659 } else if ( color_model(p)==mp_rgb_model ) {
9660 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9661 mp_print(mp, "colored ");
9662 mp_print_compact_node(mp, obj_red_loc(p),3);
9667 @ We also need a procedure for printing consecutive scaled values as if they
9668 were a known big node.
9670 @<Declare a procedure called |print_compact_node|@>=
9671 void mp_print_compact_node (MP mp,pointer p, small_number k) {
9672 pointer q; /* last location to print */
9674 mp_print_char(mp, '(');
9676 mp_print_scaled(mp, mp->mem[p].sc);
9677 if ( p<q ) mp_print_char(mp, ',');
9680 mp_print_char(mp, ')');
9683 @ @<Cases for printing graphical object node |p|@>=
9684 case mp_stroked_code:
9685 mp_print(mp, "Filled pen stroke ");
9686 mp_print_obj_color(mp, p);
9687 mp_print_char(mp, ':'); mp_print_ln(mp);
9688 mp_pr_path(mp, path_p(p));
9689 if ( dash_p(p)!=null ) {
9690 mp_print_nl(mp, "dashed (");
9691 @<Finish printing the dash pattern that |p| refers to@>;
9694 @<Print join and cap types for stroked node |p|@>;
9695 mp_print(mp, " with pen"); mp_print_ln(mp);
9696 if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9698 else mp_pr_pen(mp, pen_p(p));
9701 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9702 when it is not known to define a suitable dash pattern. This is disallowed
9703 here because the |dash_p| field should never point to such an edge header.
9704 Note that memory is allocated for |start_x(null_dash)| and we are free to
9705 give it any convenient value.
9707 @<Finish printing the dash pattern that |p| refers to@>=
9708 ok_to_dash=pen_is_elliptical(pen_p(p));
9709 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9712 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9713 mp_print(mp, " ??");
9714 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9715 while ( pp!=null_dash ) {
9716 mp_print(mp, "on ");
9717 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9718 mp_print(mp, " off ");
9719 mp_print_scaled(mp, mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
9721 if ( pp!=null_dash ) mp_print_char(mp, ' ');
9723 mp_print(mp, ") shifted ");
9724 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9725 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9728 @ @<Declare subroutines needed by |print_edges|@>=
9729 scaled mp_dash_offset (MP mp,pointer h) {
9730 scaled x; /* the answer */
9731 if ( (dash_list(h)==null_dash) || (dash_y(h)<0) ) mp_confusion(mp, "dash0");
9732 @:this can't happen dash0}{\quad dash0@>
9733 if ( dash_y(h)==0 ) {
9736 x=-(start_x(dash_list(h)) % dash_y(h));
9737 if ( x<0 ) x=x+dash_y(h);
9742 @ @<Cases for printing graphical object node |p|@>=
9744 mp_print_char(mp, '"'); mp_print_str(mp,text_p(p));
9745 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
9746 mp_print_char(mp, '"'); mp_print_ln(mp);
9747 mp_print_obj_color(mp, p);
9748 mp_print(mp, "transformed ");
9749 mp_print_compact_node(mp, text_tx_loc(p),6);
9752 @ @<Cases for printing graphical object node |p|@>=
9753 case mp_start_clip_code:
9754 mp_print(mp, "clipping path:");
9756 mp_pr_path(mp, path_p(p));
9758 case mp_stop_clip_code:
9759 mp_print(mp, "stop clipping");
9762 @ @<Cases for printing graphical object node |p|@>=
9763 case mp_start_bounds_code:
9764 mp_print(mp, "setbounds path:");
9766 mp_pr_path(mp, path_p(p));
9768 case mp_stop_bounds_code:
9769 mp_print(mp, "end of setbounds");
9772 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9773 subroutine that scans an edge structure and tries to interpret it as a dash
9774 pattern. This can only be done when there are no filled regions or clipping
9775 paths and all the pen strokes have the same color. The first step is to let
9776 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9777 project all the pen stroke paths onto the line $y=y_0$ and require that there
9778 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9779 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9780 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9782 @c @<Declare a procedure called |x_retrace_error|@>;
9783 pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9784 pointer p; /* this scans the stroked nodes in the object list */
9785 pointer p0; /* if not |null| this points to the first stroked node */
9786 pointer pp,qq,rr; /* pointers into |path_p(p)| */
9787 pointer d,dd; /* pointers used to create the dash list */
9788 @<Other local variables in |make_dashes|@>;
9789 scaled y0=0; /* the initial $y$ coordinate */
9790 if ( dash_list(h)!=null_dash )
9793 p=link(dummy_loc(h));
9795 if ( type(p)!=mp_stroked_code ) {
9796 @<Compain that the edge structure contains a node of the wrong type
9797 and |goto not_found|@>;
9800 if ( p0==null ){ p0=p; y0=y_coord(pp); };
9801 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9802 or |goto not_found| if there is an error@>;
9803 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9806 if ( dash_list(h)==null_dash )
9807 goto NOT_FOUND; /* No error message */
9808 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9809 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
9812 @<Flush the dash list, recycle |h| and return |null|@>;
9815 @ @<Compain that the edge structure contains a node of the wrong type...@>=
9817 print_err("Picture is too complicated to use as a dash pattern");
9818 help3("When you say `dashed p', picture p should not contain any")
9819 ("text, filled regions, or clipping paths. This time it did")
9820 ("so I'll just make it a solid line instead.");
9821 mp_put_get_error(mp);
9825 @ A similar error occurs when monotonicity fails.
9827 @<Declare a procedure called |x_retrace_error|@>=
9828 void mp_x_retrace_error (MP mp) {
9829 print_err("Picture is too complicated to use as a dash pattern");
9830 help3("When you say `dashed p', every path in p should be monotone")
9831 ("in x and there must be no overlapping. This failed")
9832 ("so I'll just make it a solid line instead.");
9833 mp_put_get_error(mp);
9836 @ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
9837 handle the case where the pen stroke |p| is itself dashed.
9839 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
9840 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
9843 if ( link(pp)!=pp ) {
9846 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
9847 if there is a problem@>;
9848 } while (right_type(rr)!=mp_endpoint);
9850 d=mp_get_node(mp, dash_node_size);
9851 if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
9852 if ( x_coord(pp)<x_coord(rr) ) {
9853 start_x(d)=x_coord(pp);
9854 stop_x(d)=x_coord(rr);
9856 start_x(d)=x_coord(rr);
9857 stop_x(d)=x_coord(pp);
9860 @ We also need to check for the case where the segment from |qq| to |rr| is
9861 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
9863 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
9868 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
9869 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
9870 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
9871 mp_x_retrace_error(mp); goto NOT_FOUND;
9875 if ( (x_coord(pp)>x0) || (x0>x3) ) {
9876 if ( (x_coord(pp)<x0) || (x0<x3) ) {
9877 mp_x_retrace_error(mp); goto NOT_FOUND;
9881 @ @<Other local variables in |make_dashes|@>=
9882 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
9884 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
9885 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
9886 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
9887 print_err("Picture is too complicated to use as a dash pattern");
9888 help3("When you say `dashed p', everything in picture p should")
9889 ("be the same color. I can\'t handle your color changes")
9890 ("so I'll just make it a solid line instead.");
9891 mp_put_get_error(mp);
9895 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
9896 start_x(null_dash)=stop_x(d);
9897 dd=h; /* this makes |link(dd)=dash_list(h)| */
9898 while ( start_x(link(dd))<stop_x(d) )
9901 if ( (stop_x(dd)>start_x(d)) )
9902 { mp_x_retrace_error(mp); goto NOT_FOUND; };
9907 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
9909 while ( (link(d)!=null_dash) )
9912 dash_y(h)=stop_x(d)-start_x(dd);
9913 if ( abs(y0)>dash_y(h) ) {
9915 } else if ( d!=dd ) {
9916 dash_list(h)=link(dd);
9917 stop_x(d)=stop_x(dd)+dash_y(h);
9918 mp_free_node(mp, dd,dash_node_size);
9921 @ We get here when the argument is a null picture or when there is an error.
9922 Recovering from an error involves making |dash_list(h)| empty to indicate
9923 that |h| is not known to be a valid dash pattern. We also dereference |h|
9924 since it is not being used for the return value.
9926 @<Flush the dash list, recycle |h| and return |null|@>=
9927 mp_flush_dash_list(mp, h);
9931 @ Having carefully saved the dashed stroked nodes in the
9932 corresponding dash nodes, we must be prepared to break up these dashes into
9935 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
9936 d=h; /* now |link(d)=dash_list(h)| */
9937 while ( link(d)!=null_dash ) {
9944 if ( (hh==null) ) mp_confusion(mp, "dash1");
9945 @:this can't happen dash0}{\quad dash1@>
9946 if ( dash_y(hh)==0 ) {
9949 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
9950 @:this can't happen dash0}{\quad dash1@>
9951 @<Replace |link(d)| by a dashed version as determined by edge header
9952 |hh| and scale factor |ds|@>;
9957 @ @<Other local variables in |make_dashes|@>=
9958 pointer dln; /* |link(d)| */
9959 pointer hh; /* an edge header that tells how to break up |dln| */
9960 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
9961 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
9962 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
9964 @ @<Replace |link(d)| by a dashed version as determined by edge header...@>=
9967 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
9968 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
9969 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
9970 +mp_take_scaled(mp, hsf,dash_y(hh));
9971 stop_x(null_dash)=start_x(null_dash);
9972 @<Advance |dd| until finding the first dash that overlaps |dln| when
9974 while ( start_x(dln)<=stop_x(dln) ) {
9975 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
9976 @<Insert a dash between |d| and |dln| for the overlap with the offset version
9979 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
9982 mp_free_node(mp, dln,dash_node_size)
9984 @ The name of this module is a bit of a lie because we actually just find the
9985 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
9986 overlap possible. It could be that the unoffset version of dash |dln| falls
9987 in the gap between |dd| and its predecessor.
9989 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
9990 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
9994 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
9995 if ( dd==null_dash ) {
9997 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10000 @ At this point we already know that
10001 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10003 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10004 if ( xoff+mp_take_scaled(mp, hsf,start_x(dd))<=stop_x(dln) ) {
10005 link(d)=mp_get_node(mp, dash_node_size);
10008 if ( start_x(dln)>xoff+mp_take_scaled(mp, hsf,start_x(dd)))
10009 start_x(d)=start_x(dln);
10011 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10012 if ( stop_x(dln)<xoff+mp_take_scaled(mp, hsf,stop_x(dd)) )
10013 stop_x(d)=stop_x(dln);
10015 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10018 @ The next major task is to update the bounding box information in an edge
10019 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10020 header's bounding box to accommodate the box computed by |path_bbox| or
10021 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10024 @c void mp_adjust_bbox (MP mp,pointer h) {
10025 if ( minx<minx_val(h) ) minx_val(h)=minx;
10026 if ( miny<miny_val(h) ) miny_val(h)=miny;
10027 if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
10028 if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
10031 @ Here is a special routine for updating the bounding box information in
10032 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10033 that is to be stroked with the pen~|pp|.
10035 @c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10036 pointer q; /* a knot node adjacent to knot |p| */
10037 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10038 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10039 scaled z; /* a coordinate being tested against the bounding box */
10040 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10041 integer i; /* a loop counter */
10042 if ( right_type(p)!=mp_endpoint ) {
10045 @<Make |(dx,dy)| the final direction for the path segment from
10046 |q| to~|p|; set~|d|@>;
10047 d=mp_pyth_add(mp, dx,dy);
10049 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10050 for (i=1;i<= 2;i++) {
10051 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10052 update the bounding box to accommodate it@>;
10056 if ( right_type(p)==mp_endpoint ) {
10059 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10065 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10066 if ( q==link(p) ) {
10067 dx=x_coord(p)-right_x(p);
10068 dy=y_coord(p)-right_y(p);
10069 if ( (dx==0)&&(dy==0) ) {
10070 dx=x_coord(p)-left_x(q);
10071 dy=y_coord(p)-left_y(q);
10074 dx=x_coord(p)-left_x(p);
10075 dy=y_coord(p)-left_y(p);
10076 if ( (dx==0)&&(dy==0) ) {
10077 dx=x_coord(p)-right_x(q);
10078 dy=y_coord(p)-right_y(q);
10081 dx=x_coord(p)-x_coord(q);
10082 dy=y_coord(p)-y_coord(q)
10084 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10085 dx=mp_make_fraction(mp, dx,d);
10086 dy=mp_make_fraction(mp, dy,d);
10087 mp_find_offset(mp, -dy,dx,pp);
10088 xx=mp->cur_x; yy=mp->cur_y
10090 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10091 mp_find_offset(mp, dx,dy,pp);
10092 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10093 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10094 mp_confusion(mp, "box_ends");
10095 @:this can't happen box ends}{\quad\\{box\_ends}@>
10096 z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10097 if ( z<minx_val(h) ) minx_val(h)=z;
10098 if ( z>maxx_val(h) ) maxx_val(h)=z;
10099 z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10100 if ( z<miny_val(h) ) miny_val(h)=z;
10101 if ( z>maxy_val(h) ) maxy_val(h)=z
10103 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10107 } while (right_type(p)!=mp_endpoint)
10109 @ The major difficulty in finding the bounding box of an edge structure is the
10110 effect of clipping paths. We treat them conservatively by only clipping to the
10111 clipping path's bounding box, but this still
10112 requires recursive calls to |set_bbox| in order to find the bounding box of
10114 the objects to be clipped. Such calls are distinguished by the fact that the
10115 boolean parameter |top_level| is false.
10117 @c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10118 pointer p; /* a graphical object being considered */
10119 scaled sminx,sminy,smaxx,smaxy;
10120 /* for saving the bounding box during recursive calls */
10121 scaled x0,x1,y0,y1; /* temporary registers */
10122 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10123 @<Wipe out any existing bounding box information if |bbtype(h)| is
10124 incompatible with |internal[mp_true_corners]|@>;
10125 while ( link(bblast(h))!=null ) {
10129 case mp_stop_clip_code:
10130 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10131 @:this can't happen bbox}{\quad bbox@>
10133 @<Other cases for updating the bounding box based on the type of object |p|@>;
10134 } /* all cases are enumerated above */
10136 if ( ! top_level ) mp_confusion(mp, "bbox");
10139 @ @<Internal library declarations@>=
10140 void mp_set_bbox (MP mp,pointer h, boolean top_level);
10142 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10143 switch (bbtype(h)) {
10147 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10150 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10152 } /* there are no other cases */
10154 @ @<Other cases for updating the bounding box...@>=
10156 mp_path_bbox(mp, path_p(p));
10157 if ( pen_p(p)!=null ) {
10160 mp_pen_bbox(mp, pen_p(p));
10166 mp_adjust_bbox(mp, h);
10169 @ @<Other cases for updating the bounding box...@>=
10170 case mp_start_bounds_code:
10171 if ( mp->internal[mp_true_corners]>0 ) {
10172 bbtype(h)=bounds_unset;
10174 bbtype(h)=bounds_set;
10175 mp_path_bbox(mp, path_p(p));
10176 mp_adjust_bbox(mp, h);
10177 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10181 case mp_stop_bounds_code:
10182 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10183 @:this can't happen bbox2}{\quad bbox2@>
10186 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10189 if ( link(p)==null ) mp_confusion(mp, "bbox2");
10190 @:this can't happen bbox2}{\quad bbox2@>
10192 if ( type(p)==mp_start_bounds_code ) incr(lev);
10193 else if ( type(p)==mp_stop_bounds_code ) decr(lev);
10197 @ It saves a lot of grief here to be slightly conservative and not account for
10198 omitted parts of dashed lines. We also don't worry about the material omitted
10199 when using butt end caps. The basic computation is for round end caps and
10200 |box_ends| augments it for square end caps.
10202 @<Other cases for updating the bounding box...@>=
10203 case mp_stroked_code:
10204 mp_path_bbox(mp, path_p(p));
10207 mp_pen_bbox(mp, pen_p(p));
10212 mp_adjust_bbox(mp, h);
10213 if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10214 mp_box_ends(mp, path_p(p), pen_p(p), h);
10217 @ The height width and depth information stored in a text node determines a
10218 rectangle that needs to be transformed according to the transformation
10219 parameters stored in the text node.
10221 @<Other cases for updating the bounding box...@>=
10223 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10224 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10225 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10228 if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
10229 else { minx=minx+y1; maxx=maxx+y0; }
10230 if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
10231 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10232 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10233 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10236 if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
10237 else { miny=miny+y1; maxy=maxy+y0; }
10238 if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
10239 mp_adjust_bbox(mp, h);
10242 @ This case involves a recursive call that advances |bblast(h)| to the node of
10243 type |mp_stop_clip_code| that matches |p|.
10245 @<Other cases for updating the bounding box...@>=
10246 case mp_start_clip_code:
10247 mp_path_bbox(mp, path_p(p));
10250 sminx=minx_val(h); sminy=miny_val(h);
10251 smaxx=maxx_val(h); smaxy=maxy_val(h);
10252 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10253 starting at |link(p)|@>;
10254 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10256 minx=sminx; miny=sminy;
10257 maxx=smaxx; maxy=smaxy;
10258 mp_adjust_bbox(mp, h);
10261 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10262 minx_val(h)=el_gordo;
10263 miny_val(h)=el_gordo;
10264 maxx_val(h)=-el_gordo;
10265 maxy_val(h)=-el_gordo;
10266 mp_set_bbox(mp, h,false)
10268 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10269 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10270 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10271 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10272 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10274 @* \[22] Finding an envelope.
10275 When \MP\ has a path and a polygonal pen, it needs to express the desired
10276 shape in terms of things \ps\ can understand. The present task is to compute
10277 a new path that describes the region to be filled. It is convenient to
10278 define this as a two step process where the first step is determining what
10279 offset to use for each segment of the path.
10281 @ Given a pointer |c| to a cyclic path,
10282 and a pointer~|h| to the first knot of a pen polygon,
10283 the |offset_prep| routine changes the path into cubics that are
10284 associated with particular pen offsets. Thus if the cubic between |p|
10285 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10286 has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
10287 to because |l-k| could be negative.)
10289 After overwriting the type information with offset differences, we no longer
10290 have a true path so we refer to the knot list returned by |offset_prep| as an
10293 Since an envelope spec only determines relative changes in pen offsets,
10294 |offset_prep| sets a global variable |spec_offset| to the relative change from
10295 |h| to the first offset.
10297 @d zero_off 16384 /* added to offset changes to make them positive */
10300 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10302 @ @c @<Declare subroutines needed by |offset_prep|@>;
10303 pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10304 halfword n; /* the number of vertices in the pen polygon */
10305 pointer p,q,q0,r,w, ww; /* for list manipulation */
10306 integer k_needed; /* amount to be added to |info(p)| when it is computed */
10307 pointer w0; /* a pointer to pen offset to use just before |p| */
10308 scaled dxin,dyin; /* the direction into knot |p| */
10309 integer turn_amt; /* change in pen offsets for the current cubic */
10310 @<Other local variables for |offset_prep|@>;
10312 @<Initialize the pen size~|n|@>;
10313 @<Initialize the incoming direction and pen offset at |c|@>;
10317 @<Split the cubic between |p| and |q|, if necessary, into cubics
10318 associated with single offsets, after which |q| should
10319 point to the end of the final such cubic@>;
10321 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10322 might have been introduced by the splitting process@>;
10324 @<Fix the offset change in |info(c)| and set |c| to the return value of
10329 @ We shall want to keep track of where certain knots on the cyclic path
10330 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10331 knot nodes because some nodes are deleted while removing dead cubics. Thus
10332 |offset_prep| updates the following pointers
10336 pointer spec_p2; /* pointers to distinguished knots */
10339 mp->spec_p1=null; mp->spec_p2=null;
10341 @ @<Initialize the pen size~|n|@>=
10348 @ Since the true incoming direction isn't known yet, we just pick a direction
10349 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10352 @<Initialize the incoming direction and pen offset at |c|@>=
10353 dxin=x_coord(link(h))-x_coord(knil(h));
10354 dyin=y_coord(link(h))-y_coord(knil(h));
10355 if ( (dxin==0)&&(dyin==0) ) {
10356 dxin=y_coord(knil(h))-y_coord(h);
10357 dyin=x_coord(h)-x_coord(knil(h));
10361 @ We must be careful not to remove the only cubic in a cycle.
10363 But we must also be careful for another reason. If the user-supplied
10364 path starts with a set of degenerate cubics, the target node |q| can
10365 be collapsed to the initial node |p| which might be the same as the
10366 initial node |c| of the curve. This would cause the |offset_prep| routine
10367 to bail out too early, causing distress later on. (See for example
10368 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10371 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10375 if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
10376 x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
10377 x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
10379 @<Remove the cubic following |p| and update the data structures
10380 to merge |r| into |p|@>;
10384 /* Check if we removed too much */
10388 @ @<Remove the cubic following |p| and update the data structures...@>=
10389 { k_needed=info(p)-zero_off;
10393 info(p)=k_needed+info(r);
10396 if ( r==c ) { info(p)=info(c); c=p; };
10397 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10398 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10399 r=p; mp_remove_cubic(mp, p);
10402 @ Not setting the |info| field of the newly created knot allows the splitting
10403 routine to work for paths.
10405 @<Declare subroutines needed by |offset_prep|@>=
10406 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10407 scaled v; /* an intermediate value */
10408 pointer q,r; /* for list manipulation */
10409 q=link(p); r=mp_get_node(mp, knot_node_size); link(p)=r; link(r)=q;
10410 originator(r)=mp_program_code;
10411 left_type(r)=mp_explicit; right_type(r)=mp_explicit;
10412 v=t_of_the_way(right_x(p),left_x(q));
10413 right_x(p)=t_of_the_way(x_coord(p),right_x(p));
10414 left_x(q)=t_of_the_way(left_x(q),x_coord(q));
10415 left_x(r)=t_of_the_way(right_x(p),v);
10416 right_x(r)=t_of_the_way(v,left_x(q));
10417 x_coord(r)=t_of_the_way(left_x(r),right_x(r));
10418 v=t_of_the_way(right_y(p),left_y(q));
10419 right_y(p)=t_of_the_way(y_coord(p),right_y(p));
10420 left_y(q)=t_of_the_way(left_y(q),y_coord(q));
10421 left_y(r)=t_of_the_way(right_y(p),v);
10422 right_y(r)=t_of_the_way(v,left_y(q));
10423 y_coord(r)=t_of_the_way(left_y(r),right_y(r));
10426 @ This does not set |info(p)| or |right_type(p)|.
10428 @<Declare subroutines needed by |offset_prep|@>=
10429 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10430 pointer q; /* the node that disappears */
10431 q=link(p); link(p)=link(q);
10432 right_x(p)=right_x(q); right_y(p)=right_y(q);
10433 mp_free_node(mp, q,knot_node_size);
10436 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10437 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10438 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10439 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10440 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10441 When listed by increasing $k$, these directions occur in counter-clockwise
10442 order so that $d_k\preceq d\k$ for all~$k$.
10443 The goal of |offset_prep| is to find an offset index~|k| to associate with
10444 each cubic, such that the direction $d(t)$ of the cubic satisfies
10445 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10446 We may have to split a cubic into many pieces before each
10447 piece corresponds to a unique offset.
10449 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10450 info(p)=zero_off+k_needed;
10452 @<Prepare for derivative computations;
10453 |goto not_found| if the current cubic is dead@>;
10454 @<Find the initial direction |(dx,dy)|@>;
10455 @<Update |info(p)| and find the offset $w_k$ such that
10456 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10457 the direction change at |p|@>;
10458 @<Find the final direction |(dxin,dyin)|@>;
10459 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10460 @<Complete the offset splitting process@>;
10461 w0=mp_pen_walk(mp, w0,turn_amt)
10463 @ @<Declare subroutines needed by |offset_prep|@>=
10464 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10465 /* walk |k| steps around a pen from |w| */
10466 while ( k>0 ) { w=link(w); decr(k); };
10467 while ( k<0 ) { w=knil(w); incr(k); };
10471 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10472 calculated from the quadratic polynomials
10473 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10474 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10475 Since we may be calculating directions from several cubics
10476 split from the current one, it is desirable to do these calculations
10477 without losing too much precision. ``Scaled up'' values of the
10478 derivatives, which will be less tainted by accumulated errors than
10479 derivatives found from the cubics themselves, are maintained in
10480 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10481 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10482 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)$.
10484 @<Other local variables for |offset_prep|@>=
10485 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10486 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10487 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10488 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10489 integer max_coef; /* used while scaling */
10490 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10491 fraction t; /* where the derivative passes through zero */
10492 fraction s; /* a temporary value */
10494 @ @<Prepare for derivative computations...@>=
10495 x0=right_x(p)-x_coord(p);
10496 x2=x_coord(q)-left_x(q);
10497 x1=left_x(q)-right_x(p);
10498 y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
10499 y1=left_y(q)-right_y(p);
10501 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10502 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10503 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10504 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10505 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10506 if ( max_coef==0 ) goto NOT_FOUND;
10507 while ( max_coef<fraction_half ) {
10509 double(x0); double(x1); double(x2);
10510 double(y0); double(y1); double(y2);
10513 @ Let us first solve a special case of the problem: Suppose we
10514 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10515 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10516 $d(0)\succ d_{k-1}$.
10517 Then, in a sense, we're halfway done, since one of the two relations
10518 in $(*)$ is satisfied, and the other couldn't be satisfied for
10519 any other value of~|k|.
10521 Actually, the conditions can be relaxed somewhat since a relation such as
10522 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10523 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10524 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10525 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10526 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10527 counterclockwise direction.
10529 The |fin_offset_prep| subroutine solves the stated subproblem.
10530 It has a parameter called |rise| that is |1| in
10531 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10532 the derivative of the cubic following |p|.
10533 The |w| parameter should point to offset~$w_k$ and |info(p)| should already
10534 be set properly. The |turn_amt| parameter gives the absolute value of the
10535 overall net change in pen offsets.
10537 @<Declare subroutines needed by |offset_prep|@>=
10538 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10539 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10540 integer rise, integer turn_amt) {
10541 pointer ww; /* for list manipulation */
10542 scaled du,dv; /* for slope calculation */
10543 integer t0,t1,t2; /* test coefficients */
10544 fraction t; /* place where the derivative passes a critical slope */
10545 fraction s; /* slope or reciprocal slope */
10546 integer v; /* intermediate value for updating |x0..y2| */
10547 pointer q; /* original |link(p)| */
10550 if ( rise>0 ) ww=link(w); /* a pointer to $w\k$ */
10551 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10552 @<Compute test coefficients |(t0,t1,t2)|
10553 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10554 t=mp_crossing_point(mp, t0,t1,t2);
10555 if ( t>=fraction_one ) {
10556 if ( turn_amt>0 ) t=fraction_one; else return;
10558 @<Split the cubic at $t$,
10559 and split off another cubic if the derivative crosses back@>;
10564 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10565 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10566 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10569 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10570 du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
10571 if ( abs(du)>=abs(dv) ) {
10572 s=mp_make_fraction(mp, dv,du);
10573 t0=mp_take_fraction(mp, x0,s)-y0;
10574 t1=mp_take_fraction(mp, x1,s)-y1;
10575 t2=mp_take_fraction(mp, x2,s)-y2;
10576 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10578 s=mp_make_fraction(mp, du,dv);
10579 t0=x0-mp_take_fraction(mp, y0,s);
10580 t1=x1-mp_take_fraction(mp, y1,s);
10581 t2=x2-mp_take_fraction(mp, y2,s);
10582 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10584 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10586 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10587 $(*)$, and it might cross again, yielding another solution of $(*)$.
10589 @<Split the cubic at $t$, and split off another...@>=
10591 mp_split_cubic(mp, p,t); p=link(p); info(p)=zero_off+rise;
10593 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10594 x0=t_of_the_way(v,x1);
10595 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10596 y0=t_of_the_way(v,y1);
10597 if ( turn_amt<0 ) {
10598 t1=t_of_the_way(t1,t2);
10599 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10600 t=mp_crossing_point(mp, 0,-t1,-t2);
10601 if ( t>fraction_one ) t=fraction_one;
10603 if ( (t==fraction_one)&&(link(p)!=q) ) {
10604 info(link(p))=info(link(p))-rise;
10606 mp_split_cubic(mp, p,t); info(link(p))=zero_off-rise;
10607 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10608 x2=t_of_the_way(x1,v);
10609 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10610 y2=t_of_the_way(y1,v);
10615 @ Now we must consider the general problem of |offset_prep|, when
10616 nothing is known about a given cubic. We start by finding its
10617 direction in the vicinity of |t=0|.
10619 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10620 has not yet introduced any more numerical errors. Thus we can compute
10621 the true initial direction for the given cubic, even if it is almost
10624 @<Find the initial direction |(dx,dy)|@>=
10626 if ( dx==0 && dy==0 ) {
10628 if ( dx==0 && dy==0 ) {
10632 if ( p==c ) { dx0=dx; dy0=dy; }
10634 @ @<Find the final direction |(dxin,dyin)|@>=
10636 if ( dxin==0 && dyin==0 ) {
10638 if ( dxin==0 && dyin==0 ) {
10643 @ The next step is to bracket the initial direction between consecutive
10644 edges of the pen polygon. We must be careful to turn clockwise only if
10645 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10646 counter-clockwise in order to make \&{doublepath} envelopes come out
10647 @:double_path_}{\&{doublepath} primitive@>
10648 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10650 @<Update |info(p)| and find the offset $w_k$ such that...@>=
10651 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10652 w=mp_pen_walk(mp, w0, turn_amt);
10654 info(p)=info(p)+turn_amt
10656 @ Decide how many pen offsets to go away from |w| in order to find the offset
10657 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10658 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10659 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10661 If the pen polygon has only two edges, they could both be parallel
10662 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10663 such edge in order to avoid an infinite loop.
10665 @<Declare subroutines needed by |offset_prep|@>=
10666 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10667 scaled dy, boolean ccw) {
10668 pointer ww; /* a neighbor of knot~|w| */
10669 integer s; /* turn amount so far */
10670 integer t; /* |ab_vs_cd| result */
10675 t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
10676 dx,(y_coord(ww)-y_coord(w)));
10683 while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
10684 dx,(y_coord(w)-y_coord(ww))) < 0) {
10692 @ When we're all done, the final offset is |w0| and the final curve direction
10693 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10694 can correct |info(c)| which was erroneously based on an incoming offset
10697 @d fix_by(A) info(c)=info(c)+(A)
10699 @<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
10700 mp->spec_offset=info(c)-zero_off;
10701 if ( link(c)==c ) {
10702 info(c)=zero_off+n;
10705 while ( w0!=h ) { fix_by(1); w0=link(w0); };
10706 while ( info(c)<=zero_off-n ) fix_by(n);
10707 while ( info(c)>zero_off ) fix_by(-n);
10708 if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10712 @ Finally we want to reduce the general problem to situations that
10713 |fin_offset_prep| can handle. We split the cubic into at most three parts
10714 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10716 @<Complete the offset splitting process@>=
10718 @<Compute test coeff...@>;
10719 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10720 |t:=fraction_one+1|@>;
10721 if ( t>fraction_one ) {
10722 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10724 mp_split_cubic(mp, p,t); r=link(p);
10725 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10726 x2a=t_of_the_way(x1a,x1);
10727 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10728 y2a=t_of_the_way(y1a,y1);
10729 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10730 info(r)=zero_off-1;
10731 if ( turn_amt>=0 ) {
10732 t1=t_of_the_way(t1,t2);
10734 t=mp_crossing_point(mp, 0,-t1,-t2);
10735 if ( t>fraction_one ) t=fraction_one;
10736 @<Split off another rising cubic for |fin_offset_prep|@>;
10737 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10739 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10743 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10744 mp_split_cubic(mp, r,t); info(link(r))=zero_off+1;
10745 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10746 x0a=t_of_the_way(x1,x1a);
10747 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10748 y0a=t_of_the_way(y1,y1a);
10749 mp_fin_offset_prep(mp, link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10752 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10753 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10754 need to decide whether the directions are parallel or antiparallel. We
10755 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10756 should be avoided when the value of |turn_amt| already determines the
10757 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10758 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10759 crossing and the first crossing cannot be antiparallel.
10761 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10762 t=mp_crossing_point(mp, t0,t1,t2);
10763 if ( turn_amt>=0 ) {
10767 u0=t_of_the_way(x0,x1);
10768 u1=t_of_the_way(x1,x2);
10769 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10770 v0=t_of_the_way(y0,y1);
10771 v1=t_of_the_way(y1,y2);
10772 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10773 if ( ss<0 ) t=fraction_one+1;
10775 } else if ( t>fraction_one ) {
10779 @ @<Other local variables for |offset_prep|@>=
10780 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10781 integer ss = 0; /* the part of the dot product computed so far */
10782 int d_sign; /* sign of overall change in direction for this cubic */
10784 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10785 problem to decide which way it loops around but that's OK as long we're
10786 consistent. To make \&{doublepath} envelopes work properly, reversing
10787 the path should always change the sign of |turn_amt|.
10789 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10790 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10793 if ( dy>0 ) d_sign=1; else d_sign=-1;
10795 if ( dx>0 ) d_sign=1; else d_sign=-1;
10798 @<Make |ss| negative if and only if the total change in direction is
10799 more than $180^\circ$@>;
10800 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10801 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
10803 @ In order to be invariant under path reversal, the result of this computation
10804 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
10805 then swapped with |(x2,y2)|. We make use of the identities
10806 |take_fraction(-a,-b)=take_fraction(a,b)| and
10807 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
10809 @<Make |ss| negative if and only if the total change in direction is...@>=
10810 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
10811 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
10812 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
10814 t=mp_crossing_point(mp, t0,t1,-t0);
10815 u0=t_of_the_way(x0,x1);
10816 u1=t_of_the_way(x1,x2);
10817 v0=t_of_the_way(y0,y1);
10818 v1=t_of_the_way(y1,y2);
10820 t=mp_crossing_point(mp, -t0,t1,t0);
10821 u0=t_of_the_way(x2,x1);
10822 u1=t_of_the_way(x1,x0);
10823 v0=t_of_the_way(y2,y1);
10824 v1=t_of_the_way(y1,y0);
10826 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
10827 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
10829 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
10830 that the |cur_pen| has not been walked around to the first offset.
10833 void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, char *s) {
10834 pointer p,q; /* list traversal */
10835 pointer w; /* the current pen offset */
10836 mp_print_diagnostic(mp, "Envelope spec",s,true);
10837 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
10839 mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
10840 mp_print(mp, " % beginning with offset ");
10841 mp_print_two(mp, x_coord(w),y_coord(w));
10845 @<Print the cubic between |p| and |q|@>;
10847 if ((p==cur_spec) || (info(p)!=zero_off))
10850 if ( info(p)!=zero_off ) {
10851 @<Update |w| as indicated by |info(p)| and print an explanation@>;
10853 } while (p!=cur_spec);
10854 mp_print_nl(mp, " & cycle");
10855 mp_end_diagnostic(mp, true);
10858 @ @<Update |w| as indicated by |info(p)| and print an explanation@>=
10860 w=mp_pen_walk(mp, w, (info(p)-zero_off));
10861 mp_print(mp, " % ");
10862 if ( info(p)>zero_off ) mp_print(mp, "counter");
10863 mp_print(mp, "clockwise to offset ");
10864 mp_print_two(mp, x_coord(w),y_coord(w));
10867 @ @<Print the cubic between |p| and |q|@>=
10869 mp_print_nl(mp, " ..controls ");
10870 mp_print_two(mp, right_x(p),right_y(p));
10871 mp_print(mp, " and ");
10872 mp_print_two(mp, left_x(q),left_y(q));
10873 mp_print_nl(mp, " ..");
10874 mp_print_two(mp, x_coord(q),y_coord(q));
10877 @ Once we have an envelope spec, the remaining task to construct the actual
10878 envelope by offsetting each cubic as determined by the |info| fields in
10879 the knots. First we use |offset_prep| to convert the |c| into an envelope
10880 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
10883 The |ljoin| and |miterlim| parameters control the treatment of points where the
10884 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
10885 The endpoints are easily located because |c| is given in undoubled form
10886 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
10887 track of the endpoints and treat them like very sharp corners.
10888 Butt end caps are treated like beveled joins; round end caps are treated like
10889 round joins; and square end caps are achieved by setting |join_type:=3|.
10891 None of these parameters apply to inside joins where the convolution tracing
10892 has retrograde lines. In such cases we use a simple connect-the-endpoints
10893 approach that is achieved by setting |join_type:=2|.
10895 @c @<Declare a function called |insert_knot|@>;
10896 pointer mp_make_envelope (MP mp,pointer c, pointer h, small_number ljoin,
10897 small_number lcap, scaled miterlim) {
10898 pointer p,q,r,q0; /* for manipulating the path */
10899 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
10900 pointer w,w0; /* the pen knot for the current offset */
10901 scaled qx,qy; /* unshifted coordinates of |q| */
10902 halfword k,k0; /* controls pen edge insertion */
10903 @<Other local variables for |make_envelope|@>;
10904 dxin=0; dyin=0; dxout=0; dyout=0;
10905 mp->spec_p1=null; mp->spec_p2=null;
10906 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
10907 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
10908 the initial offset@>;
10913 qx=x_coord(q); qy=y_coord(q);
10916 if ( k!=zero_off ) {
10917 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
10919 @<Add offset |w| to the cubic from |p| to |q|@>;
10920 while ( k!=zero_off ) {
10921 @<Step |w| and move |k| one step closer to |zero_off|@>;
10922 if ( (join_type==1)||(k==zero_off) )
10923 q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
10925 if ( q!=link(p) ) {
10926 @<Set |p=link(p)| and add knots between |p| and |q| as
10927 required by |join_type|@>;
10934 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
10935 c=mp_offset_prep(mp, c,h);
10936 if ( mp->internal[mp_tracing_specs]>0 )
10937 mp_print_spec(mp, c,h,"");
10938 h=mp_pen_walk(mp, h,mp->spec_offset)
10940 @ Mitered and squared-off joins depend on path directions that are difficult to
10941 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
10942 have degenerate cubics only if the entire cycle collapses to a single
10943 degenerate cubic. Setting |join_type:=2| in this case makes the computed
10944 envelope degenerate as well.
10946 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
10947 if ( k<zero_off ) {
10950 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
10951 else if ( lcap==2 ) join_type=3;
10952 else join_type=2-lcap;
10953 if ( (join_type==0)||(join_type==3) ) {
10954 @<Set the incoming and outgoing directions at |q|; in case of
10955 degeneracy set |join_type:=2|@>;
10956 if ( join_type==0 ) {
10957 @<If |miterlim| is less than the secant of half the angle at |q|
10958 then set |join_type:=2|@>;
10963 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
10965 tmp=mp_take_fraction(mp, miterlim,fraction_half+
10966 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
10968 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
10971 @ @<Other local variables for |make_envelope|@>=
10972 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
10973 scaled tmp; /* a temporary value */
10975 @ The coordinates of |p| have already been shifted unless |p| is the first
10976 knot in which case they get shifted at the very end.
10978 @<Add offset |w| to the cubic from |p| to |q|@>=
10979 right_x(p)=right_x(p)+x_coord(w);
10980 right_y(p)=right_y(p)+y_coord(w);
10981 left_x(q)=left_x(q)+x_coord(w);
10982 left_y(q)=left_y(q)+y_coord(w);
10983 x_coord(q)=x_coord(q)+x_coord(w);
10984 y_coord(q)=y_coord(q)+y_coord(w);
10985 left_type(q)=mp_explicit;
10986 right_type(q)=mp_explicit
10988 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
10989 if ( k>zero_off ){ w=link(w); decr(k); }
10990 else { w=knil(w); incr(k); }
10992 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
10993 the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
10994 case the cubic containing these control points is ``yet to be examined.''
10996 @<Declare a function called |insert_knot|@>=
10997 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
10998 /* returns the inserted knot */
10999 pointer r; /* the new knot */
11000 r=mp_get_node(mp, knot_node_size);
11001 link(r)=link(q); link(q)=r;
11002 right_x(r)=right_x(q);
11003 right_y(r)=right_y(q);
11006 right_x(q)=x_coord(q);
11007 right_y(q)=y_coord(q);
11008 left_x(r)=x_coord(r);
11009 left_y(r)=y_coord(r);
11010 left_type(r)=mp_explicit;
11011 right_type(r)=mp_explicit;
11012 originator(r)=mp_program_code;
11016 @ After setting |p:=link(p)|, either |join_type=1| or |q=link(p)|.
11018 @<Set |p=link(p)| and add knots between |p| and |q| as...@>=
11021 if ( (join_type==0)||(join_type==3) ) {
11022 if ( join_type==0 ) {
11023 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11025 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11029 right_x(r)=x_coord(r);
11030 right_y(r)=y_coord(r);
11035 @ For very small angles, adding a knot is unnecessary and would cause numerical
11036 problems, so we just set |r:=null| in that case.
11038 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11040 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11041 if ( abs(det)<26844 ) {
11042 r=null; /* sine $<10^{-4}$ */
11044 tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
11045 mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
11046 tmp=mp_make_fraction(mp, tmp,det);
11047 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11048 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11052 @ @<Other local variables for |make_envelope|@>=
11053 fraction det; /* a determinant used for mitered join calculations */
11055 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11057 ht_x=y_coord(w)-y_coord(w0);
11058 ht_y=x_coord(w0)-x_coord(w);
11059 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11060 ht_x+=ht_x; ht_y+=ht_y;
11062 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11063 product with |(ht_x,ht_y)|@>;
11064 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11065 mp_take_fraction(mp, dyin,ht_y));
11066 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11067 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11068 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11069 mp_take_fraction(mp, dyout,ht_y));
11070 r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11071 y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11074 @ @<Other local variables for |make_envelope|@>=
11075 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11076 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11077 halfword kk; /* keeps track of the pen vertices being scanned */
11078 pointer ww; /* the pen vertex being tested */
11080 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11081 from zero to |max_ht|.
11083 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11088 @<Step |ww| and move |kk| one step closer to |k0|@>;
11089 if ( kk==k0 ) break;
11090 tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
11091 mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
11092 if ( tmp>max_ht ) max_ht=tmp;
11096 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11097 if ( kk>k0 ) { ww=link(ww); decr(kk); }
11098 else { ww=knil(ww); incr(kk); }
11100 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11101 if ( left_type(c)==mp_endpoint ) {
11102 mp->spec_p1=mp_htap_ypoc(mp, c);
11103 mp->spec_p2=mp->path_tail;
11104 originator(mp->spec_p1)=mp_program_code;
11105 link(mp->spec_p2)=link(mp->spec_p1);
11106 link(mp->spec_p1)=c;
11107 mp_remove_cubic(mp, mp->spec_p1);
11109 if ( c!=link(c) ) {
11110 originator(mp->spec_p2)=mp_program_code;
11111 mp_remove_cubic(mp, mp->spec_p2);
11113 @<Make |c| look like a cycle of length one@>;
11117 @ @<Make |c| look like a cycle of length one@>=
11119 left_type(c)=mp_explicit; right_type(c)=mp_explicit;
11120 left_x(c)=x_coord(c); left_y(c)=y_coord(c);
11121 right_x(c)=x_coord(c); right_y(c)=y_coord(c);
11124 @ In degenerate situations we might have to look at the knot preceding~|q|.
11125 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11127 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11128 dxin=x_coord(q)-left_x(q);
11129 dyin=y_coord(q)-left_y(q);
11130 if ( (dxin==0)&&(dyin==0) ) {
11131 dxin=x_coord(q)-right_x(p);
11132 dyin=y_coord(q)-right_y(p);
11133 if ( (dxin==0)&&(dyin==0) ) {
11134 dxin=x_coord(q)-x_coord(p);
11135 dyin=y_coord(q)-y_coord(p);
11136 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11137 dxin=dxin+x_coord(w);
11138 dyin=dyin+y_coord(w);
11142 tmp=mp_pyth_add(mp, dxin,dyin);
11146 dxin=mp_make_fraction(mp, dxin,tmp);
11147 dyin=mp_make_fraction(mp, dyin,tmp);
11148 @<Set the outgoing direction at |q|@>;
11151 @ If |q=c| then the coordinates of |r| and the control points between |q|
11152 and~|r| have already been offset by |h|.
11154 @<Set the outgoing direction at |q|@>=
11155 dxout=right_x(q)-x_coord(q);
11156 dyout=right_y(q)-y_coord(q);
11157 if ( (dxout==0)&&(dyout==0) ) {
11159 dxout=left_x(r)-x_coord(q);
11160 dyout=left_y(r)-y_coord(q);
11161 if ( (dxout==0)&&(dyout==0) ) {
11162 dxout=x_coord(r)-x_coord(q);
11163 dyout=y_coord(r)-y_coord(q);
11167 dxout=dxout-x_coord(h);
11168 dyout=dyout-y_coord(h);
11170 tmp=mp_pyth_add(mp, dxout,dyout);
11171 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11172 @:this can't happen degerate spec}{\quad degenerate spec@>
11173 dxout=mp_make_fraction(mp, dxout,tmp);
11174 dyout=mp_make_fraction(mp, dyout,tmp)
11176 @* \[23] Direction and intersection times.
11177 A path of length $n$ is defined parametrically by functions $x(t)$ and
11178 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11179 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11180 we shall consider operations that determine special times associated with
11181 given paths: the first time that a path travels in a given direction, and
11182 a pair of times at which two paths cross each other.
11184 @ Let's start with the easier task. The function |find_direction_time| is
11185 given a direction |(x,y)| and a path starting at~|h|. If the path never
11186 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11187 it will be nonnegative.
11189 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11190 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11191 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11192 assumed to match any given direction at time~|t|.
11194 The routine solves this problem in nondegenerate cases by rotating the path
11195 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11196 to find when a given path first travels ``due east.''
11199 scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11200 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11201 pointer p,q; /* for list traversal */
11202 scaled n; /* the direction time at knot |p| */
11203 scaled tt; /* the direction time within a cubic */
11204 @<Other local variables for |find_direction_time|@>;
11205 @<Normalize the given direction for better accuracy;
11206 but |return| with zero result if it's zero@>;
11209 if ( right_type(p)==mp_endpoint ) break;
11211 @<Rotate the cubic between |p| and |q|; then
11212 |goto found| if the rotated cubic travels due east at some time |tt|;
11213 but |break| if an entire cyclic path has been traversed@>;
11221 @ @<Normalize the given direction for better accuracy...@>=
11222 if ( abs(x)<abs(y) ) {
11223 x=mp_make_fraction(mp, x,abs(y));
11224 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11225 } else if ( x==0 ) {
11228 y=mp_make_fraction(mp, y,abs(x));
11229 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11232 @ Since we're interested in the tangent directions, we work with the
11233 derivative $${\textstyle1\over3}B'(x_0,x_1,x_2,x_3;t)=
11234 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11235 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11236 in order to achieve better accuracy.
11238 The given path may turn abruptly at a knot, and it might pass the critical
11239 tangent direction at such a time. Therefore we remember the direction |phi|
11240 in which the previous rotated cubic was traveling. (The value of |phi| will be
11241 undefined on the first cubic, i.e., when |n=0|.)
11243 @<Rotate the cubic between |p| and |q|; then...@>=
11245 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11246 points of the rotated derivatives@>;
11247 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11249 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11252 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11253 @<Exit to |found| if the curve whose derivatives are specified by
11254 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11256 @ @<Other local variables for |find_direction_time|@>=
11257 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11258 angle theta,phi; /* angles of exit and entry at a knot */
11259 fraction t; /* temp storage */
11261 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11262 x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
11263 x3=x_coord(q)-left_x(q);
11264 y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
11265 y3=y_coord(q)-left_y(q);
11267 if ( abs(x2)>max ) max=abs(x2);
11268 if ( abs(x3)>max ) max=abs(x3);
11269 if ( abs(y1)>max ) max=abs(y1);
11270 if ( abs(y2)>max ) max=abs(y2);
11271 if ( abs(y3)>max ) max=abs(y3);
11272 if ( max==0 ) goto FOUND;
11273 while ( max<fraction_half ){
11274 max+=max; x1+=x1; x2+=x2; x3+=x3;
11275 y1+=y1; y2+=y2; y3+=y3;
11277 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11278 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11279 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11280 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11281 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11282 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11284 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11285 theta=mp_n_arg(mp, x1,y1);
11286 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11287 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11289 @ In this step we want to use the |crossing_point| routine to find the
11290 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11291 Several complications arise: If the quadratic equation has a double root,
11292 the curve never crosses zero, and |crossing_point| will find nothing;
11293 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11294 equation has simple roots, or only one root, we may have to negate it
11295 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11296 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11299 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11300 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11301 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11302 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11303 either |goto found| or |goto done|@>;
11306 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11307 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11309 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11310 $B(x_1,x_2,x_3;t)\ge0$@>;
11313 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11314 two roots, because we know that it isn't identically zero.
11316 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11317 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11318 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11319 subject to rounding errors. Yet this code optimistically tries to
11320 do the right thing.
11322 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11324 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11325 t=mp_crossing_point(mp, y1,y2,y3);
11326 if ( t>fraction_one ) goto DONE;
11327 y2=t_of_the_way(y2,y3);
11328 x1=t_of_the_way(x1,x2);
11329 x2=t_of_the_way(x2,x3);
11330 x1=t_of_the_way(x1,x2);
11331 if ( x1>=0 ) we_found_it;
11333 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11334 if ( t>fraction_one ) goto DONE;
11335 x1=t_of_the_way(x1,x2);
11336 x2=t_of_the_way(x2,x3);
11337 if ( t_of_the_way(x1,x2)>=0 ) {
11338 t=t_of_the_way(tt,fraction_one); we_found_it;
11341 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11342 either |goto found| or |goto done|@>=
11344 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11345 t=mp_make_fraction(mp, y1,y1-y2);
11346 x1=t_of_the_way(x1,x2);
11347 x2=t_of_the_way(x2,x3);
11348 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11349 } else if ( y3==0 ) {
11351 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11352 } else if ( x3>=0 ) {
11353 tt=unity; goto FOUND;
11359 @ At this point we know that the derivative of |y(t)| is identically zero,
11360 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11363 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11365 t=mp_crossing_point(mp, -x1,-x2,-x3);
11366 if ( t<=fraction_one ) we_found_it;
11367 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11368 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11372 @ The intersection of two cubics can be found by an interesting variant
11373 of the general bisection scheme described in the introduction to
11375 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)$,
11376 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11377 if an intersection exists. First we find the smallest rectangle that
11378 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11379 the smallest rectangle that encloses
11380 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11381 But if the rectangles do overlap, we bisect the intervals, getting
11382 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11383 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11384 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11385 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11386 levels of bisection we will have determined the intersection times $t_1$
11387 and~$t_2$ to $l$~bits of accuracy.
11389 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11390 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11391 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11392 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11393 to determine when the enclosing rectangles overlap. Here's why:
11394 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11395 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11396 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11397 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11398 overlap if and only if $u\submin\L x\submax$ and
11399 $x\submin\L u\submax$. Letting
11400 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11401 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11402 we have $u\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11404 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11405 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11406 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11407 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11408 because of the overlap condition; i.e., we know that $X\submin$,
11409 $X\submax$, and their relatives are bounded, hence $X\submax-
11410 U\submin$ and $X\submin-U\submax$ are bounded.
11412 @ Incidentally, if the given cubics intersect more than once, the process
11413 just sketched will not necessarily find the lexicographically smallest pair
11414 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11415 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11416 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11417 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11418 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11419 Shuffled order agrees with lexicographic order if all pairs of solutions
11420 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11421 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11422 and the bisection algorithm would be substantially less efficient if it were
11423 constrained by lexicographic order.
11425 For example, suppose that an overlap has been found for $l=3$ and
11426 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11427 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11428 Then there is probably an intersection in one of the subintervals
11429 $(.1011,.011x)$; but lexicographic order would require us to explore
11430 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11431 want to store all of the subdivision data for the second path, so the
11432 subdivisions would have to be regenerated many times. Such inefficiencies
11433 would be associated with every `1' in the binary representation of~$t_1$.
11435 @ The subdivision process introduces rounding errors, hence we need to
11436 make a more liberal test for overlap. It is not hard to show that the
11437 computed values of $U_i$ differ from the truth by at most~$l$, on
11438 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11439 If $\beta$ is an upper bound on the absolute error in the computed
11440 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11441 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11442 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11444 More accuracy is obtained if we try the algorithm first with |tol=0|;
11445 the more liberal tolerance is used only if an exact approach fails.
11446 It is convenient to do this double-take by letting `3' in the preceding
11447 paragraph be a parameter, which is first 0, then 3.
11450 unsigned int tol_step; /* either 0 or 3, usually */
11452 @ We shall use an explicit stack to implement the recursive bisection
11453 method described above. The |bisect_stack| array will contain numerous 5-word
11454 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11455 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11457 The following macros define the allocation of stack positions to
11458 the quantities needed for bisection-intersection.
11460 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11461 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11462 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11463 @d stack_min(A) mp->bisect_stack[(A)+3]
11464 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11465 @d stack_max(A) mp->bisect_stack[(A)+4]
11466 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11467 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11469 @d u_packet(A) ((A)-5)
11470 @d v_packet(A) ((A)-10)
11471 @d x_packet(A) ((A)-15)
11472 @d y_packet(A) ((A)-20)
11473 @d l_packets (mp->bisect_ptr-int_packets)
11474 @d r_packets mp->bisect_ptr
11475 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11476 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11477 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11478 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11479 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11480 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11481 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11482 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11484 @d u1l stack_1(ul_packet) /* $U'_1$ */
11485 @d u2l stack_2(ul_packet) /* $U'_2$ */
11486 @d u3l stack_3(ul_packet) /* $U'_3$ */
11487 @d v1l stack_1(vl_packet) /* $V'_1$ */
11488 @d v2l stack_2(vl_packet) /* $V'_2$ */
11489 @d v3l stack_3(vl_packet) /* $V'_3$ */
11490 @d x1l stack_1(xl_packet) /* $X'_1$ */
11491 @d x2l stack_2(xl_packet) /* $X'_2$ */
11492 @d x3l stack_3(xl_packet) /* $X'_3$ */
11493 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11494 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11495 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11496 @d u1r stack_1(ur_packet) /* $U''_1$ */
11497 @d u2r stack_2(ur_packet) /* $U''_2$ */
11498 @d u3r stack_3(ur_packet) /* $U''_3$ */
11499 @d v1r stack_1(vr_packet) /* $V''_1$ */
11500 @d v2r stack_2(vr_packet) /* $V''_2$ */
11501 @d v3r stack_3(vr_packet) /* $V''_3$ */
11502 @d x1r stack_1(xr_packet) /* $X''_1$ */
11503 @d x2r stack_2(xr_packet) /* $X''_2$ */
11504 @d x3r stack_3(xr_packet) /* $X''_3$ */
11505 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11506 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11507 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11509 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11510 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11511 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11512 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11513 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11514 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11517 integer *bisect_stack;
11518 unsigned int bisect_ptr;
11520 @ @<Allocate or initialize ...@>=
11521 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11523 @ @<Dealloc variables@>=
11524 xfree(mp->bisect_stack);
11526 @ @<Check the ``constant''...@>=
11527 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11529 @ Computation of the min and max is a tedious but fairly fast sequence of
11530 instructions; exactly four comparisons are made in each branch.
11533 if ( stack_1((A))<0 ) {
11534 if ( stack_3((A))>=0 ) {
11535 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11536 else stack_min((A))=stack_1((A));
11537 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11538 if ( stack_max((A))<0 ) stack_max((A))=0;
11540 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11541 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11542 stack_max((A))=stack_1((A))+stack_2((A));
11543 if ( stack_max((A))<0 ) stack_max((A))=0;
11545 } else if ( stack_3((A))<=0 ) {
11546 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11547 else stack_max((A))=stack_1((A));
11548 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11549 if ( stack_min((A))>0 ) stack_min((A))=0;
11551 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11552 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11553 stack_min((A))=stack_1((A))+stack_2((A));
11554 if ( stack_min((A))>0 ) stack_min((A))=0;
11557 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11558 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11559 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11560 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11561 plus the |scaled| values of $t_1$ and~$t_2$.
11563 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11564 finds no intersection. The routine gives up and gives an approximate answer
11565 if it has backtracked
11566 more than 5000 times (otherwise there are cases where several minutes
11567 of fruitless computation would be possible).
11569 @d max_patience 5000
11572 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11573 integer time_to_go; /* this many backtracks before giving up */
11574 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11576 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11577 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
11578 and |(pp,link(pp))|, respectively.
11580 @c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11581 pointer q,qq; /* |link(p)|, |link(pp)| */
11582 mp->time_to_go=max_patience; mp->max_t=2;
11583 @<Initialize for intersections at level zero@>;
11586 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11587 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11588 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11589 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11591 if ( mp->cur_t>=mp->max_t ){
11592 if ( mp->max_t==two ) { /* we've done 17 bisections */
11593 mp->cur_t=halfp(mp->cur_t+1); mp->cur_tt=halfp(mp->cur_tt+1); return;
11595 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11597 @<Subdivide for a new level of intersection@>;
11600 if ( mp->time_to_go>0 ) {
11601 decr(mp->time_to_go);
11603 while ( mp->appr_t<unity ) {
11604 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11606 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11608 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11612 @ The following variables are global, although they are used only by
11613 |cubic_intersection|, because it is necessary on some machines to
11614 split |cubic_intersection| up into two procedures.
11617 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11618 integer tol; /* bound on the uncertainly in the overlap test */
11620 unsigned int xy; /* pointers to the current packets of interest */
11621 integer three_l; /* |tol_step| times the bisection level */
11622 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11624 @ We shall assume that the coordinates are sufficiently non-extreme that
11625 integer overflow will not occur.
11627 @<Initialize for intersections at level zero@>=
11628 q=link(p); qq=link(pp); mp->bisect_ptr=int_packets;
11629 u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
11630 u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
11631 v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
11632 v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
11633 x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
11634 x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
11635 y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
11636 y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
11637 mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
11638 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11639 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11641 @ @<Subdivide for a new level of intersection@>=
11642 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11643 stack_uv=mp->uv; stack_xy=mp->xy;
11644 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11645 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11646 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11647 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11648 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11649 u3l=half(u2l+u2r); u1r=u3l;
11650 set_min_max(ul_packet); set_min_max(ur_packet);
11651 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11652 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11653 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11654 v3l=half(v2l+v2r); v1r=v3l;
11655 set_min_max(vl_packet); set_min_max(vr_packet);
11656 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11657 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11658 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11659 x3l=half(x2l+x2r); x1r=x3l;
11660 set_min_max(xl_packet); set_min_max(xr_packet);
11661 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11662 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11663 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11664 y3l=half(y2l+y2r); y1r=y3l;
11665 set_min_max(yl_packet); set_min_max(yr_packet);
11666 mp->uv=l_packets; mp->xy=l_packets;
11667 mp->delx+=mp->delx; mp->dely+=mp->dely;
11668 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11669 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11671 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11673 if ( odd(mp->cur_tt) ) {
11674 if ( odd(mp->cur_t) ) {
11675 @<Descend to the previous level and |goto not_found|@>;
11678 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11679 +stack_3(u_packet(mp->uv));
11680 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11681 +stack_3(v_packet(mp->uv));
11682 mp->uv=mp->uv+int_packets; /* switch from |l_packet| to |r_packet| */
11683 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11684 /* switch from |r_packet| to |l_packet| */
11685 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11686 +stack_3(x_packet(mp->xy));
11687 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11688 +stack_3(y_packet(mp->xy));
11691 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11692 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11693 -stack_3(x_packet(mp->xy));
11694 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11695 -stack_3(y_packet(mp->xy));
11696 mp->xy=mp->xy+int_packets; /* switch from |l_packet| to |r_packet| */
11699 @ @<Descend to the previous level...@>=
11701 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11702 if ( mp->cur_t==0 ) return;
11703 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11704 mp->three_l=mp->three_l-mp->tol_step;
11705 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11706 mp->uv=stack_uv; mp->xy=stack_xy;
11710 @ The |path_intersection| procedure is much simpler.
11711 It invokes |cubic_intersection| in lexicographic order until finding a
11712 pair of cubics that intersect. The final intersection times are placed in
11713 |cur_t| and~|cur_tt|.
11715 @c void mp_path_intersection (MP mp,pointer h, pointer hh) {
11716 pointer p,pp; /* link registers that traverse the given paths */
11717 integer n,nn; /* integer parts of intersection times, minus |unity| */
11718 @<Change one-point paths into dead cycles@>;
11723 if ( right_type(p)!=mp_endpoint ) {
11726 if ( right_type(pp)!=mp_endpoint ) {
11727 mp_cubic_intersection(mp, p,pp);
11728 if ( mp->cur_t>0 ) {
11729 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11733 nn=nn+unity; pp=link(pp);
11736 n=n+unity; p=link(p);
11738 mp->tol_step=mp->tol_step+3;
11739 } while (mp->tol_step<=3);
11740 mp->cur_t=-unity; mp->cur_tt=-unity;
11743 @ @<Change one-point paths...@>=
11744 if ( right_type(h)==mp_endpoint ) {
11745 right_x(h)=x_coord(h); left_x(h)=x_coord(h);
11746 right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
11748 if ( right_type(hh)==mp_endpoint ) {
11749 right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
11750 right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
11753 @* \[24] Dynamic linear equations.
11754 \MP\ users define variables implicitly by stating equations that should be
11755 satisfied; the computer is supposed to be smart enough to solve those equations.
11756 And indeed, the computer tries valiantly to do so, by distinguishing five
11757 different types of numeric values:
11760 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11761 of the variable whose address is~|p|.
11764 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11765 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11766 as a |scaled| number plus a sum of independent variables with |fraction|
11770 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11771 number'' reflecting the time this variable was first used in an equation;
11772 also |0<=m<64|, and each dependent variable
11773 that refers to this one is actually referring to the future value of
11774 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11775 scaling are sometimes needed to keep the coefficients in dependency lists
11776 from getting too large. The value of~|m| will always be even.)
11779 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11780 equation before, but it has been explicitly declared to be numeric.
11783 |type(p)=undefined| means that variable |p| hasn't appeared before.
11785 \smallskip\noindent
11786 We have actually discussed these five types in the reverse order of their
11787 history during a computation: Once |known|, a variable never again
11788 becomes |dependent|; once |dependent|, it almost never again becomes
11789 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
11790 and once |mp_numeric_type|, it never again becomes |undefined| (except
11791 of course when the user specifically decides to scrap the old value
11792 and start again). A backward step may, however, take place: Sometimes
11793 a |dependent| variable becomes |mp_independent| again, when one of the
11794 independent variables it depends on is reverting to |undefined|.
11797 The next patch detects overflow of independent-variable serial
11798 numbers. Diagnosed and patched by Thorsten Dahlheimer.
11800 @d s_scale 64 /* the serial numbers are multiplied by this factor */
11801 @d max_indep_vars 0177777777 /* $2^{25}-1$ */
11802 @d max_serial_no 017777777700 /* |max_indep_vars*s_scale| */
11803 @d new_indep(A) /* create a new independent variable */
11804 { if ( mp->serial_no==max_serial_no )
11805 mp_fatal_error(mp, "variable instance identifiers exhausted");
11806 type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
11807 value((A))=mp->serial_no;
11811 integer serial_no; /* the most recent serial number, times |s_scale| */
11813 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
11815 @ But how are dependency lists represented? It's simple: The linear combination
11816 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
11817 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
11818 @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
11819 of $\alpha_1$; and |link(p)| points to the dependency list
11820 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
11821 then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
11822 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
11823 they appear in decreasing order of their |value| fields (i.e., of
11824 their serial numbers). \ (It is convenient to use decreasing order,
11825 since |value(null)=0|. If the independent variables were not sorted by
11826 serial number but by some other criterion, such as their location in |mem|,
11827 the equation-solving mechanism would be too system-dependent, because
11828 the ordering can affect the computed results.)
11830 The |link| field in the node that contains the constant term $\beta$ is
11831 called the {\sl final link\/} of the dependency list. \MP\ maintains
11832 a doubly-linked master list of all dependency lists, in terms of a permanently
11834 in |mem| called |dep_head|. If there are no dependencies, we have
11835 |link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
11836 otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
11837 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
11838 points to its dependency list. If the final link of that dependency list
11839 occurs in location~|q|, then |link(q)| points to the next dependent
11840 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
11842 @d dep_list(A) link(value_loc((A)))
11843 /* half of the |value| field in a |dependent| variable */
11844 @d prev_dep(A) info(value_loc((A)))
11845 /* the other half; makes a doubly linked list */
11846 @d dep_node_size 2 /* the number of words per dependency node */
11848 @<Initialize table entries...@>= mp->serial_no=0;
11849 link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
11850 info(dep_head)=null; dep_list(dep_head)=null;
11852 @ Actually the description above contains a little white lie. There's
11853 another kind of variable called |mp_proto_dependent|, which is
11854 just like a |dependent| one except that the $\alpha$ coefficients
11855 in its dependency list are |scaled| instead of being fractions.
11856 Proto-dependency lists are mixed with dependency lists in the
11857 nodes reachable from |dep_head|.
11859 @ Here is a procedure that prints a dependency list in symbolic form.
11860 The second parameter should be either |dependent| or |mp_proto_dependent|,
11861 to indicate the scaling of the coefficients.
11863 @<Declare subroutines for printing expressions@>=
11864 void mp_print_dependency (MP mp,pointer p, small_number t) {
11865 integer v; /* a coefficient */
11866 pointer pp,q; /* for list manipulation */
11869 v=abs(value(p)); q=info(p);
11870 if ( q==null ) { /* the constant term */
11871 if ( (v!=0)||(p==pp) ) {
11872 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, '+');
11873 mp_print_scaled(mp, value(p));
11877 @<Print the coefficient, unless it's $\pm1.0$@>;
11878 if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
11879 @:this can't happen dep}{\quad dep@>
11880 mp_print_variable_name(mp, q); v=value(q) % s_scale;
11881 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
11886 @ @<Print the coefficient, unless it's $\pm1.0$@>=
11887 if ( value(p)<0 ) mp_print_char(mp, '-');
11888 else if ( p!=pp ) mp_print_char(mp, '+');
11889 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
11890 if ( v!=unity ) mp_print_scaled(mp, v)
11892 @ The maximum absolute value of a coefficient in a given dependency list
11893 is returned by the following simple function.
11895 @c fraction mp_max_coef (MP mp,pointer p) {
11896 fraction x; /* the maximum so far */
11898 while ( info(p)!=null ) {
11899 if ( abs(value(p))>x ) x=abs(value(p));
11905 @ One of the main operations needed on dependency lists is to add a multiple
11906 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
11907 to dependency lists and |f| is a fraction.
11909 If the coefficient of any independent variable becomes |coef_bound| or
11910 more, in absolute value, this procedure changes the type of that variable
11911 to `|independent_needing_fix|', and sets the global variable |fix_needed|
11912 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
11913 $\mu^2+\mu<8$; this means that the numbers we deal with won't
11914 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
11915 2.3723$, the safer value 7/3 is taken as the threshold.)
11917 The changes mentioned in the preceding paragraph are actually done only if
11918 the global variable |watch_coefs| is |true|. But it usually is; in fact,
11919 it is |false| only when \MP\ is making a dependency list that will soon
11920 be equated to zero.
11922 Several procedures that act on dependency lists, including |p_plus_fq|,
11923 set the global variable |dep_final| to the final (constant term) node of
11924 the dependency list that they produce.
11926 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
11927 @d independent_needing_fix 0
11930 boolean fix_needed; /* does at least one |independent| variable need scaling? */
11931 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
11932 pointer dep_final; /* location of the constant term and final link */
11935 mp->fix_needed=false; mp->watch_coefs=true;
11937 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
11938 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
11939 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
11940 should be |mp_proto_dependent| if |q| is a proto-dependency list.
11942 List |q| is unchanged by the operation; but list |p| is totally destroyed.
11944 The final link of the dependency list or proto-dependency list returned
11945 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
11946 constant term of the result will be located in the same |mem| location
11947 as the original constant term of~|p|.
11949 Coefficients of the result are assumed to be zero if they are less than
11950 a certain threshold. This compensates for inevitable rounding errors,
11951 and tends to make more variables `|known|'. The threshold is approximately
11952 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
11953 proto-dependencies.
11955 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
11956 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
11957 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
11958 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
11960 @<Declare basic dependency-list subroutines@>=
11961 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
11962 pointer q, small_number t, small_number tt) ;
11965 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
11966 pointer q, small_number t, small_number tt) {
11967 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
11968 pointer r,s; /* for list manipulation */
11969 integer mp_threshold; /* defines a neighborhood of zero */
11970 integer v; /* temporary register */
11971 if ( t==mp_dependent ) mp_threshold=fraction_threshold;
11972 else mp_threshold=scaled_threshold;
11973 r=temp_head; pp=info(p); qq=info(q);
11979 @<Contribute a term from |p|, plus |f| times the
11980 corresponding term from |q|@>
11982 } else if ( value(pp)<value(qq) ) {
11983 @<Contribute a term from |q|, multiplied by~|f|@>
11985 link(r)=p; r=p; p=link(p); pp=info(p);
11988 if ( t==mp_dependent )
11989 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
11991 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
11992 link(r)=p; mp->dep_final=p;
11993 return link(temp_head);
11996 @ @<Contribute a term from |p|, plus |f|...@>=
11998 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
11999 else v=value(p)+mp_take_scaled(mp, f,value(q));
12000 value(p)=v; s=p; p=link(p);
12001 if ( abs(v)<mp_threshold ) {
12002 mp_free_node(mp, s,dep_node_size);
12004 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12005 type(qq)=independent_needing_fix; mp->fix_needed=true;
12009 pp=info(p); q=link(q); qq=info(q);
12012 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12014 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12015 else v=mp_take_scaled(mp, f,value(q));
12016 if ( abs(v)>halfp(mp_threshold) ) {
12017 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
12018 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12019 type(qq)=independent_needing_fix; mp->fix_needed=true;
12023 q=link(q); qq=info(q);
12026 @ It is convenient to have another subroutine for the special case
12027 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12028 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12030 @c pointer mp_p_plus_q (MP mp,pointer p, pointer q, small_number t) {
12031 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12032 pointer r,s; /* for list manipulation */
12033 integer mp_threshold; /* defines a neighborhood of zero */
12034 integer v; /* temporary register */
12035 if ( t==mp_dependent ) mp_threshold=fraction_threshold;
12036 else mp_threshold=scaled_threshold;
12037 r=temp_head; pp=info(p); qq=info(q);
12043 @<Contribute a term from |p|, plus the
12044 corresponding term from |q|@>
12046 } else if ( value(pp)<value(qq) ) {
12047 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
12048 q=link(q); qq=info(q); link(r)=s; r=s;
12050 link(r)=p; r=p; p=link(p); pp=info(p);
12053 value(p)=mp_slow_add(mp, value(p),value(q));
12054 link(r)=p; mp->dep_final=p;
12055 return link(temp_head);
12058 @ @<Contribute a term from |p|, plus the...@>=
12060 v=value(p)+value(q);
12061 value(p)=v; s=p; p=link(p); pp=info(p);
12062 if ( abs(v)<mp_threshold ) {
12063 mp_free_node(mp, s,dep_node_size);
12065 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12066 type(qq)=independent_needing_fix; mp->fix_needed=true;
12070 q=link(q); qq=info(q);
12073 @ A somewhat simpler routine will multiply a dependency list
12074 by a given constant~|v|. The constant is either a |fraction| less than
12075 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12076 convert a dependency list to a proto-dependency list.
12077 Parameters |t0| and |t1| are the list types before and after;
12078 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12079 and |v_is_scaled=true|.
12081 @c pointer mp_p_times_v (MP mp,pointer p, integer v, small_number t0,
12082 small_number t1, boolean v_is_scaled) {
12083 pointer r,s; /* for list manipulation */
12084 integer w; /* tentative coefficient */
12085 integer mp_threshold;
12086 boolean scaling_down;
12087 if ( t0!=t1 ) scaling_down=true; else scaling_down=! v_is_scaled;
12088 if ( t1==mp_dependent ) mp_threshold=half_fraction_threshold;
12089 else mp_threshold=half_scaled_threshold;
12091 while ( info(p)!=null ) {
12092 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12093 else w=mp_take_scaled(mp, v,value(p));
12094 if ( abs(w)<=mp_threshold ) {
12095 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12097 if ( abs(w)>=coef_bound ) {
12098 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12100 link(r)=p; r=p; value(p)=w; p=link(p);
12104 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12105 else value(p)=mp_take_fraction(mp, value(p),v);
12106 return link(temp_head);
12109 @ Similarly, we sometimes need to divide a dependency list
12110 by a given |scaled| constant.
12112 @<Declare basic dependency-list subroutines@>=
12113 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12114 t0, small_number t1) ;
12117 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12118 t0, small_number t1) {
12119 pointer r,s; /* for list manipulation */
12120 integer w; /* tentative coefficient */
12121 integer mp_threshold;
12122 boolean scaling_down;
12123 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12124 if ( t1==mp_dependent ) mp_threshold=half_fraction_threshold;
12125 else mp_threshold=half_scaled_threshold;
12127 while ( info( p)!=null ) {
12128 if ( scaling_down ) {
12129 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12130 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12132 w=mp_make_scaled(mp, value(p),v);
12134 if ( abs(w)<=mp_threshold ) {
12135 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12137 if ( abs(w)>=coef_bound ) {
12138 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12140 link(r)=p; r=p; value(p)=w; p=link(p);
12143 link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12144 return link(temp_head);
12147 @ Here's another utility routine for dependency lists. When an independent
12148 variable becomes dependent, we want to remove it from all existing
12149 dependencies. The |p_with_x_becoming_q| function computes the
12150 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12152 This procedure has basically the same calling conventions as |p_plus_fq|:
12153 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12154 final link are inherited from~|p|; and the fourth parameter tells whether
12155 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12156 is not altered if |x| does not occur in list~|p|.
12158 @c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12159 pointer x, pointer q, small_number t) {
12160 pointer r,s; /* for list manipulation */
12161 integer v; /* coefficient of |x| */
12162 integer sx; /* serial number of |x| */
12163 s=p; r=temp_head; sx=value(x);
12164 while ( value(info(s))>sx ) { r=s; s=link(s); };
12165 if ( info(s)!=x ) {
12168 link(temp_head)=p; link(r)=link(s); v=value(s);
12169 mp_free_node(mp, s,dep_node_size);
12170 return mp_p_plus_fq(mp, link(temp_head),v,q,t,mp_dependent);
12174 @ Here's a simple procedure that reports an error when a variable
12175 has just received a known value that's out of the required range.
12177 @<Declare basic dependency-list subroutines@>=
12178 void mp_val_too_big (MP mp,scaled x) ;
12180 @ @c void mp_val_too_big (MP mp,scaled x) {
12181 if ( mp->internal[mp_warning_check]>0 ) {
12182 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, ')');
12183 @.Value is too large@>
12184 help4("The equation I just processed has given some variable")
12185 ("a value of 4096 or more. Continue and I'll try to cope")
12186 ("with that big value; but it might be dangerous.")
12187 ("(Set warningcheck:=0 to suppress this message.)");
12192 @ When a dependent variable becomes known, the following routine
12193 removes its dependency list. Here |p| points to the variable, and
12194 |q| points to the dependency list (which is one node long).
12196 @<Declare basic dependency-list subroutines@>=
12197 void mp_make_known (MP mp,pointer p, pointer q) ;
12199 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12200 int t; /* the previous type */
12201 prev_dep(link(q))=prev_dep(p);
12202 link(prev_dep(p))=link(q); t=type(p);
12203 type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12204 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12205 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12206 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12207 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12208 mp_print_variable_name(mp, p);
12209 mp_print_char(mp, '='); mp_print_scaled(mp, value(p));
12210 mp_end_diagnostic(mp, false);
12212 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12213 mp->cur_type=mp_known; mp->cur_exp=value(p);
12214 mp_free_node(mp, p,value_node_size);
12218 @ The |fix_dependencies| routine is called into action when |fix_needed|
12219 has been triggered. The program keeps a list~|s| of independent variables
12220 whose coefficients must be divided by~4.
12222 In unusual cases, this fixup process might reduce one or more coefficients
12223 to zero, so that a variable will become known more or less by default.
12225 @<Declare basic dependency-list subroutines@>=
12226 void mp_fix_dependencies (MP mp);
12228 @ @c void mp_fix_dependencies (MP mp) {
12229 pointer p,q,r,s,t; /* list manipulation registers */
12230 pointer x; /* an independent variable */
12231 r=link(dep_head); s=null;
12232 while ( r!=dep_head ){
12234 @<Run through the dependency list for variable |t|, fixing
12235 all nodes, and ending with final link~|q|@>;
12237 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12239 while ( s!=null ) {
12240 p=link(s); x=info(s); free_avail(s); s=p;
12241 type(x)=mp_independent; value(x)=value(x)+2;
12243 mp->fix_needed=false;
12246 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12248 @<Run through the dependency list for variable |t|...@>=
12249 r=value_loc(t); /* |link(r)=dep_list(t)| */
12251 q=link(r); x=info(q);
12252 if ( x==null ) break;
12253 if ( type(x)<=independent_being_fixed ) {
12254 if ( type(x)<independent_being_fixed ) {
12255 p=mp_get_avail(mp); link(p)=s; s=p;
12256 info(s)=x; type(x)=independent_being_fixed;
12258 value(q)=value(q) / 4;
12259 if ( value(q)==0 ) {
12260 link(r)=link(q); mp_free_node(mp, q,dep_node_size); q=r;
12267 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12268 linking it into the list of all known dependencies. We assume that
12269 |dep_final| points to the final node of list~|p|.
12271 @c void mp_new_dep (MP mp,pointer q, pointer p) {
12272 pointer r; /* what used to be the first dependency */
12273 dep_list(q)=p; prev_dep(q)=dep_head;
12274 r=link(dep_head); link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12278 @ Here is one of the ways a dependency list gets started.
12279 The |const_dependency| routine produces a list that has nothing but
12282 @c pointer mp_const_dependency (MP mp, scaled v) {
12283 mp->dep_final=mp_get_node(mp, dep_node_size);
12284 value(mp->dep_final)=v; info(mp->dep_final)=null;
12285 return mp->dep_final;
12288 @ And here's a more interesting way to start a dependency list from scratch:
12289 The parameter to |single_dependency| is the location of an
12290 independent variable~|x|, and the result is the simple dependency list
12293 In the unlikely event that the given independent variable has been doubled so
12294 often that we can't refer to it with a nonzero coefficient,
12295 |single_dependency| returns the simple list `0'. This case can be
12296 recognized by testing that the returned list pointer is equal to
12299 @c pointer mp_single_dependency (MP mp,pointer p) {
12300 pointer q; /* the new dependency list */
12301 integer m; /* the number of doublings */
12302 m=value(p) % s_scale;
12304 return mp_const_dependency(mp, 0);
12306 q=mp_get_node(mp, dep_node_size);
12307 value(q)=two_to_the(28-m); info(q)=p;
12308 link(q)=mp_const_dependency(mp, 0);
12313 @ We sometimes need to make an exact copy of a dependency list.
12315 @c pointer mp_copy_dep_list (MP mp,pointer p) {
12316 pointer q; /* the new dependency list */
12317 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12319 info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
12320 if ( info(mp->dep_final)==null ) break;
12321 link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12322 mp->dep_final=link(mp->dep_final); p=link(p);
12327 @ But how do variables normally become known? Ah, now we get to the heart of the
12328 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12329 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12330 appears. It equates this list to zero, by choosing an independent variable
12331 with the largest coefficient and making it dependent on the others. The
12332 newly dependent variable is eliminated from all current dependencies,
12333 thereby possibly making other dependent variables known.
12335 The given list |p| is, of course, totally destroyed by all this processing.
12337 @c void mp_linear_eq (MP mp, pointer p, small_number t) {
12338 pointer q,r,s; /* for link manipulation */
12339 pointer x; /* the variable that loses its independence */
12340 integer n; /* the number of times |x| had been halved */
12341 integer v; /* the coefficient of |x| in list |p| */
12342 pointer prev_r; /* lags one step behind |r| */
12343 pointer final_node; /* the constant term of the new dependency list */
12344 integer w; /* a tentative coefficient */
12345 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12346 x=info(q); n=value(x) % s_scale;
12347 @<Divide list |p| by |-v|, removing node |q|@>;
12348 if ( mp->internal[mp_tracing_equations]>0 ) {
12349 @<Display the new dependency@>;
12351 @<Simplify all existing dependencies by substituting for |x|@>;
12352 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12353 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12356 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12357 q=p; r=link(p); v=value(q);
12358 while ( info(r)!=null ) {
12359 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12363 @ Here we want to change the coefficients from |scaled| to |fraction|,
12364 except in the constant term. In the common case of a trivial equation
12365 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12367 @<Divide list |p| by |-v|, removing node |q|@>=
12368 s=temp_head; link(s)=p; r=p;
12371 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12373 w=mp_make_fraction(mp, value(r),v);
12374 if ( abs(w)<=half_fraction_threshold ) {
12375 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12381 } while (info(r)!=null);
12382 if ( t==mp_proto_dependent ) {
12383 value(r)=-mp_make_scaled(mp, value(r),v);
12384 } else if ( v!=-fraction_one ) {
12385 value(r)=-mp_make_fraction(mp, value(r),v);
12387 final_node=r; p=link(temp_head)
12389 @ @<Display the new dependency@>=
12390 if ( mp_interesting(mp, x) ) {
12391 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12392 mp_print_variable_name(mp, x);
12393 @:]]]\#\#_}{\.{\#\#}@>
12395 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12396 mp_print_char(mp, '='); mp_print_dependency(mp, p,mp_dependent);
12397 mp_end_diagnostic(mp, false);
12400 @ @<Simplify all existing dependencies by substituting for |x|@>=
12401 prev_r=dep_head; r=link(dep_head);
12402 while ( r!=dep_head ) {
12403 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
12404 if ( info(q)==null ) {
12405 mp_make_known(mp, r,q);
12408 do { q=link(q); } while (info(q)!=null);
12414 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12415 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12416 if ( info(p)==null ) {
12419 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12420 mp_free_node(mp, p,dep_node_size);
12421 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12422 mp->cur_exp=value(x); mp->cur_type=mp_known;
12423 mp_free_node(mp, x,value_node_size);
12426 type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12427 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12430 @ @<Divide list |p| by $2^n$@>=
12432 s=temp_head; link(temp_head)=p; r=p;
12435 else w=value(r) / two_to_the(n);
12436 if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
12438 mp_free_node(mp, r,dep_node_size);
12443 } while (info(s)!=null);
12447 @ The |check_mem| procedure, which is used only when \MP\ is being
12448 debugged, makes sure that the current dependency lists are well formed.
12450 @<Check the list of linear dependencies@>=
12451 q=dep_head; p=link(q);
12452 while ( p!=dep_head ) {
12453 if ( prev_dep(p)!=q ) {
12454 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12459 r=info(p); q=p; p=link(q);
12460 if ( r==null ) break;
12461 if ( value(info(p))>=value(r) ) {
12462 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12463 @.Out of order...@>
12468 @* \[25] Dynamic nonlinear equations.
12469 Variables of numeric type are maintained by the general scheme of
12470 independent, dependent, and known values that we have just studied;
12471 and the components of pair and transform variables are handled in the
12472 same way. But \MP\ also has five other types of values: \&{boolean},
12473 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12475 Equations are allowed between nonlinear quantities, but only in a
12476 simple form. Two variables that haven't yet been assigned values are
12477 either equal to each other, or they're not.
12479 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12480 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12481 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12482 |null| (which means that no other variables are equivalent to this one), or
12483 it points to another variable of the same undefined type. The pointers in the
12484 latter case form a cycle of nodes, which we shall call a ``ring.''
12485 Rings of undefined variables may include capsules, which arise as
12486 intermediate results within expressions or as \&{expr} parameters to macros.
12488 When one member of a ring receives a value, the same value is given to
12489 all the other members. In the case of paths and pictures, this implies
12490 making separate copies of a potentially large data structure; users should
12491 restrain their enthusiasm for such generality, unless they have lots and
12492 lots of memory space.
12494 @ The following procedure is called when a capsule node is being
12495 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12497 @c pointer mp_new_ring_entry (MP mp,pointer p) {
12498 pointer q; /* the new capsule node */
12499 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
12501 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12506 @ Conversely, we might delete a capsule or a variable before it becomes known.
12507 The following procedure simply detaches a quantity from its ring,
12508 without recycling the storage.
12510 @<Declare the recycling subroutines@>=
12511 void mp_ring_delete (MP mp,pointer p) {
12514 if ( q!=null ) if ( q!=p ){
12515 while ( value(q)!=p ) q=value(q);
12520 @ Eventually there might be an equation that assigns values to all of the
12521 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12522 propagation of values.
12524 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12525 value, it will soon be recycled.
12527 @c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12528 small_number t; /* the type of ring |p| */
12529 pointer q,r; /* link manipulation registers */
12530 t=type(p)-unknown_tag; q=value(p);
12531 if ( flush_p ) type(p)=mp_vacuous; else p=q;
12533 r=value(q); type(q)=t;
12535 case mp_boolean_type: value(q)=v; break;
12536 case mp_string_type: value(q)=v; add_str_ref(v); break;
12537 case mp_pen_type: value(q)=copy_pen(v); break;
12538 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12539 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12540 } /* there ain't no more cases */
12545 @ If two members of rings are equated, and if they have the same type,
12546 the |ring_merge| procedure is called on to make them equivalent.
12548 @c void mp_ring_merge (MP mp,pointer p, pointer q) {
12549 pointer r; /* traverses one list */
12553 @<Exclaim about a redundant equation@>;
12558 r=value(p); value(p)=value(q); value(q)=r;
12561 @ @<Exclaim about a redundant equation@>=
12563 print_err("Redundant equation");
12564 @.Redundant equation@>
12565 help2("I already knew that this equation was true.")
12566 ("But perhaps no harm has been done; let's continue.");
12567 mp_put_get_error(mp);
12570 @* \[26] Introduction to the syntactic routines.
12571 Let's pause a moment now and try to look at the Big Picture.
12572 The \MP\ program consists of three main parts: syntactic routines,
12573 semantic routines, and output routines. The chief purpose of the
12574 syntactic routines is to deliver the user's input to the semantic routines,
12575 while parsing expressions and locating operators and operands. The
12576 semantic routines act as an interpreter responding to these operators,
12577 which may be regarded as commands. And the output routines are
12578 periodically called on to produce compact font descriptions that can be
12579 used for typesetting or for making interim proof drawings. We have
12580 discussed the basic data structures and many of the details of semantic
12581 operations, so we are good and ready to plunge into the part of \MP\ that
12582 actually controls the activities.
12584 Our current goal is to come to grips with the |get_next| procedure,
12585 which is the keystone of \MP's input mechanism. Each call of |get_next|
12586 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12587 representing the next input token.
12588 $$\vbox{\halign{#\hfil\cr
12589 \hbox{|cur_cmd| denotes a command code from the long list of codes
12591 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12592 \hbox{|cur_sym| is the hash address of the symbolic token that was
12594 \hbox{\qquad or zero in the case of a numeric or string
12595 or capsule token.}\cr}}$$
12596 Underlying this external behavior of |get_next| is all the machinery
12597 necessary to convert from character files to tokens. At a given time we
12598 may be only partially finished with the reading of several files (for
12599 which \&{input} was specified), and partially finished with the expansion
12600 of some user-defined macros and/or some macro parameters, and partially
12601 finished reading some text that the user has inserted online,
12602 and so on. When reading a character file, the characters must be
12603 converted to tokens; comments and blank spaces must
12604 be removed, numeric and string tokens must be evaluated.
12606 To handle these situations, which might all be present simultaneously,
12607 \MP\ uses various stacks that hold information about the incomplete
12608 activities, and there is a finite state control for each level of the
12609 input mechanism. These stacks record the current state of an implicitly
12610 recursive process, but the |get_next| procedure is not recursive.
12613 eight_bits cur_cmd; /* current command set by |get_next| */
12614 integer cur_mod; /* operand of current command */
12615 halfword cur_sym; /* hash address of current symbol */
12617 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12618 command code and its modifier.
12619 It consists of a rather tedious sequence of print
12620 commands, and most of it is essentially an inverse to the |primitive|
12621 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12622 all of this procedure appears elsewhere in the program, together with the
12623 corresponding |primitive| calls.
12625 @<Declare the procedure called |print_cmd_mod|@>=
12626 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12628 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12629 default: mp_print(mp, "[unknown command code!]"); break;
12633 @ Here is a procedure that displays a given command in braces, in the
12634 user's transcript file.
12636 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12639 void mp_show_cmd_mod (MP mp,integer c, integer m) {
12640 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12641 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, '}');
12642 mp_end_diagnostic(mp, false);
12645 @* \[27] Input stacks and states.
12646 The state of \MP's input mechanism appears in the input stack, whose
12647 entries are records with five fields, called |index|, |start|, |loc|,
12648 |limit|, and |name|. The top element of this stack is maintained in a
12649 global variable for which no subscripting needs to be done; the other
12650 elements of the stack appear in an array. Hence the stack is declared thus:
12654 quarterword index_field;
12655 halfword start_field, loc_field, limit_field, name_field;
12659 in_state_record *input_stack;
12660 integer input_ptr; /* first unused location of |input_stack| */
12661 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12662 in_state_record cur_input; /* the ``top'' input state */
12663 int stack_size; /* maximum number of simultaneous input sources */
12665 @ @<Allocate or initialize ...@>=
12666 mp->stack_size = 300;
12667 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12669 @ @<Dealloc variables@>=
12670 xfree(mp->input_stack);
12672 @ We've already defined the special variable |loc==cur_input.loc_field|
12673 in our discussion of basic input-output routines. The other components of
12674 |cur_input| are defined in the same way:
12676 @d index mp->cur_input.index_field /* reference for buffer information */
12677 @d start mp->cur_input.start_field /* starting position in |buffer| */
12678 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12679 @d name mp->cur_input.name_field /* name of the current file */
12681 @ Let's look more closely now at the five control variables
12682 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12683 assuming that \MP\ is reading a line of characters that have been input
12684 from some file or from the user's terminal. There is an array called
12685 |buffer| that acts as a stack of all lines of characters that are
12686 currently being read from files, including all lines on subsidiary
12687 levels of the input stack that are not yet completed. \MP\ will return to
12688 the other lines when it is finished with the present input file.
12690 (Incidentally, on a machine with byte-oriented addressing, it would be
12691 appropriate to combine |buffer| with the |str_pool| array,
12692 letting the buffer entries grow downward from the top of the string pool
12693 and checking that these two tables don't bump into each other.)
12695 The line we are currently working on begins in position |start| of the
12696 buffer; the next character we are about to read is |buffer[loc]|; and
12697 |limit| is the location of the last character present. We always have
12698 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12699 that the end of a line is easily sensed.
12701 The |name| variable is a string number that designates the name of
12702 the current file, if we are reading an ordinary text file. Special codes
12703 |is_term..max_spec_src| indicate other sources of input text.
12705 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12706 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12707 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12708 @d max_spec_src is_scantok
12710 @ Additional information about the current line is available via the
12711 |index| variable, which counts how many lines of characters are present
12712 in the buffer below the current level. We have |index=0| when reading
12713 from the terminal and prompting the user for each line; then if the user types,
12714 e.g., `\.{input figs}', we will have |index=1| while reading
12715 the file \.{figs.mp}. However, it does not follow that |index| is the
12716 same as the input stack pointer, since many of the levels on the input
12717 stack may come from token lists and some |index| values may correspond
12718 to \.{MPX} files that are not currently on the stack.
12720 The global variable |in_open| is equal to the highest |index| value counting
12721 \.{MPX} files but excluding token-list input levels. Thus, the number of
12722 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12723 when we are not reading a token list.
12725 If we are not currently reading from the terminal,
12726 we are reading from the file variable |input_file[index]|. We use
12727 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12728 and |cur_file| as an abbreviation for |input_file[index]|.
12730 When \MP\ is not reading from the terminal, the global variable |line| contains
12731 the line number in the current file, for use in error messages. More precisely,
12732 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12733 the line number for each file in the |input_file| array.
12735 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12736 array so that the name doesn't get lost when the file is temporarily removed
12737 from the input stack.
12738 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12739 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12740 Since this is not an \.{MPX} file, we have
12741 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12742 This |name| field is set to |finished| when |input_file[k]| is completely
12745 If more information about the input state is needed, it can be
12746 included in small arrays like those shown here. For example,
12747 the current page or segment number in the input file might be put
12748 into a variable |page|, that is really a macro for the current entry
12749 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12750 by analogy with |line_stack|.
12751 @^system dependencies@>
12753 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12754 @d cur_file mp->input_file[index] /* the current |FILE *| variable */
12755 @d line mp->line_stack[index] /* current line number in the current source file */
12756 @d in_name mp->iname_stack[index] /* a string used to construct \.{MPX} file names */
12757 @d in_area mp->iarea_stack[index] /* another string for naming \.{MPX} files */
12758 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12759 @d mpx_reading (mp->mpx_name[index]>absent)
12760 /* when reading a file, is it an \.{MPX} file? */
12762 /* |name_field| value when the corresponding \.{MPX} file is finished */
12765 integer in_open; /* the number of lines in the buffer, less one */
12766 unsigned int open_parens; /* the number of open text files */
12767 FILE * *input_file ;
12768 integer *line_stack ; /* the line number for each file */
12769 char * *iname_stack; /* used for naming \.{MPX} files */
12770 char * *iarea_stack; /* used for naming \.{MPX} files */
12771 halfword*mpx_name ;
12773 @ @<Allocate or ...@>=
12774 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(FILE *));
12775 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
12776 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12777 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12778 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
12781 for (k=0;k<=mp->max_in_open;k++) {
12782 mp->iname_stack[k] =NULL;
12783 mp->iarea_stack[k] =NULL;
12787 @ @<Dealloc variables@>=
12790 for (l=0;l<=mp->max_in_open;l++) {
12791 xfree(mp->iname_stack[l]);
12792 xfree(mp->iarea_stack[l]);
12795 xfree(mp->input_file);
12796 xfree(mp->line_stack);
12797 xfree(mp->iname_stack);
12798 xfree(mp->iarea_stack);
12799 xfree(mp->mpx_name);
12802 @ However, all this discussion about input state really applies only to the
12803 case that we are inputting from a file. There is another important case,
12804 namely when we are currently getting input from a token list. In this case
12805 |index>max_in_open|, and the conventions about the other state variables
12808 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
12809 the node that will be read next. If |loc=null|, the token list has been
12812 \yskip\hang|start| points to the first node of the token list; this node
12813 may or may not contain a reference count, depending on the type of token
12816 \yskip\hang|token_type|, which takes the place of |index| in the
12817 discussion above, is a code number that explains what kind of token list
12820 \yskip\hang|name| points to the |eqtb| address of the control sequence
12821 being expanded, if the current token list is a macro not defined by
12822 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
12823 can be deduced by looking at their first two parameters.
12825 \yskip\hang|param_start|, which takes the place of |limit|, tells where
12826 the parameters of the current macro or loop text begin in the |param_stack|.
12828 \yskip\noindent The |token_type| can take several values, depending on
12829 where the current token list came from:
12832 \indent|forever_text|, if the token list being scanned is the body of
12833 a \&{forever} loop;
12835 \indent|loop_text|, if the token list being scanned is the body of
12836 a \&{for} or \&{forsuffixes} loop;
12838 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
12840 \indent|backed_up|, if the token list being scanned has been inserted as
12841 `to be read again'.
12843 \indent|inserted|, if the token list being scanned has been inserted as
12844 part of error recovery;
12846 \indent|macro|, if the expansion of a user-defined symbolic token is being
12850 The token list begins with a reference count if and only if |token_type=
12852 @^reference counts@>
12854 @d token_type index /* type of current token list */
12855 @d token_state (index>(int)mp->max_in_open) /* are we scanning a token list? */
12856 @d file_state (index<=(int)mp->max_in_open) /* are we scanning a file line? */
12857 @d param_start limit /* base of macro parameters in |param_stack| */
12858 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
12859 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
12860 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
12861 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
12862 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
12863 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
12865 @ The |param_stack| is an auxiliary array used to hold pointers to the token
12866 lists for parameters at the current level and subsidiary levels of input.
12867 This stack grows at a different rate from the others.
12870 pointer *param_stack; /* token list pointers for parameters */
12871 integer param_ptr; /* first unused entry in |param_stack| */
12872 integer max_param_stack; /* largest value of |param_ptr| */
12874 @ @<Allocate or initialize ...@>=
12875 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
12877 @ @<Dealloc variables@>=
12878 xfree(mp->param_stack);
12880 @ Notice that the |line| isn't valid when |token_state| is true because it
12881 depends on |index|. If we really need to know the line number for the
12882 topmost file in the index stack we use the following function. If a page
12883 number or other information is needed, this routine should be modified to
12884 compute it as well.
12885 @^system dependencies@>
12887 @<Declare a function called |true_line|@>=
12888 integer mp_true_line (MP mp) {
12889 int k; /* an index into the input stack */
12890 if ( file_state && (name>max_spec_src) ) {
12895 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
12896 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
12899 return mp->line_stack[(k-1)];
12904 @ Thus, the ``current input state'' can be very complicated indeed; there
12905 can be many levels and each level can arise in a variety of ways. The
12906 |show_context| procedure, which is used by \MP's error-reporting routine to
12907 print out the current input state on all levels down to the most recent
12908 line of characters from an input file, illustrates most of these conventions.
12909 The global variable |file_ptr| contains the lowest level that was
12910 displayed by this procedure.
12913 integer file_ptr; /* shallowest level shown by |show_context| */
12915 @ The status at each level is indicated by printing two lines, where the first
12916 line indicates what was read so far and the second line shows what remains
12917 to be read. The context is cropped, if necessary, so that the first line
12918 contains at most |half_error_line| characters, and the second contains
12919 at most |error_line|. Non-current input levels whose |token_type| is
12920 `|backed_up|' are shown only if they have not been fully read.
12922 @c void mp_show_context (MP mp) { /* prints where the scanner is */
12923 int old_setting; /* saved |selector| setting */
12924 @<Local variables for formatting calculations@>
12925 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
12926 /* store current state */
12928 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
12929 @<Display the current context@>;
12931 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
12932 decr(mp->file_ptr);
12934 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
12937 @ @<Display the current context@>=
12938 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
12939 (token_type!=backed_up) || (loc!=null) ) {
12940 /* we omit backed-up token lists that have already been read */
12941 mp->tally=0; /* get ready to count characters */
12942 old_setting=mp->selector;
12943 if ( file_state ) {
12944 @<Print location of current line@>;
12945 @<Pseudoprint the line@>;
12947 @<Print type of token list@>;
12948 @<Pseudoprint the token list@>;
12950 mp->selector=old_setting; /* stop pseudoprinting */
12951 @<Print two lines using the tricky pseudoprinted information@>;
12954 @ This routine should be changed, if necessary, to give the best possible
12955 indication of where the current line resides in the input file.
12956 For example, on some systems it is best to print both a page and line number.
12957 @^system dependencies@>
12959 @<Print location of current line@>=
12960 if ( name>max_spec_src ) {
12961 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
12962 } else if ( terminal_input ) {
12963 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
12964 else mp_print_nl(mp, "<insert>");
12965 } else if ( name==is_scantok ) {
12966 mp_print_nl(mp, "<scantokens>");
12968 mp_print_nl(mp, "<read>");
12970 mp_print_char(mp, ' ')
12972 @ Can't use case statement here because the |token_type| is not
12973 a constant expression.
12975 @<Print type of token list@>=
12977 if(token_type==forever_text) {
12978 mp_print_nl(mp, "<forever> ");
12979 } else if (token_type==loop_text) {
12980 @<Print the current loop value@>;
12981 } else if (token_type==parameter) {
12982 mp_print_nl(mp, "<argument> ");
12983 } else if (token_type==backed_up) {
12984 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
12985 else mp_print_nl(mp, "<to be read again> ");
12986 } else if (token_type==inserted) {
12987 mp_print_nl(mp, "<inserted text> ");
12988 } else if (token_type==macro) {
12990 if ( name!=null ) mp_print_text(name);
12991 else @<Print the name of a \&{vardef}'d macro@>;
12992 mp_print(mp, "->");
12994 mp_print_nl(mp, "?");/* this should never happen */
12999 @ The parameter that corresponds to a loop text is either a token list
13000 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13001 We'll discuss capsules later; for now, all we need to know is that
13002 the |link| field in a capsule parameter is |void| and that
13003 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13005 @<Print the current loop value@>=
13006 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13008 if ( link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13009 else mp_show_token_list(mp, p,null,20,mp->tally);
13011 mp_print(mp, ")> ");
13014 @ The first two parameters of a macro defined by \&{vardef} will be token
13015 lists representing the macro's prefix and ``at point.'' By putting these
13016 together, we get the macro's full name.
13018 @<Print the name of a \&{vardef}'d macro@>=
13019 { p=mp->param_stack[param_start];
13021 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13024 while ( link(q)!=null ) q=link(q);
13025 link(q)=mp->param_stack[param_start+1];
13026 mp_show_token_list(mp, p,null,20,mp->tally);
13031 @ Now it is necessary to explain a little trick. We don't want to store a long
13032 string that corresponds to a token list, because that string might take up
13033 lots of memory; and we are printing during a time when an error message is
13034 being given, so we dare not do anything that might overflow one of \MP's
13035 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13036 that stores characters into a buffer of length |error_line|, where character
13037 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13038 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13039 |tally:=0| and |trick_count:=1000000|; then when we reach the
13040 point where transition from line 1 to line 2 should occur, we
13041 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13042 tally+1+error_line-half_error_line)|. At the end of the
13043 pseudoprinting, the values of |first_count|, |tally|, and
13044 |trick_count| give us all the information we need to print the two lines,
13045 and all of the necessary text is in |trick_buf|.
13047 Namely, let |l| be the length of the descriptive information that appears
13048 on the first line. The length of the context information gathered for that
13049 line is |k=first_count|, and the length of the context information
13050 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13051 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13052 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13053 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13054 and print `\.{...}' followed by
13055 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13056 where subscripts of |trick_buf| are circular modulo |error_line|. The
13057 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13058 unless |n+m>error_line|; in the latter case, further cropping is done.
13059 This is easier to program than to explain.
13061 @<Local variables for formatting...@>=
13062 int i; /* index into |buffer| */
13063 integer l; /* length of descriptive information on line 1 */
13064 integer m; /* context information gathered for line 2 */
13065 int n; /* length of line 1 */
13066 integer p; /* starting or ending place in |trick_buf| */
13067 integer q; /* temporary index */
13069 @ The following code tells the print routines to gather
13070 the desired information.
13072 @d begin_pseudoprint {
13073 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13074 mp->trick_count=1000000;
13076 @d set_trick_count {
13077 mp->first_count=mp->tally;
13078 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13079 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13082 @ And the following code uses the information after it has been gathered.
13084 @<Print two lines using the tricky pseudoprinted information@>=
13085 if ( mp->trick_count==1000000 ) set_trick_count;
13086 /* |set_trick_count| must be performed */
13087 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13088 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13089 if ( l+mp->first_count<=mp->half_error_line ) {
13090 p=0; n=l+mp->first_count;
13092 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13093 n=mp->half_error_line;
13095 for (q=p;q<=mp->first_count-1;q++) {
13096 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13099 for (q=1;q<=n;q++) {
13100 mp_print_char(mp, ' '); /* print |n| spaces to begin line~2 */
13102 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13103 else p=mp->first_count+(mp->error_line-n-3);
13104 for (q=mp->first_count;q<=p-1;q++) {
13105 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13107 if ( m+n>mp->error_line ) mp_print(mp, "...")
13109 @ But the trick is distracting us from our current goal, which is to
13110 understand the input state. So let's concentrate on the data structures that
13111 are being pseudoprinted as we finish up the |show_context| procedure.
13113 @<Pseudoprint the line@>=
13116 for (i=start;i<=limit-1;i++) {
13117 if ( i==loc ) set_trick_count;
13118 mp_print_str(mp, mp->buffer[i]);
13122 @ @<Pseudoprint the token list@>=
13124 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13125 else mp_show_macro(mp, start,loc,100000)
13127 @ Here is the missing piece of |show_token_list| that is activated when the
13128 token beginning line~2 is about to be shown:
13130 @<Do magic computation@>=set_trick_count
13132 @* \[28] Maintaining the input stacks.
13133 The following subroutines change the input status in commonly needed ways.
13135 First comes |push_input|, which stores the current state and creates a
13136 new level (having, initially, the same properties as the old).
13138 @d push_input { /* enter a new input level, save the old */
13139 if ( mp->input_ptr>mp->max_in_stack ) {
13140 mp->max_in_stack=mp->input_ptr;
13141 if ( mp->input_ptr==mp->stack_size ) {
13142 int l = (mp->stack_size+(mp->stack_size>>2));
13143 XREALLOC(mp->input_stack, l, in_state_record);
13144 mp->stack_size = l;
13147 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13148 incr(mp->input_ptr);
13151 @ And of course what goes up must come down.
13153 @d pop_input { /* leave an input level, re-enter the old */
13154 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13157 @ Here is a procedure that starts a new level of token-list input, given
13158 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13159 set |name|, reset~|loc|, and increase the macro's reference count.
13161 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13163 @c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13164 push_input; start=p; token_type=t;
13165 param_start=mp->param_ptr; loc=p;
13168 @ When a token list has been fully scanned, the following computations
13169 should be done as we leave that level of input.
13172 @c void mp_end_token_list (MP mp) { /* leave a token-list input level */
13173 pointer p; /* temporary register */
13174 if ( token_type>=backed_up ) { /* token list to be deleted */
13175 if ( token_type<=inserted ) {
13176 mp_flush_token_list(mp, start); goto DONE;
13178 mp_delete_mac_ref(mp, start); /* update reference count */
13181 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13182 decr(mp->param_ptr);
13183 p=mp->param_stack[mp->param_ptr];
13185 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
13186 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13188 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13193 pop_input; check_interrupt;
13196 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13197 token by the |cur_tok| routine.
13200 @c @<Declare the procedure called |make_exp_copy|@>;
13201 pointer mp_cur_tok (MP mp) {
13202 pointer p; /* a new token node */
13203 small_number save_type; /* |cur_type| to be restored */
13204 integer save_exp; /* |cur_exp| to be restored */
13205 if ( mp->cur_sym==0 ) {
13206 if ( mp->cur_cmd==capsule_token ) {
13207 save_type=mp->cur_type; save_exp=mp->cur_exp;
13208 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); link(p)=null;
13209 mp->cur_type=save_type; mp->cur_exp=save_exp;
13211 p=mp_get_node(mp, token_node_size);
13212 value(p)=mp->cur_mod; name_type(p)=mp_token;
13213 if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
13214 else type(p)=mp_string_type;
13217 fast_get_avail(p); info(p)=mp->cur_sym;
13222 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13223 seen. The |back_input| procedure takes care of this by putting the token
13224 just scanned back into the input stream, ready to be read again.
13225 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13228 void mp_back_input (MP mp);
13230 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13231 pointer p; /* a token list of length one */
13233 while ( token_state &&(loc==null) )
13234 mp_end_token_list(mp); /* conserve stack space */
13238 @ The |back_error| routine is used when we want to restore or replace an
13239 offending token just before issuing an error message. We disable interrupts
13240 during the call of |back_input| so that the help message won't be lost.
13243 void mp_error (MP mp);
13244 void mp_back_error (MP mp);
13246 @ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
13247 mp->OK_to_interrupt=false;
13249 mp->OK_to_interrupt=true; mp_error(mp);
13251 void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13252 mp->OK_to_interrupt=false;
13253 mp_back_input(mp); token_type=inserted;
13254 mp->OK_to_interrupt=true; mp_error(mp);
13257 @ The |begin_file_reading| procedure starts a new level of input for lines
13258 of characters to be read from a file, or as an insertion from the
13259 terminal. It does not take care of opening the file, nor does it set |loc|
13260 or |limit| or |line|.
13261 @^system dependencies@>
13263 @c void mp_begin_file_reading (MP mp) {
13264 if ( mp->in_open==mp->max_in_open )
13265 mp_overflow(mp, "text input levels",mp->max_in_open);
13266 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13267 if ( mp->first==mp->buf_size )
13268 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13269 incr(mp->in_open); push_input; index=mp->in_open;
13270 mp->mpx_name[index]=absent;
13272 name=is_term; /* |terminal_input| is now |true| */
13275 @ Conversely, the variables must be downdated when such a level of input
13276 is finished. Any associated \.{MPX} file must also be closed and popped
13277 off the file stack.
13279 @c void mp_end_file_reading (MP mp) {
13280 if ( mp->in_open>index ) {
13281 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13282 mp_confusion(mp, "endinput");
13283 @:this can't happen endinput}{\quad endinput@>
13285 fclose(mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13286 delete_str_ref(mp->mpx_name[mp->in_open]);
13291 if ( index!=mp->in_open ) mp_confusion(mp, "endinput");
13292 if ( name>max_spec_src ) {
13294 delete_str_ref(name);
13298 pop_input; decr(mp->in_open);
13301 @ Here is a function that tries to resume input from an \.{MPX} file already
13302 associated with the current input file. It returns |false| if this doesn't
13305 @c boolean mp_begin_mpx_reading (MP mp) {
13306 if ( mp->in_open!=index+1 ) {
13309 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13310 @:this can't happen mpx}{\quad mpx@>
13311 if ( mp->first==mp->buf_size )
13312 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13313 push_input; index=mp->in_open;
13315 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13316 @<Put an empty line in the input buffer@>;
13321 @ This procedure temporarily stops reading an \.{MPX} file.
13323 @c void mp_end_mpx_reading (MP mp) {
13324 if ( mp->in_open!=index ) mp_confusion(mp, "mpx");
13325 @:this can't happen mpx}{\quad mpx@>
13327 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13333 @ Here we enforce a restriction that simplifies the input stacks considerably.
13334 This should not inconvenience the user because \.{MPX} files are generated
13335 by an auxiliary program called \.{DVItoMP}.
13337 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13339 print_err("`mpxbreak' must be at the end of a line");
13340 help4("This file contains picture expressions for btex...etex")
13341 ("blocks. Such files are normally generated automatically")
13342 ("but this one seems to be messed up. I'm going to ignore")
13343 ("the rest of this line.");
13347 @ In order to keep the stack from overflowing during a long sequence of
13348 inserted `\.{show}' commands, the following routine removes completed
13349 error-inserted lines from memory.
13351 @c void mp_clear_for_error_prompt (MP mp) {
13352 while ( file_state && terminal_input &&
13353 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13354 mp_print_ln(mp); clear_terminal;
13357 @ To get \MP's whole input mechanism going, we perform the following
13360 @<Initialize the input routines@>=
13361 { mp->input_ptr=0; mp->max_in_stack=0;
13362 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13363 mp->param_ptr=0; mp->max_param_stack=0;
13365 start=1; index=0; line=0; name=is_term;
13366 mp->mpx_name[0]=absent;
13367 mp->force_eof=false;
13368 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13369 limit=mp->last; mp->first=mp->last+1;
13370 /* |init_terminal| has set |loc| and |last| */
13373 @* \[29] Getting the next token.
13374 The heart of \MP's input mechanism is the |get_next| procedure, which
13375 we shall develop in the next few sections of the program. Perhaps we
13376 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13377 eyes and mouth, reading the source files and gobbling them up. And it also
13378 helps \MP\ to regurgitate stored token lists that are to be processed again.
13380 The main duty of |get_next| is to input one token and to set |cur_cmd|
13381 and |cur_mod| to that token's command code and modifier. Furthermore, if
13382 the input token is a symbolic token, that token's |hash| address
13383 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13385 Underlying this simple description is a certain amount of complexity
13386 because of all the cases that need to be handled.
13387 However, the inner loop of |get_next| is reasonably short and fast.
13389 @ Before getting into |get_next|, we need to consider a mechanism by which
13390 \MP\ helps keep errors from propagating too far. Whenever the program goes
13391 into a mode where it keeps calling |get_next| repeatedly until a certain
13392 condition is met, it sets |scanner_status| to some value other than |normal|.
13393 Then if an input file ends, or if an `\&{outer}' symbol appears,
13394 an appropriate error recovery will be possible.
13396 The global variable |warning_info| helps in this error recovery by providing
13397 additional information. For example, |warning_info| might indicate the
13398 name of a macro whose replacement text is being scanned.
13400 @d normal 0 /* |scanner_status| at ``quiet times'' */
13401 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13402 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13403 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13404 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13405 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13406 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13407 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13410 integer scanner_status; /* are we scanning at high speed? */
13411 integer warning_info; /* if so, what else do we need to know,
13412 in case an error occurs? */
13414 @ @<Initialize the input routines@>=
13415 mp->scanner_status=normal;
13417 @ The following subroutine
13418 is called when an `\&{outer}' symbolic token has been scanned or
13419 when the end of a file has been reached. These two cases are distinguished
13420 by |cur_sym|, which is zero at the end of a file.
13422 @c boolean mp_check_outer_validity (MP mp) {
13423 pointer p; /* points to inserted token list */
13424 if ( mp->scanner_status==normal ) {
13426 } else if ( mp->scanner_status==tex_flushing ) {
13427 @<Check if the file has ended while flushing \TeX\ material and set the
13428 result value for |check_outer_validity|@>;
13430 mp->deletions_allowed=false;
13431 @<Back up an outer symbolic token so that it can be reread@>;
13432 if ( mp->scanner_status>skipping ) {
13433 @<Tell the user what has run away and try to recover@>;
13435 print_err("Incomplete if; all text was ignored after line ");
13436 @.Incomplete if...@>
13437 mp_print_int(mp, mp->warning_info);
13438 help3("A forbidden `outer' token occurred in skipped text.")
13439 ("This kind of error happens when you say `if...' and forget")
13440 ("the matching `fi'. I've inserted a `fi'; this might work.");
13441 if ( mp->cur_sym==0 )
13442 mp->help_line[2]="The file ended while I was skipping conditional text.";
13443 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13445 mp->deletions_allowed=true;
13450 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13451 if ( mp->cur_sym!=0 ) {
13454 mp->deletions_allowed=false;
13455 print_err("TeX mode didn't end; all text was ignored after line ");
13456 mp_print_int(mp, mp->warning_info);
13457 help2("The file ended while I was looking for the `etex' to")
13458 ("finish this TeX material. I've inserted `etex' now.");
13459 mp->cur_sym = frozen_etex;
13461 mp->deletions_allowed=true;
13465 @ @<Back up an outer symbolic token so that it can be reread@>=
13466 if ( mp->cur_sym!=0 ) {
13467 p=mp_get_avail(mp); info(p)=mp->cur_sym;
13468 back_list(p); /* prepare to read the symbolic token again */
13471 @ @<Tell the user what has run away...@>=
13473 mp_runaway(mp); /* print the definition-so-far */
13474 if ( mp->cur_sym==0 ) {
13475 print_err("File ended");
13476 @.File ended while scanning...@>
13478 print_err("Forbidden token found");
13479 @.Forbidden token found...@>
13481 mp_print(mp, " while scanning ");
13482 help4("I suspect you have forgotten an `enddef',")
13483 ("causing me to read past where you wanted me to stop.")
13484 ("I'll try to recover; but if the error is serious,")
13485 ("you'd better type `E' or `X' now and fix your file.");
13486 switch (mp->scanner_status) {
13487 @<Complete the error message,
13488 and set |cur_sym| to a token that might help recover from the error@>
13489 } /* there are no other cases */
13493 @ As we consider various kinds of errors, it is also appropriate to
13494 change the first line of the help message just given; |help_line[3]|
13495 points to the string that might be changed.
13497 @<Complete the error message,...@>=
13499 mp_print(mp, "to the end of the statement");
13500 mp->help_line[3]="A previous error seems to have propagated,";
13501 mp->cur_sym=frozen_semicolon;
13504 mp_print(mp, "a text argument");
13505 mp->help_line[3]="It seems that a right delimiter was left out,";
13506 if ( mp->warning_info==0 ) {
13507 mp->cur_sym=frozen_end_group;
13509 mp->cur_sym=frozen_right_delimiter;
13510 equiv(frozen_right_delimiter)=mp->warning_info;
13515 mp_print(mp, "the definition of ");
13516 if ( mp->scanner_status==op_defining )
13517 mp_print_text(mp->warning_info);
13519 mp_print_variable_name(mp, mp->warning_info);
13520 mp->cur_sym=frozen_end_def;
13522 case loop_defining:
13523 mp_print(mp, "the text of a ");
13524 mp_print_text(mp->warning_info);
13525 mp_print(mp, " loop");
13526 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13527 mp->cur_sym=frozen_end_for;
13530 @ The |runaway| procedure displays the first part of the text that occurred
13531 when \MP\ began its special |scanner_status|, if that text has been saved.
13533 @<Declare the procedure called |runaway|@>=
13534 void mp_runaway (MP mp) {
13535 if ( mp->scanner_status>flushing ) {
13536 mp_print_nl(mp, "Runaway ");
13537 switch (mp->scanner_status) {
13538 case absorbing: mp_print(mp, "text?"); break;
13540 case op_defining: mp_print(mp,"definition?"); break;
13541 case loop_defining: mp_print(mp, "loop?"); break;
13542 } /* there are no other cases */
13544 mp_show_token_list(mp, link(hold_head),null,mp->error_line-10,0);
13548 @ We need to mention a procedure that may be called by |get_next|.
13551 void mp_firm_up_the_line (MP mp);
13553 @ And now we're ready to take the plunge into |get_next| itself.
13554 Note that the behavior depends on the |scanner_status| because percent signs
13555 and double quotes need to be passed over when skipping TeX material.
13558 void mp_get_next (MP mp) {
13559 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13561 /*restart*/ /* go here to get the next input token */
13562 /*exit*/ /* go here when the next input token has been got */
13563 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13564 /*found*/ /* go here when the end of a symbolic token has been found */
13565 /*switch*/ /* go here to branch on the class of an input character */
13566 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13567 /* go here at crucial stages when scanning a number */
13568 int k; /* an index into |buffer| */
13569 ASCII_code c; /* the current character in the buffer */
13570 ASCII_code class; /* its class number */
13571 integer n,f; /* registers for decimal-to-binary conversion */
13574 if ( file_state ) {
13575 @<Input from external file; |goto restart| if no input found,
13576 or |return| if a non-symbolic token is found@>;
13578 @<Input from token list; |goto restart| if end of list or
13579 if a parameter needs to be expanded,
13580 or |return| if a non-symbolic token is found@>;
13583 @<Finish getting the symbolic token in |cur_sym|;
13584 |goto restart| if it is illegal@>;
13587 @ When a symbolic token is declared to be `\&{outer}', its command code
13588 is increased by |outer_tag|.
13591 @<Finish getting the symbolic token in |cur_sym|...@>=
13592 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13593 if ( mp->cur_cmd>=outer_tag ) {
13594 if ( mp_check_outer_validity(mp) )
13595 mp->cur_cmd=mp->cur_cmd-outer_tag;
13600 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13601 to have a special test for end-of-line.
13604 @<Input from external file;...@>=
13607 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13609 case digit_class: goto START_NUMERIC_TOKEN; break;
13611 class=mp->char_class[mp->buffer[loc]];
13612 if ( class>period_class ) {
13614 } else if ( class<period_class ) { /* |class=digit_class| */
13615 n=0; goto START_DECIMAL_TOKEN;
13619 case space_class: goto SWITCH; break;
13620 case percent_class:
13621 if ( mp->scanner_status==tex_flushing ) {
13622 if ( loc<limit ) goto SWITCH;
13624 @<Move to next line of file, or |goto restart| if there is no next line@>;
13629 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13630 else @<Get a string token and |return|@>;
13632 case isolated_classes:
13633 k=loc-1; goto FOUND; break;
13634 case invalid_class:
13635 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13636 else @<Decry the invalid character and |goto restart|@>;
13638 default: break; /* letters, etc. */
13641 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13643 START_NUMERIC_TOKEN:
13644 @<Get the integer part |n| of a numeric token;
13645 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13646 START_DECIMAL_TOKEN:
13647 @<Get the fraction part |f| of a numeric token@>;
13649 @<Pack the numeric and fraction parts of a numeric token
13652 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13655 @ We go to |restart| instead of to |SWITCH|, because |state| might equal
13656 |token_list| after the error has been dealt with
13657 (cf.\ |clear_for_error_prompt|).
13659 @<Decry the invalid...@>=
13661 print_err("Text line contains an invalid character");
13662 @.Text line contains...@>
13663 help2("A funny symbol that I can\'t read has just been input.")
13664 ("Continue, and I'll forget that it ever happened.");
13665 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13669 @ @<Get a string token and |return|@>=
13671 if ( mp->buffer[loc]=='"' ) {
13672 mp->cur_mod=rts("");
13674 k=loc; mp->buffer[limit+1]='"';
13677 } while (mp->buffer[loc]!='"');
13679 @<Decry the missing string delimiter and |goto restart|@>;
13682 mp->cur_mod=mp->buffer[k];
13686 append_char(mp->buffer[k]); incr(k);
13688 mp->cur_mod=mp_make_string(mp);
13691 incr(loc); mp->cur_cmd=string_token;
13695 @ We go to |restart| after this error message, not to |SWITCH|,
13696 because the |clear_for_error_prompt| routine might have reinstated
13697 |token_state| after |error| has finished.
13699 @<Decry the missing string delimiter and |goto restart|@>=
13701 loc=limit; /* the next character to be read on this line will be |"%"| */
13702 print_err("Incomplete string token has been flushed");
13703 @.Incomplete string token...@>
13704 help3("Strings should finish on the same line as they began.")
13705 ("I've deleted the partial string; you might want to")
13706 ("insert another by typing, e.g., `I\"new string\"'.");
13707 mp->deletions_allowed=false; mp_error(mp);
13708 mp->deletions_allowed=true;
13712 @ @<Get the integer part |n| of a numeric token...@>=
13714 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13715 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13718 if ( mp->buffer[loc]=='.' )
13719 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13722 goto FIN_NUMERIC_TOKEN;
13725 @ @<Get the fraction part |f| of a numeric token@>=
13728 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13729 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13732 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13733 f=mp_round_decimals(mp, k);
13738 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13740 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13741 } else if ( mp->scanner_status!=tex_flushing ) {
13742 print_err("Enormous number has been reduced");
13743 @.Enormous number...@>
13744 help2("I can\'t handle numbers bigger than 32767.99998;")
13745 ("so I've changed your constant to that maximum amount.");
13746 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13747 mp->cur_mod=el_gordo;
13749 mp->cur_cmd=numeric_token; return
13751 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13753 mp->cur_mod=n*unity+f;
13754 if ( mp->cur_mod>=fraction_one ) {
13755 if ( (mp->internal[mp_warning_check]>0) &&
13756 (mp->scanner_status!=tex_flushing) ) {
13757 print_err("Number is too large (");
13758 mp_print_scaled(mp, mp->cur_mod);
13759 mp_print_char(mp, ')');
13760 help3("It is at least 4096. Continue and I'll try to cope")
13761 ("with that big value; but it might be dangerous.")
13762 ("(Set warningcheck:=0 to suppress this message.)");
13768 @ Let's consider now what happens when |get_next| is looking at a token list.
13771 @<Input from token list;...@>=
13772 if ( loc>=mp->hi_mem_min ) { /* one-word token */
13773 mp->cur_sym=info(loc); loc=link(loc); /* move to next */
13774 if ( mp->cur_sym>=expr_base ) {
13775 if ( mp->cur_sym>=suffix_base ) {
13776 @<Insert a suffix or text parameter and |goto restart|@>;
13778 mp->cur_cmd=capsule_token;
13779 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
13780 mp->cur_sym=0; return;
13783 } else if ( loc>null ) {
13784 @<Get a stored numeric or string or capsule token and |return|@>
13785 } else { /* we are done with this token list */
13786 mp_end_token_list(mp); goto RESTART; /* resume previous level */
13789 @ @<Insert a suffix or text parameter...@>=
13791 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
13792 /* |param_size=text_base-suffix_base| */
13793 mp_begin_token_list(mp,
13794 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
13799 @ @<Get a stored numeric or string or capsule token...@>=
13801 if ( name_type(loc)==mp_token ) {
13802 mp->cur_mod=value(loc);
13803 if ( type(loc)==mp_known ) {
13804 mp->cur_cmd=numeric_token;
13806 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
13809 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
13811 loc=link(loc); return;
13814 @ All of the easy branches of |get_next| have now been taken care of.
13815 There is one more branch.
13817 @<Move to next line of file, or |goto restart|...@>=
13818 if ( name>max_spec_src ) {
13819 @<Read next line of file into |buffer|, or
13820 |goto restart| if the file has ended@>;
13822 if ( mp->input_ptr>0 ) {
13823 /* text was inserted during error recovery or by \&{scantokens} */
13824 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
13826 if ( mp->selector<log_only || mp->selector>=write_file) mp_open_log_file(mp);
13827 if ( mp->interaction>mp_nonstop_mode ) {
13828 if ( limit==start ) /* previous line was empty */
13829 mp_print_nl(mp, "(Please type a command or say `end')");
13831 mp_print_ln(mp); mp->first=start;
13832 prompt_input("*"); /* input on-line into |buffer| */
13834 limit=mp->last; mp->buffer[limit]='%';
13835 mp->first=limit+1; loc=start;
13837 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
13839 /* nonstop mode, which is intended for overnight batch processing,
13840 never waits for on-line input */
13844 @ The global variable |force_eof| is normally |false|; it is set |true|
13845 by an \&{endinput} command.
13848 boolean force_eof; /* should the next \&{input} be aborted early? */
13850 @ We must decrement |loc| in order to leave the buffer in a valid state
13851 when an error condition causes us to |goto restart| without calling
13852 |end_file_reading|.
13854 @<Read next line of file into |buffer|, or
13855 |goto restart| if the file has ended@>=
13857 incr(line); mp->first=start;
13858 if ( ! mp->force_eof ) {
13859 if ( mp_input_ln(mp, cur_file,true) ) /* not end of file */
13860 mp_firm_up_the_line(mp); /* this sets |limit| */
13862 mp->force_eof=true;
13864 if ( mp->force_eof ) {
13865 mp->force_eof=false;
13867 if ( mpx_reading ) {
13868 @<Complain that the \.{MPX} file ended unexpectly; then set
13869 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
13871 mp_print_char(mp, ')'); decr(mp->open_parens);
13872 update_terminal; /* show user that file has been read */
13873 mp_end_file_reading(mp); /* resume previous level */
13874 if ( mp_check_outer_validity(mp) ) goto RESTART;
13878 mp->buffer[limit]='%'; mp->first=limit+1; loc=start; /* ready to read */
13881 @ We should never actually come to the end of an \.{MPX} file because such
13882 files should have an \&{mpxbreak} after the translation of the last
13883 \&{btex}$\,\ldots\,$\&{etex} block.
13885 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
13887 mp->mpx_name[index]=finished;
13888 print_err("mpx file ended unexpectedly");
13889 help4("The file had too few picture expressions for btex...etex")
13890 ("blocks. Such files are normally generated automatically")
13891 ("but this one got messed up. You might want to insert a")
13892 ("picture expression now.");
13893 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13894 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
13897 @ Sometimes we want to make it look as though we have just read a blank line
13898 without really doing so.
13900 @<Put an empty line in the input buffer@>=
13901 mp->last=mp->first; limit=mp->last; /* simulate |input_ln| and |firm_up_the_line| */
13902 mp->buffer[limit]='%'; mp->first=limit+1; loc=start
13904 @ If the user has set the |mp_pausing| parameter to some positive value,
13905 and if nonstop mode has not been selected, each line of input is displayed
13906 on the terminal and the transcript file, followed by `\.{=>}'.
13907 \MP\ waits for a response. If the response is null (i.e., if nothing is
13908 typed except perhaps a few blank spaces), the original
13909 line is accepted as it stands; otherwise the line typed is
13910 used instead of the line in the file.
13912 @c void mp_firm_up_the_line (MP mp) {
13913 size_t k; /* an index into |buffer| */
13915 if ( mp->internal[mp_pausing]>0 ) if ( mp->interaction>mp_nonstop_mode ) {
13916 wake_up_terminal; mp_print_ln(mp);
13917 if ( start<limit ) {
13918 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
13919 mp_print_str(mp, mp->buffer[k]);
13922 mp->first=limit; prompt_input("=>"); /* wait for user response */
13924 if ( mp->last>mp->first ) {
13925 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
13926 mp->buffer[k+start-mp->first]=mp->buffer[k];
13928 limit=start+mp->last-mp->first;
13933 @* \[30] Dealing with \TeX\ material.
13934 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
13935 features need to be implemented at a low level in the scanning process
13936 so that \MP\ can stay in synch with the a preprocessor that treats
13937 blocks of \TeX\ material as they occur in the input file without trying
13938 to expand \MP\ macros. Thus we need a special version of |get_next|
13939 that does not expand macros and such but does handle \&{btex},
13940 \&{verbatimtex}, etc.
13942 The special version of |get_next| is called |get_t_next|. It works by flushing
13943 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
13944 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
13945 \&{btex}, and switching back when it sees \&{mpxbreak}.
13951 mp_primitive(mp, "btex",start_tex,btex_code);
13952 @:btex_}{\&{btex} primitive@>
13953 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
13954 @:verbatimtex_}{\&{verbatimtex} primitive@>
13955 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
13956 @:etex_}{\&{etex} primitive@>
13957 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
13958 @:mpx_break_}{\&{mpxbreak} primitive@>
13960 @ @<Cases of |print_cmd...@>=
13961 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
13962 else mp_print(mp, "verbatimtex"); break;
13963 case etex_marker: mp_print(mp, "etex"); break;
13964 case mpx_break: mp_print(mp, "mpxbreak"); break;
13966 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
13967 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
13970 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
13973 void mp_start_mpx_input (MP mp);
13976 void mp_t_next (MP mp) {
13977 int old_status; /* saves the |scanner_status| */
13978 integer old_info; /* saves the |warning_info| */
13979 while ( mp->cur_cmd<=max_pre_command ) {
13980 if ( mp->cur_cmd==mpx_break ) {
13981 if ( ! file_state || (mp->mpx_name[index]==absent) ) {
13982 @<Complain about a misplaced \&{mpxbreak}@>;
13984 mp_end_mpx_reading(mp);
13987 } else if ( mp->cur_cmd==start_tex ) {
13988 if ( token_state || (name<=max_spec_src) ) {
13989 @<Complain that we are not reading a file@>;
13990 } else if ( mpx_reading ) {
13991 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
13992 } else if ( (mp->cur_mod!=verbatim_code)&&
13993 (mp->mpx_name[index]!=finished) ) {
13994 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
13999 @<Complain about a misplaced \&{etex}@>;
14001 goto COMMON_ENDING;
14003 @<Flush the \TeX\ material@>;
14009 @ We could be in the middle of an operation such as skipping false conditional
14010 text when \TeX\ material is encountered, so we must be careful to save the
14013 @<Flush the \TeX\ material@>=
14014 old_status=mp->scanner_status;
14015 old_info=mp->warning_info;
14016 mp->scanner_status=tex_flushing;
14017 mp->warning_info=line;
14018 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14019 mp->scanner_status=old_status;
14020 mp->warning_info=old_info
14022 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14023 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14024 help4("This file contains picture expressions for btex...etex")
14025 ("blocks. Such files are normally generated automatically")
14026 ("but this one seems to be messed up. I'll just keep going")
14027 ("and hope for the best.");
14031 @ @<Complain that we are not reading a file@>=
14032 { print_err("You can only use `btex' or `verbatimtex' in a file");
14033 help3("I'll have to ignore this preprocessor command because it")
14034 ("only works when there is a file to preprocess. You might")
14035 ("want to delete everything up to the next `etex`.");
14039 @ @<Complain about a misplaced \&{mpxbreak}@>=
14040 { print_err("Misplaced mpxbreak");
14041 help2("I'll ignore this preprocessor command because it")
14042 ("doesn't belong here");
14046 @ @<Complain about a misplaced \&{etex}@>=
14047 { print_err("Extra etex will be ignored");
14048 help1("There is no btex or verbatimtex for this to match");
14052 @* \[31] Scanning macro definitions.
14053 \MP\ has a variety of ways to tuck tokens away into token lists for later
14054 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14055 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14056 All such operations are handled by the routines in this part of the program.
14058 The modifier part of each command code is zero for the ``ending delimiters''
14059 like \&{enddef} and \&{endfor}.
14061 @d start_def 1 /* command modifier for \&{def} */
14062 @d var_def 2 /* command modifier for \&{vardef} */
14063 @d end_def 0 /* command modifier for \&{enddef} */
14064 @d start_forever 1 /* command modifier for \&{forever} */
14065 @d end_for 0 /* command modifier for \&{endfor} */
14068 mp_primitive(mp, "def",macro_def,start_def);
14069 @:def_}{\&{def} primitive@>
14070 mp_primitive(mp, "vardef",macro_def,var_def);
14071 @:var_def_}{\&{vardef} primitive@>
14072 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14073 @:primary_def_}{\&{primarydef} primitive@>
14074 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14075 @:secondary_def_}{\&{secondarydef} primitive@>
14076 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14077 @:tertiary_def_}{\&{tertiarydef} primitive@>
14078 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14079 @:end_def_}{\&{enddef} primitive@>
14081 mp_primitive(mp, "for",iteration,expr_base);
14082 @:for_}{\&{for} primitive@>
14083 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14084 @:for_suffixes_}{\&{forsuffixes} primitive@>
14085 mp_primitive(mp, "forever",iteration,start_forever);
14086 @:forever_}{\&{forever} primitive@>
14087 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14088 @:end_for_}{\&{endfor} primitive@>
14090 @ @<Cases of |print_cmd...@>=
14092 if ( m<=var_def ) {
14093 if ( m==start_def ) mp_print(mp, "def");
14094 else if ( m<start_def ) mp_print(mp, "enddef");
14095 else mp_print(mp, "vardef");
14096 } else if ( m==secondary_primary_macro ) {
14097 mp_print(mp, "primarydef");
14098 } else if ( m==tertiary_secondary_macro ) {
14099 mp_print(mp, "secondarydef");
14101 mp_print(mp, "tertiarydef");
14105 if ( m<=start_forever ) {
14106 if ( m==start_forever ) mp_print(mp, "forever");
14107 else mp_print(mp, "endfor");
14108 } else if ( m==expr_base ) {
14109 mp_print(mp, "for");
14111 mp_print(mp, "forsuffixes");
14115 @ Different macro-absorbing operations have different syntaxes, but they
14116 also have a lot in common. There is a list of special symbols that are to
14117 be replaced by parameter tokens; there is a special command code that
14118 ends the definition; the quotation conventions are identical. Therefore
14119 it makes sense to have most of the work done by a single subroutine. That
14120 subroutine is called |scan_toks|.
14122 The first parameter to |scan_toks| is the command code that will
14123 terminate scanning (either |macro_def|, |loop_repeat|, or |iteration|).
14125 The second parameter, |subst_list|, points to a (possibly empty) list
14126 of two-word nodes whose |info| and |value| fields specify symbol tokens
14127 before and after replacement. The list will be returned to free storage
14130 The third parameter is simply appended to the token list that is built.
14131 And the final parameter tells how many of the special operations
14132 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14133 When such parameters are present, they are called \.{(SUFFIX0)},
14134 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14136 @c pointer mp_scan_toks (MP mp,command_code terminator, pointer
14137 subst_list, pointer tail_end, small_number suffix_count) {
14138 pointer p; /* tail of the token list being built */
14139 pointer q; /* temporary for link management */
14140 integer balance; /* left delimiters minus right delimiters */
14141 p=hold_head; balance=1; link(hold_head)=null;
14144 if ( mp->cur_sym>0 ) {
14145 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14146 if ( mp->cur_cmd==terminator ) {
14147 @<Adjust the balance; |break| if it's zero@>;
14148 } else if ( mp->cur_cmd==macro_special ) {
14149 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14152 link(p)=mp_cur_tok(mp); p=link(p);
14154 link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14155 return link(hold_head);
14158 @ @<Substitute for |cur_sym|...@>=
14161 while ( q!=null ) {
14162 if ( info(q)==mp->cur_sym ) {
14163 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14169 @ @<Adjust the balance; |break| if it's zero@>=
14170 if ( mp->cur_mod>0 ) {
14178 @ Four commands are intended to be used only within macro texts: \&{quote},
14179 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14180 code called |macro_special|.
14182 @d quote 0 /* |macro_special| modifier for \&{quote} */
14183 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14184 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14185 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14188 mp_primitive(mp, "quote",macro_special,quote);
14189 @:quote_}{\&{quote} primitive@>
14190 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14191 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14192 mp_primitive(mp, "@@",macro_special,macro_at);
14193 @:]]]\AT!_}{\.{\AT!} primitive@>
14194 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14195 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14197 @ @<Cases of |print_cmd...@>=
14198 case macro_special:
14200 case macro_prefix: mp_print(mp, "#@@"); break;
14201 case macro_at: mp_print_char(mp, '@@'); break;
14202 case macro_suffix: mp_print(mp, "@@#"); break;
14203 default: mp_print(mp, "quote"); break;
14207 @ @<Handle quoted...@>=
14209 if ( mp->cur_mod==quote ) { get_t_next; }
14210 else if ( mp->cur_mod<=suffix_count )
14211 mp->cur_sym=suffix_base-1+mp->cur_mod;
14214 @ Here is a routine that's used whenever a token will be redefined. If
14215 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14216 substituted; the latter is redefinable but essentially impossible to use,
14217 hence \MP's tables won't get fouled up.
14219 @c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14222 if ( (mp->cur_sym==0)||(mp->cur_sym>frozen_inaccessible) ) {
14223 print_err("Missing symbolic token inserted");
14224 @.Missing symbolic token...@>
14225 help3("Sorry: You can\'t redefine a number, string, or expr.")
14226 ("I've inserted an inaccessible symbol so that your")
14227 ("definition will be completed without mixing me up too badly.");
14228 if ( mp->cur_sym>0 )
14229 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14230 else if ( mp->cur_cmd==string_token )
14231 delete_str_ref(mp->cur_mod);
14232 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14236 @ Before we actually redefine a symbolic token, we need to clear away its
14237 former value, if it was a variable. The following stronger version of
14238 |get_symbol| does that.
14240 @c void mp_get_clear_symbol (MP mp) {
14241 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14244 @ Here's another little subroutine; it checks that an equals sign
14245 or assignment sign comes along at the proper place in a macro definition.
14247 @c void mp_check_equals (MP mp) {
14248 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14249 mp_missing_err(mp, "=");
14251 help5("The next thing in this `def' should have been `=',")
14252 ("because I've already looked at the definition heading.")
14253 ("But don't worry; I'll pretend that an equals sign")
14254 ("was present. Everything from here to `enddef'")
14255 ("will be the replacement text of this macro.");
14260 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14261 handled now that we have |scan_toks|. In this case there are
14262 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14263 |expr_base| and |expr_base+1|).
14265 @c void mp_make_op_def (MP mp) {
14266 command_code m; /* the type of definition */
14267 pointer p,q,r; /* for list manipulation */
14269 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14270 info(q)=mp->cur_sym; value(q)=expr_base;
14271 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14272 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14273 info(p)=mp->cur_sym; value(p)=expr_base+1; link(p)=q;
14274 get_t_next; mp_check_equals(mp);
14275 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14276 r=mp_get_avail(mp); link(q)=r; info(r)=general_macro;
14277 link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14278 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14279 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14282 @ Parameters to macros are introduced by the keywords \&{expr},
14283 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14286 mp_primitive(mp, "expr",param_type,expr_base);
14287 @:expr_}{\&{expr} primitive@>
14288 mp_primitive(mp, "suffix",param_type,suffix_base);
14289 @:suffix_}{\&{suffix} primitive@>
14290 mp_primitive(mp, "text",param_type,text_base);
14291 @:text_}{\&{text} primitive@>
14292 mp_primitive(mp, "primary",param_type,primary_macro);
14293 @:primary_}{\&{primary} primitive@>
14294 mp_primitive(mp, "secondary",param_type,secondary_macro);
14295 @:secondary_}{\&{secondary} primitive@>
14296 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14297 @:tertiary_}{\&{tertiary} primitive@>
14299 @ @<Cases of |print_cmd...@>=
14301 if ( m>=expr_base ) {
14302 if ( m==expr_base ) mp_print(mp, "expr");
14303 else if ( m==suffix_base ) mp_print(mp, "suffix");
14304 else mp_print(mp, "text");
14305 } else if ( m<secondary_macro ) {
14306 mp_print(mp, "primary");
14307 } else if ( m==secondary_macro ) {
14308 mp_print(mp, "secondary");
14310 mp_print(mp, "tertiary");
14314 @ Let's turn next to the more complex processing associated with \&{def}
14315 and \&{vardef}. When the following procedure is called, |cur_mod|
14316 should be either |start_def| or |var_def|.
14318 @c @<Declare the procedure called |check_delimiter|@>;
14319 @<Declare the function called |scan_declared_variable|@>;
14320 void mp_scan_def (MP mp) {
14321 int m; /* the type of definition */
14322 int n; /* the number of special suffix parameters */
14323 int k; /* the total number of parameters */
14324 int c; /* the kind of macro we're defining */
14325 pointer r; /* parameter-substitution list */
14326 pointer q; /* tail of the macro token list */
14327 pointer p; /* temporary storage */
14328 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14329 pointer l_delim,r_delim; /* matching delimiters */
14330 m=mp->cur_mod; c=general_macro; link(hold_head)=null;
14331 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14332 @<Scan the token or variable to be defined;
14333 set |n|, |scanner_status|, and |warning_info|@>;
14335 if ( mp->cur_cmd==left_delimiter ) {
14336 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14338 if ( mp->cur_cmd==param_type ) {
14339 @<Absorb undelimited parameters, putting them into list |r|@>;
14341 mp_check_equals(mp);
14342 p=mp_get_avail(mp); info(p)=c; link(q)=p;
14343 @<Attach the replacement text to the tail of node |p|@>;
14344 mp->scanner_status=normal; mp_get_x_next(mp);
14347 @ We don't put `|frozen_end_group|' into the replacement text of
14348 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14350 @<Attach the replacement text to the tail of node |p|@>=
14351 if ( m==start_def ) {
14352 link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14354 q=mp_get_avail(mp); info(q)=mp->bg_loc; link(p)=q;
14355 p=mp_get_avail(mp); info(p)=mp->eg_loc;
14356 link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14358 if ( mp->warning_info==bad_vardef )
14359 mp_flush_token_list(mp, value(bad_vardef))
14363 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14365 @ @<Scan the token or variable to be defined;...@>=
14366 if ( m==start_def ) {
14367 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14368 mp->scanner_status=op_defining; n=0;
14369 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14371 p=mp_scan_declared_variable(mp);
14372 mp_flush_variable(mp, equiv(info(p)),link(p),true);
14373 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14374 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14375 mp->scanner_status=var_defining; n=2;
14376 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14379 type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14380 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14382 @ @<Change to `\.{a bad variable}'@>=
14384 print_err("This variable already starts with a macro");
14385 @.This variable already...@>
14386 help2("After `vardef a' you can\'t say `vardef a.b'.")
14387 ("So I'll have to discard this definition.");
14388 mp_error(mp); mp->warning_info=bad_vardef;
14391 @ @<Initialize table entries...@>=
14392 name_type(bad_vardef)=mp_root; link(bad_vardef)=frozen_bad_vardef;
14393 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14395 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14397 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14398 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14401 print_err("Missing parameter type; `expr' will be assumed");
14402 @.Missing parameter type@>
14403 help1("You should've had `expr' or `suffix' or `text' here.");
14404 mp_back_error(mp); base=expr_base;
14406 @<Absorb parameter tokens for type |base|@>;
14407 mp_check_delimiter(mp, l_delim,r_delim);
14409 } while (mp->cur_cmd==left_delimiter)
14411 @ @<Absorb parameter tokens for type |base|@>=
14413 link(q)=mp_get_avail(mp); q=link(q); info(q)=base+k;
14414 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14415 value(p)=base+k; info(p)=mp->cur_sym;
14416 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14417 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14418 incr(k); link(p)=r; r=p; get_t_next;
14419 } while (mp->cur_cmd==comma)
14421 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14423 p=mp_get_node(mp, token_node_size);
14424 if ( mp->cur_mod<expr_base ) {
14425 c=mp->cur_mod; value(p)=expr_base+k;
14427 value(p)=mp->cur_mod+k;
14428 if ( mp->cur_mod==expr_base ) c=expr_macro;
14429 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14432 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14433 incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; link(p)=r; r=p; get_t_next;
14434 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14435 c=of_macro; p=mp_get_node(mp, token_node_size);
14436 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14437 value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
14438 link(p)=r; r=p; get_t_next;
14442 @* \[32] Expanding the next token.
14443 Only a few command codes |<min_command| can possibly be returned by
14444 |get_t_next|; in increasing order, they are
14445 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14446 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14448 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14449 like |get_t_next| except that it keeps getting more tokens until
14450 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14451 macros and removes conditionals or iterations or input instructions that
14454 It follows that |get_x_next| might invoke itself recursively. In fact,
14455 there is massive recursion, since macro expansion can involve the
14456 scanning of arbitrarily complex expressions, which in turn involve
14457 macro expansion and conditionals, etc.
14460 Therefore it's necessary to declare a whole bunch of |forward|
14461 procedures at this point, and to insert some other procedures
14462 that will be invoked by |get_x_next|.
14465 void mp_scan_primary (MP mp);
14466 void mp_scan_secondary (MP mp);
14467 void mp_scan_tertiary (MP mp);
14468 void mp_scan_expression (MP mp);
14469 void mp_scan_suffix (MP mp);
14470 @<Declare the procedure called |macro_call|@>;
14471 void mp_get_boolean (MP mp);
14472 void mp_pass_text (MP mp);
14473 void mp_conditional (MP mp);
14474 void mp_start_input (MP mp);
14475 void mp_begin_iteration (MP mp);
14476 void mp_resume_iteration (MP mp);
14477 void mp_stop_iteration (MP mp);
14479 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14480 when it has to do exotic expansion commands.
14482 @c void mp_expand (MP mp) {
14483 pointer p; /* for list manipulation */
14484 size_t k; /* something that we hope is |<=buf_size| */
14485 pool_pointer j; /* index into |str_pool| */
14486 if ( mp->internal[mp_tracing_commands]>unity )
14487 if ( mp->cur_cmd!=defined_macro )
14489 switch (mp->cur_cmd) {
14491 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14494 @<Terminate the current conditional and skip to \&{fi}@>;
14497 @<Initiate or terminate input from a file@>;
14500 if ( mp->cur_mod==end_for ) {
14501 @<Scold the user for having an extra \&{endfor}@>;
14503 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14510 @<Exit a loop if the proper time has come@>;
14515 @<Expand the token after the next token@>;
14518 @<Put a string into the input buffer@>;
14520 case defined_macro:
14521 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14523 }; /* there are no other cases */
14526 @ @<Scold the user...@>=
14528 print_err("Extra `endfor'");
14530 help2("I'm not currently working on a for loop,")
14531 ("so I had better not try to end anything.");
14535 @ The processing of \&{input} involves the |start_input| subroutine,
14536 which will be declared later; the processing of \&{endinput} is trivial.
14539 mp_primitive(mp, "input",input,0);
14540 @:input_}{\&{input} primitive@>
14541 mp_primitive(mp, "endinput",input,1);
14542 @:end_input_}{\&{endinput} primitive@>
14544 @ @<Cases of |print_cmd_mod|...@>=
14546 if ( m==0 ) mp_print(mp, "input");
14547 else mp_print(mp, "endinput");
14550 @ @<Initiate or terminate input...@>=
14551 if ( mp->cur_mod>0 ) mp->force_eof=true;
14552 else mp_start_input(mp)
14554 @ We'll discuss the complicated parts of loop operations later. For now
14555 it suffices to know that there's a global variable called |loop_ptr|
14556 that will be |null| if no loop is in progress.
14559 { while ( token_state &&(loc==null) )
14560 mp_end_token_list(mp); /* conserve stack space */
14561 if ( mp->loop_ptr==null ) {
14562 print_err("Lost loop");
14564 help2("I'm confused; after exiting from a loop, I still seem")
14565 ("to want to repeat it. I'll try to forget the problem.");
14568 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14572 @ @<Exit a loop if the proper time has come@>=
14573 { mp_get_boolean(mp);
14574 if ( mp->internal[mp_tracing_commands]>unity )
14575 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14576 if ( mp->cur_exp==true_code ) {
14577 if ( mp->loop_ptr==null ) {
14578 print_err("No loop is in progress");
14579 @.No loop is in progress@>
14580 help1("Why say `exitif' when there's nothing to exit from?");
14581 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14583 @<Exit prematurely from an iteration@>;
14585 } else if ( mp->cur_cmd!=semicolon ) {
14586 mp_missing_err(mp, ";");
14588 help2("After `exitif <boolean exp>' I expect to see a semicolon.")
14589 ("I shall pretend that one was there."); mp_back_error(mp);
14593 @ Here we use the fact that |forever_text| is the only |token_type| that
14594 is less than |loop_text|.
14596 @<Exit prematurely...@>=
14599 if ( file_state ) {
14600 mp_end_file_reading(mp);
14602 if ( token_type<=loop_text ) p=start;
14603 mp_end_token_list(mp);
14606 if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14608 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14611 @ @<Expand the token after the next token@>=
14613 p=mp_cur_tok(mp); get_t_next;
14614 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14615 else mp_back_input(mp);
14619 @ @<Put a string into the input buffer@>=
14620 { mp_get_x_next(mp); mp_scan_primary(mp);
14621 if ( mp->cur_type!=mp_string_type ) {
14622 mp_disp_err(mp, null,"Not a string");
14624 help2("I'm going to flush this expression, since")
14625 ("scantokens should be followed by a known string.");
14626 mp_put_get_flush_error(mp, 0);
14629 if ( length(mp->cur_exp)>0 )
14630 @<Pretend we're reading a new one-line file@>;
14634 @ @<Pretend we're reading a new one-line file@>=
14635 { mp_begin_file_reading(mp); name=is_scantok;
14636 k=mp->first+length(mp->cur_exp);
14637 if ( k>=mp->max_buf_stack ) {
14638 while ( k>=mp->buf_size ) {
14639 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
14641 mp->max_buf_stack=k+1;
14643 j=mp->str_start[mp->cur_exp]; limit=k;
14644 while ( mp->first<(size_t)limit ) {
14645 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14647 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
14648 mp_flush_cur_exp(mp, 0);
14651 @ Here finally is |get_x_next|.
14653 The expression scanning routines to be considered later
14654 communicate via the global quantities |cur_type| and |cur_exp|;
14655 we must be very careful to save and restore these quantities while
14656 macros are being expanded.
14660 void mp_get_x_next (MP mp);
14662 @ @c void mp_get_x_next (MP mp) {
14663 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14665 if ( mp->cur_cmd<min_command ) {
14666 save_exp=mp_stash_cur_exp(mp);
14668 if ( mp->cur_cmd==defined_macro )
14669 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14673 } while (mp->cur_cmd<min_command);
14674 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14678 @ Now let's consider the |macro_call| procedure, which is used to start up
14679 all user-defined macros. Since the arguments to a macro might be expressions,
14680 |macro_call| is recursive.
14683 The first parameter to |macro_call| points to the reference count of the
14684 token list that defines the macro. The second parameter contains any
14685 arguments that have already been parsed (see below). The third parameter
14686 points to the symbolic token that names the macro. If the third parameter
14687 is |null|, the macro was defined by \&{vardef}, so its name can be
14688 reconstructed from the prefix and ``at'' arguments found within the
14691 What is this second parameter? It's simply a linked list of one-word items,
14692 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14693 no arguments have been scanned yet; otherwise |info(arg_list)| points to
14694 the first scanned argument, and |link(arg_list)| points to the list of
14695 further arguments (if any).
14697 Arguments of type \&{expr} are so-called capsules, which we will
14698 discuss later when we concentrate on expressions; they can be
14699 recognized easily because their |link| field is |void|. Arguments of type
14700 \&{suffix} and \&{text} are token lists without reference counts.
14702 @ After argument scanning is complete, the arguments are moved to the
14703 |param_stack|. (They can't be put on that stack any sooner, because
14704 the stack is growing and shrinking in unpredictable ways as more arguments
14705 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14706 the replacement text of the macro is placed at the top of the \MP's
14707 input stack, so that |get_t_next| will proceed to read it next.
14709 @<Declare the procedure called |macro_call|@>=
14710 @<Declare the procedure called |print_macro_name|@>;
14711 @<Declare the procedure called |print_arg|@>;
14712 @<Declare the procedure called |scan_text_arg|@>;
14713 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14714 pointer macro_name) ;
14717 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14718 pointer macro_name) {
14719 /* invokes a user-defined control sequence */
14720 pointer r; /* current node in the macro's token list */
14721 pointer p,q; /* for list manipulation */
14722 integer n; /* the number of arguments */
14723 pointer tail = 0; /* tail of the argument list */
14724 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14725 r=link(def_ref); add_mac_ref(def_ref);
14726 if ( arg_list==null ) {
14729 @<Determine the number |n| of arguments already supplied,
14730 and set |tail| to the tail of |arg_list|@>;
14732 if ( mp->internal[mp_tracing_macros]>0 ) {
14733 @<Show the text of the macro being expanded, and the existing arguments@>;
14735 @<Scan the remaining arguments, if any; set |r| to the first token
14736 of the replacement text@>;
14737 @<Feed the arguments and replacement text to the scanner@>;
14740 @ @<Show the text of the macro...@>=
14741 mp_begin_diagnostic(mp); mp_print_ln(mp);
14742 mp_print_macro_name(mp, arg_list,macro_name);
14743 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14744 mp_show_macro(mp, def_ref,null,100000);
14745 if ( arg_list!=null ) {
14749 mp_print_arg(mp, q,n,0);
14750 incr(n); p=link(p);
14753 mp_end_diagnostic(mp, false)
14756 @ @<Declare the procedure called |print_macro_name|@>=
14757 void mp_print_macro_name (MP mp,pointer a, pointer n);
14760 void mp_print_macro_name (MP mp,pointer a, pointer n) {
14761 pointer p,q; /* they traverse the first part of |a| */
14767 mp_print_text(info(info(link(a))));
14770 while ( link(q)!=null ) q=link(q);
14771 link(q)=info(link(a));
14772 mp_show_token_list(mp, p,null,1000,0);
14778 @ @<Declare the procedure called |print_arg|@>=
14779 void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
14782 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
14783 if ( link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
14784 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
14785 else mp_print_nl(mp, "(TEXT");
14786 mp_print_int(mp, n); mp_print(mp, ")<-");
14787 if ( link(q)==mp_void ) mp_print_exp(mp, q,1);
14788 else mp_show_token_list(mp, q,null,1000,0);
14791 @ @<Determine the number |n| of arguments already supplied...@>=
14793 n=1; tail=arg_list;
14794 while ( link(tail)!=null ) {
14795 incr(n); tail=link(tail);
14799 @ @<Scan the remaining arguments, if any; set |r|...@>=
14800 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
14801 while ( info(r)>=expr_base ) {
14802 @<Scan the delimited argument represented by |info(r)|@>;
14805 if ( mp->cur_cmd==comma ) {
14806 print_err("Too many arguments to ");
14807 @.Too many arguments...@>
14808 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, ';');
14809 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
14811 mp_print(mp, "' has been inserted");
14812 help3("I'm going to assume that the comma I just read was a")
14813 ("right delimiter, and then I'll begin expanding the macro.")
14814 ("You might want to delete some tokens before continuing.");
14817 if ( info(r)!=general_macro ) {
14818 @<Scan undelimited argument(s)@>;
14822 @ At this point, the reader will find it advisable to review the explanation
14823 of token list format that was presented earlier, paying special attention to
14824 the conventions that apply only at the beginning of a macro's token list.
14826 On the other hand, the reader will have to take the expression-parsing
14827 aspects of the following program on faith; we will explain |cur_type|
14828 and |cur_exp| later. (Several things in this program depend on each other,
14829 and it's necessary to jump into the circle somewhere.)
14831 @<Scan the delimited argument represented by |info(r)|@>=
14832 if ( mp->cur_cmd!=comma ) {
14834 if ( mp->cur_cmd!=left_delimiter ) {
14835 print_err("Missing argument to ");
14836 @.Missing argument...@>
14837 mp_print_macro_name(mp, arg_list,macro_name);
14838 help3("That macro has more parameters than you thought.")
14839 ("I'll continue by pretending that each missing argument")
14840 ("is either zero or null.");
14841 if ( info(r)>=suffix_base ) {
14842 mp->cur_exp=null; mp->cur_type=mp_token_list;
14844 mp->cur_exp=0; mp->cur_type=mp_known;
14846 mp_back_error(mp); mp->cur_cmd=right_delimiter;
14849 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
14851 @<Scan the argument represented by |info(r)|@>;
14852 if ( mp->cur_cmd!=comma )
14853 @<Check that the proper right delimiter was present@>;
14855 @<Append the current expression to |arg_list|@>
14857 @ @<Check that the proper right delim...@>=
14858 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
14859 if ( info(link(r))>=expr_base ) {
14860 mp_missing_err(mp, ",");
14862 help3("I've finished reading a macro argument and am about to")
14863 ("read another; the arguments weren't delimited correctly.")
14864 ("You might want to delete some tokens before continuing.");
14865 mp_back_error(mp); mp->cur_cmd=comma;
14867 mp_missing_err(mp, str(text(r_delim)));
14869 help2("I've gotten to the end of the macro parameter list.")
14870 ("You might want to delete some tokens before continuing.");
14875 @ A \&{suffix} or \&{text} parameter will be have been scanned as
14876 a token list pointed to by |cur_exp|, in which case we will have
14877 |cur_type=token_list|.
14879 @<Append the current expression to |arg_list|@>=
14881 p=mp_get_avail(mp);
14882 if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
14883 else info(p)=mp_stash_cur_exp(mp);
14884 if ( mp->internal[mp_tracing_macros]>0 ) {
14885 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
14886 mp_end_diagnostic(mp, false);
14888 if ( arg_list==null ) arg_list=p;
14893 @ @<Scan the argument represented by |info(r)|@>=
14894 if ( info(r)>=text_base ) {
14895 mp_scan_text_arg(mp, l_delim,r_delim);
14898 if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
14899 else mp_scan_expression(mp);
14902 @ The parameters to |scan_text_arg| are either a pair of delimiters
14903 or zero; the latter case is for undelimited text arguments, which
14904 end with the first semicolon or \&{endgroup} or \&{end} that is not
14905 contained in a group.
14907 @<Declare the procedure called |scan_text_arg|@>=
14908 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
14911 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
14912 integer balance; /* excess of |l_delim| over |r_delim| */
14913 pointer p; /* list tail */
14914 mp->warning_info=l_delim; mp->scanner_status=absorbing;
14915 p=hold_head; balance=1; link(hold_head)=null;
14918 if ( l_delim==0 ) {
14919 @<Adjust the balance for an undelimited argument; |break| if done@>;
14921 @<Adjust the balance for a delimited argument; |break| if done@>;
14923 link(p)=mp_cur_tok(mp); p=link(p);
14925 mp->cur_exp=link(hold_head); mp->cur_type=mp_token_list;
14926 mp->scanner_status=normal;
14929 @ @<Adjust the balance for a delimited argument...@>=
14930 if ( mp->cur_cmd==right_delimiter ) {
14931 if ( mp->cur_mod==l_delim ) {
14933 if ( balance==0 ) break;
14935 } else if ( mp->cur_cmd==left_delimiter ) {
14936 if ( mp->cur_mod==r_delim ) incr(balance);
14939 @ @<Adjust the balance for an undelimited...@>=
14940 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
14941 if ( balance==1 ) { break; }
14942 else { if ( mp->cur_cmd==end_group ) decr(balance); }
14943 } else if ( mp->cur_cmd==begin_group ) {
14947 @ @<Scan undelimited argument(s)@>=
14949 if ( info(r)<text_macro ) {
14951 if ( info(r)!=suffix_macro ) {
14952 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
14956 case primary_macro:mp_scan_primary(mp); break;
14957 case secondary_macro:mp_scan_secondary(mp); break;
14958 case tertiary_macro:mp_scan_tertiary(mp); break;
14959 case expr_macro:mp_scan_expression(mp); break;
14961 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
14964 @<Scan a suffix with optional delimiters@>;
14966 case text_macro:mp_scan_text_arg(mp, 0,0); break;
14967 } /* there are no other cases */
14969 @<Append the current expression to |arg_list|@>;
14972 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
14974 mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
14975 if ( mp->internal[mp_tracing_macros]>0 ) {
14976 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
14977 mp_end_diagnostic(mp, false);
14979 if ( arg_list==null ) arg_list=p; else link(tail)=p;
14981 if ( mp->cur_cmd!=of_token ) {
14982 mp_missing_err(mp, "of"); mp_print(mp, " for ");
14984 mp_print_macro_name(mp, arg_list,macro_name);
14985 help1("I've got the first argument; will look now for the other.");
14988 mp_get_x_next(mp); mp_scan_primary(mp);
14991 @ @<Scan a suffix with optional delimiters@>=
14993 if ( mp->cur_cmd!=left_delimiter ) {
14996 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
14998 mp_scan_suffix(mp);
14999 if ( l_delim!=null ) {
15000 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15001 mp_missing_err(mp, str(text(r_delim)));
15003 help2("I've gotten to the end of the macro parameter list.")
15004 ("You might want to delete some tokens before continuing.");
15011 @ Before we put a new token list on the input stack, it is wise to clean off
15012 all token lists that have recently been depleted. Then a user macro that ends
15013 with a call to itself will not require unbounded stack space.
15015 @<Feed the arguments and replacement text to the scanner@>=
15016 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15017 if ( mp->param_ptr+n>mp->max_param_stack ) {
15018 mp->max_param_stack=mp->param_ptr+n;
15019 if ( mp->max_param_stack>mp->param_size )
15020 mp_overflow(mp, "parameter stack size",mp->param_size);
15021 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15023 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15027 mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=link(p);
15029 mp_flush_list(mp, arg_list);
15032 @ It's sometimes necessary to put a single argument onto |param_stack|.
15033 The |stack_argument| subroutine does this.
15035 @c void mp_stack_argument (MP mp,pointer p) {
15036 if ( mp->param_ptr==mp->max_param_stack ) {
15037 incr(mp->max_param_stack);
15038 if ( mp->max_param_stack>mp->param_size )
15039 mp_overflow(mp, "parameter stack size",mp->param_size);
15040 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15042 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15045 @* \[33] Conditional processing.
15046 Let's consider now the way \&{if} commands are handled.
15048 Conditions can be inside conditions, and this nesting has a stack
15049 that is independent of other stacks.
15050 Four global variables represent the top of the condition stack:
15051 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15052 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15053 the largest code of a |fi_or_else| command that is syntactically legal;
15054 and |if_line| is the line number at which the current conditional began.
15056 If no conditions are currently in progress, the condition stack has the
15057 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15058 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15059 |link| fields of the first word contain |if_limit|, |cur_if|, and
15060 |cond_ptr| at the next level, and the second word contains the
15061 corresponding |if_line|.
15063 @d if_node_size 2 /* number of words in stack entry for conditionals */
15064 @d if_line_field(A) mp->mem[(A)+1].cint
15065 @d if_code 1 /* code for \&{if} being evaluated */
15066 @d fi_code 2 /* code for \&{fi} */
15067 @d else_code 3 /* code for \&{else} */
15068 @d else_if_code 4 /* code for \&{elseif} */
15071 pointer cond_ptr; /* top of the condition stack */
15072 integer if_limit; /* upper bound on |fi_or_else| codes */
15073 small_number cur_if; /* type of conditional being worked on */
15074 integer if_line; /* line where that conditional began */
15077 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15080 mp_primitive(mp, "if",if_test,if_code);
15081 @:if_}{\&{if} primitive@>
15082 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15083 @:fi_}{\&{fi} primitive@>
15084 mp_primitive(mp, "else",fi_or_else,else_code);
15085 @:else_}{\&{else} primitive@>
15086 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15087 @:else_if_}{\&{elseif} primitive@>
15089 @ @<Cases of |print_cmd_mod|...@>=
15093 case if_code:mp_print(mp, "if"); break;
15094 case fi_code:mp_print(mp, "fi"); break;
15095 case else_code:mp_print(mp, "else"); break;
15096 default: mp_print(mp, "elseif"); break;
15100 @ Here is a procedure that ignores text until coming to an \&{elseif},
15101 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15102 nesting. After it has acted, |cur_mod| will indicate the token that
15105 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15106 makes the skipping process a bit simpler.
15109 void mp_pass_text (MP mp) {
15111 mp->scanner_status=skipping;
15112 mp->warning_info=mp_true_line(mp);
15115 if ( mp->cur_cmd<=fi_or_else ) {
15116 if ( mp->cur_cmd<fi_or_else ) {
15120 if ( mp->cur_mod==fi_code ) decr(l);
15123 @<Decrease the string reference count,
15124 if the current token is a string@>;
15127 mp->scanner_status=normal;
15130 @ @<Decrease the string reference count...@>=
15131 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15133 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15134 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15135 condition has been evaluated, a colon will be inserted.
15136 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15138 @<Push the condition stack@>=
15139 { p=mp_get_node(mp, if_node_size); link(p)=mp->cond_ptr; type(p)=mp->if_limit;
15140 name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15141 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15142 mp->cur_if=if_code;
15145 @ @<Pop the condition stack@>=
15146 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15147 mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=link(p);
15148 mp_free_node(mp, p,if_node_size);
15151 @ Here's a procedure that changes the |if_limit| code corresponding to
15152 a given value of |cond_ptr|.
15154 @c void mp_change_if_limit (MP mp,small_number l, pointer p) {
15156 if ( p==mp->cond_ptr ) {
15157 mp->if_limit=l; /* that's the easy case */
15161 if ( q==null ) mp_confusion(mp, "if");
15162 @:this can't happen if}{\quad if@>
15163 if ( link(q)==p ) {
15171 @ The user is supposed to put colons into the proper parts of conditional
15172 statements. Therefore, \MP\ has to check for their presence.
15175 void mp_check_colon (MP mp) {
15176 if ( mp->cur_cmd!=colon ) {
15177 mp_missing_err(mp, ":");
15179 help2("There should've been a colon after the condition.")
15180 ("I shall pretend that one was there.");;
15185 @ A condition is started when the |get_x_next| procedure encounters
15186 an |if_test| command; in that case |get_x_next| calls |conditional|,
15187 which is a recursive procedure.
15190 @c void mp_conditional (MP mp) {
15191 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15192 int new_if_limit; /* future value of |if_limit| */
15193 pointer p; /* temporary register */
15194 @<Push the condition stack@>;
15195 save_cond_ptr=mp->cond_ptr;
15197 mp_get_boolean(mp); new_if_limit=else_if_code;
15198 if ( mp->internal[mp_tracing_commands]>unity ) {
15199 @<Display the boolean value of |cur_exp|@>;
15202 mp_check_colon(mp);
15203 if ( mp->cur_exp==true_code ) {
15204 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15205 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15207 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15209 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15210 if ( mp->cur_mod==fi_code ) {
15211 @<Pop the condition stack@>
15212 } else if ( mp->cur_mod==else_if_code ) {
15215 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15220 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15221 \&{else}: \\{bar} \&{fi}', the first \&{else}
15222 that we come to after learning that the \&{if} is false is not the
15223 \&{else} we're looking for. Hence the following curious logic is needed.
15225 @<Skip to \&{elseif}...@>=
15228 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15229 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15233 @ @<Display the boolean value...@>=
15234 { mp_begin_diagnostic(mp);
15235 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15236 else mp_print(mp, "{false}");
15237 mp_end_diagnostic(mp, false);
15240 @ The processing of conditionals is complete except for the following
15241 code, which is actually part of |get_x_next|. It comes into play when
15242 \&{elseif}, \&{else}, or \&{fi} is scanned.
15244 @<Terminate the current conditional and skip to \&{fi}@>=
15245 if ( mp->cur_mod>mp->if_limit ) {
15246 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15247 mp_missing_err(mp, ":");
15249 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15251 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15255 help1("I'm ignoring this; it doesn't match any if.");
15259 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15260 @<Pop the condition stack@>;
15263 @* \[34] Iterations.
15264 To bring our treatment of |get_x_next| to a close, we need to consider what
15265 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15267 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15268 that are currently active. If |loop_ptr=null|, no loops are in progress;
15269 otherwise |info(loop_ptr)| points to the iterative text of the current
15270 (innermost) loop, and |link(loop_ptr)| points to the data for any other
15271 loops that enclose the current one.
15273 A loop-control node also has two other fields, called |loop_type| and
15274 |loop_list|, whose contents depend on the type of loop:
15276 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15277 points to a list of one-word nodes whose |info| fields point to the
15278 remaining argument values of a suffix list and expression list.
15280 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15283 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15284 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15285 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15288 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15289 header and |loop_list(loop_ptr)| points into the graphical object list for
15292 \yskip\noindent In the case of a progression node, the first word is not used
15293 because the link field of words in the dynamic memory area cannot be arbitrary.
15295 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15296 @d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
15297 @d loop_list(A) link(loop_list_loc((A))) /* the remaining list elements */
15298 @d loop_node_size 2 /* the number of words in a loop control node */
15299 @d progression_node_size 4 /* the number of words in a progression node */
15300 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15301 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15302 @d progression_flag (null+2)
15303 /* |loop_type| value when |loop_list| points to a progression node */
15306 pointer loop_ptr; /* top of the loop-control-node stack */
15311 @ If the expressions that define an arithmetic progression in
15312 a \&{for} loop don't have known numeric values, the |bad_for|
15313 subroutine screams at the user.
15315 @c void mp_bad_for (MP mp, char * s) {
15316 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15317 @.Improper...replaced by 0@>
15318 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15319 help4("When you say `for x=a step b until c',")
15320 ("the initial value `a' and the step size `b'")
15321 ("and the final value `c' must have known numeric values.")
15322 ("I'm zeroing this one. Proceed, with fingers crossed.");
15323 mp_put_get_flush_error(mp, 0);
15326 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15327 has just been scanned. (This code requires slight familiarity with
15328 expression-parsing routines that we have not yet discussed; but it seems
15329 to belong in the present part of the program, even though the original author
15330 didn't write it until later. The reader may wish to come back to it.)
15332 @c void mp_begin_iteration (MP mp) {
15333 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15334 halfword n; /* hash address of the current symbol */
15335 pointer s; /* the new loop-control node */
15336 pointer p; /* substitution list for |scan_toks| */
15337 pointer q; /* link manipulation register */
15338 pointer pp; /* a new progression node */
15339 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15340 if ( m==start_forever ){
15341 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15343 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15344 info(p)=mp->cur_sym; value(p)=m;
15346 if ( mp->cur_cmd==within_token ) {
15347 @<Set up a picture iteration@>;
15349 @<Check for the |"="| or |":="| in a loop header@>;
15350 @<Scan the values to be used in the loop@>;
15353 @<Check for the presence of a colon@>;
15354 @<Scan the loop text and put it on the loop control stack@>;
15355 mp_resume_iteration(mp);
15358 @ @<Check for the |"="| or |":="| in a loop header@>=
15359 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15360 mp_missing_err(mp, "=");
15362 help3("The next thing in this loop should have been `=' or `:='.")
15363 ("But don't worry; I'll pretend that an equals sign")
15364 ("was present, and I'll look for the values next.");
15368 @ @<Check for the presence of a colon@>=
15369 if ( mp->cur_cmd!=colon ) {
15370 mp_missing_err(mp, ":");
15372 help3("The next thing in this loop should have been a `:'.")
15373 ("So I'll pretend that a colon was present;")
15374 ("everything from here to `endfor' will be iterated.");
15378 @ We append a special |frozen_repeat_loop| token in place of the
15379 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15380 at the proper time to cause the loop to be repeated.
15382 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15383 he will be foiled by the |get_symbol| routine, which keeps frozen
15384 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15385 token, so it won't be lost accidentally.)
15387 @ @<Scan the loop text...@>=
15388 q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
15389 mp->scanner_status=loop_defining; mp->warning_info=n;
15390 info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15391 link(s)=mp->loop_ptr; mp->loop_ptr=s
15393 @ @<Initialize table...@>=
15394 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15395 text(frozen_repeat_loop)=intern(" ENDFOR");
15397 @ The loop text is inserted into \MP's scanning apparatus by the
15398 |resume_iteration| routine.
15400 @c void mp_resume_iteration (MP mp) {
15401 pointer p,q; /* link registers */
15402 p=loop_type(mp->loop_ptr);
15403 if ( p==progression_flag ) {
15404 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15405 mp->cur_exp=value(p);
15406 if ( @<The arithmetic progression has ended@> ) {
15407 mp_stop_iteration(mp);
15410 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15411 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15412 } else if ( p==null ) {
15413 p=loop_list(mp->loop_ptr);
15415 mp_stop_iteration(mp);
15418 loop_list(mp->loop_ptr)=link(p); q=info(p); free_avail(p);
15419 } else if ( p==mp_void ) {
15420 mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
15422 @<Make |q| a capsule containing the next picture component from
15423 |loop_list(loop_ptr)| or |goto not_found|@>;
15425 mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
15426 mp_stack_argument(mp, q);
15427 if ( mp->internal[mp_tracing_commands]>unity ) {
15428 @<Trace the start of a loop@>;
15432 mp_stop_iteration(mp);
15435 @ @<The arithmetic progression has ended@>=
15436 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15437 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15439 @ @<Trace the start of a loop@>=
15441 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15443 if ( (q!=null)&&(link(q)==mp_void) ) mp_print_exp(mp, q,1);
15444 else mp_show_token_list(mp, q,null,50,0);
15445 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
15448 @ @<Make |q| a capsule containing the next picture component from...@>=
15449 { q=loop_list(mp->loop_ptr);
15450 if ( q==null ) goto NOT_FOUND;
15451 skip_component(q) goto NOT_FOUND;
15452 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15453 mp_init_bbox(mp, mp->cur_exp);
15454 mp->cur_type=mp_picture_type;
15455 loop_list(mp->loop_ptr)=q;
15456 q=mp_stash_cur_exp(mp);
15459 @ A level of loop control disappears when |resume_iteration| has decided
15460 not to resume, or when an \&{exitif} construction has removed the loop text
15461 from the input stack.
15463 @c void mp_stop_iteration (MP mp) {
15464 pointer p,q; /* the usual */
15465 p=loop_type(mp->loop_ptr);
15466 if ( p==progression_flag ) {
15467 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15468 } else if ( p==null ){
15469 q=loop_list(mp->loop_ptr);
15470 while ( q!=null ) {
15473 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
15474 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15476 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15479 p=q; q=link(q); free_avail(p);
15481 } else if ( p>progression_flag ) {
15482 delete_edge_ref(p);
15484 p=mp->loop_ptr; mp->loop_ptr=link(p); mp_flush_token_list(mp, info(p));
15485 mp_free_node(mp, p,loop_node_size);
15488 @ Now that we know all about loop control, we can finish up
15489 the missing portion of |begin_iteration| and we'll be done.
15491 The following code is performed after the `\.=' has been scanned in
15492 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15493 (if |m=suffix_base|).
15495 @<Scan the values to be used in the loop@>=
15496 loop_type(s)=null; q=loop_list_loc(s); link(q)=null; /* |link(q)=loop_list(s)| */
15499 if ( m!=expr_base ) {
15500 mp_scan_suffix(mp);
15502 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15504 mp_scan_expression(mp);
15505 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15506 @<Prepare for step-until construction and |break|@>;
15508 mp->cur_exp=mp_stash_cur_exp(mp);
15510 link(q)=mp_get_avail(mp); q=link(q);
15511 info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15514 } while (mp->cur_cmd==comma)
15516 @ @<Prepare for step-until construction and |break|@>=
15518 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15519 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15520 mp_get_x_next(mp); mp_scan_expression(mp);
15521 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15522 step_size(pp)=mp->cur_exp;
15523 if ( mp->cur_cmd!=until_token ) {
15524 mp_missing_err(mp, "until");
15525 @.Missing `until'@>
15526 help2("I assume you meant to say `until' after `step'.")
15527 ("So I'll look for the final value and colon next.");
15530 mp_get_x_next(mp); mp_scan_expression(mp);
15531 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15532 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15533 loop_type(s)=progression_flag;
15537 @ The last case is when we have just seen ``\&{within}'', and we need to
15538 parse a picture expression and prepare to iterate over it.
15540 @<Set up a picture iteration@>=
15541 { mp_get_x_next(mp);
15542 mp_scan_expression(mp);
15543 @<Make sure the current expression is a known picture@>;
15544 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15545 q=link(dummy_loc(mp->cur_exp));
15547 if ( is_start_or_stop(q) )
15548 if ( mp_skip_1component(mp, q)==null ) q=link(q);
15552 @ @<Make sure the current expression is a known picture@>=
15553 if ( mp->cur_type!=mp_picture_type ) {
15554 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15555 help1("When you say `for x in p', p must be a known picture.");
15556 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15557 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15560 @* \[35] File names.
15561 It's time now to fret about file names. Besides the fact that different
15562 operating systems treat files in different ways, we must cope with the
15563 fact that completely different naming conventions are used by different
15564 groups of people. The following programs show what is required for one
15565 particular operating system; similar routines for other systems are not
15566 difficult to devise.
15567 @^system dependencies@>
15569 \MP\ assumes that a file name has three parts: the name proper; its
15570 ``extension''; and a ``file area'' where it is found in an external file
15571 system. The extension of an input file is assumed to be
15572 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15573 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15574 metric files that describe characters in any fonts created by \MP; it is
15575 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15576 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15577 The file area can be arbitrary on input files, but files are usually
15578 output to the user's current area. If an input file cannot be
15579 found on the specified area, \MP\ will look for it on a special system
15580 area; this special area is intended for commonly used input files.
15582 Simple uses of \MP\ refer only to file names that have no explicit
15583 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15584 instead of `\.{input} \.{cmr10.new}'. Simple file
15585 names are best, because they make the \MP\ source files portable;
15586 whenever a file name consists entirely of letters and digits, it should be
15587 treated in the same way by all implementations of \MP. However, users
15588 need the ability to refer to other files in their environment, especially
15589 when responding to error messages concerning unopenable files; therefore
15590 we want to let them use the syntax that appears in their favorite
15593 @ \MP\ uses the same conventions that have proved to be satisfactory for
15594 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15595 @^system dependencies@>
15596 the system-independent parts of \MP\ are expressed in terms
15597 of three system-dependent
15598 procedures called |begin_name|, |more_name|, and |end_name|. In
15599 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15600 the system-independent driver program does the operations
15601 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;|more_name|(c_n);
15603 These three procedures communicate with each other via global variables.
15604 Afterwards the file name will appear in the string pool as three strings
15605 called |cur_name|\penalty10000\hskip-.05em,
15606 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15607 |""|), unless they were explicitly specified by the user.
15609 Actually the situation is slightly more complicated, because \MP\ needs
15610 to know when the file name ends. The |more_name| routine is a function
15611 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15612 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15613 returns |false|; or, it returns |true| and $c_n$ is the last character
15614 on the current input line. In other words,
15615 |more_name| is supposed to return |true| unless it is sure that the
15616 file name has been completely scanned; and |end_name| is supposed to be able
15617 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15618 whether $|more_name|(c_n)$ returned |true| or |false|.
15621 char * cur_name; /* name of file just scanned */
15622 char * cur_area; /* file area just scanned, or \.{""} */
15623 char * cur_ext; /* file extension just scanned, or \.{""} */
15625 @ It is easier to maintain reference counts if we assign initial values.
15628 mp->cur_name=xstrdup("");
15629 mp->cur_area=xstrdup("");
15630 mp->cur_ext=xstrdup("");
15632 @ @<Dealloc variables@>=
15633 xfree(mp->cur_area);
15634 xfree(mp->cur_name);
15635 xfree(mp->cur_ext);
15637 @ The file names we shall deal with for illustrative purposes have the
15638 following structure: If the name contains `\.>' or `\.:', the file area
15639 consists of all characters up to and including the final such character;
15640 otherwise the file area is null. If the remaining file name contains
15641 `\..', the file extension consists of all such characters from the first
15642 remaining `\..' to the end, otherwise the file extension is null.
15643 @^system dependencies@>
15645 We can scan such file names easily by using two global variables that keep track
15646 of the occurrences of area and extension delimiters. Note that these variables
15647 cannot be of type |pool_pointer| because a string pool compaction could occur
15648 while scanning a file name.
15651 integer area_delimiter;
15652 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15653 integer ext_delimiter; /* the relevant `\..', if any */
15655 @ Input files that can't be found in the user's area may appear in standard
15656 system areas called |MP_area| and |MF_area|. (The latter is used when the file
15657 extension is |".mf"|.) The standard system area for font metric files
15658 to be read is |MP_font_area|.
15659 This system area name will, of course, vary from place to place.
15660 @^system dependencies@>
15662 @d MP_area "MPinputs:"
15664 @d MF_area "MFinputs:"
15669 @ Here now is the first of the system-dependent routines for file name scanning.
15670 @^system dependencies@>
15672 @<Declare subroutines for parsing file names@>=
15673 void mp_begin_name (MP mp) {
15674 xfree(mp->cur_name);
15675 xfree(mp->cur_area);
15676 xfree(mp->cur_ext);
15677 mp->area_delimiter=-1;
15678 mp->ext_delimiter=-1;
15681 @ And here's the second.
15682 @^system dependencies@>
15684 @<Declare subroutines for parsing file names@>=
15685 boolean mp_more_name (MP mp, ASCII_code c) {
15689 if ( (c=='>')||(c==':') ) {
15690 mp->area_delimiter=mp->pool_ptr;
15691 mp->ext_delimiter=-1;
15692 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15693 mp->ext_delimiter=mp->pool_ptr;
15695 str_room(1); append_char(c); /* contribute |c| to the current string */
15701 @^system dependencies@>
15703 @d copy_pool_segment(A,B,C) {
15704 A = xmalloc(C+1,sizeof(char));
15705 strncpy(A,(char *)(mp->str_pool+B),C);
15708 @<Declare subroutines for parsing file names@>=
15709 void mp_end_name (MP mp) {
15710 pool_pointer s; /* length of area, name, and extension */
15713 s = mp->str_start[mp->str_ptr];
15714 if ( mp->area_delimiter<0 ) {
15715 mp->cur_area=xstrdup("");
15717 len = mp->area_delimiter-s;
15718 copy_pool_segment(mp->cur_area,s,len);
15721 if ( mp->ext_delimiter<0 ) {
15722 mp->cur_ext=xstrdup("");
15723 len = mp->pool_ptr-s;
15725 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(mp->pool_ptr-mp->ext_delimiter));
15726 len = mp->ext_delimiter-s;
15728 copy_pool_segment(mp->cur_name,s,len);
15729 mp->pool_ptr=s; /* don't need this partial string */
15732 @ Conversely, here is a routine that takes three strings and prints a file
15733 name that might have produced them. (The routine is system dependent, because
15734 some operating systems put the file area last instead of first.)
15735 @^system dependencies@>
15737 @<Basic printing...@>=
15738 void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15739 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15742 @ Another system-dependent routine is needed to convert three internal
15744 to the |name_of_file| value that is used to open files. The present code
15745 allows both lowercase and uppercase letters in the file name.
15746 @^system dependencies@>
15748 @d append_to_name(A) { c=(A);
15749 if ( k<file_name_size ) {
15750 mp->name_of_file[k]=xchr(c);
15755 @<Declare subroutines for parsing file names@>=
15756 void mp_pack_file_name (MP mp, char *n, char *a, char *e) {
15757 integer k; /* number of positions filled in |name_of_file| */
15758 ASCII_code c; /* character being packed */
15759 char *j; /* a character index */
15763 for (j=a;*j;j++) { append_to_name(*j); }
15765 for (j=n;*j;j++) { append_to_name(*j); }
15767 for (j=e;*j;j++) { append_to_name(*j); }
15769 mp->name_of_file[k]=0;
15773 @ @<Internal library declarations@>=
15774 void mp_pack_file_name (MP mp, char *n, char *a, char *e) ;
15776 @ A messier routine is also needed, since mem file names must be scanned
15777 before \MP's string mechanism has been initialized. We shall use the
15778 global variable |MP_mem_default| to supply the text for default system areas
15779 and extensions related to mem files.
15780 @^system dependencies@>
15782 @d mem_default_length 9 /* length of the |MP_mem_default| string */
15783 @d mem_ext_length 4 /* length of its `\.{.mem}' part */
15784 @d mem_extension ".mem" /* the extension, as a \.{WEB} constant */
15787 char *MP_mem_default;
15788 char *mem_name; /* for commandline */
15790 @ @<Option variables@>=
15791 char *mem_name; /* for commandline */
15793 @ @<Allocate or initialize ...@>=
15794 mp->MP_mem_default = xstrdup("plain.mem");
15795 mp->mem_name = xstrdup(opt->mem_name);
15797 @^system dependencies@>
15799 @ @<Dealloc variables@>=
15800 xfree(mp->MP_mem_default);
15801 xfree(mp->mem_name);
15803 @ @<Check the ``constant'' values for consistency@>=
15804 if ( mem_default_length>file_name_size ) mp->bad=20;
15806 @ Here is the messy routine that was just mentioned. It sets |name_of_file|
15807 from the first |n| characters of |MP_mem_default|, followed by
15808 |buffer[a..b-1]|, followed by the last |mem_ext_length| characters of
15811 We dare not give error messages here, since \MP\ calls this routine before
15812 the |error| routine is ready to roll. Instead, we simply drop excess characters,
15813 since the error will be detected in another way when a strange file name
15815 @^system dependencies@>
15817 @c void mp_pack_buffered_name (MP mp,small_number n, integer a,
15819 integer k; /* number of positions filled in |name_of_file| */
15820 ASCII_code c; /* character being packed */
15821 integer j; /* index into |buffer| or |MP_mem_default| */
15822 if ( n+b-a+1+mem_ext_length>file_name_size )
15823 b=a+file_name_size-n-1-mem_ext_length;
15825 for (j=0;j<n;j++) {
15826 append_to_name(xord((int)mp->MP_mem_default[j]));
15828 for (j=a;j<b;j++) {
15829 append_to_name(mp->buffer[j]);
15831 for (j=mem_default_length-mem_ext_length;
15832 j<mem_default_length;j++) {
15833 append_to_name(xord((int)mp->MP_mem_default[j]));
15835 mp->name_of_file[k]=0;
15839 @ Here is the only place we use |pack_buffered_name|. This part of the program
15840 becomes active when a ``virgin'' \MP\ is trying to get going, just after
15841 the preliminary initialization, or when the user is substituting another
15842 mem file by typing `\.\&' after the initial `\.{**}' prompt. The buffer
15843 contains the first line of input in |buffer[loc..(last-1)]|, where
15844 |loc<last| and |buffer[loc]<>" "|.
15847 boolean mp_open_mem_file (MP mp) ;
15850 boolean mp_open_mem_file (MP mp) {
15851 int j; /* the first space after the file name */
15852 if (mp->mem_name!=NULL) {
15853 mp->mem_file = mp_open_file(mp, mp->mem_name, "rb", mp_filetype_memfile);
15854 if ( mp->mem_file ) return true;
15857 if ( mp->buffer[loc]=='&' ) {
15858 incr(loc); j=loc; mp->buffer[mp->last]=' ';
15859 while ( mp->buffer[j]!=' ' ) incr(j);
15860 mp_pack_buffered_name(mp, 0,loc,j); /* try first without the system file area */
15861 if ( mp_w_open_in(mp, &mp->mem_file) ) goto FOUND;
15863 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
15864 @.Sorry, I can't find...@>
15867 /* now pull out all the stops: try for the system \.{plain} file */
15868 mp_pack_buffered_name(mp, mem_default_length-mem_ext_length,0,0);
15869 if ( ! mp_w_open_in(mp, &mp->mem_file) ) {
15871 wterm_ln("I can\'t find the PLAIN mem file!\n");
15872 @.I can't find PLAIN...@>
15877 loc=j; return true;
15880 @ Operating systems often make it possible to determine the exact name (and
15881 possible version number) of a file that has been opened. The following routine,
15882 which simply makes a \MP\ string from the value of |name_of_file|, should
15883 ideally be changed to deduce the full name of file~|f|, which is the file
15884 most recently opened, if it is possible to do this in a \PASCAL\ program.
15885 @^system dependencies@>
15888 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
15889 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
15890 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
15893 str_number mp_make_name_string (MP mp) {
15894 int k; /* index into |name_of_file| */
15895 str_room(mp->name_length);
15896 for (k=0;k<mp->name_length;k++) {
15897 append_char(xord((int)mp->name_of_file[k]));
15899 return mp_make_string(mp);
15902 @ Now let's consider the ``driver''
15903 routines by which \MP\ deals with file names
15904 in a system-independent manner. First comes a procedure that looks for a
15905 file name in the input by taking the information from the input buffer.
15906 (We can't use |get_next|, because the conversion to tokens would
15907 destroy necessary information.)
15909 This procedure doesn't allow semicolons or percent signs to be part of
15910 file names, because of other conventions of \MP.
15911 {\sl The {\logos METAFONT\/}book} doesn't
15912 use semicolons or percents immediately after file names, but some users
15913 no doubt will find it natural to do so; therefore system-dependent
15914 changes to allow such characters in file names should probably
15915 be made with reluctance, and only when an entire file name that
15916 includes special characters is ``quoted'' somehow.
15917 @^system dependencies@>
15919 @c void mp_scan_file_name (MP mp) {
15921 while ( mp->buffer[loc]==' ' ) incr(loc);
15923 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
15924 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
15930 @ Here is another version that takes its input from a string.
15932 @<Declare subroutines for parsing file names@>=
15933 void mp_str_scan_file (MP mp, str_number s) {
15934 pool_pointer p,q; /* current position and stopping point */
15936 p=mp->str_start[s]; q=str_stop(s);
15938 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
15944 @ And one that reads from a |char*|.
15946 @<Declare subroutines for parsing file names@>=
15947 void mp_ptr_scan_file (MP mp, char *s) {
15948 char *p, *q; /* current position and stopping point */
15950 p=s; q=p+strlen(s);
15952 if ( ! mp_more_name(mp, *p)) break;
15959 @ The global variable |job_name| contains the file name that was first
15960 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
15961 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
15964 char *job_name; /* principal file name */
15965 boolean log_opened; /* has the transcript file been opened? */
15966 char *log_name; /* full name of the log file */
15968 @ @<Option variables@>=
15969 char *job_name; /* principal file name */
15971 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
15972 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
15973 except of course for a short time just after |job_name| has become nonzero.
15975 @<Allocate or ...@>=
15976 mp->job_name=opt->job_name;
15977 mp->log_opened=false;
15979 @ @<Dealloc variables@>=
15980 xfree(mp->job_name);
15982 @ Here is a routine that manufactures the output file names, assuming that
15983 |job_name<>0|. It ignores and changes the current settings of |cur_area|
15986 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
15989 void mp_pack_job_name (MP mp, char *s) ;
15991 @ @c void mp_pack_job_name (MP mp, char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
15992 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
15993 xfree(mp->cur_area); mp->cur_area=xstrdup("");
15994 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
15998 @ If some trouble arises when \MP\ tries to open a file, the following
15999 routine calls upon the user to supply another file name. Parameter~|s|
16000 is used in the error message to identify the type of file; parameter~|e|
16001 is the default extension if none is given. Upon exit from the routine,
16002 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16003 ready for another attempt at file opening.
16006 void mp_prompt_file_name (MP mp,char * s, char * e) ;
16008 @ @c void mp_prompt_file_name (MP mp,char * s, char * e) {
16009 size_t k; /* index into |buffer| */
16010 char * saved_cur_name;
16011 if ( mp->interaction==mp_scroll_mode )
16013 if (strcmp(s,"input file name")==0) {
16014 print_err("I can\'t find file `");
16015 @.I can't find file x@>
16017 print_err("I can\'t write on file `");
16019 @.I can't write on file x@>
16020 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16021 mp_print(mp, "'.");
16022 if (strcmp(e,"")==0)
16023 mp_show_context(mp);
16024 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16026 if ( mp->interaction<mp_scroll_mode )
16027 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16028 @.job aborted, file error...@>
16029 saved_cur_name = xstrdup(mp->cur_name);
16030 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16031 if (strcmp(mp->cur_ext,"")==0)
16033 if (strlen(mp->cur_name)==0) {
16034 mp->cur_name=saved_cur_name;
16036 xfree(saved_cur_name);
16041 @ @<Scan file name in the buffer@>=
16043 mp_begin_name(mp); k=mp->first;
16044 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16046 if ( k==mp->last ) break;
16047 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16053 @ The |open_log_file| routine is used to open the transcript file and to help
16054 it catch up to what has previously been printed on the terminal.
16056 @c void mp_open_log_file (MP mp) {
16057 int old_setting; /* previous |selector| setting */
16058 int k; /* index into |months| and |buffer| */
16059 int l; /* end of first input line */
16060 integer m; /* the current month */
16061 char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16062 /* abbreviations of month names */
16063 old_setting=mp->selector;
16064 if ( mp->job_name==NULL ) {
16065 mp->job_name=xstrdup("mpout");
16067 mp_pack_job_name(mp,".log");
16068 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16069 @<Try to get a different log file name@>;
16071 mp->log_name=xstrdup(mp->name_of_file);
16072 mp->selector=log_only; mp->log_opened=true;
16073 @<Print the banner line, including the date and time@>;
16074 mp->input_stack[mp->input_ptr]=mp->cur_input;
16075 /* make sure bottom level is in memory */
16076 mp_print_nl(mp, "**");
16078 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16079 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16080 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16081 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16084 @ @<Dealloc variables@>=
16085 xfree(mp->log_name);
16087 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16088 unable to print error messages or even to |show_context|.
16089 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16090 routine will not be invoked because |log_opened| will be false.
16092 The normal idea of |mp_batch_mode| is that nothing at all should be written
16093 on the terminal. However, in the unusual case that
16094 no log file could be opened, we make an exception and allow
16095 an explanatory message to be seen.
16097 Incidentally, the program always refers to the log file as a `\.{transcript
16098 file}', because some systems cannot use the extension `\.{.log}' for
16101 @<Try to get a different log file name@>=
16103 mp->selector=term_only;
16104 mp_prompt_file_name(mp, "transcript file name",".log");
16107 @ @<Print the banner...@>=
16110 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16111 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16112 mp_print_char(mp, ' ');
16113 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16114 for (k=3*m-3;k<3*m;k++) { wlog_chr(months[k]); }
16115 mp_print_char(mp, ' ');
16116 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16117 mp_print_char(mp, ' ');
16118 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16119 mp_print_dd(mp, m / 60); mp_print_char(mp, ':'); mp_print_dd(mp, m % 60);
16122 @ The |try_extension| function tries to open an input file determined by
16123 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16124 can't find the file in |cur_area| or the appropriate system area.
16126 @c boolean mp_try_extension (MP mp,char *ext) {
16127 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16128 in_name=xstrdup(mp->cur_name);
16129 in_area=xstrdup(mp->cur_area);
16130 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16133 if (strcmp(ext,".mf")==0 ) in_area=xstrdup(MF_area);
16134 else in_area=xstrdup(MP_area);
16135 mp_pack_file_name(mp, mp->cur_name,in_area,ext);
16136 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16141 @ Let's turn now to the procedure that is used to initiate file reading
16142 when an `\.{input}' command is being processed.
16144 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16145 char *fname = NULL;
16146 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16148 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16149 if ( strlen(mp->cur_ext)==0 ) {
16150 if ( mp_try_extension(mp, ".mp") ) break;
16151 else if ( mp_try_extension(mp, "") ) break;
16152 else if ( mp_try_extension(mp, ".mf") ) break;
16153 /* |else do_nothing; | */
16154 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16157 mp_end_file_reading(mp); /* remove the level that didn't work */
16158 mp_prompt_file_name(mp, "input file name","");
16160 name=mp_a_make_name_string(mp, cur_file);
16161 fname = xstrdup(mp->name_of_file);
16162 if ( mp->job_name==NULL ) {
16163 mp->job_name=xstrdup(mp->cur_name);
16164 mp_open_log_file(mp);
16165 } /* |open_log_file| doesn't |show_context|, so |limit|
16166 and |loc| needn't be set to meaningful values yet */
16167 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16168 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
16169 mp_print_char(mp, '('); incr(mp->open_parens); mp_print(mp, fname);
16172 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16173 @<Read the first line of the new file@>;
16176 @ This code should be omitted if |a_make_name_string| returns something other
16177 than just a copy of its argument and the full file name is needed for opening
16178 \.{MPX} files or implementing the switch-to-editor option.
16179 @^system dependencies@>
16181 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16182 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16184 @ Here we have to remember to tell the |input_ln| routine not to
16185 start with a |get|. If the file is empty, it is considered to
16186 contain a single blank line.
16187 @^system dependencies@>
16189 @<Read the first line...@>=
16192 (void)mp_input_ln(mp, cur_file,false);
16193 mp_firm_up_the_line(mp);
16194 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
16197 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16198 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16199 if ( token_state ) {
16200 print_err("File names can't appear within macros");
16201 @.File names can't...@>
16202 help3("Sorry...I've converted what follows to tokens,")
16203 ("possibly garbaging the name you gave.")
16204 ("Please delete the tokens and insert the name again.");
16207 if ( file_state ) {
16208 mp_scan_file_name(mp);
16210 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16211 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16212 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16215 @ Sometimes we need to deal with two file names at once. This procedure
16216 copies the given string into a special array for an old file name.
16218 @c void mp_copy_old_name (MP mp,str_number s) {
16219 integer k; /* number of positions filled in |old_file_name| */
16220 pool_pointer j; /* index into |str_pool| */
16222 for (j=mp->str_start[s];j<=str_stop(s)-1;j++) {
16224 if ( k<=file_name_size )
16225 mp->old_file_name[k]=xchr(mp->str_pool[j]);
16227 mp->old_file_name[++k] = 0;
16231 char old_file_name[file_name_size+1]; /* analogous to |name_of_file| */
16233 @ The following simple routine starts reading the \.{MPX} file associated
16234 with the current input file.
16236 @c void mp_start_mpx_input (MP mp) {
16237 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16238 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16239 |goto not_found| if there is a problem@>;
16240 mp_begin_file_reading(mp);
16241 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16242 mp_end_file_reading(mp);
16245 name=mp_a_make_name_string(mp, cur_file);
16246 mp->mpx_name[index]=name; add_str_ref(name);
16247 @<Read the first line of the new file@>;
16250 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16253 @ This should ideally be changed to do whatever is necessary to create the
16254 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16255 of date. This requires invoking \.{MPtoTeX} on the |old_file_name| and passing
16256 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16257 completely different typesetting program if suitable postprocessor is
16258 available to perform the function of \.{DVItoMP}.)
16259 @^system dependencies@>
16261 @ @<Exported types@>=
16262 typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
16265 mp_run_make_mpx_command run_make_mpx;
16267 @ @<Option variables@>=
16268 mp_run_make_mpx_command run_make_mpx;
16270 @ @<Allocate or initialize ...@>=
16271 set_callback_option(run_make_mpx);
16273 @ @<Internal library declarations@>=
16274 int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16276 @ The default does nothing.
16278 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16279 if (mp && origname && mtxname) /* for -W */
16286 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16287 |goto not_found| if there is a problem@>=
16288 mp_copy_old_name(mp, name);
16289 if (!(mp->run_make_mpx)(mp, mp->old_file_name, mp->name_of_file))
16292 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16293 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16294 mp_print_nl(mp, ">> ");
16295 mp_print(mp, mp->old_file_name);
16296 mp_print_nl(mp, ">> ");
16297 mp_print(mp, mp->name_of_file);
16298 mp_print_nl(mp, "! Unable to make mpx file");
16299 help4("The two files given above are one of your source files")
16300 ("and an auxiliary file I need to read to find out what your")
16301 ("btex..etex blocks mean. If you don't know why I had trouble,")
16302 ("try running it manually through MPtoTeX, TeX, and DVItoMP");
16305 @ The last file-opening commands are for files accessed via the \&{readfrom}
16306 @:read_from_}{\&{readfrom} primitive@>
16307 operator and the \&{write} command. Such files are stored in separate arrays.
16308 @:write_}{\&{write} primitive@>
16310 @<Types in the outer block@>=
16311 typedef unsigned int readf_index; /* |0..max_read_files| */
16312 typedef unsigned int write_index; /* |0..max_write_files| */
16315 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16316 FILE ** rd_file; /* \&{readfrom} files */
16317 char ** rd_fname; /* corresponding file name or 0 if file not open */
16318 readf_index read_files; /* number of valid entries in the above arrays */
16319 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16320 FILE ** wr_file; /* \&{write} files */
16321 char ** wr_fname; /* corresponding file name or 0 if file not open */
16322 write_index write_files; /* number of valid entries in the above arrays */
16324 @ @<Allocate or initialize ...@>=
16325 mp->max_read_files=8;
16326 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(FILE *));
16327 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16328 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16330 mp->max_write_files=8;
16331 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(FILE *));
16332 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16333 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16337 @ This routine starts reading the file named by string~|s| without setting
16338 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16339 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16341 @c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16342 mp_ptr_scan_file(mp, s);
16344 mp_begin_file_reading(mp);
16345 if ( ! mp_a_open_in(mp, &mp->rd_file[n], mp_filetype_text) )
16347 if ( ! mp_input_ln(mp, mp->rd_file[n], false) ) {
16348 fclose(mp->rd_file[n]);
16351 mp->rd_fname[n]=xstrdup(mp->name_of_file);
16354 mp_end_file_reading(mp);
16358 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16361 void mp_open_write_file (MP mp, char *s, readf_index n) ;
16363 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16364 mp_ptr_scan_file(mp, s);
16366 while ( ! mp_a_open_out(mp, &mp->wr_file[n], mp_filetype_text) )
16367 mp_prompt_file_name(mp, "file name for write output","");
16368 mp->wr_fname[n]=xstrdup(mp->name_of_file);
16372 @* \[36] Introduction to the parsing routines.
16373 We come now to the central nervous system that sparks many of \MP's activities.
16374 By evaluating expressions, from their primary constituents to ever larger
16375 subexpressions, \MP\ builds the structures that ultimately define complete
16376 pictures or fonts of type.
16378 Four mutually recursive subroutines are involved in this process: We call them
16379 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16380 and |scan_expression|.}$$
16382 Each of them is parameterless and begins with the first token to be scanned
16383 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16384 the value of the primary or secondary or tertiary or expression that was
16385 found will appear in the global variables |cur_type| and |cur_exp|. The
16386 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16389 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16390 backup mechanisms have been added in order to provide reasonable error
16394 small_number cur_type; /* the type of the expression just found */
16395 integer cur_exp; /* the value of the expression just found */
16400 @ Many different kinds of expressions are possible, so it is wise to have
16401 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16404 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16405 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16406 construction in which there was no expression before the \&{endgroup}.
16407 In this case |cur_exp| has some irrelevant value.
16410 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16414 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16415 node that is in the ring of variables equivalent
16416 to at least one undefined boolean variable.
16419 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16420 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16421 includes this particular reference.
16424 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16425 node that is in the ring of variables equivalent
16426 to at least one undefined string variable.
16429 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16430 else points to any of the nodes in this pen. The pen may be polygonal or
16434 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16435 node that is in the ring of variables equivalent
16436 to at least one undefined pen variable.
16439 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16440 a path; nobody else points to this particular path. The control points of
16441 the path will have been chosen.
16444 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16445 node that is in the ring of variables equivalent
16446 to at least one undefined path variable.
16449 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16450 There may be other pointers to this particular set of edges. The header node
16451 contains a reference count that includes this particular reference.
16454 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16455 node that is in the ring of variables equivalent
16456 to at least one undefined picture variable.
16459 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16460 capsule node. The |value| part of this capsule
16461 points to a transform node that contains six numeric values,
16462 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16465 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16466 capsule node. The |value| part of this capsule
16467 points to a color node that contains three numeric values,
16468 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16471 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16472 capsule node. The |value| part of this capsule
16473 points to a color node that contains four numeric values,
16474 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16477 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16478 node whose type is |mp_pair_type|. The |value| part of this capsule
16479 points to a pair node that contains two numeric values,
16480 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16483 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16486 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16487 is |dependent|. The |dep_list| field in this capsule points to the associated
16491 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16492 capsule node. The |dep_list| field in this capsule
16493 points to the associated dependency list.
16496 |cur_type=independent| means that |cur_exp| points to a capsule node
16497 whose type is |independent|. This somewhat unusual case can arise, for
16498 example, in the expression
16499 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16502 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16503 tokens. This case arises only on the left-hand side of an assignment
16504 (`\.{:=}') operation, under very special circumstances.
16506 \smallskip\noindent
16507 The possible settings of |cur_type| have been listed here in increasing
16508 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16509 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16510 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16513 @ Capsules are two-word nodes that have a similar meaning
16514 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|
16515 and |link<=mp_void|; and their |type| field is one of the possibilities for
16516 |cur_type| listed above.
16518 The |value| field of a capsule is, in most cases, the value that
16519 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16520 However, when |cur_exp| would point to a capsule,
16521 no extra layer of indirection is present; the |value|
16522 field is what would have been called |value(cur_exp)| if it had not been
16523 encapsulated. Furthermore, if the type is |dependent| or
16524 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16525 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16526 always part of the general |dep_list| structure.
16528 The |get_x_next| routine is careful not to change the values of |cur_type|
16529 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16530 call a macro, which might parse an expression, which might execute lots of
16531 commands in a group; hence it's possible that |cur_type| might change
16532 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16533 |known| or |independent|, during the time |get_x_next| is called. The
16534 programs below are careful to stash sensitive intermediate results in
16535 capsules, so that \MP's generality doesn't cause trouble.
16537 Here's a procedure that illustrates these conventions. It takes
16538 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16539 and stashes them away in a
16540 capsule. It is not used when |cur_type=mp_token_list|.
16541 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16542 copy path lists or to update reference counts, etc.
16544 The special link |mp_void| is put on the capsule returned by
16545 |stash_cur_exp|, because this procedure is used to store macro parameters
16546 that must be easily distinguishable from token lists.
16548 @<Declare the stashing/unstashing routines@>=
16549 pointer mp_stash_cur_exp (MP mp) {
16550 pointer p; /* the capsule that will be returned */
16551 switch (mp->cur_type) {
16552 case unknown_types:
16553 case mp_transform_type:
16554 case mp_color_type:
16557 case mp_proto_dependent:
16558 case mp_independent:
16559 case mp_cmykcolor_type:
16563 p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
16564 type(p)=mp->cur_type; value(p)=mp->cur_exp;
16567 mp->cur_type=mp_vacuous; link(p)=mp_void;
16571 @ The inverse of |stash_cur_exp| is the following procedure, which
16572 deletes an unnecessary capsule and puts its contents into |cur_type|
16575 The program steps of \MP\ can be divided into two categories: those in
16576 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16577 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16578 information or not. It's important not to ignore them when they're alive,
16579 and it's important not to pay attention to them when they're dead.
16581 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16582 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16583 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16584 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16585 only when they are alive or dormant.
16587 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16588 are alive or dormant. The \\{unstash} procedure assumes that they are
16589 dead or dormant; it resuscitates them.
16591 @<Declare the stashing/unstashing...@>=
16592 void mp_unstash_cur_exp (MP mp,pointer p) ;
16595 void mp_unstash_cur_exp (MP mp,pointer p) {
16596 mp->cur_type=type(p);
16597 switch (mp->cur_type) {
16598 case unknown_types:
16599 case mp_transform_type:
16600 case mp_color_type:
16603 case mp_proto_dependent:
16604 case mp_independent:
16605 case mp_cmykcolor_type:
16609 mp->cur_exp=value(p);
16610 mp_free_node(mp, p,value_node_size);
16615 @ The following procedure prints the values of expressions in an
16616 abbreviated format. If its first parameter |p| is null, the value of
16617 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16618 containing the desired value. The second parameter controls the amount of
16619 output. If it is~0, dependency lists will be abbreviated to
16620 `\.{linearform}' unless they consist of a single term. If it is greater
16621 than~1, complicated structures (pens, pictures, and paths) will be displayed
16624 @<Declare subroutines for printing expressions@>=
16625 @<Declare the procedure called |print_dp|@>;
16626 @<Declare the stashing/unstashing routines@>;
16627 void mp_print_exp (MP mp,pointer p, small_number verbosity) {
16628 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16629 small_number t; /* the type of the expression */
16630 pointer q; /* a big node being displayed */
16631 integer v=0; /* the value of the expression */
16633 restore_cur_exp=false;
16635 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16638 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16639 @<Print an abbreviated value of |v| with format depending on |t|@>;
16640 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16643 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16645 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16646 case mp_boolean_type:
16647 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16649 case unknown_types: case mp_numeric_type:
16650 @<Display a variable that's been declared but not defined@>;
16652 case mp_string_type:
16653 mp_print_char(mp, '"'); mp_print_str(mp, v); mp_print_char(mp, '"');
16655 case mp_pen_type: case mp_path_type: case mp_picture_type:
16656 @<Display a complex type@>;
16658 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16659 if ( v==null ) mp_print_type(mp, t);
16660 else @<Display a big node@>;
16662 case mp_known:mp_print_scaled(mp, v); break;
16663 case mp_dependent: case mp_proto_dependent:
16664 mp_print_dp(mp, t,v,verbosity);
16666 case mp_independent:mp_print_variable_name(mp, p); break;
16667 default: mp_confusion(mp, "exp"); break;
16668 @:this can't happen exp}{\quad exp@>
16671 @ @<Display a big node@>=
16673 mp_print_char(mp, '('); q=v+mp->big_node_size[t];
16675 if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
16676 else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
16677 else mp_print_dp(mp, type(v),dep_list(v),verbosity);
16679 if ( v!=q ) mp_print_char(mp, ',');
16681 mp_print_char(mp, ')');
16684 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16685 in the log file only, unless the user has given a positive value to
16688 @<Display a complex type@>=
16689 if ( verbosity<=1 ) {
16690 mp_print_type(mp, t);
16692 if ( mp->selector==term_and_log )
16693 if ( mp->internal[mp_tracing_online]<=0 ) {
16694 mp->selector=term_only;
16695 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16696 mp->selector=term_and_log;
16699 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16700 case mp_path_type:mp_print_path(mp, v,"",false); break;
16701 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16702 } /* there are no other cases */
16705 @ @<Declare the procedure called |print_dp|@>=
16706 void mp_print_dp (MP mp,small_number t, pointer p,
16707 small_number verbosity) {
16708 pointer q; /* the node following |p| */
16710 if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16711 else mp_print(mp, "linearform");
16714 @ The displayed name of a variable in a ring will not be a capsule unless
16715 the ring consists entirely of capsules.
16717 @<Display a variable that's been declared but not defined@>=
16718 { mp_print_type(mp, t);
16720 { mp_print_char(mp, ' ');
16721 while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16722 mp_print_variable_name(mp, v);
16726 @ When errors are detected during parsing, it is often helpful to
16727 display an expression just above the error message, using |exp_err|
16728 or |disp_err| instead of |print_err|.
16730 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16732 @<Declare subroutines for printing expressions@>=
16733 void mp_disp_err (MP mp,pointer p, char *s) {
16734 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16735 mp_print_nl(mp, ">> ");
16737 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16739 mp_print_nl(mp, "! "); mp_print(mp, s);
16744 @ If |cur_type| and |cur_exp| contain relevant information that should
16745 be recycled, we will use the following procedure, which changes |cur_type|
16746 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16747 and |cur_exp| as either alive or dormant after this has been done,
16748 because |cur_exp| will not contain a pointer value.
16750 @ @c void mp_flush_cur_exp (MP mp,scaled v) {
16751 switch (mp->cur_type) {
16752 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16753 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16754 mp_recycle_value(mp, mp->cur_exp);
16755 mp_free_node(mp, mp->cur_exp,value_node_size);
16757 case mp_string_type:
16758 delete_str_ref(mp->cur_exp); break;
16759 case mp_pen_type: case mp_path_type:
16760 mp_toss_knot_list(mp, mp->cur_exp); break;
16761 case mp_picture_type:
16762 delete_edge_ref(mp->cur_exp); break;
16766 mp->cur_type=mp_known; mp->cur_exp=v;
16769 @ There's a much more general procedure that is capable of releasing
16770 the storage associated with any two-word value packet.
16772 @<Declare the recycling subroutines@>=
16773 void mp_recycle_value (MP mp,pointer p) ;
16775 @ @c void mp_recycle_value (MP mp,pointer p) {
16776 small_number t; /* a type code */
16777 integer vv; /* another value */
16778 pointer q,r,s,pp; /* link manipulation registers */
16779 integer v=0; /* a value */
16781 if ( t<mp_dependent ) v=value(p);
16783 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
16784 case mp_numeric_type:
16786 case unknown_types:
16787 mp_ring_delete(mp, p); break;
16788 case mp_string_type:
16789 delete_str_ref(v); break;
16790 case mp_path_type: case mp_pen_type:
16791 mp_toss_knot_list(mp, v); break;
16792 case mp_picture_type:
16793 delete_edge_ref(v); break;
16794 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
16795 case mp_transform_type:
16796 @<Recycle a big node@>; break;
16797 case mp_dependent: case mp_proto_dependent:
16798 @<Recycle a dependency list@>; break;
16799 case mp_independent:
16800 @<Recycle an independent variable@>; break;
16801 case mp_token_list: case mp_structured:
16802 mp_confusion(mp, "recycle"); break;
16803 @:this can't happen recycle}{\quad recycle@>
16804 case mp_unsuffixed_macro: case mp_suffixed_macro:
16805 mp_delete_mac_ref(mp, value(p)); break;
16806 } /* there are no other cases */
16810 @ @<Recycle a big node@>=
16812 q=v+mp->big_node_size[t];
16814 q=q-2; mp_recycle_value(mp, q);
16816 mp_free_node(mp, v,mp->big_node_size[t]);
16819 @ @<Recycle a dependency list@>=
16822 while ( info(q)!=null ) q=link(q);
16823 link(prev_dep(p))=link(q);
16824 prev_dep(link(q))=prev_dep(p);
16825 link(q)=null; mp_flush_node_list(mp, dep_list(p));
16828 @ When an independent variable disappears, it simply fades away, unless
16829 something depends on it. In the latter case, a dependent variable whose
16830 coefficient of dependence is maximal will take its place.
16831 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
16832 as part of his Ph.D. thesis (Stanford University, December 1982).
16833 @^Zabala Salelles, Ignacio Andres@>
16835 For example, suppose that variable $x$ is being recycled, and that the
16836 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
16837 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
16838 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
16839 we will print `\.{\#\#\# -2x=-y+a}'.
16841 There's a slight complication, however: An independent variable $x$
16842 can occur both in dependency lists and in proto-dependency lists.
16843 This makes it necessary to be careful when deciding which coefficient
16846 Furthermore, this complication is not so slight when
16847 a proto-dependent variable is chosen to become independent. For example,
16848 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
16849 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
16850 large coefficient `50'.
16852 In order to deal with these complications without wasting too much time,
16853 we shall link together the occurrences of~$x$ among all the linear
16854 dependencies, maintaining separate lists for the dependent and
16855 proto-dependent cases.
16857 @<Recycle an independent variable@>=
16859 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
16860 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
16862 while ( q!=dep_head ) {
16863 s=value_loc(q); /* now |link(s)=dep_list(q)| */
16866 if ( info(r)==null ) break;;
16867 if ( info(r)!=p ) {
16870 t=type(q); link(s)=link(r); info(r)=q;
16871 if ( abs(value(r))>mp->max_c[t] ) {
16872 @<Record a new maximum coefficient of type |t|@>;
16874 link(r)=mp->max_link[t]; mp->max_link[t]=r;
16880 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
16881 @<Choose a dependent variable to take the place of the disappearing
16882 independent variable, and change all remaining dependencies
16887 @ The code for independency removal makes use of three two-word arrays.
16890 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
16891 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
16892 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
16894 @ @<Record a new maximum coefficient...@>=
16896 if ( mp->max_c[t]>0 ) {
16897 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
16899 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
16902 @ @<Choose a dependent...@>=
16904 if ( (mp->max_c[mp_dependent] / 010000 >= mp->max_c[mp_proto_dependent]) )
16907 t=mp_proto_dependent;
16908 @<Determine the dependency list |s| to substitute for the independent
16910 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
16911 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
16912 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
16914 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
16915 else { @<Substitute new proto-dependencies in place of |p|@>;}
16916 mp_flush_node_list(mp, s);
16917 if ( mp->fix_needed ) mp_fix_dependencies(mp);
16921 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
16922 and |info(s)| points to the dependent variable~|pp| of type~|t| from
16923 whose dependency list we have removed node~|s|. We must reinsert
16924 node~|s| into the dependency list, with coefficient $-1.0$, and with
16925 |pp| as the new independent variable. Since |pp| will have a larger serial
16926 number than any other variable, we can put node |s| at the head of the
16929 @<Determine the dep...@>=
16930 s=mp->max_ptr[t]; pp=info(s); v=value(s);
16931 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
16932 r=dep_list(pp); link(s)=r;
16933 while ( info(r)!=null ) r=link(r);
16934 q=link(r); link(r)=null;
16935 prev_dep(q)=prev_dep(pp); link(prev_dep(pp))=q;
16937 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
16938 if ( mp->internal[mp_tracing_equations]>0 ) {
16939 @<Show the transformed dependency@>;
16942 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
16943 by the dependency list~|s|.
16945 @<Show the transformed...@>=
16946 if ( mp_interesting(mp, p) ) {
16947 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
16948 @:]]]\#\#\#_}{\.{\#\#\#}@>
16949 if ( v>0 ) mp_print_char(mp, '-');
16950 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
16951 else vv=mp->max_c[mp_proto_dependent];
16952 if ( vv!=unity ) mp_print_scaled(mp, vv);
16953 mp_print_variable_name(mp, p);
16954 while ( value(p) % s_scale>0 ) {
16955 mp_print(mp, "*4"); value(p)=value(p)-2;
16957 if ( t==mp_dependent ) mp_print_char(mp, '='); else mp_print(mp, " = ");
16958 mp_print_dependency(mp, s,t);
16959 mp_end_diagnostic(mp, false);
16962 @ Finally, there are dependent and proto-dependent variables whose
16963 dependency lists must be brought up to date.
16965 @<Substitute new dependencies...@>=
16966 for (t=mp_dependent;t<=mp_proto_dependent;t++){
16968 while ( r!=null ) {
16970 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
16971 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
16972 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
16973 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
16977 @ @<Substitute new proto...@>=
16978 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
16980 while ( r!=null ) {
16982 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
16983 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
16984 mp->cur_type=mp_proto_dependent;
16985 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,mp_dependent,mp_proto_dependent);
16986 type(q)=mp_proto_dependent; value(r)=mp_round_fraction(mp, value(r));
16988 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
16989 mp_make_scaled(mp, value(r),-v),s,mp_proto_dependent,mp_proto_dependent);
16990 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
16991 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
16995 @ Here are some routines that provide handy combinations of actions
16996 that are often needed during error recovery. For example,
16997 `|flush_error|' flushes the current expression, replaces it by
16998 a given value, and calls |error|.
17000 Errors often are detected after an extra token has already been scanned.
17001 The `\\{put\_get}' routines put that token back before calling |error|;
17002 then they get it back again. (Or perhaps they get another token, if
17003 the user has changed things.)
17006 void mp_flush_error (MP mp,scaled v);
17007 void mp_put_get_error (MP mp);
17008 void mp_put_get_flush_error (MP mp,scaled v) ;
17011 void mp_flush_error (MP mp,scaled v) {
17012 mp_error(mp); mp_flush_cur_exp(mp, v);
17014 void mp_put_get_error (MP mp) {
17015 mp_back_error(mp); mp_get_x_next(mp);
17017 void mp_put_get_flush_error (MP mp,scaled v) {
17018 mp_put_get_error(mp);
17019 mp_flush_cur_exp(mp, v);
17022 @ A global variable |var_flag| is set to a special command code
17023 just before \MP\ calls |scan_expression|, if the expression should be
17024 treated as a variable when this command code immediately follows. For
17025 example, |var_flag| is set to |assignment| at the beginning of a
17026 statement, because we want to know the {\sl location\/} of a variable at
17027 the left of `\.{:=}', not the {\sl value\/} of that variable.
17029 The |scan_expression| subroutine calls |scan_tertiary|,
17030 which calls |scan_secondary|, which calls |scan_primary|, which sets
17031 |var_flag:=0|. In this way each of the scanning routines ``knows''
17032 when it has been called with a special |var_flag|, but |var_flag| is
17035 A variable preceding a command that equals |var_flag| is converted to a
17036 token list rather than a value. Furthermore, an `\.{=}' sign following an
17037 expression with |var_flag=assignment| is not considered to be a relation
17038 that produces boolean expressions.
17042 int var_flag; /* command that wants a variable */
17047 @* \[37] Parsing primary expressions.
17048 The first parsing routine, |scan_primary|, is also the most complicated one,
17049 since it involves so many different cases. But each case---with one
17050 exception---is fairly simple by itself.
17052 When |scan_primary| begins, the first token of the primary to be scanned
17053 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17054 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17055 earlier. If |cur_cmd| is not between |min_primary_command| and
17056 |max_primary_command|, inclusive, a syntax error will be signaled.
17058 @<Declare the basic parsing subroutines@>=
17059 void mp_scan_primary (MP mp) {
17060 pointer p,q,r; /* for list manipulation */
17061 quarterword c; /* a primitive operation code */
17062 int my_var_flag; /* initial value of |my_var_flag| */
17063 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17064 @<Other local variables for |scan_primary|@>;
17065 my_var_flag=mp->var_flag; mp->var_flag=0;
17068 @<Supply diagnostic information, if requested@>;
17069 switch (mp->cur_cmd) {
17070 case left_delimiter:
17071 @<Scan a delimited primary@>; break;
17073 @<Scan a grouped primary@>; break;
17075 @<Scan a string constant@>; break;
17076 case numeric_token:
17077 @<Scan a primary that starts with a numeric token@>; break;
17079 @<Scan a nullary operation@>; break;
17080 case unary: case type_name: case cycle: case plus_or_minus:
17081 @<Scan a unary operation@>; break;
17082 case primary_binary:
17083 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17085 @<Convert a suffix to a string@>; break;
17086 case internal_quantity:
17087 @<Scan an internal numeric quantity@>; break;
17088 case capsule_token:
17089 mp_make_exp_copy(mp, mp->cur_mod); break;
17091 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17093 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17094 @.A primary expression...@>
17096 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17098 if ( mp->cur_cmd==left_bracket ) {
17099 if ( mp->cur_type>=mp_known ) {
17100 @<Scan a mediation construction@>;
17107 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17109 @c void mp_bad_exp (MP mp,char * s) {
17111 print_err(s); mp_print(mp, " expression can't begin with `");
17112 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17113 mp_print_char(mp, '\'');
17114 help4("I'm afraid I need some sort of value in order to continue,")
17115 ("so I've tentatively inserted `0'. You may want to")
17116 ("delete this zero and insert something else;")
17117 ("see Chapter 27 of The METAFONTbook for an example.");
17118 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17119 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17120 mp->cur_mod=0; mp_ins_error(mp);
17121 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17122 mp->var_flag=save_flag;
17125 @ @<Supply diagnostic information, if requested@>=
17127 if ( mp->panicking ) mp_check_mem(mp, false);
17129 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17130 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17133 @ @<Scan a delimited primary@>=
17135 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17136 mp_get_x_next(mp); mp_scan_expression(mp);
17137 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17138 @<Scan the rest of a delimited set of numerics@>;
17140 mp_check_delimiter(mp, l_delim,r_delim);
17144 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17145 within a ``big node.''
17147 @c void mp_stash_in (MP mp,pointer p) {
17148 pointer q; /* temporary register */
17149 type(p)=mp->cur_type;
17150 if ( mp->cur_type==mp_known ) {
17151 value(p)=mp->cur_exp;
17153 if ( mp->cur_type==mp_independent ) {
17154 @<Stash an independent |cur_exp| into a big node@>;
17156 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17157 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17158 link(prev_dep(p))=p;
17160 mp_free_node(mp, mp->cur_exp,value_node_size);
17162 mp->cur_type=mp_vacuous;
17165 @ In rare cases the current expression can become |independent|. There
17166 may be many dependency lists pointing to such an independent capsule,
17167 so we can't simply move it into place within a big node. Instead,
17168 we copy it, then recycle it.
17170 @ @<Stash an independent |cur_exp|...@>=
17172 q=mp_single_dependency(mp, mp->cur_exp);
17173 if ( q==mp->dep_final ){
17174 type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17176 type(p)=mp_dependent; mp_new_dep(mp, p,q);
17178 mp_recycle_value(mp, mp->cur_exp);
17181 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17182 are synonymous with |x_part_loc| and |y_part_loc|.
17184 @<Scan the rest of a delimited set of numerics@>=
17186 p=mp_stash_cur_exp(mp);
17187 mp_get_x_next(mp); mp_scan_expression(mp);
17188 @<Make sure the second part of a pair or color has a numeric type@>;
17189 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
17190 if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
17191 else type(q)=mp_pair_type;
17192 mp_init_big_node(mp, q); r=value(q);
17193 mp_stash_in(mp, y_part_loc(r));
17194 mp_unstash_cur_exp(mp, p);
17195 mp_stash_in(mp, x_part_loc(r));
17196 if ( mp->cur_cmd==comma ) {
17197 @<Scan the last of a triplet of numerics@>;
17199 if ( mp->cur_cmd==comma ) {
17200 type(q)=mp_cmykcolor_type;
17201 mp_init_big_node(mp, q); t=value(q);
17202 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17203 value(cyan_part_loc(t))=value(red_part_loc(r));
17204 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17205 value(magenta_part_loc(t))=value(green_part_loc(r));
17206 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17207 value(yellow_part_loc(t))=value(blue_part_loc(r));
17208 mp_recycle_value(mp, r);
17210 @<Scan the last of a quartet of numerics@>;
17212 mp_check_delimiter(mp, l_delim,r_delim);
17213 mp->cur_type=type(q);
17217 @ @<Make sure the second part of a pair or color has a numeric type@>=
17218 if ( mp->cur_type<mp_known ) {
17219 exp_err("Nonnumeric ypart has been replaced by 0");
17220 @.Nonnumeric...replaced by 0@>
17221 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';")
17222 ("but after finding a nice `a' I found a `b' that isn't")
17223 ("of numeric type. So I've changed that part to zero.")
17224 ("(The b that I didn't like appears above the error message.)");
17225 mp_put_get_flush_error(mp, 0);
17228 @ @<Scan the last of a triplet of numerics@>=
17230 mp_get_x_next(mp); mp_scan_expression(mp);
17231 if ( mp->cur_type<mp_known ) {
17232 exp_err("Nonnumeric third part has been replaced by 0");
17233 @.Nonnumeric...replaced by 0@>
17234 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'")
17235 ("isn't of numeric type. So I've changed that part to zero.")
17236 ("(The c that I didn't like appears above the error message.)");
17237 mp_put_get_flush_error(mp, 0);
17239 mp_stash_in(mp, blue_part_loc(r));
17242 @ @<Scan the last of a quartet of numerics@>=
17244 mp_get_x_next(mp); mp_scan_expression(mp);
17245 if ( mp->cur_type<mp_known ) {
17246 exp_err("Nonnumeric blackpart has been replaced by 0");
17247 @.Nonnumeric...replaced by 0@>
17248 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")
17249 ("of numeric type. So I've changed that part to zero.")
17250 ("(The k that I didn't like appears above the error message.)");
17251 mp_put_get_flush_error(mp, 0);
17253 mp_stash_in(mp, black_part_loc(r));
17256 @ The local variable |group_line| keeps track of the line
17257 where a \&{begingroup} command occurred; this will be useful
17258 in an error message if the group doesn't actually end.
17260 @<Other local variables for |scan_primary|@>=
17261 integer group_line; /* where a group began */
17263 @ @<Scan a grouped primary@>=
17265 group_line=mp_true_line(mp);
17266 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17267 save_boundary_item(p);
17269 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17270 } while (! (mp->cur_cmd!=semicolon));
17271 if ( mp->cur_cmd!=end_group ) {
17272 print_err("A group begun on line ");
17273 @.A group...never ended@>
17274 mp_print_int(mp, group_line);
17275 mp_print(mp, " never ended");
17276 help2("I saw a `begingroup' back there that hasn't been matched")
17277 ("by `endgroup'. So I've inserted `endgroup' now.");
17278 mp_back_error(mp); mp->cur_cmd=end_group;
17281 /* this might change |cur_type|, if independent variables are recycled */
17282 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17285 @ @<Scan a string constant@>=
17287 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17290 @ Later we'll come to procedures that perform actual operations like
17291 addition, square root, and so on; our purpose now is to do the parsing.
17292 But we might as well mention those future procedures now, so that the
17293 suspense won't be too bad:
17296 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17297 `\&{true}' or `\&{pencircle}');
17300 |do_unary(c)| applies a primitive operation to the current expression;
17303 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17304 and the current expression.
17306 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17308 @ @<Scan a unary operation@>=
17310 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17311 mp_do_unary(mp, c); goto DONE;
17314 @ A numeric token might be a primary by itself, or it might be the
17315 numerator of a fraction composed solely of numeric tokens, or it might
17316 multiply the primary that follows (provided that the primary doesn't begin
17317 with a plus sign or a minus sign). The code here uses the facts that
17318 |max_primary_command=plus_or_minus| and
17319 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17320 than unity, we try to retain higher precision when we use it in scalar
17323 @<Other local variables for |scan_primary|@>=
17324 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17326 @ @<Scan a primary that starts with a numeric token@>=
17328 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17329 if ( mp->cur_cmd!=slash ) {
17333 if ( mp->cur_cmd!=numeric_token ) {
17335 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17338 num=mp->cur_exp; denom=mp->cur_mod;
17339 if ( denom==0 ) { @<Protest division by zero@>; }
17340 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17341 check_arith; mp_get_x_next(mp);
17343 if ( mp->cur_cmd>=min_primary_command ) {
17344 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17345 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17346 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17347 mp_do_binary(mp, p,times);
17349 mp_frac_mult(mp, num,denom);
17350 mp_free_node(mp, p,value_node_size);
17357 @ @<Protest division...@>=
17359 print_err("Division by zero");
17360 @.Division by zero@>
17361 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17364 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17366 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17367 if ( mp->cur_cmd!=of_token ) {
17368 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17369 mp_print_cmd_mod(mp, primary_binary,c);
17371 help1("I've got the first argument; will look now for the other.");
17374 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17375 mp_do_binary(mp, p,c); goto DONE;
17378 @ @<Convert a suffix to a string@>=
17380 mp_get_x_next(mp); mp_scan_suffix(mp);
17381 mp->old_setting=mp->selector; mp->selector=new_string;
17382 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17383 mp_flush_token_list(mp, mp->cur_exp);
17384 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17385 mp->cur_type=mp_string_type;
17389 @ If an internal quantity appears all by itself on the left of an
17390 assignment, we return a token list of length one, containing the address
17391 of the internal quantity plus |hash_end|. (This accords with the conventions
17392 of the save stack, as described earlier.)
17394 @<Scan an internal...@>=
17397 if ( my_var_flag==assignment ) {
17399 if ( mp->cur_cmd==assignment ) {
17400 mp->cur_exp=mp_get_avail(mp);
17401 info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17406 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17409 @ The most difficult part of |scan_primary| has been saved for last, since
17410 it was necessary to build up some confidence first. We can now face the task
17411 of scanning a variable.
17413 As we scan a variable, we build a token list containing the relevant
17414 names and subscript values, simultaneously following along in the
17415 ``collective'' structure to see if we are actually dealing with a macro
17416 instead of a value.
17418 The local variables |pre_head| and |post_head| will point to the beginning
17419 of the prefix and suffix lists; |tail| will point to the end of the list
17420 that is currently growing.
17422 Another local variable, |tt|, contains partial information about the
17423 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17424 relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
17425 doesn't bother to update its information about type. And if
17426 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17428 @ @<Other local variables for |scan_primary|@>=
17429 pointer pre_head,post_head,tail;
17430 /* prefix and suffix list variables */
17431 small_number tt; /* approximation to the type of the variable-so-far */
17432 pointer t; /* a token */
17433 pointer macro_ref = 0; /* reference count for a suffixed macro */
17435 @ @<Scan a variable primary...@>=
17437 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17439 t=mp_cur_tok(mp); link(tail)=t;
17440 if ( tt!=undefined ) {
17441 @<Find the approximate type |tt| and corresponding~|q|@>;
17442 if ( tt>=mp_unsuffixed_macro ) {
17443 @<Either begin an unsuffixed macro call or
17444 prepare for a suffixed one@>;
17447 mp_get_x_next(mp); tail=t;
17448 if ( mp->cur_cmd==left_bracket ) {
17449 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17451 if ( mp->cur_cmd>max_suffix_token ) break;
17452 if ( mp->cur_cmd<min_suffix_token ) break;
17453 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17454 @<Handle unusual cases that masquerade as variables, and |goto restart|
17455 or |goto done| if appropriate;
17456 otherwise make a copy of the variable and |goto done|@>;
17459 @ @<Either begin an unsuffixed macro call or...@>=
17462 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17463 post_head=mp_get_avail(mp); tail=post_head; link(tail)=t;
17464 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17466 @<Set up unsuffixed macro call and |goto restart|@>;
17470 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17472 mp_get_x_next(mp); mp_scan_expression(mp);
17473 if ( mp->cur_cmd!=right_bracket ) {
17474 @<Put the left bracket and the expression back to be rescanned@>;
17476 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17477 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17481 @ The left bracket that we thought was introducing a subscript might have
17482 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17483 So we don't issue an error message at this point; but we do want to back up
17484 so as to avoid any embarrassment about our incorrect assumption.
17486 @<Put the left bracket and the expression back to be rescanned@>=
17488 mp_back_input(mp); /* that was the token following the current expression */
17489 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17490 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17493 @ Here's a routine that puts the current expression back to be read again.
17495 @c void mp_back_expr (MP mp) {
17496 pointer p; /* capsule token */
17497 p=mp_stash_cur_exp(mp); link(p)=null; back_list(p);
17500 @ Unknown subscripts lead to the following error message.
17502 @c void mp_bad_subscript (MP mp) {
17503 exp_err("Improper subscript has been replaced by zero");
17504 @.Improper subscript...@>
17505 help3("A bracketed subscript must have a known numeric value;")
17506 ("unfortunately, what I found was the value that appears just")
17507 ("above this error message. So I'll try a zero subscript.");
17508 mp_flush_error(mp, 0);
17511 @ Every time we call |get_x_next|, there's a chance that the variable we've
17512 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17513 into the variable structure; we need to start searching from the root each time.
17515 @<Find the approximate type |tt| and corresponding~|q|@>=
17518 p=link(pre_head); q=info(p); tt=undefined;
17519 if ( eq_type(q) % outer_tag==tag_token ) {
17521 if ( q==null ) goto DONE2;
17525 tt=type(q); goto DONE2;
17527 if ( type(q)!=mp_structured ) goto DONE2;
17528 q=link(attr_head(q)); /* the |collective_subscript| attribute */
17529 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17530 do { q=link(q); } while (! (attr_loc(q)>=info(p)));
17531 if ( attr_loc(q)>info(p) ) goto DONE2;
17539 @ How do things stand now? Well, we have scanned an entire variable name,
17540 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17541 |cur_sym| represent the token that follows. If |post_head=null|, a
17542 token list for this variable name starts at |link(pre_head)|, with all
17543 subscripts evaluated. But if |post_head<>null|, the variable turned out
17544 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17545 |post_head| is the head of a token list containing both `\.{\AT!}' and
17548 Our immediate problem is to see if this variable still exists. (Variable
17549 structures can change drastically whenever we call |get_x_next|; users
17550 aren't supposed to do this, but the fact that it is possible means that
17551 we must be cautious.)
17553 The following procedure prints an error message when a variable
17554 unexpectedly disappears. Its help message isn't quite right for
17555 our present purposes, but we'll be able to fix that up.
17558 void mp_obliterated (MP mp,pointer q) {
17559 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17560 mp_print(mp, " has been obliterated");
17561 @.Variable...obliterated@>
17562 help5("It seems you did a nasty thing---probably by accident,")
17563 ("but nevertheless you nearly hornswoggled me...")
17564 ("While I was evaluating the right-hand side of this")
17565 ("command, something happened, and the left-hand side")
17566 ("is no longer a variable! So I won't change anything.");
17569 @ If the variable does exist, we also need to check
17570 for a few other special cases before deciding that a plain old ordinary
17571 variable has, indeed, been scanned.
17573 @<Handle unusual cases that masquerade as variables...@>=
17574 if ( post_head!=null ) {
17575 @<Set up suffixed macro call and |goto restart|@>;
17577 q=link(pre_head); free_avail(pre_head);
17578 if ( mp->cur_cmd==my_var_flag ) {
17579 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17581 p=mp_find_variable(mp, q);
17583 mp_make_exp_copy(mp, p);
17585 mp_obliterated(mp, q);
17586 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17587 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17588 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17589 mp_put_get_flush_error(mp, 0);
17591 mp_flush_node_list(mp, q);
17594 @ The only complication associated with macro calling is that the prefix
17595 and ``at'' parameters must be packaged in an appropriate list of lists.
17597 @<Set up unsuffixed macro call and |goto restart|@>=
17599 p=mp_get_avail(mp); info(pre_head)=link(pre_head); link(pre_head)=p;
17600 info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17605 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17606 we don't care, because we have reserved a pointer (|macro_ref|) to its
17609 @<Set up suffixed macro call and |goto restart|@>=
17611 mp_back_input(mp); p=mp_get_avail(mp); q=link(post_head);
17612 info(pre_head)=link(pre_head); link(pre_head)=post_head;
17613 info(post_head)=q; link(post_head)=p; info(p)=link(q); link(q)=null;
17614 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17615 mp_get_x_next(mp); goto RESTART;
17618 @ Our remaining job is simply to make a copy of the value that has been
17619 found. Some cases are harder than others, but complexity arises solely
17620 because of the multiplicity of possible cases.
17622 @<Declare the procedure called |make_exp_copy|@>=
17623 @<Declare subroutines needed by |make_exp_copy|@>;
17624 void mp_make_exp_copy (MP mp,pointer p) {
17625 pointer q,r,t; /* registers for list manipulation */
17627 mp->cur_type=type(p);
17628 switch (mp->cur_type) {
17629 case mp_vacuous: case mp_boolean_type: case mp_known:
17630 mp->cur_exp=value(p); break;
17631 case unknown_types:
17632 mp->cur_exp=mp_new_ring_entry(mp, p);
17634 case mp_string_type:
17635 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17637 case mp_picture_type:
17638 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17641 mp->cur_exp=copy_pen(value(p));
17644 mp->cur_exp=mp_copy_path(mp, value(p));
17646 case mp_transform_type: case mp_color_type:
17647 case mp_cmykcolor_type: case mp_pair_type:
17648 @<Copy the big node |p|@>;
17650 case mp_dependent: case mp_proto_dependent:
17651 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17653 case mp_numeric_type:
17654 new_indep(p); goto RESTART;
17656 case mp_independent:
17657 q=mp_single_dependency(mp, p);
17658 if ( q==mp->dep_final ){
17659 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,value_node_size);
17661 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17665 mp_confusion(mp, "copy");
17666 @:this can't happen copy}{\quad copy@>
17671 @ The |encapsulate| subroutine assumes that |dep_final| is the
17672 tail of dependency list~|p|.
17674 @<Declare subroutines needed by |make_exp_copy|@>=
17675 void mp_encapsulate (MP mp,pointer p) {
17676 mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
17677 name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17680 @ The most tedious case arises when the user refers to a
17681 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17682 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17685 @<Copy the big node |p|@>=
17687 if ( value(p)==null )
17688 mp_init_big_node(mp, p);
17689 t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
17690 mp_init_big_node(mp, t);
17691 q=value(p)+mp->big_node_size[mp->cur_type];
17692 r=value(t)+mp->big_node_size[mp->cur_type];
17694 q=q-2; r=r-2; mp_install(mp, r,q);
17695 } while (q!=value(p));
17699 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17700 a big node that will be part of a capsule.
17702 @<Declare subroutines needed by |make_exp_copy|@>=
17703 void mp_install (MP mp,pointer r, pointer q) {
17704 pointer p; /* temporary register */
17705 if ( type(q)==mp_known ){
17706 value(r)=value(q); type(r)=mp_known;
17707 } else if ( type(q)==mp_independent ) {
17708 p=mp_single_dependency(mp, q);
17709 if ( p==mp->dep_final ) {
17710 type(r)=mp_known; value(r)=0; mp_free_node(mp, p,value_node_size);
17712 type(r)=mp_dependent; mp_new_dep(mp, r,p);
17715 type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17719 @ Expressions of the form `\.{a[b,c]}' are converted into
17720 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17721 provided that \.a is numeric.
17723 @<Scan a mediation...@>=
17725 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17726 if ( mp->cur_cmd!=comma ) {
17727 @<Put the left bracket and the expression back...@>;
17728 mp_unstash_cur_exp(mp, p);
17730 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17731 if ( mp->cur_cmd!=right_bracket ) {
17732 mp_missing_err(mp, "]");
17734 help3("I've scanned an expression of the form `a[b,c',")
17735 ("so a right bracket should have come next.")
17736 ("I shall pretend that one was there.");
17739 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17740 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17741 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17745 @ Here is a comparatively simple routine that is used to scan the
17746 \&{suffix} parameters of a macro.
17748 @<Declare the basic parsing subroutines@>=
17749 void mp_scan_suffix (MP mp) {
17750 pointer h,t; /* head and tail of the list being built */
17751 pointer p; /* temporary register */
17752 h=mp_get_avail(mp); t=h;
17754 if ( mp->cur_cmd==left_bracket ) {
17755 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17757 if ( mp->cur_cmd==numeric_token ) {
17758 p=mp_new_num_tok(mp, mp->cur_mod);
17759 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17760 p=mp_get_avail(mp); info(p)=mp->cur_sym;
17764 link(t)=p; t=p; mp_get_x_next(mp);
17766 mp->cur_exp=link(h); free_avail(h); mp->cur_type=mp_token_list;
17769 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17771 mp_get_x_next(mp); mp_scan_expression(mp);
17772 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17773 if ( mp->cur_cmd!=right_bracket ) {
17774 mp_missing_err(mp, "]");
17776 help3("I've seen a `[' and a subscript value, in a suffix,")
17777 ("so a right bracket should have come next.")
17778 ("I shall pretend that one was there.");
17781 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
17784 @* \[38] Parsing secondary and higher expressions.
17785 After the intricacies of |scan_primary|\kern-1pt,
17786 the |scan_secondary| routine is
17787 refreshingly simple. It's not trivial, but the operations are relatively
17788 straightforward; the main difficulty is, again, that expressions and data
17789 structures might change drastically every time we call |get_x_next|, so a
17790 cautious approach is mandatory. For example, a macro defined by
17791 \&{primarydef} might have disappeared by the time its second argument has
17792 been scanned; we solve this by increasing the reference count of its token
17793 list, so that the macro can be called even after it has been clobbered.
17795 @<Declare the basic parsing subroutines@>=
17796 void mp_scan_secondary (MP mp) {
17797 pointer p; /* for list manipulation */
17798 halfword c,d; /* operation codes or modifiers */
17799 pointer mac_name; /* token defined with \&{primarydef} */
17801 if ((mp->cur_cmd<min_primary_command)||
17802 (mp->cur_cmd>max_primary_command) )
17803 mp_bad_exp(mp, "A secondary");
17804 @.A secondary expression...@>
17805 mp_scan_primary(mp);
17807 if ( mp->cur_cmd<=max_secondary_command )
17808 if ( mp->cur_cmd>=min_secondary_command ) {
17809 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
17810 if ( d==secondary_primary_macro ) {
17811 mac_name=mp->cur_sym; add_mac_ref(c);
17813 mp_get_x_next(mp); mp_scan_primary(mp);
17814 if ( d!=secondary_primary_macro ) {
17815 mp_do_binary(mp, p,c);
17817 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
17818 decr(ref_count(c)); mp_get_x_next(mp);
17825 @ The following procedure calls a macro that has two parameters,
17828 @c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
17829 pointer q,r; /* nodes in the parameter list */
17830 q=mp_get_avail(mp); r=mp_get_avail(mp); link(q)=r;
17831 info(q)=p; info(r)=mp_stash_cur_exp(mp);
17832 mp_macro_call(mp, c,q,n);
17835 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
17837 @<Declare the basic parsing subroutines@>=
17838 void mp_scan_tertiary (MP mp) {
17839 pointer p; /* for list manipulation */
17840 halfword c,d; /* operation codes or modifiers */
17841 pointer mac_name; /* token defined with \&{secondarydef} */
17843 if ((mp->cur_cmd<min_primary_command)||
17844 (mp->cur_cmd>max_primary_command) )
17845 mp_bad_exp(mp, "A tertiary");
17846 @.A tertiary expression...@>
17847 mp_scan_secondary(mp);
17849 if ( mp->cur_cmd<=max_tertiary_command ) {
17850 if ( mp->cur_cmd>=min_tertiary_command ) {
17851 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
17852 if ( d==tertiary_secondary_macro ) {
17853 mac_name=mp->cur_sym; add_mac_ref(c);
17855 mp_get_x_next(mp); mp_scan_secondary(mp);
17856 if ( d!=tertiary_secondary_macro ) {
17857 mp_do_binary(mp, p,c);
17859 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
17860 decr(ref_count(c)); mp_get_x_next(mp);
17868 @ Finally we reach the deepest level in our quartet of parsing routines.
17869 This one is much like the others; but it has an extra complication from
17870 paths, which materialize here.
17872 @d continue_path 25 /* a label inside of |scan_expression| */
17873 @d finish_path 26 /* another */
17875 @<Declare the basic parsing subroutines@>=
17876 void mp_scan_expression (MP mp) {
17877 pointer p,q,r,pp,qq; /* for list manipulation */
17878 halfword c,d; /* operation codes or modifiers */
17879 int my_var_flag; /* initial value of |var_flag| */
17880 pointer mac_name; /* token defined with \&{tertiarydef} */
17881 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
17882 scaled x,y; /* explicit coordinates or tension at a path join */
17883 int t; /* knot type following a path join */
17885 my_var_flag=mp->var_flag; mac_name=null;
17887 if ((mp->cur_cmd<min_primary_command)||
17888 (mp->cur_cmd>max_primary_command) )
17889 mp_bad_exp(mp, "An");
17890 @.An expression...@>
17891 mp_scan_tertiary(mp);
17893 if ( mp->cur_cmd<=max_expression_command )
17894 if ( mp->cur_cmd>=min_expression_command ) {
17895 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
17896 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
17897 if ( d==expression_tertiary_macro ) {
17898 mac_name=mp->cur_sym; add_mac_ref(c);
17900 if ( (d<ampersand)||((d==ampersand)&&
17901 ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
17902 @<Scan a path construction operation;
17903 but |return| if |p| has the wrong type@>;
17905 mp_get_x_next(mp); mp_scan_tertiary(mp);
17906 if ( d!=expression_tertiary_macro ) {
17907 mp_do_binary(mp, p,c);
17909 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
17910 decr(ref_count(c)); mp_get_x_next(mp);
17919 @ The reader should review the data structure conventions for paths before
17920 hoping to understand the next part of this code.
17922 @<Scan a path construction operation...@>=
17925 @<Convert the left operand, |p|, into a partial path ending at~|q|;
17926 but |return| if |p| doesn't have a suitable type@>;
17928 @<Determine the path join parameters;
17929 but |goto finish_path| if there's only a direction specifier@>;
17930 if ( mp->cur_cmd==cycle ) {
17931 @<Get ready to close a cycle@>;
17933 mp_scan_tertiary(mp);
17934 @<Convert the right operand, |cur_exp|,
17935 into a partial path from |pp| to~|qq|@>;
17937 @<Join the partial paths and reset |p| and |q| to the head and tail
17939 if ( mp->cur_cmd>=min_expression_command )
17940 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
17942 @<Choose control points for the path and put the result into |cur_exp|@>;
17945 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
17947 mp_unstash_cur_exp(mp, p);
17948 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
17949 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
17952 while ( link(q)!=p ) q=link(q);
17953 if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
17954 r=mp_copy_knot(mp, p); link(q)=r; q=r;
17956 left_type(p)=mp_open; right_type(q)=mp_open;
17959 @ A pair of numeric values is changed into a knot node for a one-point path
17960 when \MP\ discovers that the pair is part of a path.
17962 @c@<Declare the procedure called |known_pair|@>;
17963 pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
17964 pointer q; /* the new node */
17965 q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
17966 right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; link(q)=q;
17967 mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
17971 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
17972 of the current expression, assuming that the current expression is a
17973 pair of known numerics. Unknown components are zeroed, and the
17974 current expression is flushed.
17976 @<Declare the procedure called |known_pair|@>=
17977 void mp_known_pair (MP mp) {
17978 pointer p; /* the pair node */
17979 if ( mp->cur_type!=mp_pair_type ) {
17980 exp_err("Undefined coordinates have been replaced by (0,0)");
17981 @.Undefined coordinates...@>
17982 help5("I need x and y numbers for this part of the path.")
17983 ("The value I found (see above) was no good;")
17984 ("so I'll try to keep going by using zero instead.")
17985 ("(Chapter 27 of The METAFONTbook explains that")
17986 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17987 ("you might want to type `I ??" "?' now.)");
17988 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
17990 p=value(mp->cur_exp);
17991 @<Make sure that both |x| and |y| parts of |p| are known;
17992 copy them into |cur_x| and |cur_y|@>;
17993 mp_flush_cur_exp(mp, 0);
17997 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
17998 if ( type(x_part_loc(p))==mp_known ) {
17999 mp->cur_x=value(x_part_loc(p));
18001 mp_disp_err(mp, x_part_loc(p),
18002 "Undefined x coordinate has been replaced by 0");
18003 @.Undefined coordinates...@>
18004 help5("I need a `known' x value for this part of the path.")
18005 ("The value I found (see above) was no good;")
18006 ("so I'll try to keep going by using zero instead.")
18007 ("(Chapter 27 of The METAFONTbook explains that")
18008 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18009 ("you might want to type `I ??" "?' now.)");
18010 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18012 if ( type(y_part_loc(p))==mp_known ) {
18013 mp->cur_y=value(y_part_loc(p));
18015 mp_disp_err(mp, y_part_loc(p),
18016 "Undefined y coordinate has been replaced by 0");
18017 help5("I need a `known' y value for this part of the path.")
18018 ("The value I found (see above) was no good;")
18019 ("so I'll try to keep going by using zero instead.")
18020 ("(Chapter 27 of The METAFONTbook explains that")
18021 ("you might want to type `I ??" "?' now.)");
18022 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18025 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18027 @<Determine the path join parameters...@>=
18028 if ( mp->cur_cmd==left_brace ) {
18029 @<Put the pre-join direction information into node |q|@>;
18032 if ( d==path_join ) {
18033 @<Determine the tension and/or control points@>;
18034 } else if ( d!=ampersand ) {
18038 if ( mp->cur_cmd==left_brace ) {
18039 @<Put the post-join direction information into |x| and |t|@>;
18040 } else if ( right_type(q)!=mp_explicit ) {
18044 @ The |scan_direction| subroutine looks at the directional information
18045 that is enclosed in braces, and also scans ahead to the following character.
18046 A type code is returned, either |open| (if the direction was $(0,0)$),
18047 or |curl| (if the direction was a curl of known value |cur_exp|), or
18048 |given| (if the direction is given by the |angle| value that now
18049 appears in |cur_exp|).
18051 There's nothing difficult about this subroutine, but the program is rather
18052 lengthy because a variety of potential errors need to be nipped in the bud.
18054 @c small_number mp_scan_direction (MP mp) {
18055 int t; /* the type of information found */
18056 scaled x; /* an |x| coordinate */
18058 if ( mp->cur_cmd==curl_command ) {
18059 @<Scan a curl specification@>;
18061 @<Scan a given direction@>;
18063 if ( mp->cur_cmd!=right_brace ) {
18064 mp_missing_err(mp, "}");
18065 @.Missing `\char`\}'@>
18066 help3("I've scanned a direction spec for part of a path,")
18067 ("so a right brace should have come next.")
18068 ("I shall pretend that one was there.");
18075 @ @<Scan a curl specification@>=
18076 { mp_get_x_next(mp); mp_scan_expression(mp);
18077 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18078 exp_err("Improper curl has been replaced by 1");
18080 help1("A curl must be a known, nonnegative number.");
18081 mp_put_get_flush_error(mp, unity);
18086 @ @<Scan a given direction@>=
18087 { mp_scan_expression(mp);
18088 if ( mp->cur_type>mp_pair_type ) {
18089 @<Get given directions separated by commas@>;
18093 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18094 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18097 @ @<Get given directions separated by commas@>=
18099 if ( mp->cur_type!=mp_known ) {
18100 exp_err("Undefined x coordinate has been replaced by 0");
18101 @.Undefined coordinates...@>
18102 help5("I need a `known' x value for this part of the path.")
18103 ("The value I found (see above) was no good;")
18104 ("so I'll try to keep going by using zero instead.")
18105 ("(Chapter 27 of The METAFONTbook explains that")
18106 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18107 ("you might want to type `I ??" "?' now.)");
18108 mp_put_get_flush_error(mp, 0);
18111 if ( mp->cur_cmd!=comma ) {
18112 mp_missing_err(mp, ",");
18114 help2("I've got the x coordinate of a path direction;")
18115 ("will look for the y coordinate next.");
18118 mp_get_x_next(mp); mp_scan_expression(mp);
18119 if ( mp->cur_type!=mp_known ) {
18120 exp_err("Undefined y coordinate has been replaced by 0");
18121 help5("I need a `known' y value for this part of the path.")
18122 ("The value I found (see above) was no good;")
18123 ("so I'll try to keep going by using zero instead.")
18124 ("(Chapter 27 of The METAFONTbook explains that")
18125 ("you might want to type `I ??" "?' now.)");
18126 mp_put_get_flush_error(mp, 0);
18128 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18131 @ At this point |right_type(q)| is usually |open|, but it may have been
18132 set to some other value by a previous splicing operation. We must maintain
18133 the value of |right_type(q)| in unusual cases such as
18134 `\.{..z1\{z2\}\&\{z3\}z1\{0,0\}..}'.
18136 @<Put the pre-join...@>=
18138 t=mp_scan_direction(mp);
18139 if ( t!=mp_open ) {
18140 right_type(q)=t; right_given(q)=mp->cur_exp;
18141 if ( left_type(q)==mp_open ) {
18142 left_type(q)=t; left_given(q)=mp->cur_exp;
18143 } /* note that |left_given(q)=left_curl(q)| */
18147 @ Since |left_tension| and |left_y| share the same position in knot nodes,
18148 and since |left_given| is similarly equivalent to |left_x|, we use
18149 |x| and |y| to hold the given direction and tension information when
18150 there are no explicit control points.
18152 @<Put the post-join...@>=
18154 t=mp_scan_direction(mp);
18155 if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
18156 else t=mp_explicit; /* the direction information is superfluous */
18159 @ @<Determine the tension and/or...@>=
18162 if ( mp->cur_cmd==tension ) {
18163 @<Set explicit tensions@>;
18164 } else if ( mp->cur_cmd==controls ) {
18165 @<Set explicit control points@>;
18167 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18170 if ( mp->cur_cmd!=path_join ) {
18171 mp_missing_err(mp, "..");
18173 help1("A path join command should end with two dots.");
18180 @ @<Set explicit tensions@>=
18182 mp_get_x_next(mp); y=mp->cur_cmd;
18183 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18184 mp_scan_primary(mp);
18185 @<Make sure that the current expression is a valid tension setting@>;
18186 if ( y==at_least ) negate(mp->cur_exp);
18187 right_tension(q)=mp->cur_exp;
18188 if ( mp->cur_cmd==and_command ) {
18189 mp_get_x_next(mp); y=mp->cur_cmd;
18190 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18191 mp_scan_primary(mp);
18192 @<Make sure that the current expression is a valid tension setting@>;
18193 if ( y==at_least ) negate(mp->cur_exp);
18198 @ @d min_tension three_quarter_unit
18200 @<Make sure that the current expression is a valid tension setting@>=
18201 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18202 exp_err("Improper tension has been set to 1");
18203 @.Improper tension@>
18204 help1("The expression above should have been a number >=3/4.");
18205 mp_put_get_flush_error(mp, unity);
18208 @ @<Set explicit control points@>=
18210 right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18211 mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
18212 if ( mp->cur_cmd!=and_command ) {
18213 x=right_x(q); y=right_y(q);
18215 mp_get_x_next(mp); mp_scan_primary(mp);
18216 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18220 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18222 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18223 else pp=mp->cur_exp;
18225 while ( link(qq)!=pp ) qq=link(qq);
18226 if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18227 r=mp_copy_knot(mp, pp); link(qq)=r; qq=r;
18229 left_type(pp)=mp_open; right_type(qq)=mp_open;
18232 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18233 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18234 shouldn't have length zero.
18236 @<Get ready to close a cycle@>=
18238 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18239 if ( d==ampersand ) if ( p==q ) {
18240 d=path_join; right_tension(q)=unity; y=unity;
18244 @ @<Join the partial paths and reset |p| and |q|...@>=
18246 if ( d==ampersand ) {
18247 if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
18248 print_err("Paths don't touch; `&' will be changed to `..'");
18249 @.Paths don't touch@>
18250 help3("When you join paths `p&q', the ending point of p")
18251 ("must be exactly equal to the starting point of q.")
18252 ("So I'm going to pretend that you said `p..q' instead.");
18253 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18256 @<Plug an opening in |right_type(pp)|, if possible@>;
18257 if ( d==ampersand ) {
18258 @<Splice independent paths together@>;
18260 @<Plug an opening in |right_type(q)|, if possible@>;
18261 link(q)=pp; left_y(pp)=y;
18262 if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
18267 @ @<Plug an opening in |right_type(q)|...@>=
18268 if ( right_type(q)==mp_open ) {
18269 if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
18270 right_type(q)=left_type(q); right_given(q)=left_given(q);
18274 @ @<Plug an opening in |right_type(pp)|...@>=
18275 if ( right_type(pp)==mp_open ) {
18276 if ( (t==mp_curl)||(t==mp_given) ) {
18277 right_type(pp)=t; right_given(pp)=x;
18281 @ @<Splice independent paths together@>=
18283 if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
18284 left_type(q)=mp_curl; left_curl(q)=unity;
18286 if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
18287 right_type(pp)=mp_curl; right_curl(pp)=unity;
18289 right_type(q)=right_type(pp); link(q)=link(pp);
18290 right_x(q)=right_x(pp); right_y(q)=right_y(pp);
18291 mp_free_node(mp, pp,knot_node_size);
18292 if ( qq==pp ) qq=q;
18295 @ @<Choose control points for the path...@>=
18297 if ( d==ampersand ) p=q;
18299 left_type(p)=mp_endpoint;
18300 if ( right_type(p)==mp_open ) {
18301 right_type(p)=mp_curl; right_curl(p)=unity;
18303 right_type(q)=mp_endpoint;
18304 if ( left_type(q)==mp_open ) {
18305 left_type(q)=mp_curl; left_curl(q)=unity;
18309 mp_make_choices(mp, p);
18310 mp->cur_type=mp_path_type; mp->cur_exp=p
18312 @ Finally, we sometimes need to scan an expression whose value is
18313 supposed to be either |true_code| or |false_code|.
18315 @<Declare the basic parsing subroutines@>=
18316 void mp_get_boolean (MP mp) {
18317 mp_get_x_next(mp); mp_scan_expression(mp);
18318 if ( mp->cur_type!=mp_boolean_type ) {
18319 exp_err("Undefined condition will be treated as `false'");
18320 @.Undefined condition...@>
18321 help2("The expression shown above should have had a definite")
18322 ("true-or-false value. I'm changing it to `false'.");
18323 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18327 @* \[39] Doing the operations.
18328 The purpose of parsing is primarily to permit people to avoid piles of
18329 parentheses. But the real work is done after the structure of an expression
18330 has been recognized; that's when new expressions are generated. We
18331 turn now to the guts of \MP, which handles individual operators that
18332 have come through the parsing mechanism.
18334 We'll start with the easy ones that take no operands, then work our way
18335 up to operators with one and ultimately two arguments. In other words,
18336 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18337 that are invoked periodically by the expression scanners.
18339 First let's make sure that all of the primitive operators are in the
18340 hash table. Although |scan_primary| and its relatives made use of the
18341 \\{cmd} code for these operators, the \\{do} routines base everything
18342 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18343 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18346 mp_primitive(mp, "true",nullary,true_code);
18347 @:true_}{\&{true} primitive@>
18348 mp_primitive(mp, "false",nullary,false_code);
18349 @:false_}{\&{false} primitive@>
18350 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18351 @:null_picture_}{\&{nullpicture} primitive@>
18352 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18353 @:null_pen_}{\&{nullpen} primitive@>
18354 mp_primitive(mp, "jobname",nullary,job_name_op);
18355 @:job_name_}{\&{jobname} primitive@>
18356 mp_primitive(mp, "readstring",nullary,read_string_op);
18357 @:read_string_}{\&{readstring} primitive@>
18358 mp_primitive(mp, "pencircle",nullary,pen_circle);
18359 @:pen_circle_}{\&{pencircle} primitive@>
18360 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18361 @:normal_deviate_}{\&{normaldeviate} primitive@>
18362 mp_primitive(mp, "readfrom",unary,read_from_op);
18363 @:read_from_}{\&{readfrom} primitive@>
18364 mp_primitive(mp, "closefrom",unary,close_from_op);
18365 @:close_from_}{\&{closefrom} primitive@>
18366 mp_primitive(mp, "odd",unary,odd_op);
18367 @:odd_}{\&{odd} primitive@>
18368 mp_primitive(mp, "known",unary,known_op);
18369 @:known_}{\&{known} primitive@>
18370 mp_primitive(mp, "unknown",unary,unknown_op);
18371 @:unknown_}{\&{unknown} primitive@>
18372 mp_primitive(mp, "not",unary,not_op);
18373 @:not_}{\&{not} primitive@>
18374 mp_primitive(mp, "decimal",unary,decimal);
18375 @:decimal_}{\&{decimal} primitive@>
18376 mp_primitive(mp, "reverse",unary,reverse);
18377 @:reverse_}{\&{reverse} primitive@>
18378 mp_primitive(mp, "makepath",unary,make_path_op);
18379 @:make_path_}{\&{makepath} primitive@>
18380 mp_primitive(mp, "makepen",unary,make_pen_op);
18381 @:make_pen_}{\&{makepen} primitive@>
18382 mp_primitive(mp, "oct",unary,oct_op);
18383 @:oct_}{\&{oct} primitive@>
18384 mp_primitive(mp, "hex",unary,hex_op);
18385 @:hex_}{\&{hex} primitive@>
18386 mp_primitive(mp, "ASCII",unary,ASCII_op);
18387 @:ASCII_}{\&{ASCII} primitive@>
18388 mp_primitive(mp, "char",unary,char_op);
18389 @:char_}{\&{char} primitive@>
18390 mp_primitive(mp, "length",unary,length_op);
18391 @:length_}{\&{length} primitive@>
18392 mp_primitive(mp, "turningnumber",unary,turning_op);
18393 @:turning_number_}{\&{turningnumber} primitive@>
18394 mp_primitive(mp, "xpart",unary,x_part);
18395 @:x_part_}{\&{xpart} primitive@>
18396 mp_primitive(mp, "ypart",unary,y_part);
18397 @:y_part_}{\&{ypart} primitive@>
18398 mp_primitive(mp, "xxpart",unary,xx_part);
18399 @:xx_part_}{\&{xxpart} primitive@>
18400 mp_primitive(mp, "xypart",unary,xy_part);
18401 @:xy_part_}{\&{xypart} primitive@>
18402 mp_primitive(mp, "yxpart",unary,yx_part);
18403 @:yx_part_}{\&{yxpart} primitive@>
18404 mp_primitive(mp, "yypart",unary,yy_part);
18405 @:yy_part_}{\&{yypart} primitive@>
18406 mp_primitive(mp, "redpart",unary,red_part);
18407 @:red_part_}{\&{redpart} primitive@>
18408 mp_primitive(mp, "greenpart",unary,green_part);
18409 @:green_part_}{\&{greenpart} primitive@>
18410 mp_primitive(mp, "bluepart",unary,blue_part);
18411 @:blue_part_}{\&{bluepart} primitive@>
18412 mp_primitive(mp, "cyanpart",unary,cyan_part);
18413 @:cyan_part_}{\&{cyanpart} primitive@>
18414 mp_primitive(mp, "magentapart",unary,magenta_part);
18415 @:magenta_part_}{\&{magentapart} primitive@>
18416 mp_primitive(mp, "yellowpart",unary,yellow_part);
18417 @:yellow_part_}{\&{yellowpart} primitive@>
18418 mp_primitive(mp, "blackpart",unary,black_part);
18419 @:black_part_}{\&{blackpart} primitive@>
18420 mp_primitive(mp, "greypart",unary,grey_part);
18421 @:grey_part_}{\&{greypart} primitive@>
18422 mp_primitive(mp, "colormodel",unary,color_model_part);
18423 @:color_model_part_}{\&{colormodel} primitive@>
18424 mp_primitive(mp, "fontpart",unary,font_part);
18425 @:font_part_}{\&{fontpart} primitive@>
18426 mp_primitive(mp, "textpart",unary,text_part);
18427 @:text_part_}{\&{textpart} primitive@>
18428 mp_primitive(mp, "pathpart",unary,path_part);
18429 @:path_part_}{\&{pathpart} primitive@>
18430 mp_primitive(mp, "penpart",unary,pen_part);
18431 @:pen_part_}{\&{penpart} primitive@>
18432 mp_primitive(mp, "dashpart",unary,dash_part);
18433 @:dash_part_}{\&{dashpart} primitive@>
18434 mp_primitive(mp, "sqrt",unary,sqrt_op);
18435 @:sqrt_}{\&{sqrt} primitive@>
18436 mp_primitive(mp, "mexp",unary,m_exp_op);
18437 @:m_exp_}{\&{mexp} primitive@>
18438 mp_primitive(mp, "mlog",unary,m_log_op);
18439 @:m_log_}{\&{mlog} primitive@>
18440 mp_primitive(mp, "sind",unary,sin_d_op);
18441 @:sin_d_}{\&{sind} primitive@>
18442 mp_primitive(mp, "cosd",unary,cos_d_op);
18443 @:cos_d_}{\&{cosd} primitive@>
18444 mp_primitive(mp, "floor",unary,floor_op);
18445 @:floor_}{\&{floor} primitive@>
18446 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18447 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18448 mp_primitive(mp, "charexists",unary,char_exists_op);
18449 @:char_exists_}{\&{charexists} primitive@>
18450 mp_primitive(mp, "fontsize",unary,font_size);
18451 @:font_size_}{\&{fontsize} primitive@>
18452 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18453 @:ll_corner_}{\&{llcorner} primitive@>
18454 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18455 @:lr_corner_}{\&{lrcorner} primitive@>
18456 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18457 @:ul_corner_}{\&{ulcorner} primitive@>
18458 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18459 @:ur_corner_}{\&{urcorner} primitive@>
18460 mp_primitive(mp, "arclength",unary,arc_length);
18461 @:arc_length_}{\&{arclength} primitive@>
18462 mp_primitive(mp, "angle",unary,angle_op);
18463 @:angle_}{\&{angle} primitive@>
18464 mp_primitive(mp, "cycle",cycle,cycle_op);
18465 @:cycle_}{\&{cycle} primitive@>
18466 mp_primitive(mp, "stroked",unary,stroked_op);
18467 @:stroked_}{\&{stroked} primitive@>
18468 mp_primitive(mp, "filled",unary,filled_op);
18469 @:filled_}{\&{filled} primitive@>
18470 mp_primitive(mp, "textual",unary,textual_op);
18471 @:textual_}{\&{textual} primitive@>
18472 mp_primitive(mp, "clipped",unary,clipped_op);
18473 @:clipped_}{\&{clipped} primitive@>
18474 mp_primitive(mp, "bounded",unary,bounded_op);
18475 @:bounded_}{\&{bounded} primitive@>
18476 mp_primitive(mp, "+",plus_or_minus,plus);
18477 @:+ }{\.{+} primitive@>
18478 mp_primitive(mp, "-",plus_or_minus,minus);
18479 @:- }{\.{-} primitive@>
18480 mp_primitive(mp, "*",secondary_binary,times);
18481 @:* }{\.{*} primitive@>
18482 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18483 @:/ }{\.{/} primitive@>
18484 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18485 @:++_}{\.{++} primitive@>
18486 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18487 @:+-+_}{\.{+-+} primitive@>
18488 mp_primitive(mp, "or",tertiary_binary,or_op);
18489 @:or_}{\&{or} primitive@>
18490 mp_primitive(mp, "and",and_command,and_op);
18491 @:and_}{\&{and} primitive@>
18492 mp_primitive(mp, "<",expression_binary,less_than);
18493 @:< }{\.{<} primitive@>
18494 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18495 @:<=_}{\.{<=} primitive@>
18496 mp_primitive(mp, ">",expression_binary,greater_than);
18497 @:> }{\.{>} primitive@>
18498 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18499 @:>=_}{\.{>=} primitive@>
18500 mp_primitive(mp, "=",equals,equal_to);
18501 @:= }{\.{=} primitive@>
18502 mp_primitive(mp, "<>",expression_binary,unequal_to);
18503 @:<>_}{\.{<>} primitive@>
18504 mp_primitive(mp, "substring",primary_binary,substring_of);
18505 @:substring_}{\&{substring} primitive@>
18506 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18507 @:subpath_}{\&{subpath} primitive@>
18508 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18509 @:direction_time_}{\&{directiontime} primitive@>
18510 mp_primitive(mp, "point",primary_binary,point_of);
18511 @:point_}{\&{point} primitive@>
18512 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18513 @:precontrol_}{\&{precontrol} primitive@>
18514 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18515 @:postcontrol_}{\&{postcontrol} primitive@>
18516 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18517 @:pen_offset_}{\&{penoffset} primitive@>
18518 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18519 @:arc_time_of_}{\&{arctime} primitive@>
18520 mp_primitive(mp, "mpversion",nullary,mp_version);
18521 @:mp_verison_}{\&{mpversion} primitive@>
18522 mp_primitive(mp, "&",ampersand,concatenate);
18523 @:!!!}{\.{\&} primitive@>
18524 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18525 @:rotated_}{\&{rotated} primitive@>
18526 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18527 @:slanted_}{\&{slanted} primitive@>
18528 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18529 @:scaled_}{\&{scaled} primitive@>
18530 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18531 @:shifted_}{\&{shifted} primitive@>
18532 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18533 @:transformed_}{\&{transformed} primitive@>
18534 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18535 @:x_scaled_}{\&{xscaled} primitive@>
18536 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18537 @:y_scaled_}{\&{yscaled} primitive@>
18538 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18539 @:z_scaled_}{\&{zscaled} primitive@>
18540 mp_primitive(mp, "infont",secondary_binary,in_font);
18541 @:in_font_}{\&{infont} primitive@>
18542 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18543 @:intersection_times_}{\&{intersectiontimes} primitive@>
18545 @ @<Cases of |print_cmd...@>=
18548 case primary_binary:
18549 case secondary_binary:
18550 case tertiary_binary:
18551 case expression_binary:
18553 case plus_or_minus:
18558 mp_print_op(mp, m);
18561 @ OK, let's look at the simplest \\{do} procedure first.
18563 @c @<Declare nullary action procedure@>;
18564 void mp_do_nullary (MP mp,quarterword c) {
18566 if ( mp->internal[mp_tracing_commands]>two )
18567 mp_show_cmd_mod(mp, nullary,c);
18569 case true_code: case false_code:
18570 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18572 case null_picture_code:
18573 mp->cur_type=mp_picture_type;
18574 mp->cur_exp=mp_get_node(mp, edge_header_size);
18575 mp_init_edges(mp, mp->cur_exp);
18577 case null_pen_code:
18578 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18580 case normal_deviate:
18581 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18584 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18587 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18588 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18591 mp->cur_type=mp_string_type;
18592 mp->cur_exp=intern(metapost_version) ;
18594 case read_string_op:
18595 @<Read a string from the terminal@>;
18597 } /* there are no other cases */
18601 @ @<Read a string...@>=
18603 if ( mp->interaction<=mp_nonstop_mode )
18604 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18605 mp_begin_file_reading(mp); name=is_read;
18606 limit=start; prompt_input("");
18607 mp_finish_read(mp);
18610 @ @<Declare nullary action procedure@>=
18611 void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18613 str_room((int)mp->last-start);
18614 for (k=start;k<=mp->last-1;k++) {
18615 append_char(mp->buffer[k]);
18617 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18618 mp->cur_exp=mp_make_string(mp);
18621 @ Things get a bit more interesting when there's an operand. The
18622 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18624 @c @<Declare unary action procedures@>;
18625 void mp_do_unary (MP mp,quarterword c) {
18626 pointer p,q,r; /* for list manipulation */
18627 integer x; /* a temporary register */
18629 if ( mp->internal[mp_tracing_commands]>two )
18630 @<Trace the current unary operation@>;
18633 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18636 @<Negate the current expression@>;
18638 @<Additional cases of unary operators@>;
18639 } /* there are no other cases */
18643 @ The |nice_pair| function returns |true| if both components of a pair
18646 @<Declare unary action procedures@>=
18647 boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18648 if ( t==mp_pair_type ) {
18650 if ( type(x_part_loc(p))==mp_known )
18651 if ( type(y_part_loc(p))==mp_known )
18657 @ The |nice_color_or_pair| function is analogous except that it also accepts
18658 fully known colors.
18660 @<Declare unary action procedures@>=
18661 boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18662 pointer q,r; /* for scanning the big node */
18663 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18667 r=q+mp->big_node_size[type(p)];
18670 if ( type(r)!=mp_known )
18677 @ @<Declare unary action...@>=
18678 void mp_print_known_or_unknown_type (MP mp,small_number t, integer v) {
18679 mp_print_char(mp, '(');
18680 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18681 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18682 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18683 mp_print_type(mp, t);
18685 mp_print_char(mp, ')');
18688 @ @<Declare unary action...@>=
18689 void mp_bad_unary (MP mp,quarterword c) {
18690 exp_err("Not implemented: "); mp_print_op(mp, c);
18691 @.Not implemented...@>
18692 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18693 help3("I'm afraid I don't know how to apply that operation to that")
18694 ("particular type. Continue, and I'll simply return the")
18695 ("argument (shown above) as the result of the operation.");
18696 mp_put_get_error(mp);
18699 @ @<Trace the current unary operation@>=
18701 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18702 mp_print_op(mp, c); mp_print_char(mp, '(');
18703 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18704 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18707 @ Negation is easy except when the current expression
18708 is of type |independent|, or when it is a pair with one or more
18709 |independent| components.
18711 It is tempting to argue that the negative of an independent variable
18712 is an independent variable, hence we don't have to do anything when
18713 negating it. The fallacy is that other dependent variables pointing
18714 to the current expression must change the sign of their
18715 coefficients if we make no change to the current expression.
18717 Instead, we work around the problem by copying the current expression
18718 and recycling it afterwards (cf.~the |stash_in| routine).
18720 @<Negate the current expression@>=
18721 switch (mp->cur_type) {
18722 case mp_color_type:
18723 case mp_cmykcolor_type:
18725 case mp_independent:
18726 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18727 if ( mp->cur_type==mp_dependent ) {
18728 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18729 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18730 p=value(mp->cur_exp);
18731 r=p+mp->big_node_size[mp->cur_type];
18734 if ( type(r)==mp_known ) negate(value(r));
18735 else mp_negate_dep_list(mp, dep_list(r));
18737 } /* if |cur_type=mp_known| then |cur_exp=0| */
18738 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18741 case mp_proto_dependent:
18742 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18745 negate(mp->cur_exp);
18748 mp_bad_unary(mp, minus);
18752 @ @<Declare unary action...@>=
18753 void mp_negate_dep_list (MP mp,pointer p) {
18756 if ( info(p)==null ) return;
18761 @ @<Additional cases of unary operators@>=
18763 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
18764 else mp->cur_exp=true_code+false_code-mp->cur_exp;
18767 @ @d three_sixty_units 23592960 /* that's |360*unity| */
18768 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
18770 @<Additional cases of unary operators@>=
18777 case uniform_deviate:
18779 case char_exists_op:
18780 if ( mp->cur_type!=mp_known ) {
18781 mp_bad_unary(mp, c);
18784 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
18785 case m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
18786 case m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
18789 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
18790 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
18791 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
18793 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
18794 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
18796 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
18797 mp->cur_type=mp_boolean_type;
18799 case char_exists_op:
18800 @<Determine if a character has been shipped out@>;
18802 } /* there are no other cases */
18806 @ @<Additional cases of unary operators@>=
18808 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
18809 p=value(mp->cur_exp);
18810 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
18811 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
18812 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
18814 mp_bad_unary(mp, angle_op);
18818 @ If the current expression is a pair, but the context wants it to
18819 be a path, we call |pair_to_path|.
18821 @<Declare unary action...@>=
18822 void mp_pair_to_path (MP mp) {
18823 mp->cur_exp=mp_new_knot(mp);
18824 mp->cur_type=mp_path_type;
18827 @ @<Additional cases of unary operators@>=
18830 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
18831 mp_take_part(mp, c);
18832 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18833 else mp_bad_unary(mp, c);
18839 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
18840 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18841 else mp_bad_unary(mp, c);
18846 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
18847 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18848 else mp_bad_unary(mp, c);
18854 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
18855 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18856 else mp_bad_unary(mp, c);
18859 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
18860 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18861 else mp_bad_unary(mp, c);
18863 case color_model_part:
18864 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18865 else mp_bad_unary(mp, c);
18868 @ In the following procedure, |cur_exp| points to a capsule, which points to
18869 a big node. We want to delete all but one part of the big node.
18871 @<Declare unary action...@>=
18872 void mp_take_part (MP mp,quarterword c) {
18873 pointer p; /* the big node */
18874 p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
18875 link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
18876 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
18877 mp_recycle_value(mp, temp_val);
18880 @ @<Initialize table entries...@>=
18881 name_type(temp_val)=mp_capsule;
18883 @ @<Additional cases of unary operators@>=
18889 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18890 else mp_bad_unary(mp, c);
18893 @ @<Declarations@>=
18894 void mp_scale_edges (MP mp);
18896 @ @<Declare unary action...@>=
18897 void mp_take_pict_part (MP mp,quarterword c) {
18898 pointer p; /* first graphical object in |cur_exp| */
18899 p=link(dummy_loc(mp->cur_exp));
18902 case x_part: case y_part: case xx_part:
18903 case xy_part: case yx_part: case yy_part:
18904 if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
18905 else goto NOT_FOUND;
18907 case red_part: case green_part: case blue_part:
18908 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
18909 else goto NOT_FOUND;
18911 case cyan_part: case magenta_part: case yellow_part:
18913 if ( has_color(p) ) {
18914 if ( color_model(p)==mp_uninitialized_model )
18915 mp_flush_cur_exp(mp, unity);
18917 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
18918 } else goto NOT_FOUND;
18921 if ( has_color(p) )
18922 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
18923 else goto NOT_FOUND;
18925 case color_model_part:
18926 if ( has_color(p) ) {
18927 if ( color_model(p)==mp_uninitialized_model )
18928 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
18930 mp_flush_cur_exp(mp, color_model(p)*unity);
18931 } else goto NOT_FOUND;
18933 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
18934 } /* all cases have been enumerated */
18938 @<Convert the current expression to a null value appropriate
18942 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
18944 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
18946 mp_flush_cur_exp(mp, text_p(p));
18947 add_str_ref(mp->cur_exp);
18948 mp->cur_type=mp_string_type;
18952 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
18954 mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
18955 add_str_ref(mp->cur_exp);
18956 mp->cur_type=mp_string_type;
18960 if ( type(p)==mp_text_code ) goto NOT_FOUND;
18961 else if ( is_stop(p) ) mp_confusion(mp, "pict");
18962 @:this can't happen pict}{\quad pict@>
18964 mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
18965 mp->cur_type=mp_path_type;
18969 if ( ! has_pen(p) ) goto NOT_FOUND;
18971 if ( pen_p(p)==null ) goto NOT_FOUND;
18972 else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
18973 mp->cur_type=mp_pen_type;
18978 if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
18979 else { if ( dash_p(p)==null ) goto NOT_FOUND;
18980 else { add_edge_ref(dash_p(p));
18981 mp->se_sf=dash_scale(p);
18982 mp->se_pic=dash_p(p);
18983 mp_scale_edges(mp);
18984 mp_flush_cur_exp(mp, mp->se_pic);
18985 mp->cur_type=mp_picture_type;
18990 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
18991 parameterless procedure even though it really takes two arguments and updates
18992 one of them. Hence the following globals are needed.
18995 pointer se_pic; /* edge header used and updated by |scale_edges| */
18996 scaled se_sf; /* the scale factor argument to |scale_edges| */
18998 @ @<Convert the current expression to a null value appropriate...@>=
19000 case text_part: case font_part:
19001 mp_flush_cur_exp(mp, rts(""));
19002 mp->cur_type=mp_string_type;
19005 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19006 left_type(mp->cur_exp)=mp_endpoint;
19007 right_type(mp->cur_exp)=mp_endpoint;
19008 link(mp->cur_exp)=mp->cur_exp;
19009 x_coord(mp->cur_exp)=0;
19010 y_coord(mp->cur_exp)=0;
19011 originator(mp->cur_exp)=mp_metapost_user;
19012 mp->cur_type=mp_path_type;
19015 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19016 mp->cur_type=mp_pen_type;
19019 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19020 mp_init_edges(mp, mp->cur_exp);
19021 mp->cur_type=mp_picture_type;
19024 mp_flush_cur_exp(mp, 0);
19028 @ @<Additional cases of unary...@>=
19030 if ( mp->cur_type!=mp_known ) {
19031 mp_bad_unary(mp, char_op);
19033 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19034 mp->cur_type=mp_string_type;
19035 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19039 if ( mp->cur_type!=mp_known ) {
19040 mp_bad_unary(mp, decimal);
19042 mp->old_setting=mp->selector; mp->selector=new_string;
19043 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19044 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19050 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19051 else mp_str_to_num(mp, c);
19054 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19055 else @<Find the design size of the font whose name is |cur_exp|@>;
19058 @ @<Declare unary action...@>=
19059 void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19060 integer n; /* accumulator */
19061 ASCII_code m; /* current character */
19062 pool_pointer k; /* index into |str_pool| */
19063 int b; /* radix of conversion */
19064 boolean bad_char; /* did the string contain an invalid digit? */
19065 if ( c==ASCII_op ) {
19066 if ( length(mp->cur_exp)==0 ) n=-1;
19067 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19069 if ( c==oct_op ) b=8; else b=16;
19070 n=0; bad_char=false;
19071 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19073 if ( (m>='0')&&(m<='9') ) m=m-'0';
19074 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19075 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19076 else { bad_char=true; m=0; };
19077 if ( m>=b ) { bad_char=true; m=0; };
19078 if ( n<32768 / b ) n=n*b+m; else n=32767;
19080 @<Give error messages if |bad_char| or |n>=4096|@>;
19082 mp_flush_cur_exp(mp, n*unity);
19085 @ @<Give error messages if |bad_char|...@>=
19087 exp_err("String contains illegal digits");
19088 @.String contains illegal digits@>
19090 help1("I zeroed out characters that weren't in the range 0..7.");
19092 help1("I zeroed out characters that weren't hex digits.");
19094 mp_put_get_error(mp);
19097 if ( mp->internal[mp_warning_check]>0 ) {
19098 print_err("Number too large (");
19099 mp_print_int(mp, n); mp_print_char(mp, ')');
19100 @.Number too large@>
19101 help2("I have trouble with numbers greater than 4095; watch out.")
19102 ("(Set warningcheck:=0 to suppress this message.)");
19103 mp_put_get_error(mp);
19107 @ The length operation is somewhat unusual in that it applies to a variety
19108 of different types of operands.
19110 @<Additional cases of unary...@>=
19112 switch (mp->cur_type) {
19113 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19114 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19115 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19116 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19118 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19119 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19120 value(x_part_loc(value(mp->cur_exp))),
19121 value(y_part_loc(value(mp->cur_exp)))));
19122 else mp_bad_unary(mp, c);
19127 @ @<Declare unary action...@>=
19128 scaled mp_path_length (MP mp) { /* computes the length of the current path */
19129 scaled n; /* the path length so far */
19130 pointer p; /* traverser */
19132 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
19133 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
19137 @ @<Declare unary action...@>=
19138 scaled mp_pict_length (MP mp) {
19139 /* counts interior components in picture |cur_exp| */
19140 scaled n; /* the count so far */
19141 pointer p; /* traverser */
19143 p=link(dummy_loc(mp->cur_exp));
19145 if ( is_start_or_stop(p) )
19146 if ( mp_skip_1component(mp, p)==null ) p=link(p);
19147 while ( p!=null ) {
19148 skip_component(p) return n;
19155 @ Implement |turningnumber|
19157 @<Additional cases of unary...@>=
19159 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19160 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19161 else if ( left_type(mp->cur_exp)==mp_endpoint )
19162 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19164 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19167 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19168 argument is |origin|.
19170 @<Declare unary action...@>=
19171 angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19172 if ( (! ((xpar==0) && (ypar==0))) )
19173 return mp_n_arg(mp, xpar,ypar);
19178 @ The actual turning number is (for the moment) computed in a C function
19179 that receives eight integers corresponding to the four controlling points,
19180 and returns a single angle. Besides those, we have to account for discrete
19181 moves at the actual points.
19183 @d floor(a) (a>=0 ? a : -(int)(-a))
19184 @d bezier_error (720<<20)+1
19185 @d sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19186 @d print_roots(a) { if (debuglevel>(65536*2))
19187 fprintf(stdout,"bezier_slope(): %s, i=%f, o=%f, angle=%f\n", (a),in,out,res); }
19188 @d out ((double)(xo>>20))
19189 @d mid ((double)(xm>>20))
19190 @d in ((double)(xi>>20))
19191 @d divisor (256*256)
19192 @d double2angle(a) (int)floor(a*256.0*256.0*16.0)
19194 @<Declare unary action...@>=
19195 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19196 integer CX,integer CY,integer DX,integer DY, int debuglevel);
19199 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19200 integer CX,integer CY,integer DX,integer DY, int debuglevel) {
19202 integer deltax,deltay;
19203 double ax,ay,bx,by,cx,cy,dx,dy;
19204 angle xi = 0, xo = 0, xm = 0;
19206 ax=AX/divisor; ay=AY/divisor;
19207 bx=BX/divisor; by=BY/divisor;
19208 cx=CX/divisor; cy=CY/divisor;
19209 dx=DX/divisor; dy=DY/divisor;
19211 deltax = (BX-AX); deltay = (BY-AY);
19212 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19213 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19214 xi = mp_an_angle(mp,deltax,deltay);
19216 deltax = (CX-BX); deltay = (CY-BY);
19217 xm = mp_an_angle(mp,deltax,deltay);
19219 deltax = (DX-CX); deltay = (DY-CY);
19220 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19221 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19222 xo = mp_an_angle(mp,deltax,deltay);
19224 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19225 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19226 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19228 if (debuglevel>(65536*2)) {
19230 "bezier_slope(): (%.2f,%.2f),(%.2f,%.2f),(%.2f,%.2f),(%.2f,%.2f)\n",
19231 ax,ay,bx,by,cx,cy,dx,dy);
19233 "bezier_slope(): a,b,c,b^2,4ac: (%.2f,%.2f,%.2f,%.2f,%.2f)\n",a,b,c,b*b,4*a*c);
19236 if ((a==0)&&(c==0)) {
19237 res = (b==0 ? 0 : (out-in));
19238 print_roots("no roots (a)");
19239 } else if ((a==0)||(c==0)) {
19240 if ((sign(b) == sign(a)) || (sign(b) == sign(c))) {
19241 res = out-in; /* ? */
19244 else if (res>180.0)
19246 print_roots("no roots (b)");
19248 res = out-in; /* ? */
19249 print_roots("one root (a)");
19251 } else if ((sign(a)*sign(c))<0) {
19252 res = out-in; /* ? */
19255 else if (res>180.0)
19257 print_roots("one root (b)");
19259 if (sign(a) == sign(b)) {
19260 res = out-in; /* ? */
19263 else if (res>180.0)
19265 print_roots("no roots (d)");
19267 if ((b*b) == (4*a*c)) {
19268 res = bezier_error;
19269 print_roots("double root"); /* cusp */
19270 } else if ((b*b) < (4*a*c)) {
19271 res = out-in; /* ? */
19272 if (res<=0.0 &&res>-180.0)
19274 else if (res>=0.0 && res<180.0)
19276 print_roots("no roots (e)");
19281 else if (res>180.0)
19283 print_roots("two roots"); /* two inflections */
19287 return double2angle(res);
19291 @d p_nextnext link(link(p))
19293 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19295 @<Declare unary action...@>=
19296 scaled mp_new_turn_cycles (MP mp,pointer c) {
19297 angle res,ang; /* the angles of intermediate results */
19298 scaled turns; /* the turn counter */
19299 pointer p; /* for running around the path */
19300 integer xp,yp; /* coordinates of next point */
19301 integer x,y; /* helper coordinates */
19302 angle in_angle,out_angle; /* helper angles */
19303 int old_setting; /* saved |selector| setting */
19307 old_setting = mp->selector; mp->selector=term_only;
19308 if ( mp->internal[mp_tracing_commands]>unity ) {
19309 mp_begin_diagnostic(mp);
19310 mp_print_nl(mp, "");
19311 mp_end_diagnostic(mp, false);
19314 xp = x_coord(p_next); yp = y_coord(p_next);
19315 ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
19316 left_x(p_next), left_y(p_next), xp, yp,
19317 mp->internal[mp_tracing_commands]);
19318 if ( ang>seven_twenty_deg ) {
19319 print_err("Strange path");
19321 mp->selector=old_setting;
19325 if ( res > one_eighty_deg ) {
19326 res = res - three_sixty_deg;
19327 turns = turns + unity;
19329 if ( res <= -one_eighty_deg ) {
19330 res = res + three_sixty_deg;
19331 turns = turns - unity;
19333 /* incoming angle at next point */
19334 x = left_x(p_next); y = left_y(p_next);
19335 if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
19336 if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
19337 in_angle = mp_an_angle(mp, xp - x, yp - y);
19338 /* outgoing angle at next point */
19339 x = right_x(p_next); y = right_y(p_next);
19340 if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
19341 if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
19342 out_angle = mp_an_angle(mp, x - xp, y- yp);
19343 ang = (out_angle - in_angle);
19347 if ( res >= one_eighty_deg ) {
19348 res = res - three_sixty_deg;
19349 turns = turns + unity;
19351 if ( res <= -one_eighty_deg ) {
19352 res = res + three_sixty_deg;
19353 turns = turns - unity;
19358 mp->selector=old_setting;
19363 @ This code is based on Bogus\l{}av Jackowski's
19364 |emergency_turningnumber| macro, with some minor changes by Taco
19365 Hoekwater. The macro code looked more like this:
19367 vardef turning\_number primary p =
19368 ~~save res, ang, turns;
19370 ~~if length p <= 2:
19371 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19373 ~~~~for t = 0 upto length p-1 :
19374 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19375 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19376 ~~~~~~if angc > 180: angc := angc - 360; fi;
19377 ~~~~~~if angc < -180: angc := angc + 360; fi;
19378 ~~~~~~res := res + angc;
19383 The general idea is to calculate only the sum of the angles of
19384 straight lines between the points, of a path, not worrying about cusps
19385 or self-intersections in the segments at all. If the segment is not
19386 well-behaved, the result is not necesarily correct. But the old code
19387 was not always correct either, and worse, it sometimes failed for
19388 well-behaved paths as well. All known bugs that were triggered by the
19389 original code no longer occur with this code, and it runs roughly 3
19390 times as fast because the algorithm is much simpler.
19392 @ It is possible to overflow the return value of the |turn_cycles|
19393 function when the path is sufficiently long and winding, but I am not
19394 going to bother testing for that. In any case, it would only return
19395 the looped result value, which is not a big problem.
19397 The macro code for the repeat loop was a bit nicer to look
19398 at than the pascal code, because it could use |point -1 of p|. In
19399 pascal, the fastest way to loop around the path is not to look
19400 backward once, but forward twice. These defines help hide the trick.
19402 @d p_to link(link(p))
19406 @<Declare unary action...@>=
19407 scaled mp_turn_cycles (MP mp,pointer c) {
19408 angle res,ang; /* the angles of intermediate results */
19409 scaled turns; /* the turn counter */
19410 pointer p; /* for running around the path */
19411 res=0; turns= 0; p=c;
19413 ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
19414 y_coord(p_to) - y_coord(p_here))
19415 - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
19416 y_coord(p_here) - y_coord(p_from));
19419 if ( res >= three_sixty_deg ) {
19420 res = res - three_sixty_deg;
19421 turns = turns + unity;
19423 if ( res <= -three_sixty_deg ) {
19424 res = res + three_sixty_deg;
19425 turns = turns - unity;
19432 @ @<Declare unary action...@>=
19433 scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19435 scaled saved_t_o; /* tracing\_online saved */
19436 if ( (link(c)==c)||(link(link(c))==c) ) {
19437 if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
19442 nval = mp_new_turn_cycles(mp, c);
19443 oval = mp_turn_cycles(mp, c);
19444 if ( nval!=oval ) {
19445 saved_t_o=mp->internal[mp_tracing_online];
19446 mp->internal[mp_tracing_online]=unity;
19447 mp_begin_diagnostic(mp);
19448 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19449 " The current computed value is ");
19450 mp_print_scaled(mp, nval);
19451 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19452 mp_print_scaled(mp, oval);
19453 mp_end_diagnostic(mp, false);
19454 mp->internal[mp_tracing_online]=saved_t_o;
19460 @ @<Declare unary action...@>=
19461 scaled mp_count_turns (MP mp,pointer c) {
19462 pointer p; /* a knot in envelope spec |c| */
19463 integer t; /* total pen offset changes counted */
19466 t=t+info(p)-zero_off;
19469 return ((t / 3)*unity);
19472 @ @d type_range(A,B) {
19473 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19474 mp_flush_cur_exp(mp, true_code);
19475 else mp_flush_cur_exp(mp, false_code);
19476 mp->cur_type=mp_boolean_type;
19479 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19480 else mp_flush_cur_exp(mp, false_code);
19481 mp->cur_type=mp_boolean_type;
19484 @<Additional cases of unary operators@>=
19485 case mp_boolean_type:
19486 type_range(mp_boolean_type,mp_unknown_boolean); break;
19487 case mp_string_type:
19488 type_range(mp_string_type,mp_unknown_string); break;
19490 type_range(mp_pen_type,mp_unknown_pen); break;
19492 type_range(mp_path_type,mp_unknown_path); break;
19493 case mp_picture_type:
19494 type_range(mp_picture_type,mp_unknown_picture); break;
19495 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19497 type_test(c); break;
19498 case mp_numeric_type:
19499 type_range(mp_known,mp_independent); break;
19500 case known_op: case unknown_op:
19501 mp_test_known(mp, c); break;
19503 @ @<Declare unary action procedures@>=
19504 void mp_test_known (MP mp,quarterword c) {
19505 int b; /* is the current expression known? */
19506 pointer p,q; /* locations in a big node */
19508 switch (mp->cur_type) {
19509 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19510 case mp_pen_type: case mp_path_type: case mp_picture_type:
19514 case mp_transform_type:
19515 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19516 p=value(mp->cur_exp);
19517 q=p+mp->big_node_size[mp->cur_type];
19520 if ( type(q)!=mp_known )
19529 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19530 else mp_flush_cur_exp(mp, true_code+false_code-b);
19531 mp->cur_type=mp_boolean_type;
19534 @ @<Additional cases of unary operators@>=
19536 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19537 else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19538 else mp_flush_cur_exp(mp, false_code);
19539 mp->cur_type=mp_boolean_type;
19542 @ @<Additional cases of unary operators@>=
19544 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19545 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19546 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19549 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19551 @^data structure assumptions@>
19553 @<Additional cases of unary operators@>=
19559 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19560 else if ( link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19561 else if ( type(link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19562 mp_flush_cur_exp(mp, true_code);
19563 else mp_flush_cur_exp(mp, false_code);
19564 mp->cur_type=mp_boolean_type;
19567 @ @<Additional cases of unary operators@>=
19569 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19570 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19572 mp->cur_type=mp_pen_type;
19573 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19577 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19579 mp->cur_type=mp_path_type;
19580 mp_make_path(mp, mp->cur_exp);
19584 if ( mp->cur_type==mp_path_type ) {
19585 p=mp_htap_ypoc(mp, mp->cur_exp);
19586 if ( right_type(p)==mp_endpoint ) p=link(p);
19587 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19588 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19589 else mp_bad_unary(mp, reverse);
19592 @ The |pair_value| routine changes the current expression to a
19593 given ordered pair of values.
19595 @<Declare unary action procedures@>=
19596 void mp_pair_value (MP mp,scaled x, scaled y) {
19597 pointer p; /* a pair node */
19598 p=mp_get_node(mp, value_node_size);
19599 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19600 type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19602 type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19603 type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19606 @ @<Additional cases of unary operators@>=
19608 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19609 else mp_pair_value(mp, minx,miny);
19612 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19613 else mp_pair_value(mp, maxx,miny);
19616 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19617 else mp_pair_value(mp, minx,maxy);
19620 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19621 else mp_pair_value(mp, maxx,maxy);
19624 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19625 box of the current expression. The boolean result is |false| if the expression
19626 has the wrong type.
19628 @<Declare unary action procedures@>=
19629 boolean mp_get_cur_bbox (MP mp) {
19630 switch (mp->cur_type) {
19631 case mp_picture_type:
19632 mp_set_bbox(mp, mp->cur_exp,true);
19633 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19634 minx=0; maxx=0; miny=0; maxy=0;
19636 minx=minx_val(mp->cur_exp);
19637 maxx=maxx_val(mp->cur_exp);
19638 miny=miny_val(mp->cur_exp);
19639 maxy=maxy_val(mp->cur_exp);
19643 mp_path_bbox(mp, mp->cur_exp);
19646 mp_pen_bbox(mp, mp->cur_exp);
19654 @ @<Additional cases of unary operators@>=
19656 case close_from_op:
19657 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19658 else mp_do_read_or_close(mp,c);
19661 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19662 a line from the file or to close the file.
19664 @d close_file 46 /* go here when closing the file */
19666 @<Declare unary action procedures@>=
19667 void mp_do_read_or_close (MP mp,quarterword c) {
19668 readf_index n,n0; /* indices for searching |rd_fname| */
19669 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19670 call |start_read_input| and |goto found| or |not_found|@>;
19671 mp_begin_file_reading(mp);
19673 if ( mp_input_ln(mp, mp->rd_file[n],true) )
19675 mp_end_file_reading(mp);
19677 @<Record the end of file and set |cur_exp| to a dummy value@>;
19680 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19683 mp_flush_cur_exp(mp, 0);
19684 mp_finish_read(mp);
19687 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19690 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19695 fn = str(mp->cur_exp);
19696 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19699 } else if ( c==close_from_op ) {
19702 if ( n0==mp->read_files ) {
19703 if ( mp->read_files<mp->max_read_files ) {
19704 incr(mp->read_files);
19709 l = mp->max_read_files + (mp->max_read_files>>2);
19710 rd_file = xmalloc((l+1), sizeof(FILE *));
19711 rd_fname = xmalloc((l+1), sizeof(char *));
19712 for (k=0;k<=l;k++) {
19713 if (k<=mp->max_read_files) {
19714 rd_file[k]=mp->rd_file[k];
19715 rd_fname[k]=mp->rd_fname[k];
19721 xfree(mp->rd_file); xfree(mp->rd_fname);
19722 mp->max_read_files = l;
19723 mp->rd_file = rd_file;
19724 mp->rd_fname = rd_fname;
19728 if ( mp_start_read_input(mp,fn,n) )
19733 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19735 if ( c==close_from_op ) {
19736 fclose(mp->rd_file[n]);
19741 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19742 xfree(mp->rd_fname[n]);
19743 mp->rd_fname[n]=NULL;
19744 if ( n==mp->read_files-1 ) mp->read_files=n;
19745 if ( c==close_from_op )
19747 mp_flush_cur_exp(mp, mp->eof_line);
19748 mp->cur_type=mp_string_type
19750 @ The string denoting end-of-file is a one-byte string at position zero, by definition
19753 str_number eof_line;
19758 @ Finally, we have the operations that combine a capsule~|p|
19759 with the current expression.
19761 @c @<Declare binary action procedures@>;
19762 void mp_do_binary (MP mp,pointer p, quarterword c) {
19763 pointer q,r,rr; /* for list manipulation */
19764 pointer old_p,old_exp; /* capsules to recycle */
19765 integer v; /* for numeric manipulation */
19767 if ( mp->internal[mp_tracing_commands]>two ) {
19768 @<Trace the current binary operation@>;
19770 @<Sidestep |independent| cases in capsule |p|@>;
19771 @<Sidestep |independent| cases in the current expression@>;
19773 case plus: case minus:
19774 @<Add or subtract the current expression from |p|@>;
19776 @<Additional cases of binary operators@>;
19777 }; /* there are no other cases */
19778 mp_recycle_value(mp, p);
19779 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
19781 @<Recycle any sidestepped |independent| capsules@>;
19784 @ @<Declare binary action...@>=
19785 void mp_bad_binary (MP mp,pointer p, quarterword c) {
19786 mp_disp_err(mp, p,"");
19787 exp_err("Not implemented: ");
19788 @.Not implemented...@>
19789 if ( c>=min_of ) mp_print_op(mp, c);
19790 mp_print_known_or_unknown_type(mp, type(p),p);
19791 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
19792 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
19793 help3("I'm afraid I don't know how to apply that operation to that")
19794 ("combination of types. Continue, and I'll return the second")
19795 ("argument (see above) as the result of the operation.");
19796 mp_put_get_error(mp);
19799 @ @<Trace the current binary operation@>=
19801 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
19802 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
19803 mp_print_char(mp,')'); mp_print_op(mp,c); mp_print_char(mp,'(');
19804 mp_print_exp(mp,null,0); mp_print(mp,")}");
19805 mp_end_diagnostic(mp, false);
19808 @ Several of the binary operations are potentially complicated by the
19809 fact that |independent| values can sneak into capsules. For example,
19810 we've seen an instance of this difficulty in the unary operation
19811 of negation. In order to reduce the number of cases that need to be
19812 handled, we first change the two operands (if necessary)
19813 to rid them of |independent| components. The original operands are
19814 put into capsules called |old_p| and |old_exp|, which will be
19815 recycled after the binary operation has been safely carried out.
19817 @<Recycle any sidestepped |independent| capsules@>=
19818 if ( old_p!=null ) {
19819 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
19821 if ( old_exp!=null ) {
19822 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
19825 @ A big node is considered to be ``tarnished'' if it contains at least one
19826 independent component. We will define a simple function called `|tarnished|'
19827 that returns |null| if and only if its argument is not tarnished.
19829 @<Sidestep |independent| cases in capsule |p|@>=
19831 case mp_transform_type:
19832 case mp_color_type:
19833 case mp_cmykcolor_type:
19835 old_p=mp_tarnished(mp, p);
19837 case mp_independent: old_p=mp_void; break;
19838 default: old_p=null; break;
19840 if ( old_p!=null ) {
19841 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
19842 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
19845 @ @<Sidestep |independent| cases in the current expression@>=
19846 switch (mp->cur_type) {
19847 case mp_transform_type:
19848 case mp_color_type:
19849 case mp_cmykcolor_type:
19851 old_exp=mp_tarnished(mp, mp->cur_exp);
19853 case mp_independent:old_exp=mp_void; break;
19854 default: old_exp=null; break;
19856 if ( old_exp!=null ) {
19857 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
19860 @ @<Declare binary action...@>=
19861 pointer mp_tarnished (MP mp,pointer p) {
19862 pointer q; /* beginning of the big node */
19863 pointer r; /* current position in the big node */
19864 q=value(p); r=q+mp->big_node_size[type(p)];
19867 if ( type(r)==mp_independent ) return mp_void;
19872 @ @<Add or subtract the current expression from |p|@>=
19873 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
19874 mp_bad_binary(mp, p,c);
19876 if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
19877 mp_add_or_subtract(mp, p,null,c);
19879 if ( mp->cur_type!=type(p) ) {
19880 mp_bad_binary(mp, p,c);
19882 q=value(p); r=value(mp->cur_exp);
19883 rr=r+mp->big_node_size[mp->cur_type];
19885 mp_add_or_subtract(mp, q,r,c);
19892 @ The first argument to |add_or_subtract| is the location of a value node
19893 in a capsule or pair node that will soon be recycled. The second argument
19894 is either a location within a pair or transform node of |cur_exp|,
19895 or it is null (which means that |cur_exp| itself should be the second
19896 argument). The third argument is either |plus| or |minus|.
19898 The sum or difference of the numeric quantities will replace the second
19899 operand. Arithmetic overflow may go undetected; users aren't supposed to
19900 be monkeying around with really big values.
19902 @<Declare binary action...@>=
19903 @<Declare the procedure called |dep_finish|@>;
19904 void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
19905 small_number s,t; /* operand types */
19906 pointer r; /* list traverser */
19907 integer v; /* second operand value */
19910 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
19913 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
19915 if ( t==mp_known ) {
19916 if ( c==minus ) negate(v);
19917 if ( type(p)==mp_known ) {
19918 v=mp_slow_add(mp, value(p),v);
19919 if ( q==null ) mp->cur_exp=v; else value(q)=v;
19922 @<Add a known value to the constant term of |dep_list(p)|@>;
19924 if ( c==minus ) mp_negate_dep_list(mp, v);
19925 @<Add operand |p| to the dependency list |v|@>;
19929 @ @<Add a known value to the constant term of |dep_list(p)|@>=
19931 while ( info(r)!=null ) r=link(r);
19932 value(r)=mp_slow_add(mp, value(r),v);
19934 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
19935 name_type(q)=mp_capsule;
19937 dep_list(q)=dep_list(p); type(q)=type(p);
19938 prev_dep(q)=prev_dep(p); link(prev_dep(p))=q;
19939 type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
19941 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
19942 nice to retain the extra accuracy of |fraction| coefficients.
19943 But we have to handle both kinds, and mixtures too.
19945 @<Add operand |p| to the dependency list |v|@>=
19946 if ( type(p)==mp_known ) {
19947 @<Add the known |value(p)| to the constant term of |v|@>;
19949 s=type(p); r=dep_list(p);
19950 if ( t==mp_dependent ) {
19951 if ( s==mp_dependent ) {
19952 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
19953 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
19954 } /* |fix_needed| will necessarily be false */
19955 t=mp_proto_dependent;
19956 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
19958 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
19959 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
19961 @<Output the answer, |v| (which might have become |known|)@>;
19964 @ @<Add the known |value(p)| to the constant term of |v|@>=
19966 while ( info(v)!=null ) v=link(v);
19967 value(v)=mp_slow_add(mp, value(p),value(v));
19970 @ @<Output the answer, |v| (which might have become |known|)@>=
19971 if ( q!=null ) mp_dep_finish(mp, v,q,t);
19972 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
19974 @ Here's the current situation: The dependency list |v| of type |t|
19975 should either be put into the current expression (if |q=null|) or
19976 into location |q| within a pair node (otherwise). The destination (|cur_exp|
19977 or |q|) formerly held a dependency list with the same
19978 final pointer as the list |v|.
19980 @<Declare the procedure called |dep_finish|@>=
19981 void mp_dep_finish (MP mp, pointer v, pointer q, small_number t) {
19982 pointer p; /* the destination */
19983 scaled vv; /* the value, if it is |known| */
19984 if ( q==null ) p=mp->cur_exp; else p=q;
19985 dep_list(p)=v; type(p)=t;
19986 if ( info(v)==null ) {
19989 mp_flush_cur_exp(mp, vv);
19991 mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
19993 } else if ( q==null ) {
19996 if ( mp->fix_needed ) mp_fix_dependencies(mp);
19999 @ Let's turn now to the six basic relations of comparison.
20001 @<Additional cases of binary operators@>=
20002 case less_than: case less_or_equal: case greater_than:
20003 case greater_or_equal: case equal_to: case unequal_to:
20004 check_arith; /* at this point |arith_error| should be |false|? */
20005 if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20006 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20007 } else if ( mp->cur_type!=type(p) ) {
20008 mp_bad_binary(mp, p,c); goto DONE;
20009 } else if ( mp->cur_type==mp_string_type ) {
20010 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20011 } else if ((mp->cur_type==mp_unknown_string)||
20012 (mp->cur_type==mp_unknown_boolean) ) {
20013 @<Check if unknowns have been equated@>;
20014 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20015 @<Reduce comparison of big nodes to comparison of scalars@>;
20016 } else if ( mp->cur_type==mp_boolean_type ) {
20017 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20019 mp_bad_binary(mp, p,c); goto DONE;
20021 @<Compare the current expression with zero@>;
20023 mp->arith_error=false; /* ignore overflow in comparisons */
20026 @ @<Compare the current expression with zero@>=
20027 if ( mp->cur_type!=mp_known ) {
20028 if ( mp->cur_type<mp_known ) {
20029 mp_disp_err(mp, p,"");
20030 help1("The quantities shown above have not been equated.")
20032 help2("Oh dear. I can\'t decide if the expression above is positive,")
20033 ("negative, or zero. So this comparison test won't be `true'.");
20035 exp_err("Unknown relation will be considered false");
20036 @.Unknown relation...@>
20037 mp_put_get_flush_error(mp, false_code);
20040 case less_than: boolean_reset(mp->cur_exp<0); break;
20041 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20042 case greater_than: boolean_reset(mp->cur_exp>0); break;
20043 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20044 case equal_to: boolean_reset(mp->cur_exp==0); break;
20045 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20046 }; /* there are no other cases */
20048 mp->cur_type=mp_boolean_type
20050 @ When two unknown strings are in the same ring, we know that they are
20051 equal. Otherwise, we don't know whether they are equal or not, so we
20054 @<Check if unknowns have been equated@>=
20056 q=value(mp->cur_exp);
20057 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20058 if ( q==p ) mp_flush_cur_exp(mp, 0);
20061 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20063 q=value(p); r=value(mp->cur_exp);
20064 rr=r+mp->big_node_size[mp->cur_type]-2;
20065 while (1) { mp_add_or_subtract(mp, q,r,minus);
20066 if ( type(r)!=mp_known ) break;
20067 if ( value(r)!=0 ) break;
20068 if ( r==rr ) break;
20071 mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
20074 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20076 @<Additional cases of binary operators@>=
20079 if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20080 mp_bad_binary(mp, p,c);
20081 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20084 @ @<Additional cases of binary operators@>=
20086 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20087 mp_bad_binary(mp, p,times);
20088 } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
20089 @<Multiply when at least one operand is known@>;
20090 } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
20091 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20092 (type(p)>mp_pair_type)) ) {
20093 mp_hard_times(mp, p); return;
20095 mp_bad_binary(mp, p,times);
20099 @ @<Multiply when at least one operand is known@>=
20101 if ( type(p)==mp_known ) {
20102 v=value(p); mp_free_node(mp, p,value_node_size);
20104 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20106 if ( mp->cur_type==mp_known ) {
20107 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20108 } else if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_color_type)||
20109 (mp->cur_type==mp_cmykcolor_type) ) {
20110 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20112 p=p-2; mp_dep_mult(mp, p,v,true);
20113 } while (p!=value(mp->cur_exp));
20115 mp_dep_mult(mp, null,v,true);
20120 @ @<Declare binary action...@>=
20121 void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20122 pointer q; /* the dependency list being multiplied by |v| */
20123 small_number s,t; /* its type, before and after */
20126 } else if ( type(p)!=mp_known ) {
20129 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20130 else value(p)=mp_take_fraction(mp, value(p),v);
20133 t=type(q); q=dep_list(q); s=t;
20134 if ( t==mp_dependent ) if ( v_is_scaled )
20135 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20136 t=mp_proto_dependent;
20137 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20138 mp_dep_finish(mp, q,p,t);
20141 @ Here is a routine that is similar to |times|; but it is invoked only
20142 internally, when |v| is a |fraction| whose magnitude is at most~1,
20143 and when |cur_type>=mp_color_type|.
20145 @c void mp_frac_mult (MP mp,scaled n, scaled d) {
20146 /* multiplies |cur_exp| by |n/d| */
20147 pointer p; /* a pair node */
20148 pointer old_exp; /* a capsule to recycle */
20149 fraction v; /* |n/d| */
20150 if ( mp->internal[mp_tracing_commands]>two ) {
20151 @<Trace the fraction multiplication@>;
20153 switch (mp->cur_type) {
20154 case mp_transform_type:
20155 case mp_color_type:
20156 case mp_cmykcolor_type:
20158 old_exp=mp_tarnished(mp, mp->cur_exp);
20160 case mp_independent: old_exp=mp_void; break;
20161 default: old_exp=null; break;
20163 if ( old_exp!=null ) {
20164 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20166 v=mp_make_fraction(mp, n,d);
20167 if ( mp->cur_type==mp_known ) {
20168 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20169 } else if ( mp->cur_type<=mp_pair_type ) {
20170 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20173 mp_dep_mult(mp, p,v,false);
20174 } while (p!=value(mp->cur_exp));
20176 mp_dep_mult(mp, null,v,false);
20178 if ( old_exp!=null ) {
20179 mp_recycle_value(mp, old_exp);
20180 mp_free_node(mp, old_exp,value_node_size);
20184 @ @<Trace the fraction multiplication@>=
20186 mp_begin_diagnostic(mp);
20187 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,'/');
20188 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20190 mp_end_diagnostic(mp, false);
20193 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20195 @<Declare binary action procedures@>=
20196 void mp_hard_times (MP mp,pointer p) {
20197 pointer q; /* a copy of the dependent variable |p| */
20198 pointer r; /* a component of the big node for the nice color or pair */
20199 scaled v; /* the known value for |r| */
20200 if ( type(p)<=mp_pair_type ) {
20201 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20202 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20203 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20208 if ( r==value(mp->cur_exp) )
20210 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20211 mp_dep_mult(mp, r,v,true);
20213 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20214 link(prev_dep(p))=r;
20215 mp_free_node(mp, p,value_node_size);
20216 mp_dep_mult(mp, r,v,true);
20219 @ @<Additional cases of binary operators@>=
20221 if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
20222 mp_bad_binary(mp, p,over);
20224 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20226 @<Squeal about division by zero@>;
20228 if ( mp->cur_type==mp_known ) {
20229 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20230 } else if ( mp->cur_type<=mp_pair_type ) {
20231 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20233 p=p-2; mp_dep_div(mp, p,v);
20234 } while (p!=value(mp->cur_exp));
20236 mp_dep_div(mp, null,v);
20243 @ @<Declare binary action...@>=
20244 void mp_dep_div (MP mp,pointer p, scaled v) {
20245 pointer q; /* the dependency list being divided by |v| */
20246 small_number s,t; /* its type, before and after */
20247 if ( p==null ) q=mp->cur_exp;
20248 else if ( type(p)!=mp_known ) q=p;
20249 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20250 t=type(q); q=dep_list(q); s=t;
20251 if ( t==mp_dependent )
20252 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20253 t=mp_proto_dependent;
20254 q=mp_p_over_v(mp, q,v,s,t);
20255 mp_dep_finish(mp, q,p,t);
20258 @ @<Squeal about division by zero@>=
20260 exp_err("Division by zero");
20261 @.Division by zero@>
20262 help2("You're trying to divide the quantity shown above the error")
20263 ("message by zero. I'm going to divide it by one instead.");
20264 mp_put_get_error(mp);
20267 @ @<Additional cases of binary operators@>=
20270 if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
20271 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20272 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20273 } else mp_bad_binary(mp, p,c);
20276 @ The next few sections of the program deal with affine transformations
20277 of coordinate data.
20279 @<Additional cases of binary operators@>=
20280 case rotated_by: case slanted_by:
20281 case scaled_by: case shifted_by: case transformed_by:
20282 case x_scaled: case y_scaled: case z_scaled:
20283 if ( type(p)==mp_path_type ) {
20284 path_trans(c,p); return;
20285 } else if ( type(p)==mp_pen_type ) {
20287 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20288 /* rounding error could destroy convexity */
20290 } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
20291 mp_big_trans(mp, p,c);
20292 } else if ( type(p)==mp_picture_type ) {
20293 mp_do_edges_trans(mp, p,c); return;
20295 mp_bad_binary(mp, p,c);
20299 @ Let |c| be one of the eight transform operators. The procedure call
20300 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20301 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20302 change at all if |c=transformed_by|.)
20304 Then, if all components of the resulting transform are |known|, they are
20305 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20306 and |cur_exp| is changed to the known value zero.
20308 @<Declare binary action...@>=
20309 void mp_set_up_trans (MP mp,quarterword c) {
20310 pointer p,q,r; /* list manipulation registers */
20311 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20312 @<Put the current transform into |cur_exp|@>;
20314 @<If the current transform is entirely known, stash it in global variables;
20315 otherwise |return|@>;
20324 scaled ty; /* current transform coefficients */
20326 @ @<Put the current transform...@>=
20328 p=mp_stash_cur_exp(mp);
20329 mp->cur_exp=mp_id_transform(mp);
20330 mp->cur_type=mp_transform_type;
20331 q=value(mp->cur_exp);
20333 @<For each of the eight cases, change the relevant fields of |cur_exp|
20335 but do nothing if capsule |p| doesn't have the appropriate type@>;
20336 }; /* there are no other cases */
20337 mp_disp_err(mp, p,"Improper transformation argument");
20338 @.Improper transformation argument@>
20339 help3("The expression shown above has the wrong type,")
20340 ("so I can\'t transform anything using it.")
20341 ("Proceed, and I'll omit the transformation.");
20342 mp_put_get_error(mp);
20344 mp_recycle_value(mp, p);
20345 mp_free_node(mp, p,value_node_size);
20348 @ @<If the current transform is entirely known, ...@>=
20349 q=value(mp->cur_exp); r=q+transform_node_size;
20352 if ( type(r)!=mp_known ) return;
20354 mp->txx=value(xx_part_loc(q));
20355 mp->txy=value(xy_part_loc(q));
20356 mp->tyx=value(yx_part_loc(q));
20357 mp->tyy=value(yy_part_loc(q));
20358 mp->tx=value(x_part_loc(q));
20359 mp->ty=value(y_part_loc(q));
20360 mp_flush_cur_exp(mp, 0)
20362 @ @<For each of the eight cases...@>=
20364 if ( type(p)==mp_known )
20365 @<Install sines and cosines, then |goto done|@>;
20368 if ( type(p)>mp_pair_type ) {
20369 mp_install(mp, xy_part_loc(q),p); goto DONE;
20373 if ( type(p)>mp_pair_type ) {
20374 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20379 if ( type(p)==mp_pair_type ) {
20380 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20381 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20385 if ( type(p)>mp_pair_type ) {
20386 mp_install(mp, xx_part_loc(q),p); goto DONE;
20390 if ( type(p)>mp_pair_type ) {
20391 mp_install(mp, yy_part_loc(q),p); goto DONE;
20395 if ( type(p)==mp_pair_type )
20396 @<Install a complex multiplier, then |goto done|@>;
20398 case transformed_by:
20402 @ @<Install sines and cosines, then |goto done|@>=
20403 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20404 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20405 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20406 value(xy_part_loc(q))=-value(yx_part_loc(q));
20407 value(yy_part_loc(q))=value(xx_part_loc(q));
20411 @ @<Install a complex multiplier, then |goto done|@>=
20414 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20415 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20416 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20417 if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20418 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20419 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20423 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20424 insists that the transformation be entirely known.
20426 @<Declare binary action...@>=
20427 void mp_set_up_known_trans (MP mp,quarterword c) {
20428 mp_set_up_trans(mp, c);
20429 if ( mp->cur_type!=mp_known ) {
20430 exp_err("Transform components aren't all known");
20431 @.Transform components...@>
20432 help3("I'm unable to apply a partially specified transformation")
20433 ("except to a fully known pair or transform.")
20434 ("Proceed, and I'll omit the transformation.");
20435 mp_put_get_flush_error(mp, 0);
20436 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20437 mp->tx=0; mp->ty=0;
20441 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20442 coordinates in locations |p| and~|q|.
20444 @<Declare binary action...@>=
20445 void mp_trans (MP mp,pointer p, pointer q) {
20446 scaled v; /* the new |x| value */
20447 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20448 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20449 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20450 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20454 @ The simplest transformation procedure applies a transform to all
20455 coordinates of a path. The |path_trans(c)(p)| macro applies
20456 a transformation defined by |cur_exp| and the transform operator |c|
20459 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20460 mp_unstash_cur_exp(mp, (B));
20461 mp_do_path_trans(mp, mp->cur_exp); }
20463 @<Declare binary action...@>=
20464 void mp_do_path_trans (MP mp,pointer p) {
20465 pointer q; /* list traverser */
20468 if ( left_type(q)!=mp_endpoint )
20469 mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
20470 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20471 if ( right_type(q)!=mp_endpoint )
20472 mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
20473 @^data structure assumptions@>
20478 @ Transforming a pen is very similar, except that there are no |left_type|
20479 and |right_type| fields.
20481 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20482 mp_unstash_cur_exp(mp, (B));
20483 mp_do_pen_trans(mp, mp->cur_exp); }
20485 @<Declare binary action...@>=
20486 void mp_do_pen_trans (MP mp,pointer p) {
20487 pointer q; /* list traverser */
20488 if ( pen_is_elliptical(p) ) {
20489 mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
20490 mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
20494 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20495 @^data structure assumptions@>
20500 @ The next transformation procedure applies to edge structures. It will do
20501 any transformation, but the results may be substandard if the picture contains
20502 text that uses downloaded bitmap fonts. The binary action procedure is
20503 |do_edges_trans|, but we also need a function that just scales a picture.
20504 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20505 should be thought of as procedures that update an edge structure |h|, except
20506 that they have to return a (possibly new) structure because of the need to call
20509 @<Declare binary action...@>=
20510 pointer mp_edges_trans (MP mp, pointer h) {
20511 pointer q; /* the object being transformed */
20512 pointer r,s; /* for list manipulation */
20513 scaled sx,sy; /* saved transformation parameters */
20514 scaled sqdet; /* square root of determinant for |dash_scale| */
20515 integer sgndet; /* sign of the determinant */
20516 scaled v; /* a temporary value */
20517 h=mp_private_edges(mp, h);
20518 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20519 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20520 if ( dash_list(h)!=null_dash ) {
20521 @<Try to transform the dash list of |h|@>;
20523 @<Make the bounding box of |h| unknown if it can't be updated properly
20524 without scanning the whole structure@>;
20525 q=link(dummy_loc(h));
20526 while ( q!=null ) {
20527 @<Transform graphical object |q|@>;
20532 void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20533 mp_set_up_known_trans(mp, c);
20534 value(p)=mp_edges_trans(mp, value(p));
20535 mp_unstash_cur_exp(mp, p);
20537 void mp_scale_edges (MP mp) {
20538 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20539 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20540 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20543 @ @<Try to transform the dash list of |h|@>=
20544 if ( (mp->txy!=0)||(mp->tyx!=0)||
20545 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20546 mp_flush_dash_list(mp, h);
20548 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20549 @<Scale the dash list by |txx| and shift it by |tx|@>;
20550 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20553 @ @<Reverse the dash list of |h|@>=
20556 dash_list(h)=null_dash;
20557 while ( r!=null_dash ) {
20559 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20560 link(s)=dash_list(h);
20565 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20567 while ( r!=null_dash ) {
20568 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20569 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20573 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20574 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20575 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20576 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20577 mp_init_bbox(mp, h);
20580 if ( minx_val(h)<=maxx_val(h) ) {
20581 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20588 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20590 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20591 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20594 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20597 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20599 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20600 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20601 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20602 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20603 if ( mp->txx+mp->txy<0 ) {
20604 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20606 if ( mp->tyx+mp->tyy<0 ) {
20607 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20611 @ Now we ready for the main task of transforming the graphical objects in edge
20614 @<Transform graphical object |q|@>=
20616 case mp_fill_code: case mp_stroked_code:
20617 mp_do_path_trans(mp, path_p(q));
20618 @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20620 case mp_start_clip_code: case mp_start_bounds_code:
20621 mp_do_path_trans(mp, path_p(q));
20625 @<Transform the compact transformation starting at |r|@>;
20627 case mp_stop_clip_code: case mp_stop_bounds_code:
20629 } /* there are no other cases */
20631 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20632 The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
20633 since the \ps\ output procedures will try to compensate for the transformation
20634 we are applying to |pen_p(q)|. Since this compensation is based on the square
20635 root of the determinant, |sqdet| is the appropriate factor.
20637 @<Transform |pen_p(q)|, making sure...@>=
20638 if ( pen_p(q)!=null ) {
20639 sx=mp->tx; sy=mp->ty;
20640 mp->tx=0; mp->ty=0;
20641 mp_do_pen_trans(mp, pen_p(q));
20642 if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
20643 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20644 if ( ! pen_is_elliptical(pen_p(q)) )
20646 pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
20647 /* this unreverses the pen */
20648 mp->tx=sx; mp->ty=sy;
20651 @ This uses the fact that transformations are stored in the order
20652 |(tx,ty,txx,txy,tyx,tyy)|.
20653 @^data structure assumptions@>
20655 @<Transform the compact transformation starting at |r|@>=
20656 mp_trans(mp, r,r+1);
20657 sx=mp->tx; sy=mp->ty;
20658 mp->tx=0; mp->ty=0;
20659 mp_trans(mp, r+2,r+4);
20660 mp_trans(mp, r+3,r+5);
20661 mp->tx=sx; mp->ty=sy
20663 @ The hard cases of transformation occur when big nodes are involved,
20664 and when some of their components are unknown.
20666 @<Declare binary action...@>=
20667 @<Declare subroutines needed by |big_trans|@>;
20668 void mp_big_trans (MP mp,pointer p, quarterword c) {
20669 pointer q,r,pp,qq; /* list manipulation registers */
20670 small_number s; /* size of a big node */
20671 s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
20674 if ( type(r)!=mp_known ) {
20675 @<Transform an unknown big node and |return|@>;
20678 @<Transform a known big node@>;
20679 }; /* node |p| will now be recycled by |do_binary| */
20681 @ @<Transform an unknown big node and |return|@>=
20683 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20684 r=value(mp->cur_exp);
20685 if ( mp->cur_type==mp_transform_type ) {
20686 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20687 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20688 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20689 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20691 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20692 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20696 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20697 and let |q| point to a another value field. The |bilin1| procedure
20698 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20700 @<Declare subroutines needed by |big_trans|@>=
20701 void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20702 scaled u, scaled delta) {
20703 pointer r; /* list traverser */
20704 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20706 if ( type(q)==mp_known ) {
20707 delta+=mp_take_scaled(mp, value(q),u);
20709 @<Ensure that |type(p)=mp_proto_dependent|@>;
20710 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20711 mp_proto_dependent,type(q));
20714 if ( type(p)==mp_known ) {
20718 while ( info(r)!=null ) r=link(r);
20720 if ( r!=dep_list(p) ) value(r)=delta;
20721 else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
20723 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20726 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
20727 if ( type(p)!=mp_proto_dependent ) {
20728 if ( type(p)==mp_known )
20729 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
20731 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
20732 mp_proto_dependent,true);
20733 type(p)=mp_proto_dependent;
20736 @ @<Transform a known big node@>=
20737 mp_set_up_trans(mp, c);
20738 if ( mp->cur_type==mp_known ) {
20739 @<Transform known by known@>;
20741 pp=mp_stash_cur_exp(mp); qq=value(pp);
20742 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20743 if ( mp->cur_type==mp_transform_type ) {
20744 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
20745 value(xy_part_loc(q)),yx_part_loc(qq),null);
20746 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
20747 value(xx_part_loc(q)),yx_part_loc(qq),null);
20748 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
20749 value(yy_part_loc(q)),xy_part_loc(qq),null);
20750 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
20751 value(yx_part_loc(q)),xy_part_loc(qq),null);
20753 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
20754 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
20755 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
20756 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
20757 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
20760 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
20761 at |dep_final|. The following procedure adds |v| times another
20762 numeric quantity to~|p|.
20764 @<Declare subroutines needed by |big_trans|@>=
20765 void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
20766 if ( type(r)==mp_known ) {
20767 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
20769 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
20770 mp_proto_dependent,type(r));
20771 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20775 @ The |bilin2| procedure is something like |bilin1|, but with known
20776 and unknown quantities reversed. Parameter |p| points to a value field
20777 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
20778 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
20779 unless it is |null| (which stands for zero). Location~|p| will be
20780 replaced by $p\cdot t+v\cdot u+q$.
20782 @<Declare subroutines needed by |big_trans|@>=
20783 void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
20784 pointer u, pointer q) {
20785 scaled vv; /* temporary storage for |value(p)| */
20786 vv=value(p); type(p)=mp_proto_dependent;
20787 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
20789 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
20790 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
20791 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
20792 if ( dep_list(p)==mp->dep_final ) {
20793 vv=value(mp->dep_final); mp_recycle_value(mp, p);
20794 type(p)=mp_known; value(p)=vv;
20798 @ @<Transform known by known@>=
20800 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20801 if ( mp->cur_type==mp_transform_type ) {
20802 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
20803 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
20804 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
20805 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
20807 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
20808 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
20811 @ Finally, in |bilin3| everything is |known|.
20813 @<Declare subroutines needed by |big_trans|@>=
20814 void mp_bilin3 (MP mp,pointer p, scaled t,
20815 scaled v, scaled u, scaled delta) {
20817 delta+=mp_take_scaled(mp, value(p),t);
20820 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
20821 else value(p)=delta;
20824 @ @<Additional cases of binary operators@>=
20826 if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
20827 else mp_bad_binary(mp, p,concatenate);
20830 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
20831 mp_chop_string(mp, value(p));
20832 else mp_bad_binary(mp, p,substring_of);
20835 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
20836 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
20837 mp_chop_path(mp, value(p));
20838 else mp_bad_binary(mp, p,subpath_of);
20841 @ @<Declare binary action...@>=
20842 void mp_cat (MP mp,pointer p) {
20843 str_number a,b; /* the strings being concatenated */
20844 pool_pointer k; /* index into |str_pool| */
20845 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
20846 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
20847 append_char(mp->str_pool[k]);
20849 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
20850 append_char(mp->str_pool[k]);
20852 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
20855 @ @<Declare binary action...@>=
20856 void mp_chop_string (MP mp,pointer p) {
20857 integer a, b; /* start and stop points */
20858 integer l; /* length of the original string */
20859 integer k; /* runs from |a| to |b| */
20860 str_number s; /* the original string */
20861 boolean reversed; /* was |a>b|? */
20862 a=mp_round_unscaled(mp, value(x_part_loc(p)));
20863 b=mp_round_unscaled(mp, value(y_part_loc(p)));
20864 if ( a<=b ) reversed=false;
20865 else { reversed=true; k=a; a=b; b=k; };
20866 s=mp->cur_exp; l=length(s);
20877 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
20878 append_char(mp->str_pool[k]);
20881 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
20882 append_char(mp->str_pool[k]);
20885 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
20888 @ @<Declare binary action...@>=
20889 void mp_chop_path (MP mp,pointer p) {
20890 pointer q; /* a knot in the original path */
20891 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
20892 scaled a,b,k,l; /* indices for chopping */
20893 boolean reversed; /* was |a>b|? */
20894 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
20895 if ( a<=b ) reversed=false;
20896 else { reversed=true; k=a; a=b; b=k; };
20897 @<Dispense with the cases |a<0| and/or |b>l|@>;
20899 while ( a>=unity ) {
20900 q=link(q); a=a-unity; b=b-unity;
20903 @<Construct a path from |pp| to |qq| of length zero@>;
20905 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
20907 left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; link(qq)=pp;
20908 mp_toss_knot_list(mp, mp->cur_exp);
20910 mp->cur_exp=link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
20916 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
20918 if ( left_type(mp->cur_exp)==mp_endpoint ) {
20919 a=0; if ( b<0 ) b=0;
20921 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
20925 if ( left_type(mp->cur_exp)==mp_endpoint ) {
20926 b=l; if ( a>l ) a=l;
20934 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
20936 pp=mp_copy_knot(mp, q); qq=pp;
20938 q=link(q); rr=qq; qq=mp_copy_knot(mp, q); link(rr)=qq; b=b-unity;
20941 ss=pp; pp=link(pp);
20942 mp_split_cubic(mp, ss,a*010000); pp=link(ss);
20943 mp_free_node(mp, ss,knot_node_size);
20945 b=mp_make_scaled(mp, b,unity-a); rr=pp;
20949 mp_split_cubic(mp, rr,(b+unity)*010000);
20950 mp_free_node(mp, qq,knot_node_size);
20955 @ @<Construct a path from |pp| to |qq| of length zero@>=
20957 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=link(q); };
20958 pp=mp_copy_knot(mp, q); qq=pp;
20961 @ @<Additional cases of binary operators@>=
20962 case point_of: case precontrol_of: case postcontrol_of:
20963 if ( mp->cur_type==mp_pair_type )
20964 mp_pair_to_path(mp);
20965 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
20966 mp_find_point(mp, value(p),c);
20968 mp_bad_binary(mp, p,c);
20970 case pen_offset_of:
20971 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
20972 mp_set_up_offset(mp, value(p));
20974 mp_bad_binary(mp, p,pen_offset_of);
20976 case direction_time_of:
20977 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
20978 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
20979 mp_set_up_direction_time(mp, value(p));
20981 mp_bad_binary(mp, p,direction_time_of);
20984 @ @<Declare binary action...@>=
20985 void mp_set_up_offset (MP mp,pointer p) {
20986 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
20987 mp_pair_value(mp, mp->cur_x,mp->cur_y);
20989 void mp_set_up_direction_time (MP mp,pointer p) {
20990 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
20991 value(y_part_loc(p)),mp->cur_exp));
20994 @ @<Declare binary action...@>=
20995 void mp_find_point (MP mp,scaled v, quarterword c) {
20996 pointer p; /* the path */
20997 scaled n; /* its length */
20999 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
21000 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
21003 } else if ( v<0 ) {
21004 if ( left_type(p)==mp_endpoint ) v=0;
21005 else v=n-1-((-v-1) % n);
21006 } else if ( v>n ) {
21007 if ( left_type(p)==mp_endpoint ) v=n;
21011 while ( v>=unity ) { p=link(p); v=v-unity; };
21013 @<Insert a fractional node by splitting the cubic@>;
21015 @<Set the current expression to the desired path coordinates@>;
21018 @ @<Insert a fractional node...@>=
21019 { mp_split_cubic(mp, p,v*010000); p=link(p); }
21021 @ @<Set the current expression to the desired path coordinates...@>=
21024 mp_pair_value(mp, x_coord(p),y_coord(p));
21026 case precontrol_of:
21027 if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21028 else mp_pair_value(mp, left_x(p),left_y(p));
21030 case postcontrol_of:
21031 if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21032 else mp_pair_value(mp, right_x(p),right_y(p));
21034 } /* there are no other cases */
21036 @ @<Additional cases of binary operators@>=
21038 if ( mp->cur_type==mp_pair_type )
21039 mp_pair_to_path(mp);
21040 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21041 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21043 mp_bad_binary(mp, p,c);
21046 @ @<Additional cases of bin...@>=
21048 if ( type(p)==mp_pair_type ) {
21049 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21050 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21052 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21053 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
21054 mp_path_intersection(mp, value(p),mp->cur_exp);
21055 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21057 mp_bad_binary(mp, p,intersect);
21061 @ @<Additional cases of bin...@>=
21063 if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
21064 mp_bad_binary(mp, p,in_font);
21065 else { mp_do_infont(mp, p); return; }
21068 @ Function |new_text_node| owns the reference count for its second argument
21069 (the text string) but not its first (the font name).
21071 @<Declare binary action...@>=
21072 void mp_do_infont (MP mp,pointer p) {
21074 q=mp_get_node(mp, edge_header_size);
21075 mp_init_edges(mp, q);
21076 link(obj_tail(q))=mp_new_text_node(mp, str(mp->cur_exp),value(p));
21077 obj_tail(q)=link(obj_tail(q));
21078 mp_free_node(mp, p,value_node_size);
21079 mp_flush_cur_exp(mp, q);
21080 mp->cur_type=mp_picture_type;
21083 @* \[40] Statements and commands.
21084 The chief executive of \MP\ is the |do_statement| routine, which
21085 contains the master switch that causes all the various pieces of \MP\
21086 to do their things, in the right order.
21088 In a sense, this is the grand climax of the program: It applies all the
21089 tools that we have worked so hard to construct. In another sense, this is
21090 the messiest part of the program: It necessarily refers to other pieces
21091 of code all over the place, so that a person can't fully understand what is
21092 going on without paging back and forth to be reminded of conventions that
21093 are defined elsewhere. We are now at the hub of the web.
21095 The structure of |do_statement| itself is quite simple. The first token
21096 of the statement is fetched using |get_x_next|. If it can be the first
21097 token of an expression, we look for an equation, an assignment, or a
21098 title. Otherwise we use a \&{case} construction to branch at high speed to
21099 the appropriate routine for various and sundry other types of commands,
21100 each of which has an ``action procedure'' that does the necessary work.
21102 The program uses the fact that
21103 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21104 to interpret a statement that starts with, e.g., `\&{string}',
21105 as a type declaration rather than a boolean expression.
21107 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21108 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21109 if ( mp->cur_cmd>max_primary_command ) {
21110 @<Worry about bad statement@>;
21111 } else if ( mp->cur_cmd>max_statement_command ) {
21112 @<Do an equation, assignment, title, or
21113 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21115 @<Do a statement that doesn't begin with an expression@>;
21117 if ( mp->cur_cmd<semicolon )
21118 @<Flush unparsable junk that was found after the statement@>;
21122 @ @<Declarations@>=
21123 @<Declare action procedures for use by |do_statement|@>;
21125 @ The only command codes |>max_primary_command| that can be present
21126 at the beginning of a statement are |semicolon| and higher; these
21127 occur when the statement is null.
21129 @<Worry about bad statement@>=
21131 if ( mp->cur_cmd<semicolon ) {
21132 print_err("A statement can't begin with `");
21133 @.A statement can't begin with x@>
21134 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, '\'');
21135 help5("I was looking for the beginning of a new statement.")
21136 ("If you just proceed without changing anything, I'll ignore")
21137 ("everything up to the next `;'. Please insert a semicolon")
21138 ("now in front of anything that you don't want me to delete.")
21139 ("(See Chapter 27 of The METAFONTbook for an example.)");
21140 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21141 mp_back_error(mp); mp_get_x_next(mp);
21145 @ The help message printed here says that everything is flushed up to
21146 a semicolon, but actually the commands |end_group| and |stop| will
21147 also terminate a statement.
21149 @<Flush unparsable junk that was found after the statement@>=
21151 print_err("Extra tokens will be flushed");
21152 @.Extra tokens will be flushed@>
21153 help6("I've just read as much of that statement as I could fathom,")
21154 ("so a semicolon should have been next. It's very puzzling...")
21155 ("but I'll try to get myself back together, by ignoring")
21156 ("everything up to the next `;'. Please insert a semicolon")
21157 ("now in front of anything that you don't want me to delete.")
21158 ("(See Chapter 27 of The METAFONTbook for an example.)");
21159 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21160 mp_back_error(mp); mp->scanner_status=flushing;
21163 @<Decrease the string reference count...@>;
21164 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21165 mp->scanner_status=normal;
21168 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21169 |cur_type=mp_vacuous| unless the statement was simply an expression;
21170 in the latter case, |cur_type| and |cur_exp| should represent that
21173 @<Do a statement that doesn't...@>=
21175 if ( mp->internal[mp_tracing_commands]>0 )
21177 switch (mp->cur_cmd ) {
21178 case type_name:mp_do_type_declaration(mp); break;
21180 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21181 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21183 @<Cases of |do_statement| that invoke particular commands@>;
21184 } /* there are no other cases */
21185 mp->cur_type=mp_vacuous;
21188 @ The most important statements begin with expressions.
21190 @<Do an equation, assignment, title, or...@>=
21192 mp->var_flag=assignment; mp_scan_expression(mp);
21193 if ( mp->cur_cmd<end_group ) {
21194 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21195 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21196 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21197 else if ( mp->cur_type!=mp_vacuous ){
21198 exp_err("Isolated expression");
21199 @.Isolated expression@>
21200 help3("I couldn't find an `=' or `:=' after the")
21201 ("expression that is shown above this error message,")
21202 ("so I guess I'll just ignore it and carry on.");
21203 mp_put_get_error(mp);
21205 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21211 if ( mp->internal[mp_tracing_titles]>0 ) {
21212 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21216 @ Equations and assignments are performed by the pair of mutually recursive
21218 routines |do_equation| and |do_assignment|. These routines are called when
21219 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21220 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21221 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21222 will be equal to the right-hand side (which will normally be equal
21223 to the left-hand side).
21225 @<Declare action procedures for use by |do_statement|@>=
21226 @<Declare the procedure called |try_eq|@>;
21227 @<Declare the procedure called |make_eq|@>;
21228 void mp_do_equation (MP mp) ;
21231 void mp_do_equation (MP mp) {
21232 pointer lhs; /* capsule for the left-hand side */
21233 pointer p; /* temporary register */
21234 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21235 mp->var_flag=assignment; mp_scan_expression(mp);
21236 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21237 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21238 if ( mp->internal[mp_tracing_commands]>two )
21239 @<Trace the current equation@>;
21240 if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
21241 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21242 }; /* in this case |make_eq| will change the pair to a path */
21243 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21246 @ And |do_assignment| is similar to |do_expression|:
21249 void mp_do_assignment (MP mp);
21251 @ @<Declare action procedures for use by |do_statement|@>=
21252 void mp_do_assignment (MP mp) ;
21255 void mp_do_assignment (MP mp) {
21256 pointer lhs; /* token list for the left-hand side */
21257 pointer p; /* where the left-hand value is stored */
21258 pointer q; /* temporary capsule for the right-hand value */
21259 if ( mp->cur_type!=mp_token_list ) {
21260 exp_err("Improper `:=' will be changed to `='");
21262 help2("I didn't find a variable name at the left of the `:=',")
21263 ("so I'm going to pretend that you said `=' instead.");
21264 mp_error(mp); mp_do_equation(mp);
21266 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21267 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21268 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21269 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21270 if ( mp->internal[mp_tracing_commands]>two )
21271 @<Trace the current assignment@>;
21272 if ( info(lhs)>hash_end ) {
21273 @<Assign the current expression to an internal variable@>;
21275 @<Assign the current expression to the variable |lhs|@>;
21277 mp_flush_node_list(mp, lhs);
21281 @ @<Trace the current equation@>=
21283 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21284 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21285 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21288 @ @<Trace the current assignment@>=
21290 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21291 if ( info(lhs)>hash_end )
21292 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21294 mp_show_token_list(mp, lhs,null,1000,0);
21295 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21296 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
21299 @ @<Assign the current expression to an internal variable@>=
21300 if ( mp->cur_type==mp_known ) {
21301 mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
21303 exp_err("Internal quantity `");
21304 @.Internal quantity...@>
21305 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21306 mp_print(mp, "' must receive a known value");
21307 help2("I can\'t set an internal quantity to anything but a known")
21308 ("numeric value, so I'll have to ignore this assignment.");
21309 mp_put_get_error(mp);
21312 @ @<Assign the current expression to the variable |lhs|@>=
21314 p=mp_find_variable(mp, lhs);
21316 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21317 mp_recycle_value(mp, p);
21318 type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21319 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21321 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21326 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21327 a pointer to a capsule that is to be equated to the current expression.
21329 @<Declare the procedure called |make_eq|@>=
21330 void mp_make_eq (MP mp,pointer lhs) ;
21334 @c void mp_make_eq (MP mp,pointer lhs) {
21335 small_number t; /* type of the left-hand side */
21336 pointer p,q; /* pointers inside of big nodes */
21337 integer v=0; /* value of the left-hand side */
21340 if ( t<=mp_pair_type ) v=value(lhs);
21342 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21343 is incompatible with~|t|@>;
21344 } /* all cases have been listed */
21345 @<Announce that the equation cannot be performed@>;
21347 check_arith; mp_recycle_value(mp, lhs);
21348 mp_free_node(mp, lhs,value_node_size);
21351 @ @<Announce that the equation cannot be performed@>=
21352 mp_disp_err(mp, lhs,"");
21353 exp_err("Equation cannot be performed (");
21354 @.Equation cannot be performed@>
21355 if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
21356 else mp_print(mp, "numeric");
21357 mp_print_char(mp, '=');
21358 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21359 else mp_print(mp, "numeric");
21360 mp_print_char(mp, ')');
21361 help2("I'm sorry, but I don't know how to make such things equal.")
21362 ("(See the two expressions just above the error message.)");
21363 mp_put_get_error(mp)
21365 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21366 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21367 case mp_path_type: case mp_picture_type:
21368 if ( mp->cur_type==t+unknown_tag ) {
21369 mp_nonlinear_eq(mp, v,mp->cur_exp,false); goto DONE;
21370 } else if ( mp->cur_type==t ) {
21371 @<Report redundant or inconsistent equation and |goto done|@>;
21374 case unknown_types:
21375 if ( mp->cur_type==t-unknown_tag ) {
21376 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21377 } else if ( mp->cur_type==t ) {
21378 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21379 } else if ( mp->cur_type==mp_pair_type ) {
21380 if ( t==mp_unknown_path ) {
21381 mp_pair_to_path(mp); goto RESTART;
21385 case mp_transform_type: case mp_color_type:
21386 case mp_cmykcolor_type: case mp_pair_type:
21387 if ( mp->cur_type==t ) {
21388 @<Do multiple equations and |goto done|@>;
21391 case mp_known: case mp_dependent:
21392 case mp_proto_dependent: case mp_independent:
21393 if ( mp->cur_type>=mp_known ) {
21394 mp_try_eq(mp, lhs,null); goto DONE;
21400 @ @<Report redundant or inconsistent equation and |goto done|@>=
21402 if ( mp->cur_type<=mp_string_type ) {
21403 if ( mp->cur_type==mp_string_type ) {
21404 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21407 } else if ( v!=mp->cur_exp ) {
21410 @<Exclaim about a redundant equation@>; goto DONE;
21412 print_err("Redundant or inconsistent equation");
21413 @.Redundant or inconsistent equation@>
21414 help2("An equation between already-known quantities can't help.")
21415 ("But don't worry; continue and I'll just ignore it.");
21416 mp_put_get_error(mp); goto DONE;
21418 print_err("Inconsistent equation");
21419 @.Inconsistent equation@>
21420 help2("The equation I just read contradicts what was said before.")
21421 ("But don't worry; continue and I'll just ignore it.");
21422 mp_put_get_error(mp); goto DONE;
21425 @ @<Do multiple equations and |goto done|@>=
21427 p=v+mp->big_node_size[t];
21428 q=value(mp->cur_exp)+mp->big_node_size[t];
21430 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21435 @ The first argument to |try_eq| is the location of a value node
21436 in a capsule that will soon be recycled. The second argument is
21437 either a location within a pair or transform node pointed to by
21438 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21439 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21440 but to equate the two operands.
21442 @<Declare the procedure called |try_eq|@>=
21443 void mp_try_eq (MP mp,pointer l, pointer r) ;
21446 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21447 pointer p; /* dependency list for right operand minus left operand */
21448 int t; /* the type of list |p| */
21449 pointer q; /* the constant term of |p| is here */
21450 pointer pp; /* dependency list for right operand */
21451 int tt; /* the type of list |pp| */
21452 boolean copied; /* have we copied a list that ought to be recycled? */
21453 @<Remove the left operand from its container, negate it, and
21454 put it into dependency list~|p| with constant term~|q|@>;
21455 @<Add the right operand to list |p|@>;
21456 if ( info(p)==null ) {
21457 @<Deal with redundant or inconsistent equation@>;
21459 mp_linear_eq(mp, p,t);
21460 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21461 if ( type(mp->cur_exp)==mp_known ) {
21462 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21463 mp_free_node(mp, pp,value_node_size);
21469 @ @<Remove the left operand from its container, negate it, and...@>=
21471 if ( t==mp_known ) {
21472 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21473 } else if ( t==mp_independent ) {
21474 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21477 p=dep_list(l); q=p;
21480 if ( info(q)==null ) break;
21483 link(prev_dep(l))=link(q); prev_dep(link(q))=prev_dep(l);
21487 @ @<Deal with redundant or inconsistent equation@>=
21489 if ( abs(value(p))>64 ) { /* off by .001 or more */
21490 print_err("Inconsistent equation");
21491 @.Inconsistent equation@>
21492 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21493 mp_print_char(mp, ')');
21494 help2("The equation I just read contradicts what was said before.")
21495 ("But don't worry; continue and I'll just ignore it.");
21496 mp_put_get_error(mp);
21497 } else if ( r==null ) {
21498 @<Exclaim about a redundant equation@>;
21500 mp_free_node(mp, p,dep_node_size);
21503 @ @<Add the right operand to list |p|@>=
21505 if ( mp->cur_type==mp_known ) {
21506 value(q)=value(q)+mp->cur_exp; goto DONE1;
21509 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21510 else pp=dep_list(mp->cur_exp);
21513 if ( type(r)==mp_known ) {
21514 value(q)=value(q)+value(r); goto DONE1;
21517 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21518 else pp=dep_list(r);
21521 if ( tt!=mp_independent ) copied=false;
21522 else { copied=true; tt=mp_dependent; };
21523 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21524 if ( copied ) mp_flush_node_list(mp, pp);
21527 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21528 mp->watch_coefs=false;
21530 p=mp_p_plus_q(mp, p,pp,t);
21531 } else if ( t==mp_proto_dependent ) {
21532 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21535 while ( info(q)!=null ) {
21536 value(q)=mp_round_fraction(mp, value(q)); q=link(q);
21538 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21540 mp->watch_coefs=true;
21542 @ Our next goal is to process type declarations. For this purpose it's
21543 convenient to have a procedure that scans a $\langle\,$declared
21544 variable$\,\rangle$ and returns the corresponding token list. After the
21545 following procedure has acted, the token after the declared variable
21546 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21549 @<Declare the function called |scan_declared_variable|@>=
21550 pointer mp_scan_declared_variable (MP mp) {
21551 pointer x; /* hash address of the variable's root */
21552 pointer h,t; /* head and tail of the token list to be returned */
21553 pointer l; /* hash address of left bracket */
21554 mp_get_symbol(mp); x=mp->cur_sym;
21555 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21556 h=mp_get_avail(mp); info(h)=x; t=h;
21559 if ( mp->cur_sym==0 ) break;
21560 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21561 if ( mp->cur_cmd==left_bracket ) {
21562 @<Descend past a collective subscript@>;
21567 link(t)=mp_get_avail(mp); t=link(t); info(t)=mp->cur_sym;
21569 if ( eq_type(x)!=tag_token ) mp_clear_symbol(mp, x,false);
21570 if ( equiv(x)==null ) mp_new_root(mp, x);
21574 @ If the subscript isn't collective, we don't accept it as part of the
21577 @<Descend past a collective subscript@>=
21579 l=mp->cur_sym; mp_get_x_next(mp);
21580 if ( mp->cur_cmd!=right_bracket ) {
21581 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21583 mp->cur_sym=collective_subscript;
21587 @ Type declarations are introduced by the following primitive operations.
21590 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21591 @:numeric_}{\&{numeric} primitive@>
21592 mp_primitive(mp, "string",type_name,mp_string_type);
21593 @:string_}{\&{string} primitive@>
21594 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21595 @:boolean_}{\&{boolean} primitive@>
21596 mp_primitive(mp, "path",type_name,mp_path_type);
21597 @:path_}{\&{path} primitive@>
21598 mp_primitive(mp, "pen",type_name,mp_pen_type);
21599 @:pen_}{\&{pen} primitive@>
21600 mp_primitive(mp, "picture",type_name,mp_picture_type);
21601 @:picture_}{\&{picture} primitive@>
21602 mp_primitive(mp, "transform",type_name,mp_transform_type);
21603 @:transform_}{\&{transform} primitive@>
21604 mp_primitive(mp, "color",type_name,mp_color_type);
21605 @:color_}{\&{color} primitive@>
21606 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21607 @:color_}{\&{rgbcolor} primitive@>
21608 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21609 @:color_}{\&{cmykcolor} primitive@>
21610 mp_primitive(mp, "pair",type_name,mp_pair_type);
21611 @:pair_}{\&{pair} primitive@>
21613 @ @<Cases of |print_cmd...@>=
21614 case type_name: mp_print_type(mp, m); break;
21616 @ Now we are ready to handle type declarations, assuming that a
21617 |type_name| has just been scanned.
21619 @<Declare action procedures for use by |do_statement|@>=
21620 void mp_do_type_declaration (MP mp) ;
21623 void mp_do_type_declaration (MP mp) {
21624 small_number t; /* the type being declared */
21625 pointer p; /* token list for a declared variable */
21626 pointer q; /* value node for the variable */
21627 if ( mp->cur_mod>=mp_transform_type )
21630 t=mp->cur_mod+unknown_tag;
21632 p=mp_scan_declared_variable(mp);
21633 mp_flush_variable(mp, equiv(info(p)),link(p),false);
21634 q=mp_find_variable(mp, p);
21636 type(q)=t; value(q)=null;
21638 print_err("Declared variable conflicts with previous vardef");
21639 @.Declared variable conflicts...@>
21640 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")
21641 ("Proceed, and I'll ignore the illegal redeclaration.");
21642 mp_put_get_error(mp);
21644 mp_flush_list(mp, p);
21645 if ( mp->cur_cmd<comma ) {
21646 @<Flush spurious symbols after the declared variable@>;
21648 } while (! end_of_statement);
21651 @ @<Flush spurious symbols after the declared variable@>=
21653 print_err("Illegal suffix of declared variable will be flushed");
21654 @.Illegal suffix...flushed@>
21655 help5("Variables in declarations must consist entirely of")
21656 ("names and collective subscripts, e.g., `x[]a'.")
21657 ("Are you trying to use a reserved word in a variable name?")
21658 ("I'm going to discard the junk I found here,")
21659 ("up to the next comma or the end of the declaration.");
21660 if ( mp->cur_cmd==numeric_token )
21661 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21662 mp_put_get_error(mp); mp->scanner_status=flushing;
21665 @<Decrease the string reference count...@>;
21666 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21667 mp->scanner_status=normal;
21670 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21671 until coming to the end of the user's program.
21672 Each execution of |do_statement| concludes with
21673 |cur_cmd=semicolon|, |end_group|, or |stop|.
21675 @c void mp_main_control (MP mp) {
21677 mp_do_statement(mp);
21678 if ( mp->cur_cmd==end_group ) {
21679 print_err("Extra `endgroup'");
21680 @.Extra `endgroup'@>
21681 help2("I'm not currently working on a `begingroup',")
21682 ("so I had better not try to end anything.");
21683 mp_flush_error(mp, 0);
21685 } while (mp->cur_cmd!=stop);
21687 int mp_run (MP mp) {
21688 @<Install and test the non-local jump buffer@>;
21689 mp_main_control(mp); /* come to life */
21690 mp_final_cleanup(mp); /* prepare for death */
21691 mp_close_files_and_terminate(mp);
21692 return mp->history;
21694 char * mp_mplib_version (MP mp) {
21696 return mplib_version;
21698 char * mp_metapost_version (MP mp) {
21700 return metapost_version;
21703 @ @<Exported function headers@>=
21704 int mp_run (MP mp);
21705 char * mp_mplib_version (MP mp);
21706 char * mp_metapost_version (MP mp);
21709 mp_primitive(mp, "end",stop,0);
21710 @:end_}{\&{end} primitive@>
21711 mp_primitive(mp, "dump",stop,1);
21712 @:dump_}{\&{dump} primitive@>
21714 @ @<Cases of |print_cmd...@>=
21716 if ( m==0 ) mp_print(mp, "end");
21717 else mp_print(mp, "dump");
21721 Let's turn now to statements that are classified as ``commands'' because
21722 of their imperative nature. We'll begin with simple ones, so that it
21723 will be clear how to hook command processing into the |do_statement| routine;
21724 then we'll tackle the tougher commands.
21726 Here's one of the simplest:
21728 @<Cases of |do_statement|...@>=
21729 case random_seed: mp_do_random_seed(mp); break;
21731 @ @<Declare action procedures for use by |do_statement|@>=
21732 void mp_do_random_seed (MP mp) ;
21734 @ @c void mp_do_random_seed (MP mp) {
21736 if ( mp->cur_cmd!=assignment ) {
21737 mp_missing_err(mp, ":=");
21739 help1("Always say `randomseed:=<numeric expression>'.");
21742 mp_get_x_next(mp); mp_scan_expression(mp);
21743 if ( mp->cur_type!=mp_known ) {
21744 exp_err("Unknown value will be ignored");
21745 @.Unknown value...ignored@>
21746 help2("Your expression was too random for me to handle,")
21747 ("so I won't change the random seed just now.");
21748 mp_put_get_flush_error(mp, 0);
21750 @<Initialize the random seed to |cur_exp|@>;
21754 @ @<Initialize the random seed to |cur_exp|@>=
21756 mp_init_randoms(mp, mp->cur_exp);
21757 if ( mp->selector>=log_only && mp->selector<write_file) {
21758 mp->old_setting=mp->selector; mp->selector=log_only;
21759 mp_print_nl(mp, "{randomseed:=");
21760 mp_print_scaled(mp, mp->cur_exp);
21761 mp_print_char(mp, '}');
21762 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
21766 @ And here's another simple one (somewhat different in flavor):
21768 @<Cases of |do_statement|...@>=
21770 mp_print_ln(mp); mp->interaction=mp->cur_mod;
21771 @<Initialize the print |selector| based on |interaction|@>;
21772 if ( mp->log_opened ) mp->selector=mp->selector+2;
21777 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
21778 @:mp_batch_mode_}{\&{batchmode} primitive@>
21779 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
21780 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
21781 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
21782 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
21783 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
21784 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
21786 @ @<Cases of |print_cmd_mod|...@>=
21789 case mp_batch_mode: mp_print(mp, "batchmode"); break;
21790 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
21791 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
21792 default: mp_print(mp, "errorstopmode"); break;
21796 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
21798 @<Cases of |do_statement|...@>=
21799 case protection_command: mp_do_protection(mp); break;
21802 mp_primitive(mp, "inner",protection_command,0);
21803 @:inner_}{\&{inner} primitive@>
21804 mp_primitive(mp, "outer",protection_command,1);
21805 @:outer_}{\&{outer} primitive@>
21807 @ @<Cases of |print_cmd...@>=
21808 case protection_command:
21809 if ( m==0 ) mp_print(mp, "inner");
21810 else mp_print(mp, "outer");
21813 @ @<Declare action procedures for use by |do_statement|@>=
21814 void mp_do_protection (MP mp) ;
21816 @ @c void mp_do_protection (MP mp) {
21817 int m; /* 0 to unprotect, 1 to protect */
21818 halfword t; /* the |eq_type| before we change it */
21821 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
21823 if ( t>=outer_tag )
21824 eq_type(mp->cur_sym)=t-outer_tag;
21825 } else if ( t<outer_tag ) {
21826 eq_type(mp->cur_sym)=t+outer_tag;
21829 } while (mp->cur_cmd==comma);
21832 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
21833 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
21834 declaration assigns the command code |left_delimiter| to `\.{(}' and
21835 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
21836 hash address of its mate.
21838 @<Cases of |do_statement|...@>=
21839 case delimiters: mp_def_delims(mp); break;
21841 @ @<Declare action procedures for use by |do_statement|@>=
21842 void mp_def_delims (MP mp) ;
21844 @ @c void mp_def_delims (MP mp) {
21845 pointer l_delim,r_delim; /* the new delimiter pair */
21846 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
21847 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
21848 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
21849 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
21853 @ Here is a procedure that is called when \MP\ has reached a point
21854 where some right delimiter is mandatory.
21856 @<Declare the procedure called |check_delimiter|@>=
21857 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
21858 if ( mp->cur_cmd==right_delimiter )
21859 if ( mp->cur_mod==l_delim )
21861 if ( mp->cur_sym!=r_delim ) {
21862 mp_missing_err(mp, str(text(r_delim)));
21864 help2("I found no right delimiter to match a left one. So I've")
21865 ("put one in, behind the scenes; this may fix the problem.");
21868 print_err("The token `"); mp_print_text(r_delim);
21869 @.The token...delimiter@>
21870 mp_print(mp, "' is no longer a right delimiter");
21871 help3("Strange: This token has lost its former meaning!")
21872 ("I'll read it as a right delimiter this time;")
21873 ("but watch out, I'll probably miss it later.");
21878 @ The next four commands save or change the values associated with tokens.
21880 @<Cases of |do_statement|...@>=
21883 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
21884 } while (mp->cur_cmd==comma);
21886 case interim_command: mp_do_interim(mp); break;
21887 case let_command: mp_do_let(mp); break;
21888 case new_internal: mp_do_new_internal(mp); break;
21890 @ @<Declare action procedures for use by |do_statement|@>=
21891 void mp_do_statement (MP mp);
21892 void mp_do_interim (MP mp);
21894 @ @c void mp_do_interim (MP mp) {
21896 if ( mp->cur_cmd!=internal_quantity ) {
21897 print_err("The token `");
21898 @.The token...quantity@>
21899 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
21900 else mp_print_text(mp->cur_sym);
21901 mp_print(mp, "' isn't an internal quantity");
21902 help1("Something like `tracingonline' should follow `interim'.");
21905 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
21907 mp_do_statement(mp);
21910 @ The following procedure is careful not to undefine the left-hand symbol
21911 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
21913 @<Declare action procedures for use by |do_statement|@>=
21914 void mp_do_let (MP mp) ;
21916 @ @c void mp_do_let (MP mp) {
21917 pointer l; /* hash location of the left-hand symbol */
21918 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
21919 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
21920 mp_missing_err(mp, "=");
21922 help3("You should have said `let symbol = something'.")
21923 ("But don't worry; I'll pretend that an equals sign")
21924 ("was present. The next token I read will be `something'.");
21928 switch (mp->cur_cmd) {
21929 case defined_macro: case secondary_primary_macro:
21930 case tertiary_secondary_macro: case expression_tertiary_macro:
21931 add_mac_ref(mp->cur_mod);
21936 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
21937 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
21938 else equiv(l)=mp->cur_mod;
21942 @ @<Declarations@>=
21943 void mp_grow_internals (MP mp, int l);
21944 void mp_do_new_internal (MP mp) ;
21947 void mp_grow_internals (MP mp, int l) {
21951 if ( hash_end+l>max_halfword ) {
21952 mp_confusion(mp, "out of memory space"); /* can't be reached */
21954 int_name = xmalloc ((l+1),sizeof(char *));
21955 internal = xmalloc ((l+1),sizeof(scaled));
21956 for (k=0;k<=l; k++ ) {
21957 if (k<=mp->max_internal) {
21958 internal[k]=mp->internal[k];
21959 int_name[k]=mp->int_name[k];
21965 xfree(mp->internal); xfree(mp->int_name);
21966 mp->int_name = int_name;
21967 mp->internal = internal;
21968 mp->max_internal = l;
21972 void mp_do_new_internal (MP mp) {
21974 if ( mp->int_ptr==mp->max_internal ) {
21975 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal>>2)));
21977 mp_get_clear_symbol(mp); incr(mp->int_ptr);
21978 eq_type(mp->cur_sym)=internal_quantity;
21979 equiv(mp->cur_sym)=mp->int_ptr;
21980 if(mp->int_name[mp->int_ptr]!=NULL)
21981 xfree(mp->int_name[mp->int_ptr]);
21982 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
21983 mp->internal[mp->int_ptr]=0;
21985 } while (mp->cur_cmd==comma);
21988 @ @<Dealloc variables@>=
21989 for (k=0;k<=mp->max_internal;k++) {
21990 xfree(mp->int_name[k]);
21992 xfree(mp->internal);
21993 xfree(mp->int_name);
21996 @ The various `\&{show}' commands are distinguished by modifier fields
21999 @d show_token_code 0 /* show the meaning of a single token */
22000 @d show_stats_code 1 /* show current memory and string usage */
22001 @d show_code 2 /* show a list of expressions */
22002 @d show_var_code 3 /* show a variable and its descendents */
22003 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22006 mp_primitive(mp, "showtoken",show_command,show_token_code);
22007 @:show_token_}{\&{showtoken} primitive@>
22008 mp_primitive(mp, "showstats",show_command,show_stats_code);
22009 @:show_stats_}{\&{showstats} primitive@>
22010 mp_primitive(mp, "show",show_command,show_code);
22011 @:show_}{\&{show} primitive@>
22012 mp_primitive(mp, "showvariable",show_command,show_var_code);
22013 @:show_var_}{\&{showvariable} primitive@>
22014 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22015 @:show_dependencies_}{\&{showdependencies} primitive@>
22017 @ @<Cases of |print_cmd...@>=
22020 case show_token_code:mp_print(mp, "showtoken"); break;
22021 case show_stats_code:mp_print(mp, "showstats"); break;
22022 case show_code:mp_print(mp, "show"); break;
22023 case show_var_code:mp_print(mp, "showvariable"); break;
22024 default: mp_print(mp, "showdependencies"); break;
22028 @ @<Cases of |do_statement|...@>=
22029 case show_command:mp_do_show_whatever(mp); break;
22031 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22032 if it's |show_code|, complicated structures are abbreviated, otherwise
22035 @<Declare action procedures for use by |do_statement|@>=
22036 void mp_do_show (MP mp) ;
22038 @ @c void mp_do_show (MP mp) {
22040 mp_get_x_next(mp); mp_scan_expression(mp);
22041 mp_print_nl(mp, ">> ");
22043 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22044 } while (mp->cur_cmd==comma);
22047 @ @<Declare action procedures for use by |do_statement|@>=
22048 void mp_disp_token (MP mp) ;
22050 @ @c void mp_disp_token (MP mp) {
22051 mp_print_nl(mp, "> ");
22053 if ( mp->cur_sym==0 ) {
22054 @<Show a numeric or string or capsule token@>;
22056 mp_print_text(mp->cur_sym); mp_print_char(mp, '=');
22057 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22058 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22059 if ( mp->cur_cmd==defined_macro ) {
22060 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22061 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22066 @ @<Show a numeric or string or capsule token@>=
22068 if ( mp->cur_cmd==numeric_token ) {
22069 mp_print_scaled(mp, mp->cur_mod);
22070 } else if ( mp->cur_cmd==capsule_token ) {
22071 mp->g_pointer=mp->cur_mod; mp_print_capsule(mp);
22073 mp_print_char(mp, '"');
22074 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, '"');
22075 delete_str_ref(mp->cur_mod);
22079 @ The following cases of |print_cmd_mod| might arise in connection
22080 with |disp_token|, although they don't correspond to any
22083 @<Cases of |print_cmd_...@>=
22084 case left_delimiter:
22085 case right_delimiter:
22086 if ( c==left_delimiter ) mp_print(mp, "left");
22087 else mp_print(mp, "right");
22088 mp_print(mp, " delimiter that matches ");
22092 if ( m==null ) mp_print(mp, "tag");
22093 else mp_print(mp, "variable");
22095 case defined_macro:
22096 mp_print(mp, "macro:");
22098 case secondary_primary_macro:
22099 case tertiary_secondary_macro:
22100 case expression_tertiary_macro:
22101 mp_print_cmd_mod(mp, macro_def,c);
22102 mp_print(mp, "'d macro:");
22103 mp_print_ln(mp); mp_show_token_list(mp, link(link(m)),null,1000,0);
22106 mp_print(mp, "[repeat the loop]");
22108 case internal_quantity:
22109 mp_print(mp, mp->int_name[m]);
22112 @ @<Declare action procedures for use by |do_statement|@>=
22113 void mp_do_show_token (MP mp) ;
22115 @ @c void mp_do_show_token (MP mp) {
22117 get_t_next; mp_disp_token(mp);
22119 } while (mp->cur_cmd==comma);
22122 @ @<Declare action procedures for use by |do_statement|@>=
22123 void mp_do_show_stats (MP mp) ;
22125 @ @c void mp_do_show_stats (MP mp) {
22126 mp_print_nl(mp, "Memory usage ");
22127 @.Memory usage...@>
22128 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used);
22130 mp_print(mp, "unknown");
22131 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22132 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22133 mp_print_nl(mp, "String usage ");
22134 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22135 mp_print_char(mp, '&'); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22137 mp_print(mp, "unknown");
22138 mp_print(mp, " (");
22139 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, '&');
22140 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22141 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22145 @ Here's a recursive procedure that gives an abbreviated account
22146 of a variable, for use by |do_show_var|.
22148 @<Declare action procedures for use by |do_statement|@>=
22149 void mp_disp_var (MP mp,pointer p) ;
22151 @ @c void mp_disp_var (MP mp,pointer p) {
22152 pointer q; /* traverses attributes and subscripts */
22153 int n; /* amount of macro text to show */
22154 if ( type(p)==mp_structured ) {
22155 @<Descend the structure@>;
22156 } else if ( type(p)>=mp_unsuffixed_macro ) {
22157 @<Display a variable macro@>;
22158 } else if ( type(p)!=undefined ){
22159 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22160 mp_print_char(mp, '=');
22161 mp_print_exp(mp, p,0);
22165 @ @<Descend the structure@>=
22168 do { mp_disp_var(mp, q); q=link(q); } while (q!=end_attr);
22170 while ( name_type(q)==mp_subscr ) {
22171 mp_disp_var(mp, q); q=link(q);
22175 @ @<Display a variable macro@>=
22177 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22178 if ( type(p)>mp_unsuffixed_macro )
22179 mp_print(mp, "@@#"); /* |suffixed_macro| */
22180 mp_print(mp, "=macro:");
22181 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22182 else n=mp->max_print_line-mp->file_offset-15;
22183 mp_show_macro(mp, value(p),null,n);
22186 @ @<Declare action procedures for use by |do_statement|@>=
22187 void mp_do_show_var (MP mp) ;
22189 @ @c void mp_do_show_var (MP mp) {
22192 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22193 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22194 mp_disp_var(mp, mp->cur_mod); goto DONE;
22199 } while (mp->cur_cmd==comma);
22202 @ @<Declare action procedures for use by |do_statement|@>=
22203 void mp_do_show_dependencies (MP mp) ;
22205 @ @c void mp_do_show_dependencies (MP mp) {
22206 pointer p; /* link that runs through all dependencies */
22208 while ( p!=dep_head ) {
22209 if ( mp_interesting(mp, p) ) {
22210 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22211 if ( type(p)==mp_dependent ) mp_print_char(mp, '=');
22212 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22213 mp_print_dependency(mp, dep_list(p),type(p));
22216 while ( info(p)!=null ) p=link(p);
22222 @ Finally we are ready for the procedure that governs all of the
22225 @<Declare action procedures for use by |do_statement|@>=
22226 void mp_do_show_whatever (MP mp) ;
22228 @ @c void mp_do_show_whatever (MP mp) {
22229 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
22230 switch (mp->cur_mod) {
22231 case show_token_code:mp_do_show_token(mp); break;
22232 case show_stats_code:mp_do_show_stats(mp); break;
22233 case show_code:mp_do_show(mp); break;
22234 case show_var_code:mp_do_show_var(mp); break;
22235 case show_dependencies_code:mp_do_show_dependencies(mp); break;
22236 } /* there are no other cases */
22237 if ( mp->internal[mp_showstopping]>0 ){
22240 if ( mp->interaction<mp_error_stop_mode ) {
22241 help0; decr(mp->error_count);
22243 help1("This isn't an error message; I'm just showing something.");
22245 if ( mp->cur_cmd==semicolon ) mp_error(mp);
22246 else mp_put_get_error(mp);
22250 @ The `\&{addto}' command needs the following additional primitives:
22252 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
22253 @d contour_code 1 /* command modifier for `\&{contour}' */
22254 @d also_code 2 /* command modifier for `\&{also}' */
22256 @ Pre and postscripts need two new identifiers:
22258 @d with_pre_script 11
22259 @d with_post_script 13
22262 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
22263 @:double_path_}{\&{doublepath} primitive@>
22264 mp_primitive(mp, "contour",thing_to_add,contour_code);
22265 @:contour_}{\&{contour} primitive@>
22266 mp_primitive(mp, "also",thing_to_add,also_code);
22267 @:also_}{\&{also} primitive@>
22268 mp_primitive(mp, "withpen",with_option,mp_pen_type);
22269 @:with_pen_}{\&{withpen} primitive@>
22270 mp_primitive(mp, "dashed",with_option,mp_picture_type);
22271 @:dashed_}{\&{dashed} primitive@>
22272 mp_primitive(mp, "withprescript",with_option,with_pre_script);
22273 @:with_pre_script_}{\&{withprescript} primitive@>
22274 mp_primitive(mp, "withpostscript",with_option,with_post_script);
22275 @:with_post_script_}{\&{withpostscript} primitive@>
22276 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
22277 @:with_color_}{\&{withoutcolor} primitive@>
22278 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
22279 @:with_color_}{\&{withgreyscale} primitive@>
22280 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
22281 @:with_color_}{\&{withcolor} primitive@>
22282 /* \&{withrgbcolor} is an alias for \&{withcolor} */
22283 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
22284 @:with_color_}{\&{withrgbcolor} primitive@>
22285 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
22286 @:with_color_}{\&{withcmykcolor} primitive@>
22288 @ @<Cases of |print_cmd...@>=
22290 if ( m==contour_code ) mp_print(mp, "contour");
22291 else if ( m==double_path_code ) mp_print(mp, "doublepath");
22292 else mp_print(mp, "also");
22295 if ( m==mp_pen_type ) mp_print(mp, "withpen");
22296 else if ( m==with_pre_script ) mp_print(mp, "withprescript");
22297 else if ( m==with_post_script ) mp_print(mp, "withpostscript");
22298 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
22299 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
22300 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
22301 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
22302 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
22303 else mp_print(mp, "dashed");
22306 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
22307 updates the list of graphical objects starting at |p|. Each $\langle$with
22308 clause$\rangle$ updates all graphical objects whose |type| is compatible.
22309 Other objects are ignored.
22311 @<Declare action procedures for use by |do_statement|@>=
22312 void mp_scan_with_list (MP mp,pointer p) ;
22314 @ @c void mp_scan_with_list (MP mp,pointer p) {
22315 small_number t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
22316 pointer q; /* for list manipulation */
22317 int old_setting; /* saved |selector| setting */
22318 pointer k; /* for finding the near-last item in a list */
22319 str_number s; /* for string cleanup after combining */
22320 pointer cp,pp,dp,ap,bp;
22321 /* objects being updated; |void| initially; |null| to suppress update */
22322 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
22324 while ( mp->cur_cmd==with_option ){
22327 if ( t!=mp_no_model ) mp_scan_expression(mp);
22328 if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
22329 ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
22330 ((t==mp_uninitialized_model)&&
22331 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
22332 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
22333 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
22334 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
22335 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
22336 ((t==mp_pen_type)&&(mp->cur_type!=t))||
22337 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
22338 @<Complain about improper type@>;
22339 } else if ( t==mp_uninitialized_model ) {
22340 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22342 @<Transfer a color from the current expression to object~|cp|@>;
22343 mp_flush_cur_exp(mp, 0);
22344 } else if ( t==mp_rgb_model ) {
22345 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22347 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
22348 mp_flush_cur_exp(mp, 0);
22349 } else if ( t==mp_cmyk_model ) {
22350 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22352 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
22353 mp_flush_cur_exp(mp, 0);
22354 } else if ( t==mp_grey_model ) {
22355 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22357 @<Transfer a greyscale from the current expression to object~|cp|@>;
22358 mp_flush_cur_exp(mp, 0);
22359 } else if ( t==mp_no_model ) {
22360 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22362 @<Transfer a noncolor from the current expression to object~|cp|@>;
22363 } else if ( t==mp_pen_type ) {
22364 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
22366 if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
22367 pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
22369 } else if ( t==with_pre_script ) {
22372 while ( (ap!=null)&&(! has_color(ap)) )
22375 if ( pre_script(ap)!=null ) { /* build a new,combined string */
22377 old_setting=mp->selector;
22378 mp->selector=new_string;
22379 str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
22380 mp_print_str(mp, mp->cur_exp);
22381 append_char(13); /* a forced \ps\ newline */
22382 mp_print_str(mp, pre_script(ap));
22383 pre_script(ap)=mp_make_string(mp);
22385 mp->selector=old_setting;
22387 pre_script(ap)=mp->cur_exp;
22389 mp->cur_type=mp_vacuous;
22391 } else if ( t==with_post_script ) {
22395 while ( link(k)!=null ) {
22397 if ( has_color(k) ) bp=k;
22400 if ( post_script(bp)!=null ) {
22402 old_setting=mp->selector;
22403 mp->selector=new_string;
22404 str_room(length(post_script(bp))+length(mp->cur_exp)+2);
22405 mp_print_str(mp, post_script(bp));
22406 append_char(13); /* a forced \ps\ newline */
22407 mp_print_str(mp, mp->cur_exp);
22408 post_script(bp)=mp_make_string(mp);
22410 mp->selector=old_setting;
22412 post_script(bp)=mp->cur_exp;
22414 mp->cur_type=mp_vacuous;
22418 @<Make |dp| a stroked node in list~|p|@>;
22420 if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
22421 dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
22422 dash_scale(dp)=unity;
22423 mp->cur_type=mp_vacuous;
22427 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
22431 @ @<Complain about improper type@>=
22432 { exp_err("Improper type");
22434 help2("Next time say `withpen <known pen expression>';")
22435 ("I'll ignore the bad `with' clause and look for another.");
22436 if ( t==with_pre_script )
22437 mp->help_line[1]="Next time say `withprescript <known string expression>';";
22438 else if ( t==with_post_script )
22439 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
22440 else if ( t==mp_picture_type )
22441 mp->help_line[1]="Next time say `dashed <known picture expression>';";
22442 else if ( t==mp_uninitialized_model )
22443 mp->help_line[1]="Next time say `withcolor <known color expression>';";
22444 else if ( t==mp_rgb_model )
22445 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
22446 else if ( t==mp_cmyk_model )
22447 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
22448 else if ( t==mp_grey_model )
22449 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
22450 mp_put_get_flush_error(mp, 0);
22453 @ Forcing the color to be between |0| and |unity| here guarantees that no
22454 picture will ever contain a color outside the legal range for \ps\ graphics.
22456 @<Transfer a color from the current expression to object~|cp|@>=
22457 { if ( mp->cur_type==mp_color_type )
22458 @<Transfer a rgbcolor from the current expression to object~|cp|@>
22459 else if ( mp->cur_type==mp_cmykcolor_type )
22460 @<Transfer a cmykcolor from the current expression to object~|cp|@>
22461 else if ( mp->cur_type==mp_known )
22462 @<Transfer a greyscale from the current expression to object~|cp|@>
22463 else if ( mp->cur_exp==false_code )
22464 @<Transfer a noncolor from the current expression to object~|cp|@>;
22467 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
22468 { q=value(mp->cur_exp);
22473 red_val(cp)=value(red_part_loc(q));
22474 green_val(cp)=value(green_part_loc(q));
22475 blue_val(cp)=value(blue_part_loc(q));
22476 color_model(cp)=mp_rgb_model;
22477 if ( red_val(cp)<0 ) red_val(cp)=0;
22478 if ( green_val(cp)<0 ) green_val(cp)=0;
22479 if ( blue_val(cp)<0 ) blue_val(cp)=0;
22480 if ( red_val(cp)>unity ) red_val(cp)=unity;
22481 if ( green_val(cp)>unity ) green_val(cp)=unity;
22482 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
22485 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
22486 { q=value(mp->cur_exp);
22487 cyan_val(cp)=value(cyan_part_loc(q));
22488 magenta_val(cp)=value(magenta_part_loc(q));
22489 yellow_val(cp)=value(yellow_part_loc(q));
22490 black_val(cp)=value(black_part_loc(q));
22491 color_model(cp)=mp_cmyk_model;
22492 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
22493 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
22494 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
22495 if ( black_val(cp)<0 ) black_val(cp)=0;
22496 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
22497 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
22498 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
22499 if ( black_val(cp)>unity ) black_val(cp)=unity;
22502 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
22509 color_model(cp)=mp_grey_model;
22510 if ( grey_val(cp)<0 ) grey_val(cp)=0;
22511 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
22514 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
22521 color_model(cp)=mp_no_model;
22524 @ @<Make |cp| a colored object in object list~|p|@>=
22526 while ( cp!=null ){
22527 if ( has_color(cp) ) break;
22532 @ @<Make |pp| an object in list~|p| that needs a pen@>=
22534 while ( pp!=null ) {
22535 if ( has_pen(pp) ) break;
22540 @ @<Make |dp| a stroked node in list~|p|@>=
22542 while ( dp!=null ) {
22543 if ( type(dp)==mp_stroked_code ) break;
22548 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
22549 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
22551 @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
22552 if ( dp>mp_void ) @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>
22554 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
22556 while ( q!=null ) {
22557 if ( has_color(q) ) {
22558 red_val(q)=red_val(cp);
22559 green_val(q)=green_val(cp);
22560 blue_val(q)=blue_val(cp);
22561 black_val(q)=black_val(cp);
22562 color_model(q)=color_model(cp);
22568 @ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
22570 while ( q!=null ) {
22571 if ( has_pen(q) ) {
22572 if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
22573 pen_p(q)=copy_pen(pen_p(pp));
22579 @ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
22581 while ( q!=null ) {
22582 if ( type(q)==mp_stroked_code ) {
22583 if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
22584 dash_p(q)=dash_p(dp);
22585 dash_scale(q)=unity;
22586 if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
22592 @ One of the things we need to do when we've parsed an \&{addto} or
22593 similar command is find the header of a supposed \&{picture} variable, given
22594 a token list for that variable. Since the edge structure is about to be
22595 updated, we use |private_edges| to make sure that this is possible.
22597 @<Declare action procedures for use by |do_statement|@>=
22598 pointer mp_find_edges_var (MP mp, pointer t) ;
22600 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
22602 pointer cur_edges; /* the return value */
22603 p=mp_find_variable(mp, t); cur_edges=null;
22605 mp_obliterated(mp, t); mp_put_get_error(mp);
22606 } else if ( type(p)!=mp_picture_type ) {
22607 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
22608 @.Variable x is the wrong type@>
22609 mp_print(mp, " is the wrong type (");
22610 mp_print_type(mp, type(p)); mp_print_char(mp, ')');
22611 help2("I was looking for a \"known\" picture variable.")
22612 ("So I'll not change anything just now.");
22613 mp_put_get_error(mp);
22615 value(p)=mp_private_edges(mp, value(p));
22616 cur_edges=value(p);
22618 mp_flush_node_list(mp, t);
22622 @ @<Cases of |do_statement|...@>=
22623 case add_to_command: mp_do_add_to(mp); break;
22624 case bounds_command:mp_do_bounds(mp); break;
22627 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
22628 @:clip_}{\&{clip} primitive@>
22629 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
22630 @:set_bounds_}{\&{setbounds} primitive@>
22632 @ @<Cases of |print_cmd...@>=
22633 case bounds_command:
22634 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
22635 else mp_print(mp, "setbounds");
22638 @ The following function parses the beginning of an \&{addto} or \&{clip}
22639 command: it expects a variable name followed by a token with |cur_cmd=sep|
22640 and then an expression. The function returns the token list for the variable
22641 and stores the command modifier for the separator token in the global variable
22642 |last_add_type|. We must be careful because this variable might get overwritten
22643 any time we call |get_x_next|.
22646 quarterword last_add_type;
22647 /* command modifier that identifies the last \&{addto} command */
22649 @ @<Declare action procedures for use by |do_statement|@>=
22650 pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
22652 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
22653 pointer lhv; /* variable to add to left */
22654 quarterword add_type=0; /* value to be returned in |last_add_type| */
22656 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
22657 if ( mp->cur_type!=mp_token_list ) {
22658 @<Abandon edges command because there's no variable@>;
22660 lhv=mp->cur_exp; add_type=mp->cur_mod;
22661 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
22663 mp->last_add_type=add_type;
22667 @ @<Abandon edges command because there's no variable@>=
22668 { exp_err("Not a suitable variable");
22669 @.Not a suitable variable@>
22670 help4("At this point I needed to see the name of a picture variable.")
22671 ("(Or perhaps you have indeed presented me with one; I might")
22672 ("have missed it, if it wasn't followed by the proper token.)")
22673 ("So I'll not change anything just now.");
22674 mp_put_get_flush_error(mp, 0);
22677 @ Here is an example of how to use |start_draw_cmd|.
22679 @<Declare action procedures for use by |do_statement|@>=
22680 void mp_do_bounds (MP mp) ;
22682 @ @c void mp_do_bounds (MP mp) {
22683 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
22684 pointer p; /* for list manipulation */
22685 integer m; /* initial value of |cur_mod| */
22687 lhv=mp_start_draw_cmd(mp, to_token);
22689 lhe=mp_find_edges_var(mp, lhv);
22691 mp_flush_cur_exp(mp, 0);
22692 } else if ( mp->cur_type!=mp_path_type ) {
22693 exp_err("Improper `clip'");
22694 @.Improper `addto'@>
22695 help2("This expression should have specified a known path.")
22696 ("So I'll not change anything just now.");
22697 mp_put_get_flush_error(mp, 0);
22698 } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
22699 @<Complain about a non-cycle@>;
22701 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
22706 @ @<Complain about a non-cycle@>=
22707 { print_err("Not a cycle");
22709 help2("That contour should have ended with `..cycle' or `&cycle'.")
22710 ("So I'll not change anything just now."); mp_put_get_error(mp);
22713 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
22714 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
22715 link(p)=link(dummy_loc(lhe));
22716 link(dummy_loc(lhe))=p;
22717 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
22718 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
22719 type(p)=stop_type(m);
22720 link(obj_tail(lhe))=p;
22722 mp_init_bbox(mp, lhe);
22725 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
22726 cases to deal with.
22728 @<Declare action procedures for use by |do_statement|@>=
22729 void mp_do_add_to (MP mp) ;
22731 @ @c void mp_do_add_to (MP mp) {
22732 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
22733 pointer p; /* the graphical object or list for |scan_with_list| to update */
22734 pointer e; /* an edge structure to be merged */
22735 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
22736 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
22738 if ( add_type==also_code ) {
22739 @<Make sure the current expression is a suitable picture and set |e| and |p|
22742 @<Create a graphical object |p| based on |add_type| and the current
22745 mp_scan_with_list(mp, p);
22746 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
22750 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
22751 setting |e:=null| prevents anything from being added to |lhe|.
22753 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
22756 if ( mp->cur_type!=mp_picture_type ) {
22757 exp_err("Improper `addto'");
22758 @.Improper `addto'@>
22759 help2("This expression should have specified a known picture.")
22760 ("So I'll not change anything just now."); mp_put_get_flush_error(mp, 0);
22762 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
22763 p=link(dummy_loc(e));
22767 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
22768 attempts to add to the edge structure.
22770 @<Create a graphical object |p| based on |add_type| and the current...@>=
22772 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
22773 if ( mp->cur_type!=mp_path_type ) {
22774 exp_err("Improper `addto'");
22775 @.Improper `addto'@>
22776 help2("This expression should have specified a known path.")
22777 ("So I'll not change anything just now.");
22778 mp_put_get_flush_error(mp, 0);
22779 } else if ( add_type==contour_code ) {
22780 if ( left_type(mp->cur_exp)==mp_endpoint ) {
22781 @<Complain about a non-cycle@>;
22783 p=mp_new_fill_node(mp, mp->cur_exp);
22784 mp->cur_type=mp_vacuous;
22787 p=mp_new_stroked_node(mp, mp->cur_exp);
22788 mp->cur_type=mp_vacuous;
22792 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
22793 lhe=mp_find_edges_var(mp, lhv);
22795 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
22796 if ( e!=null ) delete_edge_ref(e);
22797 } else if ( add_type==also_code ) {
22799 @<Merge |e| into |lhe| and delete |e|@>;
22803 } else if ( p!=null ) {
22804 link(obj_tail(lhe))=p;
22806 if ( add_type==double_path_code )
22807 if ( pen_p(p)==null )
22808 pen_p(p)=mp_get_pen_circle(mp, 0);
22811 @ @<Merge |e| into |lhe| and delete |e|@>=
22812 { if ( link(dummy_loc(e))!=null ) {
22813 link(obj_tail(lhe))=link(dummy_loc(e));
22814 obj_tail(lhe)=obj_tail(e);
22815 obj_tail(e)=dummy_loc(e);
22816 link(dummy_loc(e))=null;
22817 mp_flush_dash_list(mp, lhe);
22819 mp_toss_edges(mp, e);
22822 @ @<Cases of |do_statement|...@>=
22823 case ship_out_command: mp_do_ship_out(mp); break;
22825 @ @<Declare action procedures for use by |do_statement|@>=
22826 @<Declare the function called |tfm_check|@>;
22827 @<Declare the \ps\ output procedures@>;
22828 void mp_do_ship_out (MP mp) ;
22830 @ @c void mp_do_ship_out (MP mp) {
22831 integer c; /* the character code */
22832 mp_get_x_next(mp); mp_scan_expression(mp);
22833 if ( mp->cur_type!=mp_picture_type ) {
22834 @<Complain that it's not a known picture@>;
22836 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
22837 if ( c<0 ) c=c+256;
22838 @<Store the width information for character code~|c|@>;
22839 mp_ship_out(mp, mp->cur_exp);
22840 mp_flush_cur_exp(mp, 0);
22844 @ @<Complain that it's not a known picture@>=
22846 exp_err("Not a known picture");
22847 help1("I can only output known pictures.");
22848 mp_put_get_flush_error(mp, 0);
22851 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
22854 @<Cases of |do_statement|...@>=
22855 case every_job_command:
22856 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
22860 halfword start_sym; /* a symbolic token to insert at beginning of job */
22865 @ Finally, we have only the ``message'' commands remaining.
22868 @d err_message_code 1
22870 @d filename_template_code 3
22871 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
22872 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
22874 mp->pool_ptr = mp->pool_ptr - g;
22876 mp_print_char(mp, '0');
22879 mp_print_int(mp, (A));
22884 mp_primitive(mp, "message",message_command,message_code);
22885 @:message_}{\&{message} primitive@>
22886 mp_primitive(mp, "errmessage",message_command,err_message_code);
22887 @:err_message_}{\&{errmessage} primitive@>
22888 mp_primitive(mp, "errhelp",message_command,err_help_code);
22889 @:err_help_}{\&{errhelp} primitive@>
22890 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
22891 @:filename_template_}{\&{filenametemplate} primitive@>
22893 @ @<Cases of |print_cmd...@>=
22894 case message_command:
22895 if ( m<err_message_code ) mp_print(mp, "message");
22896 else if ( m==err_message_code ) mp_print(mp, "errmessage");
22897 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
22898 else mp_print(mp, "errhelp");
22901 @ @<Cases of |do_statement|...@>=
22902 case message_command: mp_do_message(mp); break;
22904 @ @<Declare action procedures for use by |do_statement|@>=
22905 @<Declare a procedure called |no_string_err|@>;
22906 void mp_do_message (MP mp) ;
22909 @c void mp_do_message (MP mp) {
22910 int m; /* the type of message */
22911 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
22912 if ( mp->cur_type!=mp_string_type )
22913 mp_no_string_err(mp, "A message should be a known string expression.");
22917 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
22919 case err_message_code:
22920 @<Print string |cur_exp| as an error message@>;
22922 case err_help_code:
22923 @<Save string |cur_exp| as the |err_help|@>;
22925 case filename_template_code:
22926 @<Save the filename template@>;
22928 } /* there are no other cases */
22930 mp_flush_cur_exp(mp, 0);
22933 @ @<Declare a procedure called |no_string_err|@>=
22934 void mp_no_string_err (MP mp,char *s) {
22935 exp_err("Not a string");
22938 mp_put_get_error(mp);
22941 @ The global variable |err_help| is zero when the user has most recently
22942 given an empty help string, or if none has ever been given.
22944 @<Save string |cur_exp| as the |err_help|@>=
22946 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
22947 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
22948 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
22951 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
22952 \&{errhelp}, we don't want to give a long help message each time. So we
22953 give a verbose explanation only once.
22956 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
22958 @ @<Set init...@>=mp->long_help_seen=false;
22960 @ @<Print string |cur_exp| as an error message@>=
22962 print_err(""); mp_print_str(mp, mp->cur_exp);
22963 if ( mp->err_help!=0 ) {
22964 mp->use_err_help=true;
22965 } else if ( mp->long_help_seen ) {
22966 help1("(That was another `errmessage'.)") ;
22968 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
22969 help4("This error message was generated by an `errmessage'")
22970 ("command, so I can\'t give any explicit help.")
22971 ("Pretend that you're Miss Marple: Examine all clues,")
22973 ("and deduce the truth by inspired guesses.");
22975 mp_put_get_error(mp); mp->use_err_help=false;
22978 @ @<Cases of |do_statement|...@>=
22979 case write_command: mp_do_write(mp); break;
22981 @ @<Declare action procedures for use by |do_statement|@>=
22982 void mp_do_write (MP mp) ;
22984 @ @c void mp_do_write (MP mp) {
22985 str_number t; /* the line of text to be written */
22986 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
22987 int old_setting; /* for saving |selector| during output */
22989 mp_scan_expression(mp);
22990 if ( mp->cur_type!=mp_string_type ) {
22991 mp_no_string_err(mp, "The text to be written should be a known string expression");
22992 } else if ( mp->cur_cmd!=to_token ) {
22993 print_err("Missing `to' clause");
22994 help1("A write command should end with `to <filename>'");
22995 mp_put_get_error(mp);
22997 t=mp->cur_exp; mp->cur_type=mp_vacuous;
22999 mp_scan_expression(mp);
23000 if ( mp->cur_type!=mp_string_type )
23001 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23003 @<Write |t| to the file named by |cur_exp|@>;
23007 mp_flush_cur_exp(mp, 0);
23010 @ @<Write |t| to the file named by |cur_exp|@>=
23012 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23013 |cur_exp| must be inserted@>;
23014 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23015 @<Record the end of file on |wr_file[n]|@>;
23017 old_setting=mp->selector;
23018 mp->selector=n+write_file;
23019 mp_print_str(mp, t); mp_print_ln(mp);
23020 mp->selector = old_setting;
23024 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23026 char *fn = str(mp->cur_exp);
23028 n0=mp->write_files;
23029 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23030 if ( n==0 ) { /* bottom reached */
23031 if ( n0==mp->write_files ) {
23032 if ( mp->write_files<mp->max_write_files ) {
23033 incr(mp->write_files);
23038 l = mp->max_write_files + (mp->max_write_files>>2);
23039 wr_file = xmalloc((l+1),sizeof(FILE *));
23040 wr_fname = xmalloc((l+1),sizeof(char *));
23041 for (k=0;k<=l;k++) {
23042 if (k<=mp->max_write_files) {
23043 wr_file[k]=mp->wr_file[k];
23044 wr_fname[k]=mp->wr_fname[k];
23050 xfree(mp->wr_file); xfree(mp->wr_fname);
23051 mp->max_write_files = l;
23052 mp->wr_file = wr_file;
23053 mp->wr_fname = wr_fname;
23057 mp_open_write_file(mp, fn ,n);
23060 if ( mp->wr_fname[n]==NULL ) n0=n;
23065 @ @<Record the end of file on |wr_file[n]|@>=
23066 { fclose(mp->wr_file[n]);
23067 xfree(mp->wr_fname[n]);
23068 mp->wr_fname[n]=NULL;
23069 if ( n==mp->write_files-1 ) mp->write_files=n;
23073 @* \[42] Writing font metric data.
23074 \TeX\ gets its knowledge about fonts from font metric files, also called
23075 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23076 but other programs know about them too. One of \MP's duties is to
23077 write \.{TFM} files so that the user's fonts can readily be
23078 applied to typesetting.
23079 @:TFM files}{\.{TFM} files@>
23080 @^font metric files@>
23082 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23083 Since the number of bytes is always a multiple of~4, we could
23084 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23085 byte interpretation. The format of \.{TFM} files was designed by
23086 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23087 @^Ramshaw, Lyle Harold@>
23088 of information in a compact but useful form.
23091 FILE * tfm_file; /* the font metric output goes here */
23092 char * metric_file_name; /* full name of the font metric file */
23094 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23095 integers that give the lengths of the various subsequent portions
23096 of the file. These twelve integers are, in order:
23097 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23098 |lf|&length of the entire file, in words;\cr
23099 |lh|&length of the header data, in words;\cr
23100 |bc|&smallest character code in the font;\cr
23101 |ec|&largest character code in the font;\cr
23102 |nw|&number of words in the width table;\cr
23103 |nh|&number of words in the height table;\cr
23104 |nd|&number of words in the depth table;\cr
23105 |ni|&number of words in the italic correction table;\cr
23106 |nl|&number of words in the lig/kern table;\cr
23107 |nk|&number of words in the kern table;\cr
23108 |ne|&number of words in the extensible character table;\cr
23109 |np|&number of font parameter words.\cr}}$$
23110 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23112 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23113 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23114 and as few as 0 characters (if |bc=ec+1|).
23116 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23117 16 or more bits, the most significant bytes appear first in the file.
23118 This is called BigEndian order.
23119 @^BigEndian order@>
23121 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23124 The most important data type used here is a |fix_word|, which is
23125 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23126 quantity, with the two's complement of the entire word used to represent
23127 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23128 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23129 the smallest is $-2048$. We will see below, however, that all but two of
23130 the |fix_word| values must lie between $-16$ and $+16$.
23132 @ The first data array is a block of header information, which contains
23133 general facts about the font. The header must contain at least two words,
23134 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23135 header information of use to other software routines might also be
23136 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23137 For example, 16 more words of header information are in use at the Xerox
23138 Palo Alto Research Center; the first ten specify the character coding
23139 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23140 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23141 last gives the ``face byte.''
23143 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23144 the \.{GF} output file. This helps ensure consistency between files,
23145 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23146 should match the check sums on actual fonts that are used. The actual
23147 relation between this check sum and the rest of the \.{TFM} file is not
23148 important; the check sum is simply an identification number with the
23149 property that incompatible fonts almost always have distinct check sums.
23152 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23153 font, in units of \TeX\ points. This number must be at least 1.0; it is
23154 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23155 font, i.e., a font that was designed to look best at a 10-point size,
23156 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23157 $\delta$ \.{pt}', the effect is to override the design size and replace it
23158 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23159 the font image by a factor of $\delta$ divided by the design size. {\sl
23160 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23161 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23162 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23163 since many fonts have a design size equal to one em. The other dimensions
23164 must be less than 16 design-size units in absolute value; thus,
23165 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23166 \.{TFM} file whose first byte might be something besides 0 or 255.
23168 @ Next comes the |char_info| array, which contains one |char_info_word|
23169 per character. Each word in this part of the file contains six fields
23170 packed into four bytes as follows.
23172 \yskip\hang first byte: |width_index| (8 bits)\par
23173 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23175 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23177 \hang fourth byte: |remainder| (8 bits)\par
23179 The actual width of a character is \\{width}|[width_index]|, in design-size
23180 units; this is a device for compressing information, since many characters
23181 have the same width. Since it is quite common for many characters
23182 to have the same height, depth, or italic correction, the \.{TFM} format
23183 imposes a limit of 16 different heights, 16 different depths, and
23184 64 different italic corrections.
23186 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23187 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23188 value of zero. The |width_index| should never be zero unless the
23189 character does not exist in the font, since a character is valid if and
23190 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23192 @ The |tag| field in a |char_info_word| has four values that explain how to
23193 interpret the |remainder| field.
23195 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23196 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23197 program starting at location |remainder| in the |lig_kern| array.\par
23198 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23199 characters of ascending sizes, and not the largest in the chain. The
23200 |remainder| field gives the character code of the next larger character.\par
23201 \hang|tag=3| (|ext_tag|) means that this character code represents an
23202 extensible character, i.e., a character that is built up of smaller pieces
23203 so that it can be made arbitrarily large. The pieces are specified in
23204 |exten[remainder]|.\par
23206 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23207 unless they are used in special circumstances in math formulas. For example,
23208 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23209 operation looks for both |list_tag| and |ext_tag|.
23211 @d no_tag 0 /* vanilla character */
23212 @d lig_tag 1 /* character has a ligature/kerning program */
23213 @d list_tag 2 /* character has a successor in a charlist */
23214 @d ext_tag 3 /* character is extensible */
23216 @ The |lig_kern| array contains instructions in a simple programming language
23217 that explains what to do for special letter pairs. Each word in this array is a
23218 |lig_kern_command| of four bytes.
23220 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23221 step if the byte is 128 or more, otherwise the next step is obtained by
23222 skipping this number of intervening steps.\par
23223 \hang second byte: |next_char|, ``if |next_char| follows the current character,
23224 then perform the operation and stop, otherwise continue.''\par
23225 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
23226 a kern step otherwise.\par
23227 \hang fourth byte: |remainder|.\par
23230 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
23231 between the current character and |next_char|. This amount is
23232 often negative, so that the characters are brought closer together
23233 by kerning; but it might be positive.
23235 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
23236 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
23237 |remainder| is inserted between the current character and |next_char|;
23238 then the current character is deleted if $b=0$, and |next_char| is
23239 deleted if $c=0$; then we pass over $a$~characters to reach the next
23240 current character (which may have a ligature/kerning program of its own).
23242 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
23243 the |next_char| byte is the so-called right boundary character of this font;
23244 the value of |next_char| need not lie between |bc| and~|ec|.
23245 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
23246 there is a special ligature/kerning program for a left boundary character,
23247 beginning at location |256*op_byte+remainder|.
23248 The interpretation is that \TeX\ puts implicit boundary characters
23249 before and after each consecutive string of characters from the same font.
23250 These implicit characters do not appear in the output, but they can affect
23251 ligatures and kerning.
23253 If the very first instruction of a character's |lig_kern| program has
23254 |skip_byte>128|, the program actually begins in location
23255 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
23256 arrays, because the first instruction must otherwise
23257 appear in a location |<=255|.
23259 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
23261 $$\hbox{|256*op_byte+remainder<nl|.}$$
23262 If such an instruction is encountered during
23263 normal program execution, it denotes an unconditional halt; no ligature
23264 command is performed.
23267 /* value indicating `\.{STOP}' in a lig/kern program */
23268 @d kern_flag (128) /* op code for a kern step */
23269 @d skip_byte(A) mp->lig_kern[(A)].b0
23270 @d next_char(A) mp->lig_kern[(A)].b1
23271 @d op_byte(A) mp->lig_kern[(A)].b2
23272 @d rem_byte(A) mp->lig_kern[(A)].b3
23274 @ Extensible characters are specified by an |extensible_recipe|, which
23275 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
23276 order). These bytes are the character codes of individual pieces used to
23277 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
23278 present in the built-up result. For example, an extensible vertical line is
23279 like an extensible bracket, except that the top and bottom pieces are missing.
23281 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
23282 if the piece isn't present. Then the extensible characters have the form
23283 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
23284 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
23285 The width of the extensible character is the width of $R$; and the
23286 height-plus-depth is the sum of the individual height-plus-depths of the
23287 components used, since the pieces are butted together in a vertical list.
23289 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
23290 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
23291 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
23292 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
23294 @ The final portion of a \.{TFM} file is the |param| array, which is another
23295 sequence of |fix_word| values.
23297 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
23298 to help position accents. For example, |slant=.25| means that when you go
23299 up one unit, you also go .25 units to the right. The |slant| is a pure
23300 number; it is the only |fix_word| other than the design size itself that is
23301 not scaled by the design size.
23303 \hang|param[2]=space| is the normal spacing between words in text.
23304 Note that character 040 in the font need not have anything to do with
23307 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
23309 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
23311 \hang|param[5]=x_height| is the size of one ex in the font; it is also
23312 the height of letters for which accents don't have to be raised or lowered.
23314 \hang|param[6]=quad| is the size of one em in the font.
23316 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
23320 If fewer than seven parameters are present, \TeX\ sets the missing parameters
23325 @d space_stretch_code 3
23326 @d space_shrink_code 4
23329 @d extra_space_code 7
23331 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
23332 information, and it does this all at once at the end of a job.
23333 In order to prepare for such frenetic activity, it squirrels away the
23334 necessary facts in various arrays as information becomes available.
23336 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
23337 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
23338 |tfm_ital_corr|. Other information about a character (e.g., about
23339 its ligatures or successors) is accessible via the |char_tag| and
23340 |char_remainder| arrays. Other information about the font as a whole
23341 is kept in additional arrays called |header_byte|, |lig_kern|,
23342 |kern|, |exten|, and |param|.
23344 @d max_tfm_int 32510
23345 @d undefined_label max_tfm_int /* an undefined local label */
23348 #define TFM_ITEMS 257
23350 eight_bits ec; /* smallest and largest character codes shipped out */
23351 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
23352 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
23353 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
23354 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
23355 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
23356 int char_tag[TFM_ITEMS]; /* |remainder| category */
23357 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
23358 char *header_byte; /* bytes of the \.{TFM} header */
23359 int header_last; /* last initialized \.{TFM} header byte */
23360 int header_size; /* size of the \.{TFM} header */
23361 four_quarters *lig_kern; /* the ligature/kern table */
23362 short nl; /* the number of ligature/kern steps so far */
23363 scaled *kern; /* distinct kerning amounts */
23364 short nk; /* the number of distinct kerns so far */
23365 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
23366 short ne; /* the number of extensible characters so far */
23367 scaled *param; /* \&{fontinfo} parameters */
23368 short np; /* the largest \&{fontinfo} parameter specified so far */
23369 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
23370 short skip_table[TFM_ITEMS]; /* local label status */
23371 boolean lk_started; /* has there been a lig/kern step in this command yet? */
23372 integer bchar; /* right boundary character */
23373 short bch_label; /* left boundary starting location */
23374 short ll;short lll; /* registers used for lig/kern processing */
23375 short label_loc[257]; /* lig/kern starting addresses */
23376 eight_bits label_char[257]; /* characters for |label_loc| */
23377 short label_ptr; /* highest position occupied in |label_loc| */
23379 @ @<Allocate or initialize ...@>=
23380 mp->header_last = 0; mp->header_size = 128; /* just for init */
23381 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
23382 mp->lig_kern = NULL; /* allocated when needed */
23383 mp->kern = NULL; /* allocated when needed */
23384 mp->param = NULL; /* allocated when needed */
23386 @ @<Dealloc variables@>=
23387 xfree(mp->header_byte);
23388 xfree(mp->lig_kern);
23393 for (k=0;k<= 255;k++ ) {
23394 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
23395 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
23396 mp->skip_table[k]=undefined_label;
23398 memset(mp->header_byte,0,mp->header_size);
23399 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
23400 mp->internal[mp_boundary_char]=-unity;
23401 mp->bch_label=undefined_label;
23402 mp->label_loc[0]=-1; mp->label_ptr=0;
23404 @ @<Declarations@>=
23405 scaled mp_tfm_check (MP mp,small_number m) ;
23407 @ @<Declare the function called |tfm_check|@>=
23408 scaled mp_tfm_check (MP mp,small_number m) {
23409 if ( abs(mp->internal[m])>=fraction_half ) {
23410 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
23411 @.Enormous charwd...@>
23412 @.Enormous chardp...@>
23413 @.Enormous charht...@>
23414 @.Enormous charic...@>
23415 @.Enormous designsize...@>
23416 mp_print(mp, " has been reduced");
23417 help1("Font metric dimensions must be less than 2048pt.");
23418 mp_put_get_error(mp);
23419 if ( mp->internal[m]>0 ) return (fraction_half-1);
23420 else return (1-fraction_half);
23422 return mp->internal[m];
23426 @ @<Store the width information for character code~|c|@>=
23427 if ( c<mp->bc ) mp->bc=c;
23428 if ( c>mp->ec ) mp->ec=c;
23429 mp->char_exists[c]=true;
23430 mp->tfm_width[c]=mp_tfm_check(mp, mp_char_wd);
23431 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
23432 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
23433 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
23435 @ Now let's consider \MP's special \.{TFM}-oriented commands.
23437 @<Cases of |do_statement|...@>=
23438 case tfm_command: mp_do_tfm_command(mp); break;
23440 @ @d char_list_code 0
23441 @d lig_table_code 1
23442 @d extensible_code 2
23443 @d header_byte_code 3
23444 @d font_dimen_code 4
23447 mp_primitive(mp, "charlist",tfm_command,char_list_code);
23448 @:char_list_}{\&{charlist} primitive@>
23449 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
23450 @:lig_table_}{\&{ligtable} primitive@>
23451 mp_primitive(mp, "extensible",tfm_command,extensible_code);
23452 @:extensible_}{\&{extensible} primitive@>
23453 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
23454 @:header_byte_}{\&{headerbyte} primitive@>
23455 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
23456 @:font_dimen_}{\&{fontdimen} primitive@>
23458 @ @<Cases of |print_cmd...@>=
23461 case char_list_code:mp_print(mp, "charlist"); break;
23462 case lig_table_code:mp_print(mp, "ligtable"); break;
23463 case extensible_code:mp_print(mp, "extensible"); break;
23464 case header_byte_code:mp_print(mp, "headerbyte"); break;
23465 default: mp_print(mp, "fontdimen"); break;
23469 @ @<Declare action procedures for use by |do_statement|@>=
23470 eight_bits mp_get_code (MP mp) ;
23472 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
23473 integer c; /* the code value found */
23474 mp_get_x_next(mp); mp_scan_expression(mp);
23475 if ( mp->cur_type==mp_known ) {
23476 c=mp_round_unscaled(mp, mp->cur_exp);
23477 if ( c>=0 ) if ( c<256 ) return c;
23478 } else if ( mp->cur_type==mp_string_type ) {
23479 if ( length(mp->cur_exp)==1 ) {
23480 c=mp->str_pool[mp->str_start[mp->cur_exp]];
23484 exp_err("Invalid code has been replaced by 0");
23485 @.Invalid code...@>
23486 help2("I was looking for a number between 0 and 255, or for a")
23487 ("string of length 1. Didn't find it; will use 0 instead.");
23488 mp_put_get_flush_error(mp, 0); c=0;
23492 @ @<Declare action procedures for use by |do_statement|@>=
23493 void mp_set_tag (MP mp,halfword c, small_number t, halfword r) ;
23495 @ @c void mp_set_tag (MP mp,halfword c, small_number t, halfword r) {
23496 if ( mp->char_tag[c]==no_tag ) {
23497 mp->char_tag[c]=t; mp->char_remainder[c]=r;
23499 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
23500 mp->label_char[mp->label_ptr]=c;
23503 @<Complain about a character tag conflict@>;
23507 @ @<Complain about a character tag conflict@>=
23509 print_err("Character ");
23510 if ( (c>' ')&&(c<127) ) mp_print_char(mp,c);
23511 else if ( c==256 ) mp_print(mp, "||");
23512 else { mp_print(mp, "code "); mp_print_int(mp, c); };
23513 mp_print(mp, " is already ");
23514 @.Character c is already...@>
23515 switch (mp->char_tag[c]) {
23516 case lig_tag: mp_print(mp, "in a ligtable"); break;
23517 case list_tag: mp_print(mp, "in a charlist"); break;
23518 case ext_tag: mp_print(mp, "extensible"); break;
23519 } /* there are no other cases */
23520 help2("It's not legal to label a character more than once.")
23521 ("So I'll not change anything just now.");
23522 mp_put_get_error(mp);
23525 @ @<Declare action procedures for use by |do_statement|@>=
23526 void mp_do_tfm_command (MP mp) ;
23528 @ @c void mp_do_tfm_command (MP mp) {
23529 int c,cc; /* character codes */
23530 int k; /* index into the |kern| array */
23531 int j; /* index into |header_byte| or |param| */
23532 switch (mp->cur_mod) {
23533 case char_list_code:
23535 /* we will store a list of character successors */
23536 while ( mp->cur_cmd==colon ) {
23537 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
23540 case lig_table_code:
23541 if (mp->lig_kern==NULL)
23542 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
23543 if (mp->kern==NULL)
23544 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
23545 @<Store a list of ligature/kern steps@>;
23547 case extensible_code:
23548 @<Define an extensible recipe@>;
23550 case header_byte_code:
23551 case font_dimen_code:
23552 c=mp->cur_mod; mp_get_x_next(mp);
23553 mp_scan_expression(mp);
23554 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
23555 exp_err("Improper location");
23556 @.Improper location@>
23557 help2("I was looking for a known, positive number.")
23558 ("For safety's sake I'll ignore the present command.");
23559 mp_put_get_error(mp);
23561 j=mp_round_unscaled(mp, mp->cur_exp);
23562 if ( mp->cur_cmd!=colon ) {
23563 mp_missing_err(mp, ":");
23565 help1("A colon should follow a headerbyte or fontinfo location.");
23568 if ( c==header_byte_code ) {
23569 @<Store a list of header bytes@>;
23571 if (mp->param==NULL)
23572 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
23573 @<Store a list of font dimensions@>;
23577 } /* there are no other cases */
23580 @ @<Store a list of ligature/kern steps@>=
23582 mp->lk_started=false;
23585 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
23586 @<Process a |skip_to| command and |goto done|@>;
23587 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
23588 else { mp_back_input(mp); c=mp_get_code(mp); };
23589 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
23590 @<Record a label in a lig/kern subprogram and |goto continue|@>;
23592 if ( mp->cur_cmd==lig_kern_token ) {
23593 @<Compile a ligature/kern command@>;
23595 print_err("Illegal ligtable step");
23596 @.Illegal ligtable step@>
23597 help1("I was looking for `=:' or `kern' here.");
23598 mp_back_error(mp); next_char(mp->nl)=qi(0);
23599 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
23600 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
23602 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
23604 if ( mp->cur_cmd==comma ) goto CONTINUE;
23605 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
23610 mp_primitive(mp, "=:",lig_kern_token,0);
23611 @:=:_}{\.{=:} primitive@>
23612 mp_primitive(mp, "=:|",lig_kern_token,1);
23613 @:=:/_}{\.{=:\char'174} primitive@>
23614 mp_primitive(mp, "=:|>",lig_kern_token,5);
23615 @:=:/>_}{\.{=:\char'174>} primitive@>
23616 mp_primitive(mp, "|=:",lig_kern_token,2);
23617 @:=:/_}{\.{\char'174=:} primitive@>
23618 mp_primitive(mp, "|=:>",lig_kern_token,6);
23619 @:=:/>_}{\.{\char'174=:>} primitive@>
23620 mp_primitive(mp, "|=:|",lig_kern_token,3);
23621 @:=:/_}{\.{\char'174=:\char'174} primitive@>
23622 mp_primitive(mp, "|=:|>",lig_kern_token,7);
23623 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
23624 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
23625 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
23626 mp_primitive(mp, "kern",lig_kern_token,128);
23627 @:kern_}{\&{kern} primitive@>
23629 @ @<Cases of |print_cmd...@>=
23630 case lig_kern_token:
23632 case 0:mp_print(mp, "=:"); break;
23633 case 1:mp_print(mp, "=:|"); break;
23634 case 2:mp_print(mp, "|=:"); break;
23635 case 3:mp_print(mp, "|=:|"); break;
23636 case 5:mp_print(mp, "=:|>"); break;
23637 case 6:mp_print(mp, "|=:>"); break;
23638 case 7:mp_print(mp, "|=:|>"); break;
23639 case 11:mp_print(mp, "|=:|>>"); break;
23640 default: mp_print(mp, "kern"); break;
23644 @ Local labels are implemented by maintaining the |skip_table| array,
23645 where |skip_table[c]| is either |undefined_label| or the address of the
23646 most recent lig/kern instruction that skips to local label~|c|. In the
23647 latter case, the |skip_byte| in that instruction will (temporarily)
23648 be zero if there were no prior skips to this label, or it will be the
23649 distance to the prior skip.
23651 We may need to cancel skips that span more than 127 lig/kern steps.
23653 @d cancel_skips(A) mp->ll=(A);
23655 mp->lll=qo(skip_byte(mp->ll));
23656 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
23657 } while (mp->lll!=0)
23658 @d skip_error(A) { print_err("Too far to skip");
23659 @.Too far to skip@>
23660 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
23661 mp_error(mp); cancel_skips((A));
23664 @<Process a |skip_to| command and |goto done|@>=
23667 if ( mp->nl-mp->skip_table[c]>128 ) { /* |skip_table[c]<<nl<=undefined_label| */
23668 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
23670 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
23671 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
23672 mp->skip_table[c]=mp->nl-1; goto DONE;
23675 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
23677 if ( mp->cur_cmd==colon ) {
23678 if ( c==256 ) mp->bch_label=mp->nl;
23679 else mp_set_tag(mp, c,lig_tag,mp->nl);
23680 } else if ( mp->skip_table[c]<undefined_label ) {
23681 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
23683 mp->lll=qo(skip_byte(mp->ll));
23684 if ( mp->nl-mp->ll>128 ) {
23685 skip_error(mp->ll); goto CONTINUE;
23687 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
23688 } while (mp->lll!=0);
23693 @ @<Compile a ligature/kern...@>=
23695 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
23696 if ( mp->cur_mod<128 ) { /* ligature op */
23697 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
23699 mp_get_x_next(mp); mp_scan_expression(mp);
23700 if ( mp->cur_type!=mp_known ) {
23701 exp_err("Improper kern");
23703 help2("The amount of kern should be a known numeric value.")
23704 ("I'm zeroing this one. Proceed, with fingers crossed.");
23705 mp_put_get_flush_error(mp, 0);
23707 mp->kern[mp->nk]=mp->cur_exp;
23709 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
23711 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
23714 op_byte(mp->nl)=kern_flag+(k / 256);
23715 rem_byte(mp->nl)=qi((k % 256));
23717 mp->lk_started=true;
23720 @ @d missing_extensible_punctuation(A)
23721 { mp_missing_err(mp, (A));
23722 @.Missing `\char`\#'@>
23723 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
23726 @<Define an extensible recipe@>=
23728 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
23729 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
23730 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
23731 ext_top(mp->ne)=qi(mp_get_code(mp));
23732 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
23733 ext_mid(mp->ne)=qi(mp_get_code(mp));
23734 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
23735 ext_bot(mp->ne)=qi(mp_get_code(mp));
23736 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
23737 ext_rep(mp->ne)=qi(mp_get_code(mp));
23741 @ The header could contain ASCII zeroes, so can't use |strdup|.
23743 @<Store a list of header bytes@>=
23745 if ( j>=mp->header_size ) {
23746 int l = mp->header_size + (mp->header_size >> 2);
23747 char *t = xmalloc(l,sizeof(char));
23749 memcpy(t,mp->header_byte,mp->header_size);
23750 xfree (mp->header_byte);
23751 mp->header_byte = t;
23752 mp->header_size = l;
23754 mp->header_byte[j]=mp_get_code(mp);
23755 incr(j); incr(mp->header_last);
23756 } while (mp->cur_cmd==comma)
23758 @ @<Store a list of font dimensions@>=
23760 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
23761 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
23762 mp_get_x_next(mp); mp_scan_expression(mp);
23763 if ( mp->cur_type!=mp_known ){
23764 exp_err("Improper font parameter");
23765 @.Improper font parameter@>
23766 help1("I'm zeroing this one. Proceed, with fingers crossed.");
23767 mp_put_get_flush_error(mp, 0);
23769 mp->param[j]=mp->cur_exp; incr(j);
23770 } while (mp->cur_cmd==comma)
23772 @ OK: We've stored all the data that is needed for the \.{TFM} file.
23773 All that remains is to output it in the correct format.
23775 An interesting problem needs to be solved in this connection, because
23776 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
23777 and 64~italic corrections. If the data has more distinct values than
23778 this, we want to meet the necessary restrictions by perturbing the
23779 given values as little as possible.
23781 \MP\ solves this problem in two steps. First the values of a given
23782 kind (widths, heights, depths, or italic corrections) are sorted;
23783 then the list of sorted values is perturbed, if necessary.
23785 The sorting operation is facilitated by having a special node of
23786 essentially infinite |value| at the end of the current list.
23788 @<Initialize table entries...@>=
23789 value(inf_val)=fraction_four;
23791 @ Straight linear insertion is good enough for sorting, since the lists
23792 are usually not terribly long. As we work on the data, the current list
23793 will start at |link(temp_head)| and end at |inf_val|; the nodes in this
23794 list will be in increasing order of their |value| fields.
23796 Given such a list, the |sort_in| function takes a value and returns a pointer
23797 to where that value can be found in the list. The value is inserted in
23798 the proper place, if necessary.
23800 At the time we need to do these operations, most of \MP's work has been
23801 completed, so we will have plenty of memory to play with. The value nodes
23802 that are allocated for sorting will never be returned to free storage.
23804 @d clear_the_list link(temp_head)=inf_val
23806 @c pointer mp_sort_in (MP mp,scaled v) {
23807 pointer p,q,r; /* list manipulation registers */
23811 if ( v<=value(q) ) break;
23814 if ( v<value(q) ) {
23815 r=mp_get_node(mp, value_node_size); value(r)=v; link(r)=q; link(p)=r;
23820 @ Now we come to the interesting part, where we reduce the list if necessary
23821 until it has the required size. The |min_cover| routine is basic to this
23822 process; it computes the minimum number~|m| such that the values of the
23823 current sorted list can be covered by |m|~intervals of width~|d|. It
23824 also sets the global value |perturbation| to the smallest value $d'>d$
23825 such that the covering found by this algorithm would be different.
23827 In particular, |min_cover(0)| returns the number of distinct values in the
23828 current list and sets |perturbation| to the minimum distance between
23831 @c integer mp_min_cover (MP mp,scaled d) {
23832 pointer p; /* runs through the current list */
23833 scaled l; /* the least element covered by the current interval */
23834 integer m; /* lower bound on the size of the minimum cover */
23835 m=0; p=link(temp_head); mp->perturbation=el_gordo;
23836 while ( p!=inf_val ){
23837 incr(m); l=value(p);
23838 do { p=link(p); } while (value(p)<=l+d);
23839 if ( value(p)-l<mp->perturbation )
23840 mp->perturbation=value(p)-l;
23846 scaled perturbation; /* quantity related to \.{TFM} rounding */
23847 integer excess; /* the list is this much too long */
23849 @ The smallest |d| such that a given list can be covered with |m| intervals
23850 is determined by the |threshold| routine, which is sort of an inverse
23851 to |min_cover|. The idea is to increase the interval size rapidly until
23852 finding the range, then to go sequentially until the exact borderline has
23855 @c scaled mp_threshold (MP mp,integer m) {
23856 scaled d; /* lower bound on the smallest interval size */
23857 mp->excess=mp_min_cover(mp, 0)-m;
23858 if ( mp->excess<=0 ) {
23862 d=mp->perturbation;
23863 } while (mp_min_cover(mp, d+d)>m);
23864 while ( mp_min_cover(mp, d)>m )
23865 d=mp->perturbation;
23870 @ The |skimp| procedure reduces the current list to at most |m| entries,
23871 by changing values if necessary. It also sets |info(p):=k| if |value(p)|
23872 is the |k|th distinct value on the resulting list, and it sets
23873 |perturbation| to the maximum amount by which a |value| field has
23874 been changed. The size of the resulting list is returned as the
23877 @c integer mp_skimp (MP mp,integer m) {
23878 scaled d; /* the size of intervals being coalesced */
23879 pointer p,q,r; /* list manipulation registers */
23880 scaled l; /* the least value in the current interval */
23881 scaled v; /* a compromise value */
23882 d=mp_threshold(mp, m); mp->perturbation=0;
23883 q=temp_head; m=0; p=link(temp_head);
23884 while ( p!=inf_val ) {
23885 incr(m); l=value(p); info(p)=m;
23886 if ( value(link(p))<=l+d ) {
23887 @<Replace an interval of values by its midpoint@>;
23894 @ @<Replace an interval...@>=
23897 p=link(p); info(p)=m;
23898 decr(mp->excess); if ( mp->excess==0 ) d=0;
23899 } while (value(link(p))<=l+d);
23900 v=l+halfp(value(p)-l);
23901 if ( value(p)-v>mp->perturbation )
23902 mp->perturbation=value(p)-v;
23905 r=link(r); value(r)=v;
23907 link(q)=p; /* remove duplicate values from the current list */
23910 @ A warning message is issued whenever something is perturbed by
23911 more than 1/16\thinspace pt.
23913 @c void mp_tfm_warning (MP mp,small_number m) {
23914 mp_print_nl(mp, "(some ");
23915 mp_print(mp, mp->int_name[m]);
23916 @.some charwds...@>
23917 @.some chardps...@>
23918 @.some charhts...@>
23919 @.some charics...@>
23920 mp_print(mp, " values had to be adjusted by as much as ");
23921 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
23924 @ Here's an example of how we use these routines.
23925 The width data needs to be perturbed only if there are 256 distinct
23926 widths, but \MP\ must check for this case even though it is
23929 An integer variable |k| will be defined when we use this code.
23930 The |dimen_head| array will contain pointers to the sorted
23931 lists of dimensions.
23933 @<Massage the \.{TFM} widths@>=
23935 for (k=mp->bc;k<=mp->ec;k++) {
23936 if ( mp->char_exists[k] )
23937 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
23939 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=link(temp_head);
23940 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
23943 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
23945 @ Heights, depths, and italic corrections are different from widths
23946 not only because their list length is more severely restricted, but
23947 also because zero values do not need to be put into the lists.
23949 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
23951 for (k=mp->bc;k<=mp->ec;k++) {
23952 if ( mp->char_exists[k] ) {
23953 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
23954 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
23957 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=link(temp_head);
23958 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
23960 for (k=mp->bc;k<=mp->ec;k++) {
23961 if ( mp->char_exists[k] ) {
23962 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
23963 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
23966 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=link(temp_head);
23967 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
23969 for (k=mp->bc;k<=mp->ec;k++) {
23970 if ( mp->char_exists[k] ) {
23971 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
23972 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
23975 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=link(temp_head);
23976 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
23978 @ @<Initialize table entries...@>=
23979 value(zero_val)=0; info(zero_val)=0;
23981 @ Bytes 5--8 of the header are set to the design size, unless the user has
23982 some crazy reason for specifying them differently.
23984 Error messages are not allowed at the time this procedure is called,
23985 so a warning is printed instead.
23987 The value of |max_tfm_dimen| is calculated so that
23988 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
23989 < \\{three\_bytes}.$$
23991 @d three_bytes 0100000000 /* $2^{24}$ */
23994 void mp_fix_design_size (MP mp) {
23995 scaled d; /* the design size */
23996 d=mp->internal[mp_design_size];
23997 if ( (d<unity)||(d>=fraction_half) ) {
23999 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24000 @.illegal design size...@>
24001 d=040000000; mp->internal[mp_design_size]=d;
24003 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24004 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24005 mp->header_byte[4]=d / 04000000;
24006 mp->header_byte[5]=(d / 4096) % 256;
24007 mp->header_byte[6]=(d / 16) % 256;
24008 mp->header_byte[7]=(d % 16)*16;
24010 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-mp->internal[mp_design_size] / 010000000;
24011 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24014 @ The |dimen_out| procedure computes a |fix_word| relative to the
24015 design size. If the data was out of range, it is corrected and the
24016 global variable |tfm_changed| is increased by~one.
24018 @c integer mp_dimen_out (MP mp,scaled x) {
24019 if ( abs(x)>mp->max_tfm_dimen ) {
24020 incr(mp->tfm_changed);
24021 if ( x>0 ) x=three_bytes-1; else x=1-three_bytes;
24023 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24029 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24030 integer tfm_changed; /* the number of data entries that were out of bounds */
24032 @ If the user has not specified any of the first four header bytes,
24033 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24034 from the |tfm_width| data relative to the design size.
24037 @c void mp_fix_check_sum (MP mp) {
24038 eight_bits k; /* runs through character codes */
24039 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24040 integer x; /* hash value used in check sum computation */
24041 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24042 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24043 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24044 mp->header_byte[0]=B1; mp->header_byte[1]=B2;
24045 mp->header_byte[2]=B3; mp->header_byte[3]=B4;
24050 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24051 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24052 for (k=mp->bc;k<=mp->ec;k++) {
24053 if ( mp->char_exists[k] ) {
24054 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24055 B1=(B1+B1+x) % 255;
24056 B2=(B2+B2+x) % 253;
24057 B3=(B3+B3+x) % 251;
24058 B4=(B4+B4+x) % 247;
24062 @ Finally we're ready to actually write the \.{TFM} information.
24063 Here are some utility routines for this purpose.
24065 @d tfm_out(A) fputc((A),mp->tfm_file) /* output one byte to |tfm_file| */
24067 @c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24068 tfm_out(x / 256); tfm_out(x % 256);
24070 void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24071 if ( x>=0 ) tfm_out(x / three_bytes);
24073 x=x+010000000000; /* use two's complement for negative values */
24075 tfm_out((x / three_bytes) + 128);
24077 x=x % three_bytes; tfm_out(x / unity);
24078 x=x % unity; tfm_out(x / 0400);
24081 void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24082 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24083 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24086 @ @<Finish the \.{TFM} file@>=
24087 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24088 mp_pack_job_name(mp, ".tfm");
24089 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24090 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24091 mp->metric_file_name=xstrdup(mp->name_of_file);
24092 @<Output the subfile sizes and header bytes@>;
24093 @<Output the character information bytes, then
24094 output the dimensions themselves@>;
24095 @<Output the ligature/kern program@>;
24096 @<Output the extensible character recipes and the font metric parameters@>;
24097 if ( mp->internal[mp_tracing_stats]>0 )
24098 @<Log the subfile sizes of the \.{TFM} file@>;
24099 mp_print_nl(mp, "Font metrics written on ");
24100 mp_print(mp, mp->metric_file_name); mp_print_char(mp, '.');
24101 @.Font metrics written...@>
24102 fclose(mp->tfm_file)
24104 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24107 @<Output the subfile sizes and header bytes@>=
24109 LH=(k+3) / 4; /* this is the number of header words */
24110 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24111 @<Compute the ligature/kern program offset and implant the
24112 left boundary label@>;
24113 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24114 +lk_offset+mp->nk+mp->ne+mp->np);
24115 /* this is the total number of file words that will be output */
24116 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24117 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24118 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24119 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24120 mp_tfm_two(mp, mp->np);
24121 for (k=0;k< 4*LH;k++) {
24122 tfm_out(mp->header_byte[k]);
24125 @ @<Output the character information bytes...@>=
24126 for (k=mp->bc;k<=mp->ec;k++) {
24127 if ( ! mp->char_exists[k] ) {
24128 mp_tfm_four(mp, 0);
24130 tfm_out(info(mp->tfm_width[k])); /* the width index */
24131 tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
24132 tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24133 tfm_out(mp->char_remainder[k]);
24137 for (k=1;k<=4;k++) {
24138 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24139 while ( p!=inf_val ) {
24140 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=link(p);
24145 @ We need to output special instructions at the beginning of the
24146 |lig_kern| array in order to specify the right boundary character
24147 and/or to handle starting addresses that exceed 255. The |label_loc|
24148 and |label_char| arrays have been set up to record all the
24149 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24150 \le|label_loc|[|label_ptr]|$.
24152 @<Compute the ligature/kern program offset...@>=
24153 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24154 if ((mp->bchar<0)||(mp->bchar>255))
24155 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24156 else { mp->lk_started=true; lk_offset=1; };
24157 @<Find the minimum |lk_offset| and adjust all remainders@>;
24158 if ( mp->bch_label<undefined_label )
24159 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24160 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24161 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24162 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24165 @ @<Find the minimum |lk_offset|...@>=
24166 k=mp->label_ptr; /* pointer to the largest unallocated label */
24167 if ( mp->label_loc[k]+lk_offset>255 ) {
24168 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24170 mp->char_remainder[mp->label_char[k]]=lk_offset;
24171 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24172 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24174 incr(lk_offset); decr(k);
24175 } while (! (lk_offset+mp->label_loc[k]<256));
24176 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24178 if ( lk_offset>0 ) {
24180 mp->char_remainder[mp->label_char[k]]
24181 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24186 @ @<Output the ligature/kern program@>=
24187 for (k=0;k<= 255;k++ ) {
24188 if ( mp->skip_table[k]<undefined_label ) {
24189 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24190 @.local label l:: was missing@>
24191 cancel_skips(mp->skip_table[k]);
24194 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24195 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24197 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24198 mp->ll=mp->label_loc[mp->label_ptr];
24199 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24200 else { tfm_out(255); tfm_out(mp->bchar); };
24201 mp_tfm_two(mp, mp->ll+lk_offset);
24203 decr(mp->label_ptr);
24204 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24207 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24208 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24210 @ @<Output the extensible character recipes...@>=
24211 for (k=0;k<=mp->ne-1;k++)
24212 mp_tfm_qqqq(mp, mp->exten[k]);
24213 for (k=1;k<=mp->np;k++) {
24215 if ( abs(mp->param[1])<fraction_half ) {
24216 mp_tfm_four(mp, mp->param[1]*16);
24218 incr(mp->tfm_changed);
24219 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
24220 else mp_tfm_four(mp, -el_gordo);
24223 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
24226 if ( mp->tfm_changed>0 ) {
24227 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
24228 @.a font metric dimension...@>
24230 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
24231 @.font metric dimensions...@>
24232 mp_print(mp, " font metric dimensions");
24234 mp_print(mp, " had to be decreased)");
24237 @ @<Log the subfile sizes of the \.{TFM} file@>=
24241 if ( mp->bch_label<undefined_label ) decr(mp->nl);
24242 snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
24243 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
24247 @* \[43] Reading font metric data.
24249 \MP\ isn't a typesetting program but it does need to find the bounding box
24250 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
24251 well as write them.
24256 @ All the width, height, and depth information is stored in an array called
24257 |font_info|. This array is allocated sequentially and each font is stored
24258 as a series of |char_info| words followed by the width, height, and depth
24259 tables. Since |font_name| entries are permanent, their |str_ref| values are
24260 set to |max_str_ref|.
24263 typedef unsigned int font_number; /* |0..font_max| */
24265 @ The |font_info| array is indexed via a group directory arrays.
24266 For example, the |char_info| data for character~|c| in font~|f| will be
24267 in |font_info[char_base[f]+c].qqqq|.
24270 font_number font_max; /* maximum font number for included text fonts */
24271 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
24272 memory_word *font_info; /* height, width, and depth data */
24273 char **font_enc_name; /* encoding names, if any */
24274 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
24275 int next_fmem; /* next unused entry in |font_info| */
24276 font_number last_fnum; /* last font number used so far */
24277 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
24278 char **font_name; /* name as specified in the \&{infont} command */
24279 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
24280 font_number last_ps_fnum; /* last valid |font_ps_name| index */
24281 eight_bits *font_bc;
24282 eight_bits *font_ec; /* first and last character code */
24283 int *char_base; /* base address for |char_info| */
24284 int *width_base; /* index for zeroth character width */
24285 int *height_base; /* index for zeroth character height */
24286 int *depth_base; /* index for zeroth character depth */
24287 pointer *font_sizes;
24289 @ @<Allocate or initialize ...@>=
24290 mp->font_mem_size = 10000;
24291 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
24292 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
24293 mp->font_enc_name = NULL;
24294 mp->font_ps_name_fixed = NULL;
24295 mp->font_dsize = NULL;
24296 mp->font_name = NULL;
24297 mp->font_ps_name = NULL;
24298 mp->font_bc = NULL;
24299 mp->font_ec = NULL;
24300 mp->last_fnum = null_font;
24301 mp->char_base = NULL;
24302 mp->width_base = NULL;
24303 mp->height_base = NULL;
24304 mp->depth_base = NULL;
24305 mp->font_sizes = null;
24307 @ @<Dealloc variables@>=
24308 xfree(mp->font_info);
24309 xfree(mp->font_enc_name);
24310 xfree(mp->font_ps_name_fixed);
24311 xfree(mp->font_dsize);
24312 xfree(mp->font_name);
24313 xfree(mp->font_ps_name);
24314 xfree(mp->font_bc);
24315 xfree(mp->font_ec);
24316 xfree(mp->char_base);
24317 xfree(mp->width_base);
24318 xfree(mp->height_base);
24319 xfree(mp->depth_base);
24320 xfree(mp->font_sizes);
24324 void mp_reallocate_fonts (MP mp, font_number l) {
24326 XREALLOC(mp->font_enc_name, l, char *);
24327 XREALLOC(mp->font_ps_name_fixed, l, boolean);
24328 XREALLOC(mp->font_dsize, l, scaled);
24329 XREALLOC(mp->font_name, l, char *);
24330 XREALLOC(mp->font_ps_name, l, char *);
24331 XREALLOC(mp->font_bc, l, eight_bits);
24332 XREALLOC(mp->font_ec, l, eight_bits);
24333 XREALLOC(mp->char_base, l, int);
24334 XREALLOC(mp->width_base, l, int);
24335 XREALLOC(mp->height_base, l, int);
24336 XREALLOC(mp->depth_base, l, int);
24337 XREALLOC(mp->font_sizes, l, pointer);
24338 for (f=(mp->last_fnum+1);f<=l;f++) {
24339 mp->font_enc_name[f]=NULL;
24340 mp->font_ps_name_fixed[f] = false;
24341 mp->font_name[f]=NULL;
24342 mp->font_ps_name[f]=NULL;
24343 mp->font_sizes[f]=null;
24348 @ @<Declare |mp_reallocate| functions@>=
24349 void mp_reallocate_fonts (MP mp, font_number l);
24352 @ A |null_font| containing no characters is useful for error recovery. Its
24353 |font_name| entry starts out empty but is reset each time an erroneous font is
24354 found. This helps to cut down on the number of duplicate error messages without
24355 wasting a lot of space.
24357 @d null_font 0 /* the |font_number| for an empty font */
24359 @<Set initial...@>=
24360 mp->font_dsize[null_font]=0;
24361 mp->font_bc[null_font]=1;
24362 mp->font_ec[null_font]=0;
24363 mp->char_base[null_font]=0;
24364 mp->width_base[null_font]=0;
24365 mp->height_base[null_font]=0;
24366 mp->depth_base[null_font]=0;
24368 mp->last_fnum=null_font;
24369 mp->last_ps_fnum=null_font;
24370 mp->font_name[null_font]="nullfont";
24371 mp->font_ps_name[null_font]="";
24373 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
24374 the |width index|; the |b1| field contains the height
24375 index; the |b2| fields contains the depth index, and the |b3| field used only
24376 for temporary storage. (It is used to keep track of which characters occur in
24377 an edge structure that is being shipped out.)
24378 The corresponding words in the width, height, and depth tables are stored as
24379 |scaled| values in units of \ps\ points.
24381 With the macros below, the |char_info| word for character~|c| in font~|f| is
24382 |char_info(f)(c)| and the width is
24383 $$\hbox{|char_width(f)(char_info(f)(c)).sc|.}$$
24385 @d char_info_end(A) (A)].qqqq
24386 @d char_info(A) mp->font_info[mp->char_base[(A)]+char_info_end
24387 @d char_width_end(A) (A).b0].sc
24388 @d char_width(A) mp->font_info[mp->width_base[(A)]+char_width_end
24389 @d char_height_end(A) (A).b1].sc
24390 @d char_height(A) mp->font_info[mp->height_base[(A)]+char_height_end
24391 @d char_depth_end(A) (A).b2].sc
24392 @d char_depth(A) mp->font_info[mp->depth_base[(A)]+char_depth_end
24393 @d ichar_exists(A) ((A).b0>0)
24395 @ The |font_ps_name| for a built-in font should be what PostScript expects.
24396 A preliminary name is obtained here from the \.{TFM} name as given in the
24397 |fname| argument. This gets updated later from an external table if necessary.
24399 @<Declare text measuring subroutines@>=
24400 @<Declare subroutines for parsing file names@>;
24401 font_number mp_read_font_info (MP mp, char*fname) {
24402 boolean file_opened; /* has |tfm_infile| been opened? */
24403 font_number n; /* the number to return */
24404 halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
24405 size_t whd_size; /* words needed for heights, widths, and depths */
24406 int i,ii; /* |font_info| indices */
24407 int jj; /* counts bytes to be ignored */
24408 scaled z; /* used to compute the design size */
24410 /* height, width, or depth as a fraction of design size times $2^{-8}$ */
24411 eight_bits h_and_d; /* height and depth indices being unpacked */
24412 int tfbyte; /* a byte read from the file */
24414 @<Open |tfm_infile| for input@>;
24415 @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
24416 otherwise |goto bad_tfm| or |goto done| as appropriate@>;
24418 @<Complain that the \.{TFM} file is bad@>;
24420 if ( file_opened ) fclose(mp->tfm_infile);
24421 if ( n!=null_font ) {
24422 mp->font_ps_name[n]=fname;
24423 mp->font_name[n]=fname;
24428 @ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
24429 precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
24430 @.TFtoPL@> @.PLtoTF@>
24431 and \.{PLtoTF} can be used to debug \.{TFM} files.
24433 @<Complain that the \.{TFM} file is bad@>=
24434 print_err("Font ");
24435 mp_print(mp, fname);
24436 if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
24437 else mp_print(mp, " not usable: TFM file not found");
24438 help3("I wasn't able to read the size data for this font so this")
24439 ("`infont' operation won't produce anything. If the font name")
24440 ("is right, you might ask an expert to make a TFM file");
24442 mp->help_line[0]="is right, try asking an expert to fix the TFM file";
24445 @ @<Read data from |tfm_infile|; if there is no room, say so...@>=
24446 @<Read the \.{TFM} size fields@>;
24447 @<Use the size fields to allocate space in |font_info|@>;
24448 @<Read the \.{TFM} header@>;
24449 @<Read the character data and the width, height, and depth tables and
24452 @ A bad \.{TFM} file can be shorter than it claims to be. The code given here
24453 might try to read past the end of the file if this happens. Changes will be
24454 needed if it causes a system error to refer to |tfm_infile^| or call
24455 |get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
24456 @^system dependencies@>
24457 of |tfget| could be changed to
24458 ``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
24460 @d tfget {tfbyte = fgetc(mp->tfm_infile); }
24461 @d read_two(A) { (A)=tfbyte;
24462 if ( (A)>127 ) goto BAD_TFM;
24463 tfget; (A)=(A)*0400+tfbyte;
24465 @d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
24467 @<Read the \.{TFM} size fields@>=
24468 tfget; read_two(lf);
24469 tfget; read_two(tfm_lh);
24470 tfget; read_two(bc);
24471 tfget; read_two(ec);
24472 if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
24473 tfget; read_two(nw);
24474 tfget; read_two(nh);
24475 tfget; read_two(nd);
24476 whd_size=(ec+1-bc)+nw+nh+nd;
24477 if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
24480 @ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
24481 necessary to apply the |so| and |qo| macros when looking up the width of a
24482 character in the string pool. In order to ensure nonnegative |char_base|
24483 values when |bc>0|, it may be necessary to reserve a few unused |font_info|
24486 @<Use the size fields to allocate space in |font_info|@>=
24487 if ( mp->next_fmem<bc) mp->next_fmem=bc; /* ensure nonnegative |char_base| */
24488 if (mp->last_fnum==mp->font_max)
24489 mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max>>2)));
24490 while (mp->next_fmem+whd_size>=mp->font_mem_size) {
24491 size_t l = mp->font_mem_size+(mp->font_mem_size>>2);
24492 memory_word *font_info;
24493 font_info = xmalloc ((l+1),sizeof(memory_word));
24494 memset (font_info,0,sizeof(memory_word)*(l+1));
24495 memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
24496 xfree(mp->font_info);
24497 mp->font_info = font_info;
24498 mp->font_mem_size = l;
24500 incr(mp->last_fnum);
24504 mp->char_base[n]=mp->next_fmem-bc;
24505 mp->width_base[n]=mp->next_fmem+ec-bc+1;
24506 mp->height_base[n]=mp->width_base[n]+nw;
24507 mp->depth_base[n]=mp->height_base[n]+nh;
24508 mp->next_fmem=mp->next_fmem+whd_size;
24511 @ @<Read the \.{TFM} header@>=
24512 if ( tfm_lh<2 ) goto BAD_TFM;
24514 tfget; read_two(z);
24515 tfget; z=z*0400+tfbyte;
24516 tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
24517 mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
24518 /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
24519 tf_ignore(4*(tfm_lh-2))
24521 @ @<Read the character data and the width, height, and depth tables...@>=
24522 ii=mp->width_base[n];
24523 i=mp->char_base[n]+bc;
24525 tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
24526 tfget; h_and_d=tfbyte;
24527 mp->font_info[i].qqqq.b1=h_and_d / 16;
24528 mp->font_info[i].qqqq.b2=h_and_d % 16;
24532 while ( i<mp->next_fmem ) {
24533 @<Read a four byte dimension, scale it by the design size, store it in
24534 |font_info[i]|, and increment |i|@>;
24536 if (feof(mp->tfm_infile) ) goto BAD_TFM;
24539 @ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
24540 interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
24541 we can multiply it by sixteen and think of it as a |fraction| that has been
24542 divided by sixteen. This cancels the extra scale factor contained in
24545 @<Read a four byte dimension, scale it by the design size, store it in...@>=
24548 if ( d>=0200 ) d=d-0400;
24549 tfget; d=d*0400+tfbyte;
24550 tfget; d=d*0400+tfbyte;
24551 tfget; d=d*0400+tfbyte;
24552 mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
24556 @ This function does no longer use the file name parser, because |fname| is
24557 a C string already.
24558 @<Open |tfm_infile| for input@>=
24560 mp_ptr_scan_file(mp, fname);
24561 if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); mp->cur_area=xstrdup(MP_font_area);}
24562 if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
24564 mp->tfm_infile = mp_open_file(mp, mp->name_of_file, "rb",mp_filetype_metrics);
24565 if ( !mp->tfm_infile ) goto BAD_TFM;
24568 @ When we have a font name and we don't know whether it has been loaded yet,
24569 we scan the |font_name| array before calling |read_font_info|.
24571 @<Declare text measuring subroutines@>=
24572 font_number mp_find_font (MP mp, char *f) {
24574 for (n=0;n<=mp->last_fnum;n++) {
24575 if (mp_xstrcmp(f,mp->font_name[n])==0 )
24578 return mp_read_font_info(mp, f);
24581 @ One simple application of |find_font| is the implementation of the |font_size|
24582 operator that gets the design size for a given font name.
24584 @<Find the design size of the font whose name is |cur_exp|@>=
24585 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
24587 @ If we discover that the font doesn't have a requested character, we omit it
24588 from the bounding box computation and expect the \ps\ interpreter to drop it.
24589 This routine issues a warning message if the user has asked for it.
24591 @<Declare text measuring subroutines@>=
24592 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
24593 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
24594 mp_begin_diagnostic(mp);
24595 if ( mp->selector==log_only ) incr(mp->selector);
24596 mp_print_nl(mp, "Missing character: There is no ");
24597 @.Missing character@>
24598 mp_print_str(mp, mp->str_pool[k]);
24599 mp_print(mp, " in font ");
24600 mp_print(mp, mp->font_name[f]); mp_print_char(mp, '!');
24601 mp_end_diagnostic(mp, false);
24605 @ The whole purpose of saving the height, width, and depth information is to be
24606 able to find the bounding box of an item of text in an edge structure. The
24607 |set_text_box| procedure takes a text node and adds this information.
24609 @<Declare text measuring subroutines@>=
24610 void mp_set_text_box (MP mp,pointer p) {
24611 font_number f; /* |font_n(p)| */
24612 ASCII_code bc,ec; /* range of valid characters for font |f| */
24613 pool_pointer k,kk; /* current character and character to stop at */
24614 four_quarters cc; /* the |char_info| for the current character */
24615 scaled h,d; /* dimensions of the current character */
24617 height_val(p)=-el_gordo;
24618 depth_val(p)=-el_gordo;
24622 kk=str_stop(text_p(p));
24623 k=mp->str_start[text_p(p)];
24625 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
24627 @<Set the height and depth to zero if the bounding box is empty@>;
24630 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
24632 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
24633 mp_lost_warning(mp, f,k);
24635 cc=char_info(f)(mp->str_pool[k]);
24636 if ( ! ichar_exists(cc) ) {
24637 mp_lost_warning(mp, f,k);
24639 width_val(p)=width_val(p)+char_width(f)(cc);
24640 h=char_height(f)(cc);
24641 d=char_depth(f)(cc);
24642 if ( h>height_val(p) ) height_val(p)=h;
24643 if ( d>depth_val(p) ) depth_val(p)=d;
24649 @ Let's hope modern compilers do comparisons correctly when the difference would
24652 @<Set the height and depth to zero if the bounding box is empty@>=
24653 if ( height_val(p)<-depth_val(p) ) {
24658 @ The new primitives fontmapfile and fontmapline.
24660 @<Declare action procedures for use by |do_statement|@>=
24661 void mp_do_mapfile (MP mp) ;
24662 void mp_do_mapline (MP mp) ;
24664 @ @c void mp_do_mapfile (MP mp) {
24665 mp_get_x_next(mp); mp_scan_expression(mp);
24666 if ( mp->cur_type!=mp_string_type ) {
24667 @<Complain about improper map operation@>;
24669 mp_map_file(mp,mp->cur_exp);
24672 void mp_do_mapline (MP mp) {
24673 mp_get_x_next(mp); mp_scan_expression(mp);
24674 if ( mp->cur_type!=mp_string_type ) {
24675 @<Complain about improper map operation@>;
24677 mp_map_line(mp,mp->cur_exp);
24681 @ @<Complain about improper map operation@>=
24683 exp_err("Unsuitable expression");
24684 help1("Only known strings can be map files or map lines.");
24685 mp_put_get_error(mp);
24688 @ This is temporary.
24690 @d ps_room(A) mp_ps_room(mp,A)
24692 @ To print |scaled| value to PDF output we need some subroutines to ensure
24695 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
24698 scaled one_bp; /* scaled value corresponds to 1bp */
24699 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
24700 scaled one_hundred_inch; /* scaled value corresponds to 100in */
24701 integer ten_pow[10]; /* $10^0..10^9$ */
24702 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
24705 mp->one_bp = 65782; /* 65781.76 */
24706 mp->one_hundred_bp = 6578176;
24707 mp->one_hundred_inch = 473628672;
24708 mp->ten_pow[0] = 1;
24709 for (i = 1;i<= 9; i++ ) {
24710 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
24713 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
24715 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
24719 if ( s < 0 ) { sign = -sign; s = -s; }
24720 if ( m < 0 ) { sign = -sign; m = -m; }
24722 mp_confusion(mp, "arithmetic: divided by zero");
24723 else if ( m >= (max_integer / 10) )
24724 mp_confusion(mp, "arithmetic: number too big");
24727 for (i = 1;i<=dd;i++) {
24728 q = 10*q + (10*r) / m;
24731 if ( 2*r >= m ) { incr(q); r = r - m; }
24732 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
24736 @* \[44] Shipping pictures out.
24737 The |ship_out| procedure, to be described below, is given a pointer to
24738 an edge structure. Its mission is to output a file containing the \ps\
24739 description of an edge structure.
24741 @ Each time an edge structure is shipped out we write a new \ps\ output
24742 file named according to the current \&{charcode}.
24743 @:char_code_}{\&{charcode} primitive@>
24745 @<Declare the \ps\ output procedures@>=
24746 void mp_open_output_file (MP mp) ;
24748 @ @c void mp_open_output_file (MP mp) {
24749 integer c; /* \&{charcode} rounded to the nearest integer */
24750 int old_setting; /* previous |selector| setting */
24751 pool_pointer i; /* indexes into |filename_template| */
24752 integer cc; /* a temporary integer for template building */
24753 integer f,g=0; /* field widths */
24754 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24755 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
24756 if ( mp->filename_template==0 ) {
24757 char *s; /* a file extension derived from |c| */
24761 @<Use |c| to compute the file extension |s|@>;
24762 mp_pack_job_name(mp, s);
24764 while ( ! mp_a_open_out(mp, &mp->ps_file, mp_filetype_postscript) )
24765 mp_prompt_file_name(mp, "file name for output",s);
24766 } else { /* initializations */
24767 str_number s, n; /* a file extension derived from |c| */
24768 old_setting=mp->selector;
24769 mp->selector=new_string;
24771 i = mp->str_start[mp->filename_template];
24772 n = rts(""); /* initialize */
24773 while ( i<str_stop(mp->filename_template) ) {
24774 if ( mp->str_pool[i]=='%' ) {
24777 if ( i<str_stop(mp->filename_template) ) {
24778 if ( mp->str_pool[i]=='j' ) {
24779 mp_print(mp, mp->job_name);
24780 } else if ( mp->str_pool[i]=='d' ) {
24781 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
24782 print_with_leading_zeroes(cc);
24783 } else if ( mp->str_pool[i]=='m' ) {
24784 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
24785 print_with_leading_zeroes(cc);
24786 } else if ( mp->str_pool[i]=='y' ) {
24787 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
24788 print_with_leading_zeroes(cc);
24789 } else if ( mp->str_pool[i]=='H' ) {
24790 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
24791 print_with_leading_zeroes(cc);
24792 } else if ( mp->str_pool[i]=='M' ) {
24793 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
24794 print_with_leading_zeroes(cc);
24795 } else if ( mp->str_pool[i]=='c' ) {
24796 if ( c<0 ) mp_print(mp, "ps");
24797 else print_with_leading_zeroes(c);
24798 } else if ( (mp->str_pool[i]>='0') &&
24799 (mp->str_pool[i]<='9') ) {
24801 f = (f*10) + mp->str_pool[i]-'0';
24804 mp_print_str(mp, mp->str_pool[i]);
24808 if ( mp->str_pool[i]=='.' )
24810 n = mp_make_string(mp);
24811 mp_print_str(mp, mp->str_pool[i]);
24815 s = mp_make_string(mp);
24816 mp->selector= old_setting;
24817 if (length(n)==0) {
24821 mp_pack_file_name(mp, str(n),"",str(s));
24822 while ( ! mp_a_open_out(mp, &mp->ps_file, mp_filetype_postscript) )
24823 mp_prompt_file_name(mp, "file name for output",str(s));
24827 @<Store the true output file name if appropriate@>;
24828 @<Begin the progress report for the output of picture~|c|@>;
24831 @ The file extension created here could be up to five characters long in
24832 extreme cases so it may have to be shortened on some systems.
24833 @^system dependencies@>
24835 @<Use |c| to compute the file extension |s|@>=
24838 snprintf(s,7,".%i",(int)c);
24841 @ The user won't want to see all the output file names so we only save the
24842 first and last ones and a count of how many there were. For this purpose
24843 files are ordered primarily by \&{charcode} and secondarily by order of
24845 @:char_code_}{\&{charcode} primitive@>
24847 @<Store the true output file name if appropriate@>=
24848 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
24849 mp->first_output_code=c;
24850 xfree(mp->first_file_name);
24851 mp->first_file_name=xstrdup(mp->name_of_file);
24853 if ( c>=mp->last_output_code ) {
24854 mp->last_output_code=c;
24855 xfree(mp->last_file_name);
24856 mp->last_file_name=xstrdup(mp->name_of_file);
24860 char * first_file_name;
24861 char * last_file_name; /* full file names */
24862 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
24863 @:char_code_}{\&{charcode} primitive@>
24864 integer total_shipped; /* total number of |ship_out| operations completed */
24867 mp->first_file_name=xstrdup("");
24868 mp->last_file_name=xstrdup("");
24869 mp->first_output_code=32768;
24870 mp->last_output_code=-32768;
24871 mp->total_shipped=0;
24873 @ @<Dealloc variables@>=
24874 xfree(mp->first_file_name);
24875 xfree(mp->last_file_name);
24877 @ @<Begin the progress report for the output of picture~|c|@>=
24878 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
24879 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
24880 mp_print_char(mp, '[');
24881 if ( c>=0 ) mp_print_int(mp, c)
24883 @ @<End progress report@>=
24884 mp_print_char(mp, ']');
24886 incr(mp->total_shipped)
24888 @ @<Explain what output files were written@>=
24889 if ( mp->total_shipped>0 ) {
24890 mp_print_nl(mp, "");
24891 mp_print_int(mp, mp->total_shipped);
24892 mp_print(mp, " output file");
24893 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
24894 mp_print(mp, " written: ");
24895 mp_print(mp, mp->first_file_name);
24896 if ( mp->total_shipped>1 ) {
24897 if ( 31+strlen(mp->first_file_name)+
24898 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
24900 mp_print(mp, " .. ");
24901 mp_print(mp, mp->last_file_name);
24906 @ The most important output procedure is the one that gives the \ps\ version of
24909 @<Declare the \ps\ output procedures@>=
24910 void mp_ps_path_out (MP mp,pointer h) {
24911 pointer p,q; /* for scanning the path */
24912 scaled d; /* a temporary value */
24913 boolean curved; /* |true| unless the cubic is almost straight */
24915 if ( mp->need_newpath )
24916 mp_ps_print_cmd(mp, "newpath ","n ");
24917 mp->need_newpath=true;
24918 mp_ps_pair_out(mp, x_coord(h),y_coord(h));
24919 mp_ps_print_cmd(mp, "moveto","m");
24922 if ( right_type(p)==mp_endpoint ) {
24923 if ( p==h ) mp_ps_print_cmd(mp, " 0 0 rlineto"," 0 0 r");
24927 @<Start a new line and print the \ps\ commands for the curve from
24931 mp_ps_print_cmd(mp, " closepath"," p");
24935 boolean need_newpath;
24936 /* will |ps_path_out| need to issue a \&{newpath} command next time */
24937 @:newpath_}{\&{newpath} command@>
24939 @ @<Start a new line and print the \ps\ commands for the curve from...@>=
24941 @<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>;
24944 mp_ps_pair_out(mp, right_x(p),right_y(p));
24945 mp_ps_pair_out(mp, left_x(q),left_y(q));
24946 mp_ps_pair_out(mp, x_coord(q),y_coord(q));
24947 mp_ps_print_cmd(mp, "curveto","c");
24948 } else if ( q!=h ){
24949 mp_ps_pair_out(mp, x_coord(q),y_coord(q));
24950 mp_ps_print_cmd(mp, "lineto","l");
24953 @ Two types of straight lines come up often in \MP\ paths:
24954 cubics with zero initial and final velocity as created by |make_path| or
24955 |make_envelope|, and cubics with control points uniformly spaced on a line
24956 as created by |make_choices|.
24958 @d bend_tolerance 131 /* allow rounding error of $2\cdot10^{-3}$ */
24960 @<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>=
24961 if ( right_x(p)==x_coord(p) )
24962 if ( right_y(p)==y_coord(p) )
24963 if ( left_x(q)==x_coord(q) )
24964 if ( left_y(q)==y_coord(q) ) curved=false;
24965 d=left_x(q)-right_x(p);
24966 if ( abs(right_x(p)-x_coord(p)-d)<=bend_tolerance )
24967 if ( abs(x_coord(q)-left_x(q)-d)<=bend_tolerance )
24968 { d=left_y(q)-right_y(p);
24969 if ( abs(right_y(p)-y_coord(p)-d)<=bend_tolerance )
24970 if ( abs(y_coord(q)-left_y(q)-d)<=bend_tolerance ) curved=false;
24973 @ We need to keep track of several parameters from the \ps\ graphics state.
24975 This allows us to be sure that \ps\ has the correct values when they are
24976 needed without wasting time and space setting them unnecessarily.
24979 @d gs_red mp->mem[mp->gs_state+1].sc
24980 @d gs_green mp->mem[mp->gs_state+2].sc
24981 @d gs_blue mp->mem[mp->gs_state+3].sc
24982 @d gs_black mp->mem[mp->gs_state+4].sc
24983 /* color from the last \&{setcmykcolor} or \&{setrgbcolor} or \&{setgray} command */
24984 @d gs_colormodel mp->mem[mp->gs_state+5].qqqq.b0
24985 /* the current colormodel */
24986 @d gs_ljoin mp->mem[mp->gs_state+5].qqqq.b1
24987 @d gs_lcap mp->mem[mp->gs_state+5].qqqq.b2
24988 /* values from the last \&{setlinejoin} and \&{setlinecap} commands */
24989 @d gs_adj_wx mp->mem[mp->gs_state+5].qqqq.b3
24990 /* what resolution-dependent adjustment applies to the width */
24991 @d gs_miterlim mp->mem[mp->gs_state+6].sc
24992 /* the value from the last \&{setmiterlimit} command */
24993 @d gs_dash_p mp->mem[mp->gs_state+7].hh.lh
24994 /* edge structure for last \&{setdash} command */
24995 @d gs_previous mp->mem[mp->gs_state+7].hh.rh
24996 /* backlink to the previous |gs_state| structure */
24997 @d gs_dash_sc mp->mem[mp->gs_state+8].sc
24998 /* scale factor used with |gs_dash_p| */
24999 @d gs_width mp->mem[mp->gs_state+9].sc
25000 /* width setting or $-1$ if no \&{setlinewidth} command so far */
25008 @ To avoid making undue assumptions about the initial graphics state, these
25009 parameters are given special values that are guaranteed not to match anything
25010 in the edge structure being shipped out. On the other hand, the initial color
25011 should be black so that the translation of an all-black picture will have no
25012 \&{setcolor} commands. (These would be undesirable in a font application.)
25013 Hence we use |c=0| when initializing the graphics state and we use |c<0|
25014 to recover from a situation where we have lost track of the graphics state.
25016 @<Declare the \ps\ output procedures@>=
25017 void mp_unknown_graphics_state (MP mp,scaled c) ;
25019 @ @c void mp_unknown_graphics_state (MP mp,scaled c) {
25020 pointer p; /* to shift graphic states around */
25021 quarterword k; /* a loop index for copying the |gs_state| */
25022 if ( (c==0)||(c==-1) ) {
25023 if ( mp->gs_state==null ) {
25024 mp->gs_state = mp_get_node(mp, gs_node_size);
25027 while ( gs_previous!=null ) {
25029 mp_free_node(mp, mp->gs_state,gs_node_size);
25033 gs_red=c; gs_green=c; gs_blue=c; gs_black=c;
25034 gs_colormodel=mp_uninitialized_model;
25041 } else if ( c==1 ) {
25043 mp->gs_state = mp_get_node(mp, gs_node_size);
25044 for (k=1;k<=gs_node_size-1;k++)
25045 mp->mem[mp->gs_state+k]=mp->mem[p+k];
25047 } else if ( c==2 ) {
25049 mp_free_node(mp, mp->gs_state,gs_node_size);
25054 @ When it is time to output a graphical object, |fix_graphics_state| ensures
25055 that \ps's idea of the graphics state agrees with what is stored in the object.
25057 @<Declare the \ps\ output procedures@>=
25058 @<Declare subroutines needed by |fix_graphics_state|@>;
25059 void mp_fix_graphics_state (MP mp, pointer p) ;
25062 void mp_fix_graphics_state (MP mp, pointer p) {
25063 /* get ready to output graphical object |p| */
25064 pointer hh,pp; /* for list manipulation */
25065 scaled wx,wy,ww; /* dimensions of pen bounding box */
25066 boolean adj_wx; /* whether pixel rounding should be based on |wx| or |wy| */
25067 integer tx,ty; /* temporaries for computing |adj_wx| */
25068 scaled scf; /* a scale factor for the dash pattern */
25069 if ( has_color(p) )
25070 @<Make sure \ps\ will use the right color for object~|p|@>;
25071 if ( (type(p)==mp_fill_code)||(type(p)==mp_stroked_code) )
25072 if ( pen_p(p)!=null )
25073 if ( pen_is_elliptical(pen_p(p)) ) {
25074 @<Generate \ps\ code that sets the stroke width to the
25075 appropriate rounded value@>;
25076 @<Make sure \ps\ will use the right dash pattern for |dash_p(p)|@>;
25077 @<Decide whether the line cap parameter matters and set it if necessary@>;
25078 @<Set the other numeric parameters as needed for object~|p|@>;
25080 if ( mp->ps_offset>0 ) mp_print_ln(mp);
25083 @ @<Decide whether the line cap parameter matters and set it if necessary@>=
25084 if ( type(p)==mp_stroked_code )
25085 if ( (left_type(path_p(p))==mp_endpoint)||(dash_p(p)!=null) )
25086 if ( gs_lcap!=lcap_val(p) ) {
25088 mp_print_char(mp, ' ');
25089 mp_print_char(mp, '0'+lcap_val(p));
25090 mp_ps_print_cmd(mp, " setlinecap"," lc");
25091 gs_lcap=lcap_val(p);
25094 @ @<Set the other numeric parameters as needed for object~|p|@>=
25095 if ( gs_ljoin!=ljoin_val(p) ) {
25097 mp_print_char(mp, ' ');
25098 mp_print_char(mp, '0'+ljoin_val(p)); mp_ps_print_cmd(mp, " setlinejoin"," lj");
25099 gs_ljoin=ljoin_val(p);
25101 if ( gs_miterlim!=miterlim_val(p) ) {
25103 mp_print_char(mp, ' ');
25104 mp_print_scaled(mp, miterlim_val(p)); mp_ps_print_cmd(mp, " setmiterlimit"," ml");
25105 gs_miterlim=miterlim_val(p);
25108 @ @<Make sure \ps\ will use the right color for object~|p|@>=
25110 if ( (color_model(p)==mp_rgb_model)||
25111 ((color_model(p)==mp_uninitialized_model)&&
25112 ((mp->internal[mp_default_color_model] / unity)==mp_rgb_model)) ) {
25113 if ( (gs_colormodel!=mp_rgb_model)||(gs_red!=red_val(p))||
25114 (gs_green!=green_val(p))||(gs_blue!=blue_val(p)) ) {
25116 gs_green=green_val(p);
25117 gs_blue=blue_val(p);
25119 gs_colormodel=mp_rgb_model;
25121 mp_print_char(mp, ' ');
25122 mp_print_scaled(mp, gs_red); mp_print_char(mp, ' ');
25123 mp_print_scaled(mp, gs_green); mp_print_char(mp, ' ');
25124 mp_print_scaled(mp, gs_blue);
25125 mp_ps_print_cmd(mp, " setrgbcolor", " R");
25128 } else if ( (color_model(p)==mp_cmyk_model)||
25129 ((color_model(p)==mp_uninitialized_model)&&
25130 ((mp->internal[mp_default_color_model] / unity)==mp_cmyk_model)) ) {
25131 if ( (gs_red!=cyan_val(p))||(gs_green!=magenta_val(p))||
25132 (gs_blue!=yellow_val(p))||(gs_black!=black_val(p))||
25133 (gs_colormodel!=mp_cmyk_model) ) {
25134 if ( color_model(p)==mp_uninitialized_model ) {
25140 gs_red=cyan_val(p);
25141 gs_green=magenta_val(p);
25142 gs_blue=yellow_val(p);
25143 gs_black=black_val(p);
25145 gs_colormodel=mp_cmyk_model;
25147 mp_print_char(mp, ' ');
25148 mp_print_scaled(mp, gs_red); mp_print_char(mp, ' ');
25149 mp_print_scaled(mp, gs_green); mp_print_char(mp, ' ');
25150 mp_print_scaled(mp, gs_blue); mp_print_char(mp, ' ');
25151 mp_print_scaled(mp, gs_black);
25152 mp_ps_print_cmd(mp, " setcmykcolor"," C");
25155 } else if ( (color_model(p)==mp_grey_model)||
25156 ((color_model(p)==mp_uninitialized_model)&&
25157 ((mp->internal[mp_default_color_model] / unity)==mp_grey_model)) ) {
25158 if ( (gs_red!=grey_val(p))||(gs_colormodel!=mp_grey_model) ) {
25159 gs_red = grey_val(p);
25163 gs_colormodel=mp_grey_model;
25165 mp_print_char(mp, ' ');
25166 mp_print_scaled(mp, gs_red);
25167 mp_ps_print_cmd(mp, " setgray"," G");
25171 if ( color_model(p)==mp_no_model )
25172 gs_colormodel=mp_no_model;
25175 @ In order to get consistent widths for horizontal and vertical pen strokes, we
25176 want \ps\ to use an integer number of pixels for the \&{setwidth} parameter.
25177 @:setwidth}{\&{setwidth}command@>
25178 We set |gs_width| to the ideal horizontal or vertical stroke width and then
25179 generate \ps\ code that computes the rounded value. For non-circular pens, the
25180 pen shape will be rescaled so that horizontal or vertical parts of the stroke
25181 have the computed width.
25183 Rounding the width to whole pixels is not likely to improve the appearance of
25184 diagonal or curved strokes, but we do it anyway for consistency. The
25185 \&{truncate} command generated here tends to make all the strokes a little
25186 @:truncate}{\&{truncate} command@>
25187 thinner, but this is appropriate for \ps's scan-conversion rules. Even with
25188 truncation, an ideal with of $w$~pixels gets mapped into $\lfloor w\rfloor+1$.
25189 It would be better to have $\lceil w\rceil$ but that is ridiculously expensive
25192 @<Generate \ps\ code that sets the stroke width...@>=
25193 @<Set |wx| and |wy| to the width and height of the bounding box for
25195 @<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more
25196 important and set |adj_wx| and |ww| accordingly@>;
25197 if ( (ww!=gs_width) || (adj_wx!=gs_adj_wx) ) {
25200 mp_print_char(mp, ' '); mp_print_scaled(mp, ww);
25201 mp_ps_print_cmd(mp,
25202 " 0 dtransform exch truncate exch idtransform pop setlinewidth"," hlw");
25204 if ( mp->internal[mp_procset]>0 ) {
25206 mp_print_char(mp, ' ');
25207 mp_print_scaled(mp, ww);
25208 mp_ps_print(mp, " vlw");
25211 mp_print(mp, " 0 "); mp_print_scaled(mp, ww);
25212 mp_ps_print(mp, " dtransform truncate idtransform setlinewidth pop");
25216 gs_adj_wx = adj_wx;
25219 @ @<Set |wx| and |wy| to the width and height of the bounding box for...@>=
25221 if ( (right_x(pp)==x_coord(pp)) && (left_y(pp)==y_coord(pp)) ) {
25222 wx = abs(left_x(pp) - x_coord(pp));
25223 wy = abs(right_y(pp) - y_coord(pp));
25225 wx = mp_pyth_add(mp, left_x(pp)-x_coord(pp), right_x(pp)-x_coord(pp));
25226 wy = mp_pyth_add(mp, left_y(pp)-y_coord(pp), right_y(pp)-y_coord(pp));
25229 @ The path is considered ``essentially horizontal'' if its range of
25230 $y$~coordinates is less than the $y$~range |wy| for the pen. ``Essentially
25231 vertical'' paths are detected similarly. This code ensures that no component
25232 of the pen transformation is more that |aspect_bound*(ww+1)|.
25234 @d aspect_bound 10 /* ``less important'' of |wx|, |wy| cannot exceed the other by
25235 more than this factor */
25237 @<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more...@>=
25239 if ( mp_coord_rangeOK(mp, path_p(p), y_loc(0), wy) ) tx=aspect_bound;
25240 else if ( mp_coord_rangeOK(mp, path_p(p), x_loc(0), wx) ) ty=aspect_bound;
25241 if ( wy / ty>=wx / tx ) { ww=wy; adj_wx=false; }
25242 else { ww=wx; adj_wx=true; }
25244 @ This routine quickly tests if path |h| is ``essentially horizontal'' or
25245 ``essentially vertical,'' where |zoff| is |x_loc(0)| or |y_loc(0)| and |dz| is
25246 allowable range for $x$ or~$y$. We do not need and cannot afford a full
25247 bounding-box computation.
25249 @<Declare subroutines needed by |fix_graphics_state|@>=
25250 boolean mp_coord_rangeOK (MP mp,pointer h,
25251 small_number zoff, scaled dz) {
25252 pointer p; /* for scanning the path form |h| */
25253 scaled zlo,zhi; /* coordinate range so far */
25254 scaled z; /* coordinate currently being tested */
25255 zlo=knot_coord(h+zoff);
25258 while ( right_type(p)!=mp_endpoint ) {
25259 z=right_coord(p+zoff);
25260 @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
25262 z=left_coord(p+zoff);
25263 @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
25264 z=knot_coord(p+zoff);
25265 @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
25271 @ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>=
25272 if ( z<zlo ) zlo=z;
25273 else if ( z>zhi ) zhi=z;
25274 if ( zhi-zlo>dz ) return false
25276 @ Filling with an elliptical pen is implemented via a combination of \&{stroke}
25277 and \&{fill} commands and a nontrivial dash pattern would interfere with this.
25278 @:stroke}{\&{stroke} command@>
25279 @:fill}{\&{fill} command@>
25280 Note that we don't use |delete_edge_ref| because |gs_dash_p| is not counted as
25283 @<Make sure \ps\ will use the right dash pattern for |dash_p(p)|@>=
25284 if ( type(p)==mp_fill_code ) {
25288 scf=mp_get_pen_scale(mp, pen_p(p));
25290 if ( gs_width==0 ) scf=dash_scale(p); else hh=null;
25292 scf=mp_make_scaled(mp, gs_width,scf);
25293 scf=mp_take_scaled(mp, scf,dash_scale(p));
25297 if ( gs_dash_p!=null ) {
25298 mp_ps_print_cmd(mp, " [] 0 setdash"," rd");
25301 } else if ( (gs_dash_sc!=scf) || ! mp_same_dashes(mp, gs_dash_p,hh) ) {
25302 @<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>;
25305 @ Translating a dash list into \ps\ is very similar to printing it symbolically
25306 in |print_edges|. A dash pattern with |dash_y(hh)=0| has length zero and is
25307 ignored. The same fate applies in the bizarre case of a dash pattern that
25308 cannot be printed without overflow.
25310 @<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>=
25313 if ( (dash_y(hh)==0) || (abs(dash_y(hh)) / unity >= el_gordo / scf)){
25314 mp_ps_print_cmd(mp, " [] 0 setdash"," rd");
25317 start_x(null_dash)=start_x(pp)+dash_y(hh);
25319 mp_print(mp, " [");
25320 while ( pp!=null_dash ) {
25321 mp_ps_pair_out(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf),
25322 mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
25326 mp_print(mp, "] ");
25327 mp_print_scaled(mp, mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
25328 mp_ps_print_cmd(mp, " setdash"," sd");
25332 @ @<Declare subroutines needed by |fix_graphics_state|@>=
25333 boolean mp_same_dashes (MP mp,pointer h, pointer hh) ;
25336 boolean mp_same_dashes (MP mp,pointer h, pointer hh) {
25337 /* do |h| and |hh| represent the same dash pattern? */
25338 pointer p,pp; /* dash nodes being compared */
25339 if ( h==hh ) return true;
25340 else if ( (h<=mp_void)||(hh<=mp_void) ) return false;
25341 else if ( dash_y(h)!=dash_y(hh) ) return false;
25342 else { @<Compare |dash_list(h)| and |dash_list(hh)|@>; }
25343 return false; /* can't happen */
25346 @ @<Compare |dash_list(h)| and |dash_list(hh)|@>=
25349 while ( (p!=null_dash)&&(pp!=null_dash) ) {
25350 if ( (start_x(p)!=start_x(pp))||(stop_x(p)!=stop_x(pp)) ) {
25360 @ When stroking a path with an elliptical pen, it is necessary to transform
25361 the coordinate system so that a unit circular pen will have the desired shape.
25362 To keep this transformation local, we enclose it in a
25363 $$\&{gsave}\ldots\&{grestore}$$
25364 block. Any translation component must be applied to the path being stroked
25365 while the rest of the transformation must apply only to the pen.
25366 If |fill_also=true|, the path is to be filled as well as stroked so we must
25367 insert commands to do this after giving the path.
25369 @<Declare the \ps\ output procedures@>=
25370 void mp_stroke_ellipse (MP mp,pointer h, boolean fill_also) ;
25373 @c void mp_stroke_ellipse (MP mp,pointer h, boolean fill_also) {
25374 /* generate an elliptical pen stroke from object |h| */
25375 scaled txx,txy,tyx,tyy; /* transformation parameters */
25376 pointer p; /* the pen to stroke with */
25377 scaled d1,det; /* for tweaking transformation parameters */
25378 integer s; /* also for tweaking transformation paramters */
25379 boolean transformed; /* keeps track of whether gsave/grestore are needed */
25381 @<Use |pen_p(h)| to set the transformation parameters and give the initial
25383 @<Tweak the transformation parameters so the transformation is nonsingular@>;
25384 mp_ps_path_out(mp, path_p(h));
25385 if ( mp->internal[mp_procset]==0 ) {
25386 if ( fill_also ) mp_print_nl(mp, "gsave fill grestore");
25387 @<Issue \ps\ commands to transform the coordinate system@>;
25388 mp_ps_print(mp, " stroke");
25389 if ( transformed ) mp_ps_print(mp, " grestore");
25391 if ( fill_also ) mp_print_nl(mp, "B"); else mp_print_ln(mp);
25392 if ( (txy!=0)||(tyx!=0) ) {
25393 mp_print(mp, " [");
25394 mp_ps_pair_out(mp, txx,tyx);
25395 mp_ps_pair_out(mp, txy,tyy);
25396 mp_ps_print(mp, "0 0] t");
25397 } else if ((txx!=unity)||(tyy!=unity) ) {
25398 mp_ps_pair_out(mp,txx,tyy);
25399 mp_print(mp, " s");
25401 mp_ps_print(mp, " S");
25402 if ( transformed ) mp_ps_print(mp, " Q");
25407 @ @<Use |pen_p(h)| to set the transformation parameters and give the...@>=
25413 if ( (x_coord(p)!=0)||(y_coord(p)!=0) ) {
25414 mp_print_nl(mp, ""); mp_ps_print_cmd(mp, "gsave ","q ");
25415 mp_ps_pair_out(mp, x_coord(p),y_coord(p));
25416 mp_ps_print(mp, "translate ");
25423 mp_print_nl(mp, "");
25425 @<Adjust the transformation to account for |gs_width| and output the
25426 initial \&{gsave} if |transformed| should be |true|@>
25428 @ @<Adjust the transformation to account for |gs_width| and output the...@>=
25429 if ( gs_width!=unity ) {
25430 if ( gs_width==0 ) {
25431 txx=unity; tyy=unity;
25433 txx=mp_make_scaled(mp, txx,gs_width);
25434 txy=mp_make_scaled(mp, txy,gs_width);
25435 tyx=mp_make_scaled(mp, tyx,gs_width);
25436 tyy=mp_make_scaled(mp, tyy,gs_width);
25439 if ( (txy!=0)||(tyx!=0)||(txx!=unity)||(tyy!=unity) ) {
25440 if ( (! transformed) ){
25441 mp_ps_print_cmd(mp, "gsave ","q ");
25446 @ @<Issue \ps\ commands to transform the coordinate system@>=
25447 if ( (txy!=0)||(tyx!=0) ){
25449 mp_print_char(mp, '[');
25450 mp_ps_pair_out(mp, txx,tyx);
25451 mp_ps_pair_out(mp, txy,tyy);
25452 mp_ps_print(mp, "0 0] concat");
25453 } else if ( (txx!=unity)||(tyy!=unity) ){
25455 mp_ps_pair_out(mp, txx,tyy);
25456 mp_print(mp, "scale");
25459 @ The \ps\ interpreter will probably abort if it encounters a singular
25460 transformation matrix. The determinant must be large enough to ensure that
25461 the printed representation will be nonsingular. Since the printed
25462 representation is always within $2^{-17}$ of the internal |scaled| value, the
25463 total error is at most $4T_{\rm max}2^{-17}$, where $T_{\rm max}$ is a bound on
25464 the magnitudes of |txx/65536|, |txy/65536|, etc.
25466 The |aspect_bound*(gs_width+1)| bound on the components of the pen
25467 transformation allows $T_{\rm max}$ to be at most |2*aspect_bound|.
25469 @<Tweak the transformation parameters so the transformation is nonsingular@>=
25470 det=mp_take_scaled(mp, txx,tyy) - mp_take_scaled(mp, txy,tyx);
25471 d1=4*aspect_bound+1;
25472 if ( abs(det)<d1 ) {
25473 if ( det>=0 ) { d1=d1-det; s=1; }
25474 else { d1=-d1-det; s=-1; };
25476 if ( abs(txx)+abs(tyy)>=abs(txy)+abs(tyy) ) {
25477 if ( abs(txx)>abs(tyy) ) tyy=tyy+(d1+s*abs(txx)) / txx;
25478 else txx=txx+(d1+s*abs(tyy)) / tyy;
25480 if ( abs(txy)>abs(tyx) ) tyx=tyx+(d1+s*abs(txy)) / txy;
25481 else txy=txy+(d1+s*abs(tyx)) / tyx;
25485 @ Here is a simple routine that just fills a cycle.
25487 @<Declare the \ps\ output procedures@>=
25488 void mp_ps_fill_out (MP mp,pointer p) ;
25491 void mp_ps_fill_out (MP mp,pointer p) { /* fill cyclic path~|p| */
25492 mp_ps_path_out(mp, p);
25493 mp_ps_print_cmd(mp, " fill"," F");
25497 @ Given a cyclic path~|p| and a graphical object~|h|, the |do_outer_envelope|
25498 procedure fills the cycle generated by |make_envelope|. It need not do
25499 anything unless some region has positive winding number with respect to~|p|,
25500 but it does not seem worthwhile to test for this.
25502 @<Declare the \ps\ output procedures@>=
25503 void mp_do_outer_envelope (MP mp,pointer p, pointer h) ;
25506 void mp_do_outer_envelope (MP mp,pointer p, pointer h) {
25507 p=mp_make_envelope(mp, p, pen_p(h), ljoin_val(h), 0, miterlim_val(h));
25508 mp_ps_fill_out(mp, p);
25509 mp_toss_knot_list(mp, p);
25512 @ A text node may specify an arbitrary transformation but the usual case
25513 involves only shifting, scaling, and occasionally rotation. The purpose
25514 of |choose_scale| is to select a scale factor so that the remaining
25515 transformation is as ``nice'' as possible. The definition of ``nice''
25516 is somewhat arbitrary but shifting and $90^\circ$ rotation are especially
25517 nice because they work out well for bitmap fonts. The code here selects
25518 a scale factor equal to $1/\sqrt2$ times the Frobenius norm of the
25519 non-shifting part of the transformation matrix. It is careful to avoid
25520 additions that might cause undetected overflow.
25522 @<Declare the \ps\ output procedures@>=
25523 scaled mp_choose_scale (MP mp,pointer p) ;
25525 @ @c scaled mp_choose_scale (MP mp,pointer p) {
25526 /* |p| should point to a text node */
25527 scaled a,b,c,d,ad,bc; /* temporary values */
25532 if ( (a<0) ) negate(a);
25533 if ( (b<0) ) negate(b);
25534 if ( (c<0) ) negate(c);
25535 if ( (d<0) ) negate(d);
25538 return mp_pyth_add(mp, mp_pyth_add(mp, d+ad,ad), mp_pyth_add(mp, c+bc,bc));
25541 @ There may be many sizes of one font and we need to keep track of the
25542 characters used for each size. This is done by keeping a linked list of
25543 sizes for each font with a counter in each text node giving the appropriate
25544 position in the size list for its font.
25546 @d sc_factor(A) mp->mem[(A)+1].sc /* the scale factor stored in a font size node */
25547 @d font_size_size 2 /* size of a font size node */
25549 @ @<Internal library declarations@>=
25550 boolean mp_has_font_size(MP mp, font_number f );
25553 boolean mp_has_font_size(MP mp, font_number f ) {
25554 return (mp->font_sizes[f]!=null);
25558 @ The potential overflow here is caused by the fact the returned value
25559 has to fit in a |name_type|, which is a quarterword.
25561 @d fscale_tolerance 65 /* that's $.001\times2^{16}$ */
25563 @<Declare the \ps\ output procedures@>=
25564 quarterword mp_size_index (MP mp, font_number f, scaled s) {
25565 pointer p,q; /* the previous and current font size nodes */
25566 quarterword i; /* the size index for |q| */
25567 q=mp->font_sizes[f];
25569 while ( q!=null ) {
25570 if ( abs(s-sc_factor(q))<=fscale_tolerance )
25573 { p=q; q=link(q); incr(i); };
25574 if ( i==max_quarterword )
25575 mp_overflow(mp, "sizes per font",max_quarterword);
25576 @:MetaPost capacity exceeded sizes per font}{\quad sizes per font@>
25578 q=mp_get_node(mp, font_size_size);
25580 if ( i==0 ) mp->font_sizes[f]=q; else link(p)=q;
25584 @ @<Internal library ...@>=
25585 scaled mp_indexed_size (MP mp,font_number f, quarterword j);
25588 scaled mp_indexed_size (MP mp,font_number f, quarterword j) {
25589 pointer p; /* a font size node */
25590 quarterword i; /* the size index for |p| */
25591 p=mp->font_sizes[f];
25593 if ( p==null ) mp_confusion(mp, "size");
25595 incr(i); p=link(p);
25596 if ( p==null ) mp_confusion(mp, "size");
25598 return sc_factor(p);
25601 @ @<Declare the \ps\ output procedures@>=
25602 void mp_clear_sizes (MP mp) ;
25604 @ @c void mp_clear_sizes (MP mp) {
25605 font_number f; /* the font whose size list is being cleared */
25606 pointer p; /* current font size nodes */
25607 for (f=null_font+1;f<=mp->last_fnum;f++) {
25608 while ( mp->font_sizes[f]!=null ) {
25609 p=mp->font_sizes[f];
25610 mp->font_sizes[f]=link(p);
25611 mp_free_node(mp, p,font_size_size);
25616 @ The \&{special} command saves up lines of text to be printed during the next
25617 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25620 pointer last_pending; /* the last token in a list of pending specials */
25623 mp->last_pending=spec_head;
25625 @ @<Cases of |do_statement|...@>=
25626 case special_command:
25627 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25628 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25632 @ @<Declare action procedures for use by |do_statement|@>=
25633 void mp_do_special (MP mp) ;
25635 @ @c void mp_do_special (MP mp) {
25636 mp_get_x_next(mp); mp_scan_expression(mp);
25637 if ( mp->cur_type!=mp_string_type ) {
25638 @<Complain about improper special operation@>;
25640 link(mp->last_pending)=mp_stash_cur_exp(mp);
25641 mp->last_pending=link(mp->last_pending);
25642 link(mp->last_pending)=null;
25646 @ @<Complain about improper special operation@>=
25648 exp_err("Unsuitable expression");
25649 help1("Only known strings are allowed for output as specials.");
25650 mp_put_get_error(mp);
25653 @ @<Print any pending specials@>=
25655 while ( t!=null ) {
25656 mp_print_str(mp, value(t));
25660 mp_flush_token_list(mp, link(spec_head));
25661 link(spec_head)=null;
25662 mp->last_pending=spec_head
25664 @ We are now ready for the main output procedure. Note that the |selector|
25665 setting is saved in a global variable so that |begin_diagnostic| can access it.
25667 @<Declare the \ps\ output procedures@>=
25668 void mp_ship_out (MP mp, pointer h) ;
25671 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25672 pointer p; /* the current graphical object */
25673 pointer q; /* something that |p| points to */
25674 integer t; /* a temporary value */
25675 font_number f; /* fonts used in a text node or as loop counters */
25676 scaled ds,scf; /* design size and scale factor for a text node */
25677 boolean transformed; /* is the coordinate system being transformed? */
25678 mp_open_output_file(mp);
25679 mp->non_ps_setting=mp->selector;
25680 mp->selector=ps_file_only;
25681 mp_set_bbox(mp, h, true);
25682 mp_print_initial_comment(mp, h, minx_val(h),miny_val(h),maxx_val(h),maxy_val(h));
25683 if ( (mp->internal[mp_prologues]==two)||(mp->internal[mp_prologues]==three) ) {
25684 @<Scan all the text nodes and mark the used characters@>;
25685 @<Update encoding names@>;
25686 mp_print_improved_prologue(mp, h);
25688 @<Scan all the text nodes and set the |font_sizes| lists;
25689 if |internal[mp_prologues]<=0| list the sizes selected by |choose_scale|,
25690 apply |unmark_font| to each font encountered, and call |mark_string|
25691 whenever the size index is zero@>;
25692 mp_print_prologue(mp, h);
25694 @<Print any pending specials@>;
25695 mp_unknown_graphics_state(mp, 0);
25696 mp->need_newpath=true;
25697 p=link(dummy_loc(h));
25698 while ( p!=null ) {
25699 if ( has_color(p) ) {
25700 if ( (pre_script(p))!=null ) {
25701 mp_print_nl (mp, str(pre_script(p))); mp_print_ln(mp);
25704 mp_fix_graphics_state(mp, p);
25706 @<Cases for translating graphical object~|p| into \ps@>;
25707 case mp_start_bounds_code:
25708 case mp_stop_bounds_code:
25710 } /* all cases are enumerated */
25713 mp_ps_print_cmd(mp, "showpage","P"); mp_print_ln(mp);
25714 mp_print(mp, "%%EOF"); mp_print_ln(mp);
25715 fclose(mp->ps_file);
25716 mp->selector=mp->non_ps_setting;
25717 if ( mp->internal[mp_prologues]<=0 ) mp_clear_sizes(mp);
25718 @<End progress report@>;
25719 if ( mp->internal[mp_tracing_output]>0 )
25720 mp_print_edges(mp, h," (just shipped out)",true);
25723 @ @<Internal library declarations@>=
25724 void mp_apply_mark_string_chars(MP mp, pointer h, int next_size);
25727 void mp_apply_mark_string_chars(MP mp, pointer h, int next_size) {
25729 p=link(dummy_loc(h));
25730 while ( p!=null ) {
25731 if ( type(p)==mp_text_code )
25732 if ( font_n(p)!=null_font )
25733 if ( name_type(p)==next_size )
25734 mp_mark_string_chars(mp, font_n(p),text_p(p));
25739 @ @<Scan all the text nodes and mark the used ...@>=
25740 for (f=null_font+1;f<=mp->last_fnum;f++) {
25741 if ( mp->font_sizes[f]!=null ) {
25742 mp_unmark_font(mp, f);
25743 mp->font_sizes[f]=null;
25746 for (f=null_font+1;f<=mp->last_fnum;f++) {
25747 p=link(dummy_loc(h));
25748 while ( p!=null ) {
25749 if ( type(p)==mp_text_code ) {
25750 if ( font_n(p)!=null_font ) {
25751 mp->font_sizes[font_n(p)] = mp_void;
25752 mp_mark_string_chars(mp, font_n(p),text_p(p));
25753 if ( mp_has_fm_entry(mp,font_n(p),NULL) )
25754 mp->font_ps_name[font_n(p)] = mp_fm_font_name(mp,font_n(p));
25761 @ @<Update encoding names@>=
25762 mp_reload_encodings(mp);
25763 p=link(dummy_loc(h));
25764 while ( p!=null ) {
25765 if ( type(p)==mp_text_code )
25766 if ( font_n(p)!=null_font )
25767 if ( mp_has_fm_entry(mp,font_n(p),NULL) )
25768 if ( mp->font_enc_name[font_n(p)]==NULL )
25769 mp->font_enc_name[font_n(p)] = mp_fm_encoding_name(mp,font_n(p));
25774 @ @<Scan all the text nodes and set the |font_sizes| lists;...@>=
25775 for (f=null_font+1;f<=mp->last_fnum;f++)
25776 mp->font_sizes[f]=null;
25777 p=link(dummy_loc(h));
25778 while ( p!=null ) {
25779 if ( type(p)==mp_text_code ) {
25780 if ( font_n(p)!=null_font ) {
25782 if ( mp->internal[mp_prologues]>0 ) {
25783 mp->font_sizes[f]=mp_void;
25785 if ( mp->font_sizes[f]==null )
25786 mp_unmark_font(mp, f);
25787 name_type(p)=mp_size_index(mp, f,mp_choose_scale(mp, p));
25788 if ( name_type(p)==0 )
25789 mp_mark_string_chars(mp, f,text_p(p));
25799 @ @<Cases for translating graphical object~|p| into \ps@>=
25800 case mp_start_clip_code:
25801 mp_print_nl(mp, ""); mp_ps_print_cmd(mp, "gsave ","q ");
25802 mp_ps_path_out(mp, path_p(p));
25803 mp_ps_print_cmd(mp, " clip"," W");
25805 if ( mp->internal[mp_restore_clip_color]>0 )
25806 mp_unknown_graphics_state(mp, 1);
25808 case mp_stop_clip_code:
25809 mp_print_nl(mp, ""); mp_ps_print_cmd(mp, "grestore","Q");
25811 if ( mp->internal[mp_restore_clip_color]>0 )
25812 mp_unknown_graphics_state(mp, 2);
25814 mp_unknown_graphics_state(mp, -1);
25817 @ @<Cases for translating graphical object~|p| into \ps@>=
25819 if ( pen_p(p)==null ) mp_ps_fill_out(mp, path_p(p));
25820 else if ( pen_is_elliptical(pen_p(p)) ) mp_stroke_ellipse(mp, p,true);
25822 mp_do_outer_envelope(mp, mp_copy_path(mp, path_p(p)), p);
25823 mp_do_outer_envelope(mp, mp_htap_ypoc(mp, path_p(p)), p);
25825 if ( (post_script(p))!=null ) {
25826 mp_print_nl (mp, str(post_script(p))); mp_print_ln(mp);
25829 case mp_stroked_code:
25830 if ( pen_is_elliptical(pen_p(p)) ) mp_stroke_ellipse(mp, p,false);
25832 q=mp_copy_path(mp, path_p(p));
25834 @<Break the cycle and set |t:=1| if path |q| is cyclic@>;
25835 q=mp_make_envelope(mp, q,pen_p(p),ljoin_val(p),t,miterlim_val(p));
25836 mp_ps_fill_out(mp, q);
25837 mp_toss_knot_list(mp, q);
25839 if ( (post_script(p))!=null ) {
25840 mp_print_nl (mp, str(post_script(p))); mp_print_ln(mp);
25844 @ The envelope of a cyclic path~|q| could be computed by calling
25845 |make_envelope| once for |q| and once for its reversal. We don't do this
25846 because it would fail color regions that are covered by the pen regardless
25847 of where it is placed on~|q|.
25849 @<Break the cycle and set |t:=1| if path |q| is cyclic@>=
25850 if ( left_type(q)!=mp_endpoint ) {
25851 left_type(mp_insert_knot(mp, q,x_coord(q),y_coord(q)))=mp_endpoint;
25852 right_type(q)=mp_endpoint;
25857 @ @<Cases for translating graphical object~|p| into \ps@>=
25859 if ( (font_n(p)!=null_font) && (length(text_p(p))>0) ) {
25860 if ( mp->internal[mp_prologues]>0 )
25861 scf=mp_choose_scale(mp, p);
25863 scf=mp_indexed_size(mp, font_n(p), name_type(p));
25864 @<Shift or transform as necessary before outputting text node~|p| at scale
25865 factor~|scf|; set |transformed:=true| if the original transformation must
25867 mp_ps_string_out(mp, str(text_p(p)));
25868 mp_ps_name_out(mp, mp->font_name[font_n(p)],false);
25869 @<Print the size information and \ps\ commands for text node~|p|@>;
25872 if ( (post_script(p))!=null ) {
25873 mp_print_nl (mp, str(post_script(p))); mp_print_ln(mp);
25877 @ @<Print the size information and \ps\ commands for text node~|p|@>=
25879 mp_print_char(mp, ' ');
25880 ds=(mp->font_dsize[font_n(p)]+8) / 16;
25881 mp_print_scaled(mp, mp_take_scaled(mp, ds,scf));
25882 mp_print(mp, " fshow");
25884 mp_ps_print_cmd(mp, " grestore"," Q")
25886 @ @<Shift or transform as necessary before outputting text node~|p| at...@>=
25887 transformed=(txx_val(p)!=scf)||(tyy_val(p)!=scf)||
25888 (txy_val(p)!=0)||(tyx_val(p)!=0);
25889 if ( transformed ) {
25890 mp_ps_print_cmd(mp, "gsave [", "q [");
25891 mp_ps_pair_out(mp, mp_make_scaled(mp, txx_val(p),scf),
25892 mp_make_scaled(mp, tyx_val(p),scf));
25893 mp_ps_pair_out(mp, mp_make_scaled(mp, txy_val(p),scf),
25894 mp_make_scaled(mp, tyy_val(p),scf));
25895 mp_ps_pair_out(mp, tx_val(p),ty_val(p));
25896 mp_ps_print_cmd(mp, "] concat 0 0 moveto","] t 0 0 m");
25898 mp_ps_pair_out(mp, tx_val(p),ty_val(p));
25899 mp_ps_print_cmd(mp, "moveto","m");
25903 @ Now that we've finished |ship_out|, let's look at the other commands
25904 by which a user can send things to the \.{GF} file.
25906 @ @<Determine if a character has been shipped out@>=
25908 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
25909 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
25910 boolean_reset(mp->char_exists[mp->cur_exp]);
25911 mp->cur_type=mp_boolean_type;
25917 @ @<Allocate or initialize ...@>=
25918 mp_backend_initialize(mp);
25921 mp_backend_free(mp);
25924 @* \[45] Dumping and undumping the tables.
25925 After \.{INIMP} has seen a collection of macros, it
25926 can write all the necessary information on an auxiliary file so
25927 that production versions of \MP\ are able to initialize their
25928 memory at high speed. The present section of the program takes
25929 care of such output and input. We shall consider simultaneously
25930 the processes of storing and restoring,
25931 so that the inverse relation between them is clear.
25934 The global variable |mem_ident| is a string that is printed right
25935 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
25936 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
25937 for example, `\.{(mem=plain 90.4.14)}', showing the year,
25938 month, and day that the mem file was created. We have |mem_ident=0|
25939 before \MP's tables are loaded.
25945 mp->mem_ident=NULL;
25947 @ @<Initialize table entries...@>=
25948 mp->mem_ident=xstrdup(" (INIMP)");
25950 @ @<Declare act...@>=
25951 void mp_store_mem_file (MP mp) ;
25953 @ @c void mp_store_mem_file (MP mp) {
25954 integer k; /* all-purpose index */
25955 pointer p,q; /* all-purpose pointers */
25956 integer x; /* something to dump */
25957 four_quarters w; /* four ASCII codes */
25959 @<Create the |mem_ident|, open the mem file,
25960 and inform the user that dumping has begun@>;
25961 @<Dump constants for consistency check@>;
25962 @<Dump the string pool@>;
25963 @<Dump the dynamic memory@>;
25964 @<Dump the table of equivalents and the hash table@>;
25965 @<Dump a few more things and the closing check word@>;
25966 @<Close the mem file@>;
25969 @ Corresponding to the procedure that dumps a mem file, we also have a function
25970 that reads~one~in. The function returns |false| if the dumped mem is
25971 incompatible with the present \MP\ table sizes, etc.
25973 @d off_base 6666 /* go here if the mem file is unacceptable */
25974 @d too_small(A) { wake_up_terminal;
25975 wterm_ln("---! Must increase the "); wterm((A));
25976 @.Must increase the x@>
25981 boolean mp_load_mem_file (MP mp) {
25982 integer k; /* all-purpose index */
25983 pointer p,q; /* all-purpose pointers */
25984 integer x; /* something undumped */
25985 str_number s; /* some temporary string */
25986 four_quarters w; /* four ASCII codes */
25988 @<Undump constants for consistency check@>;
25989 @<Undump the string pool@>;
25990 @<Undump the dynamic memory@>;
25991 @<Undump the table of equivalents and the hash table@>;
25992 @<Undump a few more things and the closing check word@>;
25993 return true; /* it worked! */
25996 wterm_ln("(Fatal mem file error; I'm stymied)\n");
25997 @.Fatal mem file error@>
26001 @ @<Declarations@>=
26002 boolean mp_load_mem_file (MP mp) ;
26004 @ Mem files consist of |memory_word| items, and we use the following
26005 macros to dump words of different types:
26007 @d dump_wd(A) { WW=(A); fwrite(&WW,sizeof(WW),1,mp->mem_file); }
26008 @d dump_int(A) { int cint=(A); fwrite(&cint,sizeof(cint),1,mp->mem_file); }
26009 @d dump_hh(A) { WW.hh=(A); fwrite(&WW,sizeof(WW),1,mp->mem_file); }
26010 @d dump_qqqq(A) { WW.qqqq=(A); fwrite(&WW,sizeof(WW),1,mp->mem_file); }
26011 @d dump_string(A) { dump_int(strlen(A)+1);
26012 fwrite(A,strlen(A)+1,1,mp->mem_file); }
26015 FILE * mem_file; /* for input or output of mem information */
26017 @ The inverse macros are slightly more complicated, since we need to check
26018 the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
26019 read an integer value |x| that is supposed to be in the range |a<=x<=b|.
26021 @d undump_wd(A) { fread(&WW,sizeof(WW),1,mp->mem_file); (A)=WW; }
26022 @d undump_int(A) { int cint; fread(&cint,sizeof(cint),1,mp->mem_file); (A)=cint; }
26023 @d undump_hh(A) { fread(&WW,sizeof(WW),1,mp->mem_file); (A)=WW.hh; }
26024 @d undump_qqqq(A) { fread(&WW,sizeof(WW),1,mp->mem_file); (A)=WW.qqqq; }
26025 @d undump_strings(A,B,C) {
26026 undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else (C)=str(x); }
26027 @d undump(A,B,C) { undump_int(x); if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else (C)=x; }
26028 @d undump_size(A,B,C,D) { undump_int(x);
26029 if (x<(A)) goto OFF_BASE;
26030 if (x>(B)) { too_small((C)); } else {(D)=x;} }
26031 @d undump_string(A) { integer XX=0; undump_int(XX);
26032 A = xmalloc(XX,sizeof(char));
26033 fread(A,XX,1,mp->mem_file); }
26035 @ The next few sections of the program should make it clear how we use the
26036 dump/undump macros.
26038 @<Dump constants for consistency check@>=
26039 dump_int(mp->mem_top);
26040 dump_int(mp->hash_size);
26041 dump_int(mp->hash_prime)
26042 dump_int(mp->param_size);
26043 dump_int(mp->max_in_open);
26045 @ Sections of a \.{WEB} program that are ``commented out'' still contribute
26046 strings to the string pool; therefore \.{INIMP} and \MP\ will have
26047 the same strings. (And it is, of course, a good thing that they do.)
26051 @<Undump constants for consistency check@>=
26052 undump_int(x); mp->mem_top = x;
26053 undump_int(x); if (mp->hash_size != x) goto OFF_BASE;
26054 undump_int(x); if (mp->hash_prime != x) goto OFF_BASE;
26055 undump_int(x); if (mp->param_size != x) goto OFF_BASE;
26056 undump_int(x); if (mp->max_in_open != x) goto OFF_BASE
26058 @ We do string pool compaction to avoid dumping unused strings.
26061 w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
26062 w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
26065 @<Dump the string pool@>=
26066 mp_do_compaction(mp, mp->pool_size);
26067 dump_int(mp->pool_ptr);
26068 dump_int(mp->max_str_ptr);
26069 dump_int(mp->str_ptr);
26071 while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
26074 while ( k<=mp->max_str_ptr ) {
26075 dump_int(mp->next_str[k]); incr(k);
26079 dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
26080 if ( k==mp->str_ptr ) {
26087 while (k+4<mp->pool_ptr ) {
26088 dump_four_ASCII; k=k+4;
26090 k=mp->pool_ptr-4; dump_four_ASCII;
26091 mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
26092 mp_print(mp, " strings of total length ");
26093 mp_print_int(mp, mp->pool_ptr)
26095 @ @d undump_four_ASCII
26097 mp->str_pool[k]=qo(w.b0); mp->str_pool[k+1]=qo(w.b1);
26098 mp->str_pool[k+2]=qo(w.b2); mp->str_pool[k+3]=qo(w.b3)
26100 @<Undump the string pool@>=
26101 undump_int(mp->pool_ptr);
26102 mp_reallocate_pool(mp, mp->pool_ptr) ;
26103 undump_int(mp->max_str_ptr);
26104 mp_reallocate_strings (mp,mp->max_str_ptr) ;
26105 undump(0,mp->max_str_ptr,mp->str_ptr);
26106 undump(0,mp->max_str_ptr+1,s);
26107 for (k=0;k<=s-1;k++)
26108 mp->next_str[k]=k+1;
26109 for (k=s;k<=mp->max_str_ptr;k++)
26110 undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
26111 mp->fixed_str_use=0;
26114 undump(0,mp->pool_ptr,mp->str_start[k]);
26115 if ( k==mp->str_ptr ) break;
26116 mp->str_ref[k]=max_str_ref;
26117 incr(mp->fixed_str_use);
26118 mp->last_fixed_str=k; k=mp->next_str[k];
26121 while ( k+4<mp->pool_ptr ) {
26122 undump_four_ASCII; k=k+4;
26124 k=mp->pool_ptr-4; undump_four_ASCII;
26125 mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
26126 mp->max_pool_ptr=mp->pool_ptr;
26127 mp->strs_used_up=mp->fixed_str_use;
26128 mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
26129 mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
26130 mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
26132 @ By sorting the list of available spaces in the variable-size portion of
26133 |mem|, we are usually able to get by without having to dump very much
26134 of the dynamic memory.
26136 We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
26137 information even when it has not been gathering statistics.
26139 @<Dump the dynamic memory@>=
26140 mp_sort_avail(mp); mp->var_used=0;
26141 dump_int(mp->lo_mem_max); dump_int(mp->rover);
26142 p=0; q=mp->rover; x=0;
26144 for (k=p;k<= q+1;k++)
26145 dump_wd(mp->mem[k]);
26146 x=x+q+2-p; mp->var_used=mp->var_used+q-p;
26147 p=q+node_size(q); q=rlink(q);
26148 } while (q!=mp->rover);
26149 mp->var_used=mp->var_used+mp->lo_mem_max-p;
26150 mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
26151 for (k=p;k<= mp->lo_mem_max;k++ )
26152 dump_wd(mp->mem[k]);
26153 x=x+mp->lo_mem_max+1-p;
26154 dump_int(mp->hi_mem_min); dump_int(mp->avail);
26155 for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
26156 dump_wd(mp->mem[k]);
26157 x=x+mp->mem_end+1-mp->hi_mem_min;
26159 while ( p!=null ) {
26160 decr(mp->dyn_used); p=link(p);
26162 dump_int(mp->var_used); dump_int(mp->dyn_used);
26163 mp_print_ln(mp); mp_print_int(mp, x);
26164 mp_print(mp, " memory locations dumped; current usage is ");
26165 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used)
26167 @ @<Undump the dynamic memory@>=
26168 undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
26169 undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
26172 for (k=p;k<= q+1; k++)
26173 undump_wd(mp->mem[k]);
26175 if ( (p>mp->lo_mem_max)||((q>=rlink(q))&&(rlink(q)!=mp->rover)) )
26178 } while (q!=mp->rover);
26179 for (k=p;k<=mp->lo_mem_max;k++ )
26180 undump_wd(mp->mem[k]);
26181 undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
26182 undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
26183 for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
26184 undump_wd(mp->mem[k]);
26185 undump_int(mp->var_used); undump_int(mp->dyn_used)
26187 @ A different scheme is used to compress the hash table, since its lower region
26188 is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
26189 words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
26190 packed for |p>=hash_used|, so the remaining entries are output in~a~block.
26192 @<Dump the table of equivalents and the hash table@>=
26193 dump_int(mp->hash_used);
26194 mp->st_count=frozen_inaccessible-1-mp->hash_used;
26195 for (p=1;p<=mp->hash_used;p++) {
26196 if ( text(p)!=0 ) {
26197 dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
26200 for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
26201 dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
26203 dump_int(mp->st_count);
26204 mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
26206 @ @<Undump the table of equivalents and the hash table@>=
26207 undump(1,frozen_inaccessible,mp->hash_used);
26210 undump(p+1,mp->hash_used,p);
26211 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26212 } while (p!=mp->hash_used);
26213 for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
26214 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26216 undump_int(mp->st_count)
26218 @ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
26219 to prevent them appearing again.
26221 @<Dump a few more things and the closing check word@>=
26222 dump_int(mp->max_internal);
26223 dump_int(mp->int_ptr);
26224 for (k=1;k<= mp->int_ptr;k++ ) {
26225 dump_int(mp->internal[k]);
26226 dump_string(mp->int_name[k]);
26228 dump_int(mp->start_sym);
26229 dump_int(mp->interaction);
26230 dump_string(mp->mem_ident);
26231 dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
26232 mp->internal[mp_tracing_stats]=0
26234 @ @<Undump a few more things and the closing check word@>=
26236 if (x>mp->max_internal) mp_grow_internals(mp,x);
26237 undump_int(mp->int_ptr);
26238 for (k=1;k<= mp->int_ptr;k++) {
26239 undump_int(mp->internal[k]);
26240 undump_string(mp->int_name[k]);
26242 undump(0,frozen_inaccessible,mp->start_sym);
26243 if (mp->interaction==mp_unspecified_mode) {
26244 undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
26246 undump(mp_unspecified_mode,mp_error_stop_mode,x);
26248 undump_string(mp->mem_ident);
26249 undump(1,hash_end,mp->bg_loc);
26250 undump(1,hash_end,mp->eg_loc);
26251 undump_int(mp->serial_no);
26253 if ( (x!=69073)|| feof(mp->mem_file) ) goto OFF_BASE
26255 @ @<Create the |mem_ident|...@>=
26257 xfree(mp->mem_ident);
26258 mp->mem_ident = xmalloc(256,1);
26259 snprintf(mp->mem_ident,256," (mem=%s %i.%i.%i)",
26261 (int)(mp_round_unscaled(mp, mp->internal[mp_year]) % 100),
26262 (int)mp_round_unscaled(mp, mp->internal[mp_month]),
26263 (int)mp_round_unscaled(mp, mp->internal[mp_day]));
26264 mp_pack_job_name(mp, mem_extension);
26265 while (! mp_w_open_out(mp, &mp->mem_file) )
26266 mp_prompt_file_name(mp, "mem file name", mem_extension);
26267 mp_print_nl(mp, "Beginning to dump on file ");
26268 @.Beginning to dump...@>
26269 mp_print(mp, mp->name_of_file);
26270 mp_print_nl(mp, mp->mem_ident);
26273 @ @<Dealloc variables@>=
26274 xfree(mp->mem_ident);
26276 @ @<Close the mem file@>=
26277 fclose(mp->mem_file)
26279 @* \[46] The main program.
26280 This is it: the part of \MP\ that executes all those procedures we have
26283 Well---almost. We haven't put the parsing subroutines into the
26284 program yet; and we'd better leave space for a few more routines that may
26285 have been forgotten.
26287 @c @<Declare the basic parsing subroutines@>;
26288 @<Declare miscellaneous procedures that were declared |forward|@>;
26289 @<Last-minute procedures@>
26291 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
26293 has to be run first; it initializes everything from scratch, without
26294 reading a mem file, and it has the capability of dumping a mem file.
26295 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
26297 to input a mem file in order to get started. \.{VIRMP} typically has
26298 a bit more memory capacity than \.{INIMP}, because it does not need the
26299 space consumed by the dumping/undumping routines and the numerous calls on
26302 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
26303 the best implementations therefore allow for production versions of \MP\ that
26304 not only avoid the loading routine for \PASCAL\ object code, they also have
26305 a mem file pre-loaded.
26308 boolean ini_version; /* are we iniMP? */
26310 @ @<Option variables@>=
26311 int ini_version; /* are we iniMP? */
26313 @ @<Set |ini_version|@>=
26314 mp->ini_version = (opt->ini_version ? true : false);
26316 @ Here we do whatever is needed to complete \MP's job gracefully on the
26317 local operating system. The code here might come into play after a fatal
26318 error; it must therefore consist entirely of ``safe'' operations that
26319 cannot produce error messages. For example, it would be a mistake to call
26320 |str_room| or |make_string| at this time, because a call on |overflow|
26321 might lead to an infinite loop.
26322 @^system dependencies@>
26324 This program doesn't bother to close the input files that may still be open.
26326 @<Last-minute...@>=
26327 void mp_close_files_and_terminate (MP mp) {
26328 integer k; /* all-purpose index */
26329 integer LH; /* the length of the \.{TFM} header, in words */
26330 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
26331 pointer p; /* runs through a list of \.{TFM} dimensions */
26332 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
26333 if ( mp->internal[mp_tracing_stats]>0 )
26334 @<Output statistics about this job@>;
26336 @<Do all the finishing work on the \.{TFM} file@>;
26337 @<Explain what output files were written@>;
26338 if ( mp->log_opened ){
26340 fclose(mp->log_file); mp->selector=mp->selector-2;
26341 if ( mp->selector==term_only ) {
26342 mp_print_nl(mp, "Transcript written on ");
26343 @.Transcript written...@>
26344 mp_print(mp, mp->log_name); mp_print_char(mp, '.');
26350 @ @<Declarations@>=
26351 void mp_close_files_and_terminate (MP mp) ;
26353 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
26354 if (mp->rd_fname!=NULL) {
26355 for (k=0;k<=(int)mp->read_files-1;k++ ) {
26356 if ( mp->rd_fname[k]!=NULL ) {
26357 fclose(mp->rd_file[k]);
26361 if (mp->wr_fname!=NULL) {
26362 for (k=0;k<=(int)mp->write_files-1;k++) {
26363 if ( mp->wr_fname[k]!=NULL ) {
26364 fclose(mp->wr_file[k]);
26370 for (k=0;k<(int)mp->max_read_files;k++ ) {
26371 if ( mp->rd_fname[k]!=NULL ) {
26372 fclose(mp->rd_file[k]);
26373 mp_xfree(mp->rd_fname[k]);
26376 mp_xfree(mp->rd_file);
26377 mp_xfree(mp->rd_fname);
26378 for (k=0;k<(int)mp->max_write_files;k++) {
26379 if ( mp->wr_fname[k]!=NULL ) {
26380 fclose(mp->wr_file[k]);
26381 mp_xfree(mp->wr_fname[k]);
26384 mp_xfree(mp->wr_file);
26385 mp_xfree(mp->wr_fname);
26388 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
26390 We reclaim all of the variable-size memory at this point, so that
26391 there is no chance of another memory overflow after the memory capacity
26392 has already been exceeded.
26394 @<Do all the finishing work on the \.{TFM} file@>=
26395 if ( mp->internal[mp_fontmaking]>0 ) {
26396 @<Make the dynamic memory into one big available node@>;
26397 @<Massage the \.{TFM} widths@>;
26398 mp_fix_design_size(mp); mp_fix_check_sum(mp);
26399 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
26400 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
26401 @<Finish the \.{TFM} file@>;
26404 @ @<Make the dynamic memory into one big available node@>=
26405 mp->rover=lo_mem_stat_max+1; link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26406 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26407 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26408 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
26409 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
26411 @ The present section goes directly to the log file instead of using
26412 |print| commands, because there's no need for these strings to take
26413 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26415 @<Output statistics...@>=
26416 if ( mp->log_opened ) {
26419 wlog_ln("Here is how much of MetaPost's memory you used:");
26420 @.Here is how much...@>
26421 snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26422 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26423 (int)(mp->max_strings-1-mp->init_str_use));
26425 snprintf(s,128," %i string characters out of %i",
26426 (int)mp->max_pl_used-mp->init_pool_ptr,
26427 (int)mp->pool_size-mp->init_pool_ptr);
26429 snprintf(s,128," %i words of memory out of %i",
26430 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26431 (int)mp->mem_end+1);
26433 snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26435 snprintf(s,128," %ii, %in, %ip, %ib stack positions out of %ii, %in, %ip, %ib",
26436 (int)mp->max_in_stack,(int)mp->int_ptr,
26437 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26438 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26440 snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26441 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26445 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26448 @<Last-minute...@>=
26449 void mp_final_cleanup (MP mp) {
26450 small_number c; /* 0 for \&{end}, 1 for \&{dump} */
26452 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26453 while ( mp->input_ptr>0 ) {
26454 if ( token_state ) mp_end_token_list(mp);
26455 else mp_end_file_reading(mp);
26457 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26458 while ( mp->open_parens>0 ) {
26459 mp_print(mp, " )"); decr(mp->open_parens);
26461 while ( mp->cond_ptr!=null ) {
26462 mp_print_nl(mp, "(end occurred when ");
26463 @.end occurred...@>
26464 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26465 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26466 if ( mp->if_line!=0 ) {
26467 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26469 mp_print(mp, " was incomplete)");
26470 mp->if_line=if_line_field(mp->cond_ptr);
26471 mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=link(mp->cond_ptr);
26473 if ( mp->history!=mp_spotless )
26474 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26475 if ( mp->selector==term_and_log ) {
26476 mp->selector=term_only;
26477 mp_print_nl(mp, "(see the transcript file for additional information)");
26478 @.see the transcript file...@>
26479 mp->selector=term_and_log;
26482 if (mp->ini_version) {
26483 mp_store_mem_file(mp); return;
26485 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26486 @.dump...only by INIMP@>
26490 @ @<Declarations@>=
26491 void mp_final_cleanup (MP mp) ;
26492 void mp_init_prim (MP mp) ;
26493 void mp_init_tab (MP mp) ;
26495 @ @<Last-minute...@>=
26496 void mp_init_prim (MP mp) { /* initialize all the primitives */
26500 void mp_init_tab (MP mp) { /* initialize other tables */
26501 integer k; /* all-purpose index */
26502 @<Initialize table entries (done by \.{INIMP} only)@>;
26506 @ When we begin the following code, \MP's tables may still contain garbage;
26507 the strings might not even be present. Thus we must proceed cautiously to get
26510 But when we finish this part of the program, \MP\ is ready to call on the
26511 |main_control| routine to do its work.
26513 @<Get the first line...@>=
26515 @<Initialize the input routines@>;
26516 if ( (mp->mem_ident==NULL)||(mp->buffer[loc]=='&') ) {
26517 if ( mp->mem_ident!=NULL ) {
26518 mp_do_initialize(mp); /* erase preloaded mem */
26520 if ( ! mp_open_mem_file(mp) ) return mp_fatal_error_stop;
26521 if ( ! mp_load_mem_file(mp) ) {
26522 fclose( mp->mem_file); return mp_fatal_error_stop;
26524 fclose( mp->mem_file);
26525 while ( (loc<limit)&&(mp->buffer[loc]==' ') ) incr(loc);
26527 mp->buffer[limit]='%';
26528 mp_fix_date_and_time(mp);
26529 mp->sys_random_seed = (scaled)(mp->get_random_seed)(mp);
26530 mp_init_randoms(mp, mp->sys_random_seed);
26531 @<Initialize the print |selector|...@>;
26532 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26533 mp_start_input(mp); /* \&{input} assumed */
26536 @ @<Run inimpost commands@>=
26538 mp_get_strings_started(mp);
26539 mp_init_tab(mp); /* initialize the tables */
26540 mp_init_prim(mp); /* call |primitive| for each primitive */
26541 mp->init_str_use=mp->str_ptr; mp->init_pool_ptr=mp->pool_ptr;
26542 mp->max_str_ptr=mp->str_ptr; mp->max_pool_ptr=mp->pool_ptr;
26543 mp_fix_date_and_time(mp);
26547 @* \[47] Debugging.
26548 Once \MP\ is working, you should be able to diagnose most errors with
26549 the \.{show} commands and other diagnostic features. But for the initial
26550 stages of debugging, and for the revelation of really deep mysteries, you
26551 can compile \MP\ with a few more aids, including the \PASCAL\ runtime
26552 checks and its debugger. An additional routine called |debug_help|
26553 will also come into play when you type `\.D' after an error message;
26554 |debug_help| also occurs just before a fatal error causes \MP\ to succumb.
26556 @^system dependencies@>
26558 The interface to |debug_help| is primitive, but it is good enough when used
26559 with a \PASCAL\ debugger that allows you to set breakpoints and to read
26560 variables and change their values. After getting the prompt `\.{debug \#}', you
26561 type either a negative number (this exits |debug_help|), or zero (this
26562 goes to a location where you can set a breakpoint, thereby entering into
26563 dialog with the \PASCAL\ debugger), or a positive number |m| followed by
26564 an argument |n|. The meaning of |m| and |n| will be clear from the
26565 program below. (If |m=13|, there is an additional argument, |l|.)
26568 @<Last-minute...@>=
26569 void mp_debug_help (MP mp) { /* routine to display various things */
26574 mp_print_nl(mp, "debug # (-1 to exit):"); update_terminal;
26577 fscanf(mp->term_in,"%i",&m);
26581 fscanf(mp->term_in,"%i",&n);
26583 @<Numbered cases for |debug_help|@>;
26584 default: mp_print(mp, "?"); break;
26589 @ @<Numbered cases...@>=
26590 case 1: mp_print_word(mp, mp->mem[n]); /* display |mem[n]| in all forms */
26592 case 2: mp_print_int(mp, info(n));
26594 case 3: mp_print_int(mp, link(n));
26596 case 4: mp_print_int(mp, eq_type(n)); mp_print_char(mp, ':'); mp_print_int(mp, equiv(n));
26598 case 5: mp_print_variable_name(mp, n);
26600 case 6: mp_print_int(mp, mp->internal[n]);
26602 case 7: mp_do_show_dependencies(mp);
26604 case 9: mp_show_token_list(mp, n,null,100000,0);
26606 case 10: mp_print_str(mp, n);
26608 case 11: mp_check_mem(mp, n>0); /* check wellformedness; print new busy locations if |n>0| */
26610 case 12: mp_search_mem(mp, n); /* look for pointers to |n| */
26612 case 13: l = 0; fscanf(mp->term_in,"%i",&l); mp_print_cmd_mod(mp, n,l);
26614 case 14: for (k=0;k<=n;k++) mp_print_str(mp, mp->buffer[k]);
26616 case 15: mp->panicking=! mp->panicking;
26620 @ Saving the filename template
26622 @<Save the filename template@>=
26624 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26625 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26627 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26631 @* \[48] System-dependent changes.
26632 This section should be replaced, if necessary, by any special
26633 modification of the program
26634 that are necessary to make \MP\ work at a particular installation.
26635 It is usually best to design your change file so that all changes to
26636 previous sections preserve the section numbering; then everybody's version
26637 will be consistent with the published program. More extensive changes,
26638 which introduce new sections, can be inserted here; then only the index
26639 itself will get a new section number.
26640 @^system dependencies@>
26643 Here is where you can find all uses of each identifier in the program,
26644 with underlined entries pointing to where the identifier was defined.
26645 If the identifier is only one letter long, however, you get to see only
26646 the underlined entries. {\sl All references are to section numbers instead of
26649 This index also lists error messages and other aspects of the program
26650 that you might want to look up some day. For example, the entry
26651 for ``system dependencies'' lists all sections that should receive
26652 special attention from people who are installing \MP\ in a new
26653 operating environment. A list of various things that can't happen appears
26654 under ``this can't happen''.
26655 Approximately 25 sections are listed under ``inner loop''; these account
26656 for more than 60\pct! of \MP's running time, exclusive of input and output.