3 % Copyright 2008 Taco Hoekwater.
5 % This program is free software: you can redistribute it and/or modify
6 % it under the terms of the GNU General Public License as published by
7 % the Free Software Foundation, either version 2 of the License, or
8 % (at your option) any later version.
10 % This program is distributed in the hope that it will be useful,
11 % but WITHOUT ANY WARRANTY; without even the implied warranty of
12 % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 % GNU General Public License for more details.
15 % You should have received a copy of the GNU General Public License
16 % along with this program. If not, see <http://www.gnu.org/licenses/>.
18 % TeX is a trademark of the American Mathematical Society.
19 % METAFONT is a trademark of Addison-Wesley Publishing Company.
20 % PostScript is a trademark of Adobe Systems Incorporated.
22 % Here is TeX material that gets inserted after \input webmac
23 \def\hang{\hangindent 3em\noindent\ignorespaces}
24 \def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
26 \def\psqrt#1{\sqrt{\mathstrut#1}}
28 \def\pct!{{\char`\%}} % percent sign in ordinary text
29 \font\tenlogo=logo10 % font used for the METAFONT logo
31 \def\MF{{\tenlogo META}\-{\tenlogo FONT}}
32 \def\MP{{\tenlogo META}\-{\tenlogo POST}}
33 \def\[#1]{\ignorespaces} % left over from pascal web
34 \def\<#1>{$\langle#1\rangle$}
35 \def\section{\mathhexbox278}
36 \let\swap=\leftrightarrow
37 \def\round{\mathop{\rm round}\nolimits}
38 \mathchardef\vb="026A % synonym for `\|'
40 \def\(#1){} % this is used to make section names sort themselves better
41 \def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
48 This is \MP\ by John Hobby, a graphics-language processor based on D. E. Knuth's \MF.
50 Much of the original Pascal version of this program was copied with
51 permission from MF.web Version 1.9. It interprets a language very
52 similar to D.E. Knuth's METAFONT, but with changes designed to make it
53 more suitable for PostScript output.
55 The main purpose of the following program is to explain the algorithms of \MP\
56 as clearly as possible. However, the program has been written so that it
57 can be tuned to run efficiently in a wide variety of operating environments
58 by making comparatively few changes. Such flexibility is possible because
59 the documentation that follows is written in the \.{WEB} language, which is
60 at a higher level than C.
62 A large piece of software like \MP\ has inherent complexity that cannot
63 be reduced below a certain level of difficulty, although each individual
64 part is fairly simple by itself. The \.{WEB} language is intended to make
65 the algorithms as readable as possible, by reflecting the way the
66 individual program pieces fit together and by providing the
67 cross-references that connect different parts. Detailed comments about
68 what is going on, and about why things were done in certain ways, have
69 been liberally sprinkled throughout the program. These comments explain
70 features of the implementation, but they rarely attempt to explain the
71 \MP\ language itself, since the reader is supposed to be familiar with
72 {\sl The {\logos METAFONT\/}book} as well as the manual
74 @:METAFONTbook}{\sl The {\logos METAFONT\/}book}@>
75 {\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
76 AT\AM T Bell Laboratories.
78 @ The present implementation is a preliminary version, but the possibilities
79 for new features are limited by the desire to remain as nearly compatible
80 with \MF\ as possible.
82 On the other hand, the \.{WEB} description can be extended without changing
83 the core of the program, and it has been designed so that such
84 extensions are not extremely difficult to make.
85 The |banner| string defined here should be changed whenever \MP\
86 undergoes any modifications, so that it will be clear which version of
87 \MP\ might be the guilty party when a problem arises.
89 @^system dependencies@>
91 @d default_banner "This is MetaPost, Version 1.080" /* printed when \MP\ starts */
92 @d metapost_version "1.080"
97 @ The external library header for \MP\ is |mplib.h|. It contains a
98 few typedefs and the header defintions for the externally used
101 The most important of the typedefs is the definition of the structure
102 |MP_options|, that acts as a small, configurable front-end to the fairly
103 large |MP_instance| structure.
106 typedef struct MP_instance * MP;
108 typedef struct MP_options {
111 @<Exported function headers@>
113 @ The internal header file is much longer: it not only lists the complete
114 |MP_instance|, but also a lot of functions that have to be available to
115 the \ps\ backend, that is defined in a separate \.{WEB} file.
117 The variables from |MP_options| are included inside the |MP_instance|
122 typedef struct psout_data_struct * psout_data;
130 @<Types in the outer block@>
131 @<Constants in the outer block@>
132 # ifndef LIBAVL_ALLOCATOR
133 # define LIBAVL_ALLOCATOR
134 struct libavl_allocator {
135 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
136 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
139 typedef struct MP_instance {
143 @<Internal library declarations@>
152 #include <unistd.h> /* for access() */
153 #include <time.h> /* for struct tm \& co */
155 #include "psout.h" /* external header */
156 #include "mpmp.h" /* internal header */
157 #include "mppsout.h" /* internal header */
160 @<Basic printing procedures@>
161 @<Error handling procedures@>
163 @ Here are the functions that set up the \MP\ instance.
166 @<Declare |mp_reallocate| functions@>
167 MP_options *mp_options (void);
168 MP mp_initialize (MP_options *opt);
171 MP_options *mp_options (void) {
173 size_t l = sizeof(MP_options);
177 opt->ini_version = true;
182 @ The whole instance structure is initialized with zeroes,
183 this greatly reduces the number of statements needed in
184 the |Allocate or initialize variables| block.
186 @d set_callback_option(A) do { mp->A = mp_##A;
187 if (opt->A!=NULL) mp->A = opt->A;
192 mp_do_new (jmp_buf *buf) {
193 MP mp = malloc(sizeof(MP_instance));
196 memset(mp,0,sizeof(MP_instance));
202 static void mp_free (MP mp) {
203 int k; /* loop variable */
204 @<Dealloc variables@>
205 if (mp->noninteractive) {
206 @<Finish non-interactive use@>;
212 void mp_do_initialize ( MP mp) {
213 @<Local variables for initialization@>
214 @<Set initial values of key variables@>
217 @ This procedure gets things started properly.
219 MP mp_initialize (MP_options *opt) {
222 @<Setup the non-local jump buffer in |mp_new|@>;
223 mp = mp_do_new(&buf);
226 mp->userdata=opt->userdata;
227 @<Set |ini_version|@>;
228 mp->noninteractive=opt->noninteractive;
229 set_callback_option(find_file);
230 set_callback_option(open_file);
231 set_callback_option(read_ascii_file);
232 set_callback_option(read_binary_file);
233 set_callback_option(close_file);
234 set_callback_option(eof_file);
235 set_callback_option(flush_file);
236 set_callback_option(write_ascii_file);
237 set_callback_option(write_binary_file);
238 set_callback_option(shipout_backend);
239 if (opt->banner && *(opt->banner)) {
240 mp->banner = xstrdup(opt->banner);
242 mp->banner = xstrdup(default_banner);
244 if (opt->command_line && *(opt->command_line))
245 mp->command_line = xstrdup(opt->command_line);
246 if (mp->noninteractive) {
247 @<Prepare function pointers for non-interactive use@>;
249 /* open the terminal for output */
251 @<Find constant sizes@>;
252 @<Allocate or initialize variables@>
253 mp_reallocate_memory(mp,mp->mem_max);
254 mp_reallocate_paths(mp,1000);
255 mp_reallocate_fonts(mp,8);
256 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
257 @<Check the ``constant'' values...@>;
260 mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
261 "---case %i",(int)mp->bad);
262 do_fprintf(mp->err_out,(char *)ss);
266 mp_do_initialize(mp); /* erase preloaded mem */
267 if (mp->ini_version) {
268 @<Run inimpost commands@>;
270 if (!mp->noninteractive) {
271 @<Initialize the output routines@>;
272 @<Get the first line of input and prepare to start@>;
273 @<Initializations after first line is read@>;
275 mp->history=mp_spotless;
280 @ @<Initializations after first line is read@>=
282 mp_init_map_file(mp, mp->troff_mode);
283 mp->history=mp_spotless; /* ready to go! */
284 if (mp->troff_mode) {
285 mp->internal[mp_gtroffmode]=unity;
286 mp->internal[mp_prologues]=unity;
288 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
289 mp->cur_sym=mp->start_sym; mp_back_input(mp);
292 @ @<Exported function headers@>=
293 extern MP_options *mp_options (void);
294 extern MP mp_initialize (MP_options *opt) ;
295 extern int mp_status(MP mp);
296 extern void *mp_userdata(MP mp);
299 int mp_status(MP mp) { return mp->history; }
302 void *mp_userdata(MP mp) { return mp->userdata; }
304 @ The overall \MP\ program begins with the heading just shown, after which
305 comes a bunch of procedure declarations and function declarations.
306 Finally we will get to the main program, which begins with the
307 comment `|start_here|'. If you want to skip down to the
308 main program now, you can look up `|start_here|' in the index.
309 But the author suggests that the best way to understand this program
310 is to follow pretty much the order of \MP's components as they appear in the
311 \.{WEB} description you are now reading, since the present ordering is
312 intended to combine the advantages of the ``bottom up'' and ``top down''
313 approaches to the problem of understanding a somewhat complicated system.
315 @ Some of the code below is intended to be used only when diagnosing the
316 strange behavior that sometimes occurs when \MP\ is being installed or
317 when system wizards are fooling around with \MP\ without quite knowing
318 what they are doing. Such code will not normally be compiled; it is
319 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
321 @ This program has two important variations: (1) There is a long and slow
322 version called \.{INIMP}, which does the extra calculations needed to
324 initialize \MP's internal tables; and (2)~there is a shorter and faster
325 production version, which cuts the initialization to a bare minimum.
327 Which is which is decided at runtime.
329 @ The following parameters can be changed at compile time to extend or
330 reduce \MP's capacity. They may have different values in \.{INIMP} and
331 in production versions of \MP.
333 @^system dependencies@>
336 #define file_name_size 255 /* file names shouldn't be longer than this */
337 #define bistack_size 1500 /* size of stack for bisection algorithms;
338 should probably be left at this value */
340 @ Like the preceding parameters, the following quantities can be changed
341 to extend or reduce \MP's capacity. But if they are changed,
342 it is necessary to rerun the initialization program \.{INIMP}
344 to generate new tables for the production \MP\ program.
345 One can't simply make helter-skelter changes to the following constants,
346 since certain rather complex initialization
347 numbers are computed from them.
350 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
351 int pool_size; /* maximum number of characters in strings, including all
352 error messages and help texts, and the names of all identifiers */
353 int mem_max; /* greatest index in \MP's internal |mem| array;
354 must be strictly less than |max_halfword|;
355 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
356 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
357 must not be greater than |mem_max| */
358 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
360 @ @<Option variables@>=
361 int error_line; /* width of context lines on terminal error messages */
362 int half_error_line; /* width of first lines of contexts in terminal
363 error messages; should be between 30 and |error_line-15| */
364 int max_print_line; /* width of longest text lines output; should be at least 60 */
365 unsigned hash_size; /* maximum number of symbolic tokens,
366 must be less than |max_halfword-3*param_size| */
367 int param_size; /* maximum number of simultaneous macro parameters */
368 int max_in_open; /* maximum number of input files and error insertions that
369 can be going on simultaneously */
370 int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
371 void *userdata; /* this allows the calling application to setup local */
372 char *banner; /* the banner that is printed to the screen and log */
374 @ @<Dealloc variables@>=
378 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
383 set_value(mp->error_line,opt->error_line,79);
384 set_value(mp->half_error_line,opt->half_error_line,50);
385 if (mp->half_error_line>mp->error_line-15 )
386 mp->half_error_line = mp->error_line-15;
387 set_value(mp->max_print_line,opt->max_print_line,100);
389 @ In case somebody has inadvertently made bad settings of the ``constants,''
390 \MP\ checks them using a global variable called |bad|.
392 This is the second of many sections of \MP\ where global variables are
396 integer bad; /* is some ``constant'' wrong? */
398 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
399 or something similar. (We can't do that until |max_halfword| has been defined.)
401 In case you are wondering about the non-consequtive values of |bad|: some
402 of the things that used to be WEB constants are now runtime variables
403 with checking at assignment time.
405 @<Check the ``constant'' values for consistency@>=
407 if ( mp->mem_top<=1100 ) mp->bad=4;
409 @ Some |goto| labels are used by the following definitions. The label
410 `|restart|' is occasionally used at the very beginning of a procedure; and
411 the label `|reswitch|' is occasionally used just prior to a |case|
412 statement in which some cases change the conditions and we wish to branch
413 to the newly applicable case. Loops that are set up with the |loop|
414 construction defined below are commonly exited by going to `|done|' or to
415 `|found|' or to `|not_found|', and they are sometimes repeated by going to
416 `|continue|'. If two or more parts of a subroutine start differently but
417 end up the same, the shared code may be gathered together at
420 @ Here are some macros for common programming idioms.
422 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
423 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
424 @d negate(A) (A)=-(A) /* change the sign of a variable */
425 @d double(A) (A)=(A)+(A)
427 @d do_nothing /* empty statement */
429 @* \[2] The character set.
430 In order to make \MP\ readily portable to a wide variety of
431 computers, all of its input text is converted to an internal eight-bit
432 code that includes standard ASCII, the ``American Standard Code for
433 Information Interchange.'' This conversion is done immediately when each
434 character is read in. Conversely, characters are converted from ASCII to
435 the user's external representation just before they are output to a
439 Such an internal code is relevant to users of \MP\ only with respect to
440 the \&{char} and \&{ASCII} operations, and the comparison of strings.
442 @ Characters of text that have been converted to \MP's internal form
443 are said to be of type |ASCII_code|, which is a subrange of the integers.
446 typedef unsigned char ASCII_code; /* eight-bit numbers */
448 @ The present specification of \MP\ has been written under the assumption
449 that the character set contains at least the letters and symbols associated
450 with ASCII codes 040 through 0176; all of these characters are now
451 available on most computer terminals.
454 typedef unsigned char text_char; /* the data type of characters in text files */
456 @ @<Local variables for init...@>=
459 @ The \MP\ processor converts between ASCII code and
460 the user's external character set by means of arrays |xord| and |xchr|
461 that are analogous to Pascal's |ord| and |chr| functions.
463 @d xchr(A) mp->xchr[(A)]
464 @d xord(A) mp->xord[(A)]
467 ASCII_code xord[256]; /* specifies conversion of input characters */
468 text_char xchr[256]; /* specifies conversion of output characters */
470 @ The core system assumes all 8-bit is acceptable. If it is not,
471 a change file has to alter the below section.
472 @^system dependencies@>
474 Additionally, people with extended character sets can
475 assign codes arbitrarily, giving an |xchr| equivalent to whatever
476 characters the users of \MP\ are allowed to have in their input files.
477 Appropriate changes to \MP's |char_class| table should then be made.
478 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
479 codes, called the |char_class|.) Such changes make portability of programs
480 more difficult, so they should be introduced cautiously if at all.
481 @^character set dependencies@>
482 @^system dependencies@>
485 for (i=0;i<=0377;i++) { xchr(i)=(text_char)i; }
487 @ The following system-independent code makes the |xord| array contain a
488 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
489 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
490 |j| or more; hence, standard ASCII code numbers will be used instead of
491 codes below 040 in case there is a coincidence.
494 for (i=0;i<=255;i++) {
497 for (i=0200;i<=0377;i++) { xord(xchr(i))=(ASCII_code)i;}
498 for (i=0;i<=0176;i++) { xord(xchr(i))=(ASCII_code)i;}
500 @* \[3] Input and output.
501 The bane of portability is the fact that different operating systems treat
502 input and output quite differently, perhaps because computer scientists
503 have not given sufficient attention to this problem. People have felt somehow
504 that input and output are not part of ``real'' programming. Well, it is true
505 that some kinds of programming are more fun than others. With existing
506 input/output conventions being so diverse and so messy, the only sources of
507 joy in such parts of the code are the rare occasions when one can find a
508 way to make the program a little less bad than it might have been. We have
509 two choices, either to attack I/O now and get it over with, or to postpone
510 I/O until near the end. Neither prospect is very attractive, so let's
513 The basic operations we need to do are (1)~inputting and outputting of
514 text, to or from a file or the user's terminal; (2)~inputting and
515 outputting of eight-bit bytes, to or from a file; (3)~instructing the
516 operating system to initiate (``open'') or to terminate (``close'') input or
517 output from a specified file; (4)~testing whether the end of an input
518 file has been reached; (5)~display of bits on the user's screen.
519 The bit-display operation will be discussed in a later section; we shall
520 deal here only with more traditional kinds of I/O.
522 @ Finding files happens in a slightly roundabout fashion: the \MP\
523 instance object contains a field that holds a function pointer that finds a
524 file, and returns its name, or NULL. For this, it receives three
525 parameters: the non-qualified name |fname|, the intended |fopen|
526 operation type |fmode|, and the type of the file |ftype|.
528 The file types that are passed on in |ftype| can be used to
529 differentiate file searches if a library like kpathsea is used,
530 the fopen mode is passed along for the same reason.
533 typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
535 @ @<Exported types@>=
537 mp_filetype_terminal = 0, /* the terminal */
538 mp_filetype_error, /* the terminal */
539 mp_filetype_program , /* \MP\ language input */
540 mp_filetype_log, /* the log file */
541 mp_filetype_postscript, /* the postscript output */
542 mp_filetype_memfile, /* memory dumps */
543 mp_filetype_metrics, /* TeX font metric files */
544 mp_filetype_fontmap, /* PostScript font mapping files */
545 mp_filetype_font, /* PostScript type1 font programs */
546 mp_filetype_encoding, /* PostScript font encoding files */
547 mp_filetype_text /* first text file for readfrom and writeto primitives */
549 typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
550 typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
551 typedef char *(*mp_file_reader)(MP, void *, size_t *);
552 typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
553 typedef void (*mp_file_closer)(MP, void *);
554 typedef int (*mp_file_eoftest)(MP, void *);
555 typedef void (*mp_file_flush)(MP, void *);
556 typedef void (*mp_file_writer)(MP, void *, const char *);
557 typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
559 @ @<Option variables@>=
560 mp_file_finder find_file;
561 mp_file_opener open_file;
562 mp_file_reader read_ascii_file;
563 mp_binfile_reader read_binary_file;
564 mp_file_closer close_file;
565 mp_file_eoftest eof_file;
566 mp_file_flush flush_file;
567 mp_file_writer write_ascii_file;
568 mp_binfile_writer write_binary_file;
570 @ The default function for finding files is |mp_find_file|. It is
571 pretty stupid: it will only find files in the current directory.
573 This function may disappear altogether, it is currently only
574 used for the default font map file.
577 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
579 if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
580 return strdup(fname);
585 @ Because |mp_find_file| is used so early, it has to be in the helpers
589 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
590 void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
591 char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
592 void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
593 void mp_close_file (MP mp, void *f) ;
594 int mp_eof_file (MP mp, void *f) ;
595 void mp_flush_file (MP mp, void *f) ;
596 void mp_write_ascii_file (MP mp, void *f, const char *s) ;
597 void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
599 @ The function to open files can now be very short.
602 void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
605 realmode[0] = *fmode;
608 if (ftype==mp_filetype_terminal) {
609 return (fmode[0] == 'r' ? stdin : stdout);
610 } else if (ftype==mp_filetype_error) {
612 } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
613 return (void *)fopen(fname, realmode);
618 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
621 char name_of_file[file_name_size+1]; /* the name of a system file */
622 int name_length;/* this many characters are actually
623 relevant in |name_of_file| (the rest are blank) */
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,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, void **f, int ftype) {
660 /* open a text file for input */
664 boolean mp_w_open_in (MP mp, void **f) {
665 /* open a word file for input */
666 *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
667 return (*f ? true : false);
670 boolean mp_a_open_out (MP mp, void **f, int ftype) {
671 /* open a text file for output */
675 boolean mp_b_open_out (MP mp, void **f, int ftype) {
676 /* open a binary file for output */
680 boolean mp_w_open_out (MP mp, void **f) {
681 /* open a word file for output */
682 int ftype = mp_filetype_memfile;
687 char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
689 size_t len = 0, lim = 128;
691 FILE *f = (FILE *)ff;
693 (void) mp; /* for -Wunused */
700 if (s==NULL) return NULL;
701 while (c!=EOF && c!='\n' && c!='\r') {
703 s =realloc(s, (lim+(lim>>2)));
704 if (s==NULL) return NULL;
712 if (c!=EOF && c!='\n')
721 void mp_write_ascii_file (MP mp, void *f, const char *s) {
729 void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
733 len = fread(*data,1,*size,(FILE *)f);
738 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
741 (void)fwrite(s,size,1,(FILE *)f);
746 void mp_close_file (MP mp, void *f) {
753 int mp_eof_file (MP mp, void *f) {
756 return feof((FILE *)f);
762 void mp_flush_file (MP mp, void *f) {
768 @ Input from text files is read one line at a time, using a routine called
769 |input_ln|. This function is defined in terms of global variables called
770 |buffer|, |first|, and |last| that will be described in detail later; for
771 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
772 values, and that |first| and |last| are indices into this array
773 representing the beginning and ending of a line of text.
776 size_t buf_size; /* maximum number of characters simultaneously present in
777 current lines of open files */
778 ASCII_code *buffer; /* lines of characters being read */
779 size_t first; /* the first unused position in |buffer| */
780 size_t last; /* end of the line just input to |buffer| */
781 size_t max_buf_stack; /* largest index used in |buffer| */
783 @ @<Allocate or initialize ...@>=
785 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
787 @ @<Dealloc variables@>=
791 void mp_reallocate_buffer(MP mp, size_t l) {
793 if (l>max_halfword) {
794 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
796 buffer = xmalloc((l+1),sizeof(ASCII_code));
797 memcpy(buffer,mp->buffer,(mp->buf_size+1));
799 mp->buffer = buffer ;
803 @ The |input_ln| function brings the next line of input from the specified
804 field into available positions of the buffer array and returns the value
805 |true|, unless the file has already been entirely read, in which case it
806 returns |false| and sets |last:=first|. In general, the |ASCII_code|
807 numbers that represent the next line of the file are input into
808 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
809 global variable |last| is set equal to |first| plus the length of the
810 line. Trailing blanks are removed from the line; thus, either |last=first|
811 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
814 The variable |max_buf_stack|, which is used to keep track of how large
815 the |buf_size| parameter must be to accommodate the present job, is
816 also kept up to date by |input_ln|.
819 boolean mp_input_ln (MP mp, void *f ) {
820 /* inputs the next line or returns |false| */
823 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
824 s = (mp->read_ascii_file)(mp,f, &size);
828 mp->last = mp->first+size;
829 if ( mp->last>=mp->max_buf_stack ) {
830 mp->max_buf_stack=mp->last+1;
831 while ( mp->max_buf_stack>=mp->buf_size ) {
832 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
835 memcpy((mp->buffer+mp->first),s,size);
836 /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
842 @ The user's terminal acts essentially like other files of text, except
843 that it is used both for input and for output. When the terminal is
844 considered an input file, the file variable is called |term_in|, and when it
845 is considered an output file the file variable is |term_out|.
846 @^system dependencies@>
849 void * term_in; /* the terminal as an input file */
850 void * term_out; /* the terminal as an output file */
851 void * err_out; /* the terminal as an output file */
853 @ Here is how to open the terminal files. In the default configuration,
854 nothing happens except that the command line (if there is one) is copied
855 to the input buffer. The variable |command_line| will be filled by the
856 |main| procedure. The copying can not be done earlier in the program
857 logic because in the |INI| version, the |buffer| is also used for primitive
860 @d t_open_out do {/* open the terminal for text output */
861 mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
862 mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
864 @d t_open_in do { /* open the terminal for text input */
865 mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
866 if (mp->command_line!=NULL) {
867 mp->last = strlen(mp->command_line);
868 strncpy((char *)mp->buffer,mp->command_line,mp->last);
869 xfree(mp->command_line);
875 @<Option variables@>=
878 @ Sometimes it is necessary to synchronize the input/output mixture that
879 happens on the user's terminal, and three system-dependent
880 procedures are used for this
881 purpose. The first of these, |update_terminal|, is called when we want
882 to make sure that everything we have output to the terminal so far has
883 actually left the computer's internal buffers and been sent.
884 The second, |clear_terminal|, is called when we wish to cancel any
885 input that the user may have typed ahead (since we are about to
886 issue an unexpected error message). The third, |wake_up_terminal|,
887 is supposed to revive the terminal if the user has disabled it by
888 some instruction to the operating system. The following macros show how
889 these operations can be specified:
890 @^system dependencies@>
892 @d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
893 @d clear_terminal do_nothing /* clear the terminal input buffer */
894 @d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
895 /* cancel the user's cancellation of output */
897 @ We need a special routine to read the first line of \MP\ input from
898 the user's terminal. This line is different because it is read before we
899 have opened the transcript file; there is sort of a ``chicken and
900 egg'' problem here. If the user types `\.{input cmr10}' on the first
901 line, or if some macro invoked by that line does such an \.{input},
902 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
903 commands are performed during the first line of terminal input, the transcript
904 file will acquire its default name `\.{mpout.log}'. (The transcript file
905 will not contain error messages generated by the first line before the
906 first \.{input} command.)
908 The first line is even more special. It's nice to let the user start
909 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
910 such a case, \MP\ will operate as if the first line of input were
911 `\.{cmr10}', i.e., the first line will consist of the remainder of the
912 command line, after the part that invoked \MP.
914 @ Different systems have different ways to get started. But regardless of
915 what conventions are adopted, the routine that initializes the terminal
916 should satisfy the following specifications:
918 \yskip\textindent{1)}It should open file |term_in| for input from the
919 terminal. (The file |term_out| will already be open for output to the
922 \textindent{2)}If the user has given a command line, this line should be
923 considered the first line of terminal input. Otherwise the
924 user should be prompted with `\.{**}', and the first line of input
925 should be whatever is typed in response.
927 \textindent{3)}The first line of input, which might or might not be a
928 command line, should appear in locations |first| to |last-1| of the
931 \textindent{4)}The global variable |loc| should be set so that the
932 character to be read next by \MP\ is in |buffer[loc]|. This
933 character should not be blank, and we should have |loc<last|.
935 \yskip\noindent(It may be necessary to prompt the user several times
936 before a non-blank line comes in. The prompt is `\.{**}' instead of the
937 later `\.*' because the meaning is slightly different: `\.{input}' need
938 not be typed immediately after~`\.{**}'.)
940 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
943 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
946 loc = 0; mp->first = 0;
950 if (!mp->noninteractive) {
951 wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
954 if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
955 do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
956 @.End of file on the terminal@>
959 loc=(halfword)mp->first;
960 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
962 if ( loc<(int)mp->last ) {
963 return true; /* return unless the line was all blank */
965 if (!mp->noninteractive) {
966 do_fprintf(mp->term_out,"Please type the name of your input file.\n");
972 boolean mp_init_terminal (MP mp) ;
975 @* \[4] String handling.
976 Symbolic token names and diagnostic messages are variable-length strings
977 of eight-bit characters. Many strings \MP\ uses are simply literals
978 in the compiled source, like the error messages and the names of the
979 internal parameters. Other strings are used or defined from the \MP\ input
980 language, and these have to be interned.
982 \MP\ uses strings more extensively than \MF\ does, but the necessary
983 operations can still be handled with a fairly simple data structure.
984 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
985 of the strings, and the array |str_start| contains indices of the starting
986 points of each string. Strings are referred to by integer numbers, so that
987 string number |s| comprises the characters |str_pool[j]| for
988 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
989 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
990 location. The first string number not currently in use is |str_ptr|
991 and |next_str[str_ptr]| begins a list of free string numbers. String
992 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
993 string currently being constructed.
995 String numbers 0 to 255 are reserved for strings that correspond to single
996 ASCII characters. This is in accordance with the conventions of \.{WEB},
998 which converts single-character strings into the ASCII code number of the
999 single character involved, while it converts other strings into integers
1000 and builds a string pool file. Thus, when the string constant \.{"."} appears
1001 in the program below, \.{WEB} converts it into the integer 46, which is the
1002 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
1003 into some integer greater than~255. String number 46 will presumably be the
1004 single character `\..'\thinspace; but some ASCII codes have no standard visible
1005 representation, and \MP\ may need to be able to print an arbitrary
1006 ASCII character, so the first 256 strings are used to specify exactly what
1007 should be printed for each of the 256 possibilities.
1010 typedef int pool_pointer; /* for variables that point into |str_pool| */
1011 typedef int str_number; /* for variables that point into |str_start| */
1014 ASCII_code *str_pool; /* the characters */
1015 pool_pointer *str_start; /* the starting pointers */
1016 str_number *next_str; /* for linking strings in order */
1017 pool_pointer pool_ptr; /* first unused position in |str_pool| */
1018 str_number str_ptr; /* number of the current string being created */
1019 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
1020 str_number init_str_use; /* the initial number of strings in use */
1021 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
1022 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
1024 @ @<Allocate or initialize ...@>=
1025 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
1026 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
1027 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
1029 @ @<Dealloc variables@>=
1030 xfree(mp->str_pool);
1031 xfree(mp->str_start);
1032 xfree(mp->next_str);
1034 @ Most printing is done from |char *|s, but sometimes not. Here are
1035 functions that convert an internal string into a |char *| for use
1036 by the printing routines, and vice versa.
1038 @d str(A) mp_str(mp,A)
1039 @d rts(A) mp_rts(mp,A)
1043 int mp_xstrcmp (const char *a, const char *b);
1044 char * mp_str (MP mp, str_number s);
1047 str_number mp_rts (MP mp, const char *s);
1048 str_number mp_make_string (MP mp);
1051 int mp_xstrcmp (const char *a, const char *b) {
1052 if (a==NULL && b==NULL)
1061 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1062 very good: it does not handle nesting over more than one level.
1065 char * mp_str (MP mp, str_number ss) {
1068 if (ss==mp->str_ptr) {
1071 len = (size_t)length(ss);
1072 s = xmalloc(len+1,sizeof(char));
1073 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1078 str_number mp_rts (MP mp, const char *s) {
1079 int r; /* the new string */
1080 int old; /* a possible string in progress */
1084 } else if (strlen(s)==1) {
1088 str_room((integer)strlen(s));
1089 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1090 old = mp_make_string(mp);
1095 r = mp_make_string(mp);
1097 str_room(length(old));
1098 while (i<length(old)) {
1099 append_char((mp->str_start[old]+i));
1101 mp_flush_string(mp,old);
1107 @ Except for |strs_used_up|, the following string statistics are only
1108 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1112 integer strs_used_up; /* strings in use or unused but not reclaimed */
1113 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1114 integer strs_in_use; /* total number of strings actually in use */
1115 integer max_pl_used; /* maximum |pool_in_use| so far */
1116 integer max_strs_used; /* maximum |strs_in_use| so far */
1118 @ Several of the elementary string operations are performed using \.{WEB}
1119 macros instead of functions, because many of the
1120 operations are done quite frequently and we want to avoid the
1121 overhead of procedure calls. For example, here is
1122 a simple macro that computes the length of a string.
1125 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string \# */
1126 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1128 @ The length of the current string is called |cur_length|. If we decide that
1129 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1130 |cur_length| becomes zero.
1132 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1133 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1135 @ Strings are created by appending character codes to |str_pool|.
1136 The |append_char| macro, defined here, does not check to see if the
1137 value of |pool_ptr| has gotten too high; this test is supposed to be
1138 made before |append_char| is used.
1140 To test if there is room to append |l| more characters to |str_pool|,
1141 we shall write |str_room(l)|, which tries to make sure there is enough room
1142 by compacting the string pool if necessary. If this does not work,
1143 |do_compaction| aborts \MP\ and gives an apologetic error message.
1145 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1146 { mp->str_pool[mp->pool_ptr]=(ASCII_code)(A); incr(mp->pool_ptr);
1148 @d str_room(A) /* make sure that the pool hasn't overflowed */
1149 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1150 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1151 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1154 @ The following routine is similar to |str_room(1)| but it uses the
1155 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1156 string space is exhausted.
1158 @<Declare the procedure called |unit_str_room|@>=
1159 void mp_unit_str_room (MP mp);
1162 void mp_unit_str_room (MP mp) {
1163 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1164 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1167 @ \MP's string expressions are implemented in a brute-force way: Every
1168 new string or substring that is needed is simply copied into the string pool.
1169 Space is eventually reclaimed by a procedure called |do_compaction| with
1170 the aid of a simple system system of reference counts.
1171 @^reference counts@>
1173 The number of references to string number |s| will be |str_ref[s]|. The
1174 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1175 positive number of references; such strings will never be recycled. If
1176 a string is ever referred to more than 126 times, simultaneously, we
1177 put it in this category. Hence a single byte suffices to store each |str_ref|.
1179 @d max_str_ref 127 /* ``infinite'' number of references */
1180 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]); }
1185 @ @<Allocate or initialize ...@>=
1186 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1188 @ @<Dealloc variables@>=
1191 @ Here's what we do when a string reference disappears:
1193 @d delete_str_ref(A) {
1194 if ( mp->str_ref[(A)]<max_str_ref ) {
1195 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1196 else mp_flush_string(mp, (A));
1200 @<Declare the procedure called |flush_string|@>=
1201 void mp_flush_string (MP mp,str_number s) ;
1204 @ We can't flush the first set of static strings at all, so there
1205 is no point in trying
1208 void mp_flush_string (MP mp,str_number s) {
1210 mp->pool_in_use=mp->pool_in_use-length(s);
1211 decr(mp->strs_in_use);
1212 if ( mp->next_str[s]!=mp->str_ptr ) {
1216 decr(mp->strs_used_up);
1218 mp->pool_ptr=mp->str_start[mp->str_ptr];
1222 @ C literals cannot be simply added, they need to be set so they can't
1225 @d intern(A) mp_intern(mp,(A))
1228 str_number mp_intern (MP mp, const char *s) {
1231 mp->str_ref[r] = max_str_ref;
1236 str_number mp_intern (MP mp, const char *s);
1239 @ Once a sequence of characters has been appended to |str_pool|, it
1240 officially becomes a string when the function |make_string| is called.
1241 This function returns the identification number of the new string as its
1244 When getting the next unused string number from the linked list, we pretend
1246 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1247 are linked sequentially even though the |next_str| entries have not been
1248 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1249 |do_compaction| is responsible for making sure of this.
1252 @<Declare the procedure called |do_compaction|@>
1253 @<Declare the procedure called |unit_str_room|@>
1254 str_number mp_make_string (MP mp);
1257 str_number mp_make_string (MP mp) { /* current string enters the pool */
1258 str_number s; /* the new string */
1261 mp->str_ptr=mp->next_str[s];
1262 if ( mp->str_ptr>mp->max_str_ptr ) {
1263 if ( mp->str_ptr==mp->max_strings ) {
1265 mp_do_compaction(mp, 0);
1268 mp->max_str_ptr=mp->str_ptr;
1269 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1273 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1274 incr(mp->strs_used_up);
1275 incr(mp->strs_in_use);
1276 mp->pool_in_use=mp->pool_in_use+length(s);
1277 if ( mp->pool_in_use>mp->max_pl_used )
1278 mp->max_pl_used=mp->pool_in_use;
1279 if ( mp->strs_in_use>mp->max_strs_used )
1280 mp->max_strs_used=mp->strs_in_use;
1284 @ The most interesting string operation is string pool compaction. The idea
1285 is to recover unused space in the |str_pool| array by recopying the strings
1286 to close the gaps created when some strings become unused. All string
1287 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1288 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1289 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1290 with |needed=mp->pool_size| supresses all overflow tests.
1292 The compaction process starts with |last_fixed_str| because all lower numbered
1293 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1296 str_number last_fixed_str; /* last permanently allocated string */
1297 str_number fixed_str_use; /* number of permanently allocated strings */
1299 @ @<Declare the procedure called |do_compaction|@>=
1300 void mp_do_compaction (MP mp, pool_pointer needed) ;
1303 void mp_do_compaction (MP mp, pool_pointer needed) {
1304 str_number str_use; /* a count of strings in use */
1305 str_number r,s,t; /* strings being manipulated */
1306 pool_pointer p,q; /* destination and source for copying string characters */
1307 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1308 r=mp->last_fixed_str;
1311 while ( s!=mp->str_ptr ) {
1312 while ( mp->str_ref[s]==0 ) {
1313 @<Advance |s| and add the old |s| to the list of free string numbers;
1314 then |break| if |s=str_ptr|@>;
1316 r=s; s=mp->next_str[s];
1318 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1319 after the end of the string@>;
1322 @<Move the current string back so that it starts at |p|@>;
1323 if ( needed<mp->pool_size ) {
1324 @<Make sure that there is room for another string with |needed| characters@>;
1326 @<Account for the compaction and make sure the statistics agree with the
1328 mp->strs_used_up=str_use;
1331 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1332 t=mp->next_str[mp->last_fixed_str];
1333 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1334 incr(mp->fixed_str_use);
1335 mp->last_fixed_str=t;
1338 str_use=mp->fixed_str_use
1340 @ Because of the way |flush_string| has been written, it should never be
1341 necessary to |break| here. The extra line of code seems worthwhile to
1342 preserve the generality of |do_compaction|.
1344 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1349 mp->next_str[t]=mp->next_str[mp->str_ptr];
1350 mp->next_str[mp->str_ptr]=t;
1351 if ( s==mp->str_ptr ) goto DONE;
1354 @ The string currently starts at |str_start[r]| and ends just before
1355 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1356 to locate the next string.
1358 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1361 while ( q<mp->str_start[s] ) {
1362 mp->str_pool[p]=mp->str_pool[q];
1366 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1367 we do this, anything between them should be moved.
1369 @ @<Move the current string back so that it starts at |p|@>=
1370 q=mp->str_start[mp->str_ptr];
1371 mp->str_start[mp->str_ptr]=p;
1372 while ( q<mp->pool_ptr ) {
1373 mp->str_pool[p]=mp->str_pool[q];
1378 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1380 @<Make sure that there is room for another string with |needed| char...@>=
1381 if ( str_use>=mp->max_strings-1 )
1382 mp_reallocate_strings (mp,str_use);
1383 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1384 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1385 mp->max_pool_ptr=mp->pool_ptr+needed;
1389 void mp_reallocate_strings (MP mp, str_number str_use) ;
1390 void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1393 void mp_reallocate_strings (MP mp, str_number str_use) {
1394 while ( str_use>=mp->max_strings-1 ) {
1395 int l = mp->max_strings + (mp->max_strings/4);
1396 XREALLOC (mp->str_ref, l, int);
1397 XREALLOC (mp->str_start, l, pool_pointer);
1398 XREALLOC (mp->next_str, l, str_number);
1399 mp->max_strings = l;
1402 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1403 while ( needed>mp->pool_size ) {
1404 int l = mp->pool_size + (mp->pool_size/4);
1405 XREALLOC (mp->str_pool, l, ASCII_code);
1410 @ @<Account for the compaction and make sure the statistics agree with...@>=
1411 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1412 mp_confusion(mp, "string");
1413 @:this can't happen string}{\quad string@>
1414 incr(mp->pact_count);
1415 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1416 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1418 @ A few more global variables are needed to keep track of statistics when
1419 |stat| $\ldots$ |tats| blocks are not commented out.
1422 integer pact_count; /* number of string pool compactions so far */
1423 integer pact_chars; /* total number of characters moved during compactions */
1424 integer pact_strs; /* total number of strings moved during compactions */
1426 @ @<Initialize compaction statistics@>=
1431 @ The following subroutine compares string |s| with another string of the
1432 same length that appears in |buffer| starting at position |k|;
1433 the result is |true| if and only if the strings are equal.
1436 boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1437 /* test equality of strings */
1438 pool_pointer j; /* running index */
1440 while ( j<str_stop(s) ) {
1441 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1447 @ Here is a similar routine, but it compares two strings in the string pool,
1448 and it does not assume that they have the same length. If the first string
1449 is lexicographically greater than, less than, or equal to the second,
1450 the result is respectively positive, negative, or zero.
1453 integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1454 /* test equality of strings */
1455 pool_pointer j,k; /* running indices */
1456 integer ls,lt; /* lengths */
1457 integer l; /* length remaining to test */
1458 ls=length(s); lt=length(t);
1459 if ( ls<=lt ) l=ls; else l=lt;
1460 j=mp->str_start[s]; k=mp->str_start[t];
1462 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1463 return (mp->str_pool[j]-mp->str_pool[k]);
1470 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1471 and |str_ptr| are computed by the \.{INIMP} program, based in part
1472 on the information that \.{WEB} has output while processing \MP.
1477 void mp_get_strings_started (MP mp) {
1478 /* initializes the string pool,
1479 but returns |false| if something goes wrong */
1480 int k; /* small indices or counters */
1481 str_number g; /* a new string */
1482 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1485 mp->pool_in_use=0; mp->strs_in_use=0;
1486 mp->max_pl_used=0; mp->max_strs_used=0;
1487 @<Initialize compaction statistics@>;
1489 @<Make the first 256 strings@>;
1490 g=mp_make_string(mp); /* string 256 == "" */
1491 mp->str_ref[g]=max_str_ref;
1492 mp->last_fixed_str=mp->str_ptr-1;
1493 mp->fixed_str_use=mp->str_ptr;
1498 void mp_get_strings_started (MP mp);
1500 @ The first 256 strings will consist of a single character only.
1502 @<Make the first 256...@>=
1503 for (k=0;k<=255;k++) {
1505 g=mp_make_string(mp);
1506 mp->str_ref[g]=max_str_ref;
1509 @ The first 128 strings will contain 95 standard ASCII characters, and the
1510 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1511 unless a system-dependent change is made here. Installations that have
1512 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1513 would like string 032 to be printed as the single character 032 instead
1514 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1515 even people with an extended character set will want to represent string
1516 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1517 to produce visible strings instead of tabs or line-feeds or carriage-returns
1518 or bell-rings or characters that are treated anomalously in text files.
1520 The boolean expression defined here should be |true| unless \MP\ internal
1521 code number~|k| corresponds to a non-troublesome visible symbol in the
1522 local character set.
1523 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1524 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1526 @^character set dependencies@>
1527 @^system dependencies@>
1529 @<Character |k| cannot be printed@>=
1532 @* \[5] On-line and off-line printing.
1533 Messages that are sent to a user's terminal and to the transcript-log file
1534 are produced by several `|print|' procedures. These procedures will
1535 direct their output to a variety of places, based on the setting of
1536 the global variable |selector|, which has the following possible
1540 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1543 \hang |log_only|, prints only on the transcript file.
1545 \hang |term_only|, prints only on the terminal.
1547 \hang |no_print|, doesn't print at all. This is used only in rare cases
1548 before the transcript file is open.
1550 \hang |pseudo|, puts output into a cyclic buffer that is used
1551 by the |show_context| routine; when we get to that routine we shall discuss
1552 the reasoning behind this curious mode.
1554 \hang |new_string|, appends the output to the current string in the
1557 \hang |>=write_file| prints on one of the files used for the \&{write}
1558 @:write_}{\&{write} primitive@>
1562 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1563 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1564 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1565 relations are not used when |selector| could be |pseudo|, or |new_string|.
1566 We need not check for unprintable characters when |selector<pseudo|.
1568 Three additional global variables, |tally|, |term_offset| and |file_offset|
1569 record the number of characters that have been printed
1570 since they were most recently cleared to zero. We use |tally| to record
1571 the length of (possibly very long) stretches of printing; |term_offset|,
1572 and |file_offset|, on the other hand, keep track of how many
1573 characters have appeared so far on the current line that has been output
1574 to the terminal, the transcript file, or the \ps\ output file, respectively.
1576 @d new_string 0 /* printing is deflected to the string pool */
1577 @d pseudo 2 /* special |selector| setting for |show_context| */
1578 @d no_print 3 /* |selector| setting that makes data disappear */
1579 @d term_only 4 /* printing is destined for the terminal only */
1580 @d log_only 5 /* printing is destined for the transcript file only */
1581 @d term_and_log 6 /* normal |selector| setting */
1582 @d write_file 7 /* first write file selector */
1585 void * log_file; /* transcript of \MP\ session */
1586 void * ps_file; /* the generic font output goes here */
1587 unsigned int selector; /* where to print a message */
1588 unsigned char dig[23]; /* digits in a number, for rounding */
1589 integer tally; /* the number of characters recently printed */
1590 unsigned int term_offset;
1591 /* the number of characters on the current terminal line */
1592 unsigned int file_offset;
1593 /* the number of characters on the current file line */
1594 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1595 integer trick_count; /* threshold for pseudoprinting, explained later */
1596 integer first_count; /* another variable for pseudoprinting */
1598 @ @<Allocate or initialize ...@>=
1599 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1601 @ @<Dealloc variables@>=
1602 xfree(mp->trick_buf);
1604 @ @<Initialize the output routines@>=
1605 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
1607 @ Macro abbreviations for output to the terminal and to the log file are
1608 defined here for convenience. Some systems need special conventions
1609 for terminal output, and it is possible to adhere to those conventions
1610 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1611 @^system dependencies@>
1613 @d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
1614 @d wterm(A) do_fprintf(mp->term_out,(A))
1615 @d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0';
1616 do_fprintf(mp->term_out,(char *)ss); }
1617 @d wterm_cr do_fprintf(mp->term_out,"\n")
1618 @d wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
1619 @d wlog(A) do_fprintf(mp->log_file,(A))
1620 @d wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0';
1621 do_fprintf(mp->log_file,(char *)ss); }
1622 @d wlog_cr do_fprintf(mp->log_file, "\n")
1623 @d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
1626 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1627 use an array |wr_file| that will be declared later.
1629 @d mp_print_text(A) mp_print_str(mp,text((A)))
1632 void mp_print_ln (MP mp);
1633 void mp_print_visible_char (MP mp, ASCII_code s);
1634 void mp_print_char (MP mp, ASCII_code k);
1635 void mp_print (MP mp, const char *s);
1636 void mp_print_str (MP mp, str_number s);
1637 void mp_print_nl (MP mp, const char *s);
1638 void mp_print_two (MP mp,scaled x, scaled y) ;
1639 void mp_print_scaled (MP mp,scaled s);
1641 @ @<Basic print...@>=
1642 void mp_print_ln (MP mp) { /* prints an end-of-line */
1643 switch (mp->selector) {
1646 mp->term_offset=0; mp->file_offset=0;
1649 wlog_cr; mp->file_offset=0;
1652 wterm_cr; mp->term_offset=0;
1659 do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1661 } /* note that |tally| is not affected */
1663 @ The |print_visible_char| procedure sends one character to the desired
1664 destination, using the |xchr| array to map it into an external character
1665 compatible with |input_ln|. (It assumes that it is always called with
1666 a visible ASCII character.) All printing comes through |print_ln| or
1667 |print_char|, which ultimately calls |print_visible_char|, hence these
1668 routines are the ones that limit lines to at most |max_print_line| characters.
1669 But we must make an exception for the \ps\ output file since it is not safe
1670 to cut up lines arbitrarily in \ps.
1672 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1673 |do_compaction| and |do_compaction| can call the error routines. Actually,
1674 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1676 @<Basic printing...@>=
1677 void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1678 switch (mp->selector) {
1680 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1681 incr(mp->term_offset); incr(mp->file_offset);
1682 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1683 wterm_cr; mp->term_offset=0;
1685 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1686 wlog_cr; mp->file_offset=0;
1690 wlog_chr(xchr(s)); incr(mp->file_offset);
1691 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1694 wterm_chr(xchr(s)); incr(mp->term_offset);
1695 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1700 if ( mp->tally<mp->trick_count )
1701 mp->trick_buf[mp->tally % mp->error_line]=s;
1704 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1705 mp_unit_str_room(mp);
1706 if ( mp->pool_ptr>=mp->pool_size )
1707 goto DONE; /* drop characters if string space is full */
1712 { text_char ss[2]; ss[0] = xchr(s); ss[1]=0;
1713 do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
1720 @ The |print_char| procedure sends one character to the desired destination.
1721 File names and string expressions might contain |ASCII_code| values that
1722 can't be printed using |print_visible_char|. These characters will be
1723 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1724 (This procedure assumes that it is safe to bypass all checks for unprintable
1725 characters when |selector| is in the range |0..max_write_files-1|.
1726 The user might want to write unprintable characters.
1728 @<Basic printing...@>=
1729 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
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 int l; /* small index or counter */
1741 mp_print_visible_char(mp, xord(l<10 ? l+'0' : l-10+'a'));
1743 mp_print_visible_char(mp, xord(l<10 ? l+'0' : l-10+'a'));
1746 mp_print_visible_char(mp, k);
1750 @ An entire string is output by calling |print|. Note that if we are outputting
1751 the single standard ASCII character \.c, we could call |print("c")|, since
1752 |"c"=99| is the number of a single-character string, as explained above. But
1753 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1754 routine when it knows that this is safe. (The present implementation
1755 assumes that it is always safe to print a visible ASCII character.)
1756 @^system dependencies@>
1759 void mp_do_print (MP mp, const char *ss, size_t len) { /* prints string |s| */
1762 mp_print_char(mp, xord((int)ss[j])); incr(j);
1768 void mp_print (MP mp, const char *ss) {
1769 if (ss==NULL) return;
1770 mp_do_print(mp, ss,strlen(ss));
1772 void mp_print_str (MP mp, str_number s) {
1773 pool_pointer j; /* current character code position */
1774 if ( (s<0)||(s>mp->max_str_ptr) ) {
1775 mp_do_print(mp,"???",3); /* this can't happen */
1779 mp_do_print(mp, (char *)(mp->str_pool+j), (size_t)(str_stop(s)-j));
1783 @ Here is the very first thing that \MP\ prints: a headline that identifies
1784 the version number and base name. The |term_offset| variable is temporarily
1785 incorrect, but the discrepancy is not serious since we assume that the banner
1786 and mem identifier together will occupy at most |max_print_line|
1787 character positions.
1789 @<Initialize the output...@>=
1791 if (mp->mem_ident!=NULL)
1792 mp_print(mp,mp->mem_ident);
1796 @ The procedure |print_nl| is like |print|, but it makes sure that the
1797 string appears at the beginning of a new line.
1800 void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1801 switch(mp->selector) {
1803 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1806 if ( mp->file_offset>0 ) mp_print_ln(mp);
1809 if ( mp->term_offset>0 ) mp_print_ln(mp);
1815 } /* there are no other cases */
1819 @ The following procedure, which prints out the decimal representation of a
1820 given integer |n|, assumes that all integers fit nicely into a |int|.
1821 @^system dependencies@>
1824 void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1826 mp_snprintf(s,12,"%d", (int)n);
1831 void mp_print_int (MP mp,integer n);
1833 @ \MP\ also makes use of a trivial procedure to print two digits. The
1834 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1837 void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1839 mp_print_char(mp, xord('0'+(n / 10)));
1840 mp_print_char(mp, xord('0'+(n % 10)));
1845 void mp_print_dd (MP mp,integer n);
1847 @ Here is a procedure that asks the user to type a line of input,
1848 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1849 The input is placed into locations |first| through |last-1| of the
1850 |buffer| array, and echoed on the transcript file if appropriate.
1852 This procedure is never called when |interaction<mp_scroll_mode|.
1854 @d prompt_input(A) do {
1855 if (!mp->noninteractive) {
1856 wake_up_terminal; mp_print(mp, (A));
1859 } while (0) /* prints a string and gets a line of input */
1862 void mp_term_input (MP mp) { /* gets a line from the terminal */
1863 size_t k; /* index into |buffer| */
1864 if (mp->noninteractive) {
1865 if (!mp_input_ln(mp, mp->term_in ))
1866 longjmp(*(mp->jump_buf),1); /* chunk finished */
1867 mp->buffer[mp->last]=xord('%');
1869 update_terminal; /* Now the user sees the prompt for sure */
1870 if (!mp_input_ln(mp, mp->term_in )) {
1871 mp_fatal_error(mp, "End of file on the terminal!");
1872 @.End of file on the terminal@>
1874 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1875 decr(mp->selector); /* prepare to echo the input */
1876 if ( mp->last!=mp->first ) {
1877 for (k=mp->first;k<=mp->last-1;k++) {
1878 mp_print_char(mp, mp->buffer[k]);
1882 mp->buffer[mp->last]=xord('%');
1883 incr(mp->selector); /* restore previous status */
1887 @* \[6] Reporting errors.
1888 When something anomalous is detected, \MP\ typically does something like this:
1889 $$\vbox{\halign{#\hfil\cr
1890 |print_err("Something anomalous has been detected");|\cr
1891 |help3("This is the first line of my offer to help.")|\cr
1892 |("This is the second line. I'm trying to")|\cr
1893 |("explain the best way for you to proceed.");|\cr
1895 A two-line help message would be given using |help2|, etc.; these informal
1896 helps should use simple vocabulary that complements the words used in the
1897 official error message that was printed. (Outside the U.S.A., the help
1898 messages should preferably be translated into the local vernacular. Each
1899 line of help is at most 60 characters long, in the present implementation,
1900 so that |max_print_line| will not be exceeded.)
1902 The |print_err| procedure supplies a `\.!' before the official message,
1903 and makes sure that the terminal is awake if a stop is going to occur.
1904 The |error| procedure supplies a `\..' after the official message, then it
1905 shows the location of the error; and if |interaction=error_stop_mode|,
1906 it also enters into a dialog with the user, during which time the help
1907 message may be printed.
1908 @^system dependencies@>
1910 @ The global variable |interaction| has four settings, representing increasing
1911 amounts of user interaction:
1914 enum mp_interaction_mode {
1915 mp_unspecified_mode=0, /* extra value for command-line switch */
1916 mp_batch_mode, /* omits all stops and omits terminal output */
1917 mp_nonstop_mode, /* omits all stops */
1918 mp_scroll_mode, /* omits error stops */
1919 mp_error_stop_mode /* stops at every opportunity to interact */
1922 @ @<Option variables@>=
1923 int interaction; /* current level of interaction */
1924 int noninteractive; /* do we have a terminal? */
1926 @ Set it here so it can be overwritten by the commandline
1928 @<Allocate or initialize ...@>=
1929 mp->interaction=opt->interaction;
1930 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
1931 mp->interaction=mp_error_stop_mode;
1932 if (mp->interaction<mp_unspecified_mode)
1933 mp->interaction=mp_batch_mode;
1937 @d print_err(A) mp_print_err(mp,(A))
1940 void mp_print_err(MP mp, const char * A);
1943 void mp_print_err(MP mp, const char * A) {
1944 if ( mp->interaction==mp_error_stop_mode )
1946 mp_print_nl(mp, "! ");
1952 @ \MP\ is careful not to call |error| when the print |selector| setting
1953 might be unusual. The only possible values of |selector| at the time of
1956 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
1957 and |log_file| not yet open);
1959 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
1961 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
1963 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
1965 @<Initialize the print |selector| based on |interaction|@>=
1966 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
1968 @ A global variable |deletions_allowed| is set |false| if the |get_next|
1969 routine is active when |error| is called; this ensures that |get_next|
1970 will never be called recursively.
1973 The global variable |history| records the worst level of error that
1974 has been detected. It has four possible values: |spotless|, |warning_issued|,
1975 |error_message_issued|, and |fatal_error_stop|.
1977 Another global variable, |error_count|, is increased by one when an
1978 |error| occurs without an interactive dialog, and it is reset to zero at
1979 the end of every statement. If |error_count| reaches 100, \MP\ decides
1980 that there is no point in continuing further.
1983 enum mp_history_states {
1984 mp_spotless=0, /* |history| value when nothing has been amiss yet */
1985 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
1986 mp_error_message_issued, /* |history| value when |error| has been called */
1987 mp_fatal_error_stop, /* |history| value when termination was premature */
1988 mp_system_error_stop /* |history| value when termination was due to disaster */
1992 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
1993 int history; /* has the source input been clean so far? */
1994 int error_count; /* the number of scrolled errors since the last statement ended */
1996 @ The value of |history| is initially |fatal_error_stop|, but it will
1997 be changed to |spotless| if \MP\ survives the initialization process.
1999 @<Allocate or ...@>=
2000 mp->deletions_allowed=true; /* |history| is initialized elsewhere */
2002 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2003 error procedures near the beginning of the program. But the error procedures
2004 in turn use some other procedures, which need to be declared |forward|
2005 before we get to |error| itself.
2007 It is possible for |error| to be called recursively if some error arises
2008 when |get_next| is being used to delete a token, and/or if some fatal error
2009 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2011 is never more than two levels deep.
2014 void mp_get_next (MP mp);
2015 void mp_term_input (MP mp);
2016 void mp_show_context (MP mp);
2017 void mp_begin_file_reading (MP mp);
2018 void mp_open_log_file (MP mp);
2019 void mp_clear_for_error_prompt (MP mp);
2020 @<Declare the procedure called |flush_string|@>
2023 void mp_normalize_selector (MP mp);
2025 @ Individual lines of help are recorded in the array |help_line|, which
2026 contains entries in positions |0..(help_ptr-1)|. They should be printed
2027 in reverse order, i.e., with |help_line[0]| appearing last.
2029 @d hlp1(A) mp->help_line[0]=A; }
2030 @d hlp2(A,B) mp->help_line[1]=A; hlp1(B)
2031 @d hlp3(A,B,C) mp->help_line[2]=A; hlp2(B,C)
2032 @d hlp4(A,B,C,D) mp->help_line[3]=A; hlp3(B,C,D)
2033 @d hlp5(A,B,C,D,E) mp->help_line[4]=A; hlp4(B,C,D,E)
2034 @d hlp6(A,B,C,D,E,F) mp->help_line[5]=A; hlp5(B,C,D,E,F)
2035 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2036 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2037 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2038 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2039 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2040 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2041 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2044 const char * help_line[6]; /* helps for the next |error| */
2045 unsigned int help_ptr; /* the number of help lines present */
2046 boolean use_err_help; /* should the |err_help| string be shown? */
2047 str_number err_help; /* a string set up by \&{errhelp} */
2048 str_number filename_template; /* a string set up by \&{filenametemplate} */
2050 @ @<Allocate or ...@>=
2051 mp->use_err_help=false;
2053 @ The |jump_out| procedure just cuts across all active procedure levels and
2054 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2055 whole program. It is used when there is no recovery from a particular error.
2057 The program uses a |jump_buf| to handle this, this is initialized at three
2058 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2059 of |mp_run|. Those are the only library enty points.
2061 @^system dependencies@>
2066 @ @<Install and test the non-local jump buffer@>=
2067 mp->jump_buf = &buf;
2068 if (setjmp(*(mp->jump_buf)) != 0) { return mp->history; }
2070 @ @<Setup the non-local jump buffer in |mp_new|@>=
2071 if (setjmp(buf) != 0) { return NULL; }
2074 @ If the array of internals is still |NULL| when |jump_out| is called, a
2075 crash occured during initialization, and it is not safe to run the normal
2079 void mp_jump_out (MP mp) {
2080 if (mp->internal!=NULL && mp->history < mp_system_error_stop)
2081 mp_close_files_and_terminate(mp);
2082 longjmp(*(mp->jump_buf),1);
2085 @ Here now is the general |error| routine.
2088 void mp_error (MP mp) { /* completes the job of error reporting */
2089 ASCII_code c; /* what the user types */
2090 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2091 pool_pointer j; /* character position being printed */
2092 if ( mp->history<mp_error_message_issued )
2093 mp->history=mp_error_message_issued;
2094 mp_print_char(mp, xord('.')); mp_show_context(mp);
2095 if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
2096 @<Get user's advice and |return|@>;
2098 incr(mp->error_count);
2099 if ( mp->error_count==100 ) {
2100 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2101 @.That makes 100 errors...@>
2102 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2104 @<Put help message on the transcript file@>;
2106 void mp_warn (MP mp, const char *msg) {
2107 unsigned saved_selector = mp->selector;
2108 mp_normalize_selector(mp);
2109 mp_print_nl(mp,"Warning: ");
2112 mp->selector = saved_selector;
2115 @ @<Exported function ...@>=
2116 void mp_error (MP mp);
2117 void mp_warn (MP mp, const char *msg);
2120 @ @<Get user's advice...@>=
2123 mp_clear_for_error_prompt(mp); prompt_input("? ");
2125 if ( mp->last==mp->first ) return;
2126 c=mp->buffer[mp->first];
2127 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2128 @<Interpret code |c| and |return| if done@>;
2131 @ It is desirable to provide an `\.E' option here that gives the user
2132 an easy way to return from \MP\ to the system editor, with the offending
2133 line ready to be edited. But such an extension requires some system
2134 wizardry, so the present implementation simply types out the name of the
2136 edited and the relevant line number.
2137 @^system dependencies@>
2140 typedef void (*mp_run_editor_command)(MP, char *, int);
2142 @ @<Option variables@>=
2143 mp_run_editor_command run_editor;
2145 @ @<Allocate or initialize ...@>=
2146 set_callback_option(run_editor);
2149 void mp_run_editor (MP mp, char *fname, int fline);
2151 @ @c void mp_run_editor (MP mp, char *fname, int fline) {
2152 mp_print_nl(mp, "You want to edit file ");
2153 @.You want to edit file x@>
2154 mp_print(mp, fname);
2155 mp_print(mp, " at line ");
2156 mp_print_int(mp, fline);
2157 mp->interaction=mp_scroll_mode;
2162 There is a secret `\.D' option available when the debugging routines haven't
2166 @<Interpret code |c| and |return| if done@>=
2168 case '0': case '1': case '2': case '3': case '4':
2169 case '5': case '6': case '7': case '8': case '9':
2170 if ( mp->deletions_allowed ) {
2171 @<Delete |c-"0"| tokens and |continue|@>;
2175 if ( mp->file_ptr>0 ){
2176 (mp->run_editor)(mp,
2177 str(mp->input_stack[mp->file_ptr].name_field),
2182 @<Print the help information and |continue|@>;
2185 @<Introduce new material from the terminal and |return|@>;
2187 case 'Q': case 'R': case 'S':
2188 @<Change the interaction level and |return|@>;
2191 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2196 @<Print the menu of available options@>
2198 @ @<Print the menu...@>=
2200 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2201 @.Type <return> to proceed...@>
2202 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2203 mp_print_nl(mp, "I to insert something, ");
2204 if ( mp->file_ptr>0 )
2205 mp_print(mp, "E to edit your file,");
2206 if ( mp->deletions_allowed )
2207 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2208 mp_print_nl(mp, "H for help, X to quit.");
2211 @ Here the author of \MP\ apologizes for making use of the numerical
2212 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2213 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2214 @^Knuth, Donald Ervin@>
2216 @<Change the interaction...@>=
2218 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2219 mp_print(mp, "OK, entering ");
2221 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2222 case 'R': mp_print(mp, "nonstopmode"); break;
2223 case 'S': mp_print(mp, "scrollmode"); break;
2224 } /* there are no other cases */
2225 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2228 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2229 contain the material inserted by the user; otherwise another prompt will
2230 be given. In order to understand this part of the program fully, you need
2231 to be familiar with \MP's input stacks.
2233 @<Introduce new material...@>=
2235 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2236 if ( mp->last>mp->first+1 ) {
2237 loc=(halfword)(mp->first+1); mp->buffer[mp->first]=xord(' ');
2239 prompt_input("insert>"); loc=(halfword)mp->first;
2242 mp->first=mp->last+1; mp->cur_input.limit_field=(halfword)mp->last; return;
2245 @ We allow deletion of up to 99 tokens at a time.
2247 @<Delete |c-"0"| tokens...@>=
2249 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2250 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2251 c=xord(c*10+mp->buffer[mp->first+1]-'0'*11);
2255 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2256 @<Decrease the string reference count, if the current token is a string@>;
2259 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2260 help2("I have just deleted some text, as you asked.",
2261 "You can now delete more, or insert, or whatever.");
2262 mp_show_context(mp);
2266 @ @<Print the help info...@>=
2268 if ( mp->use_err_help ) {
2269 @<Print the string |err_help|, possibly on several lines@>;
2270 mp->use_err_help=false;
2272 if ( mp->help_ptr==0 ) {
2273 help2("Sorry, I don't know how to help in this situation.",
2274 "Maybe you should try asking a human?");
2277 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2278 } while (mp->help_ptr!=0);
2280 help4("Sorry, I already gave what help I could...",
2281 "Maybe you should try asking a human?",
2282 "An error might have occurred before I noticed any problems.",
2283 "``If all else fails, read the instructions.''");
2287 @ @<Print the string |err_help|, possibly on several lines@>=
2288 j=mp->str_start[mp->err_help];
2289 while ( j<str_stop(mp->err_help) ) {
2290 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2291 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2292 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2293 else { incr(j); mp_print_char(mp, xord('%')); };
2297 @ @<Put help message on the transcript file@>=
2298 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2299 if ( mp->use_err_help ) {
2300 mp_print_nl(mp, "");
2301 @<Print the string |err_help|, possibly on several lines@>;
2303 while ( mp->help_ptr>0 ){
2304 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2308 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2311 @ In anomalous cases, the print selector might be in an unknown state;
2312 the following subroutine is called to fix things just enough to keep
2313 running a bit longer.
2316 void mp_normalize_selector (MP mp) {
2317 if ( mp->log_opened ) mp->selector=term_and_log;
2318 else mp->selector=term_only;
2319 if ( mp->job_name==NULL) mp_open_log_file(mp);
2320 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2323 @ The following procedure prints \MP's last words before dying.
2325 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2326 mp->interaction=mp_scroll_mode; /* no more interaction */
2327 if ( mp->log_opened ) mp_error(mp);
2328 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2332 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2333 mp_normalize_selector(mp);
2334 print_err("Emergency stop"); help1(s); succumb;
2338 @ @<Exported function ...@>=
2339 void mp_fatal_error (MP mp, const char *s);
2342 @ Here is the most dreaded error message.
2345 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2347 mp_normalize_selector(mp);
2348 mp_snprintf(msg, 256, "MetaPost capacity exceeded, sorry [%s=%d]",s,(int)n);
2349 @.MetaPost capacity exceeded ...@>
2351 help2("If you really absolutely need more capacity,",
2352 "you can ask a wizard to enlarge me.");
2356 @ @<Internal library declarations@>=
2357 void mp_overflow (MP mp, const char *s, integer n);
2359 @ The program might sometime run completely amok, at which point there is
2360 no choice but to stop. If no previous error has been detected, that's bad
2361 news; a message is printed that is really intended for the \MP\
2362 maintenance person instead of the user (unless the user has been
2363 particularly diabolical). The index entries for `this can't happen' may
2364 help to pinpoint the problem.
2367 @<Internal library ...@>=
2368 void mp_confusion (MP mp, const char *s);
2370 @ Consistency check violated; |s| tells where.
2372 void mp_confusion (MP mp, const char *s) {
2374 mp_normalize_selector(mp);
2375 if ( mp->history<mp_error_message_issued ) {
2376 mp_snprintf(msg, 256, "This can't happen (%s)",s);
2377 @.This can't happen@>
2379 help1("I'm broken. Please show this to someone who can fix can fix");
2381 print_err("I can\'t go on meeting you like this");
2382 @.I can't go on...@>
2383 help2("One of your faux pas seems to have wounded me deeply...",
2384 "in fact, I'm barely conscious. Please fix it and try again.");
2389 @ Users occasionally want to interrupt \MP\ while it's running.
2390 If the runtime system allows this, one can implement
2391 a routine that sets the global variable |interrupt| to some nonzero value
2392 when such an interrupt is signaled. Otherwise there is probably at least
2393 a way to make |interrupt| nonzero using the C debugger.
2394 @^system dependencies@>
2397 @d check_interrupt { if ( mp->interrupt!=0 )
2398 mp_pause_for_instructions(mp); }
2401 integer interrupt; /* should \MP\ pause for instructions? */
2402 boolean OK_to_interrupt; /* should interrupts be observed? */
2403 integer run_state; /* are we processing input ?*/
2404 boolean finished; /* set true by |close_files_and_terminate| */
2406 @ @<Allocate or ...@>=
2407 mp->OK_to_interrupt=true;
2410 @ When an interrupt has been detected, the program goes into its
2411 highest interaction level and lets the user have the full flexibility of
2412 the |error| routine. \MP\ checks for interrupts only at times when it is
2416 void mp_pause_for_instructions (MP mp) {
2417 if ( mp->OK_to_interrupt ) {
2418 mp->interaction=mp_error_stop_mode;
2419 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2421 print_err("Interruption");
2424 "Try to insert some instructions for me (e.g.,`I show x'),",
2425 "unless you just want to quit by typing `X'.");
2426 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2431 @ Many of \MP's error messages state that a missing token has been
2432 inserted behind the scenes. We can save string space and program space
2433 by putting this common code into a subroutine.
2436 void mp_missing_err (MP mp, const char *s) {
2438 mp_snprintf(msg, 256, "Missing `%s' has been inserted", s);
2439 @.Missing...inserted@>
2443 @* \[7] Arithmetic with scaled numbers.
2444 The principal computations performed by \MP\ are done entirely in terms of
2445 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2446 program can be carried out in exactly the same way on a wide variety of
2447 computers, including some small ones.
2450 But C does not rigidly define the |/| operation in the case of negative
2451 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2452 computers and |-n| on others (is this true ?). There are two principal
2453 types of arithmetic: ``translation-preserving,'' in which the identity
2454 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2455 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2456 different results, although the differences should be negligible when the
2457 language is being used properly. The \TeX\ processor has been defined
2458 carefully so that both varieties of arithmetic will produce identical
2459 output, but it would be too inefficient to constrain \MP\ in a similar way.
2461 @d el_gordo 0x7fffffff /* $2^{31}-1$, the largest value that \MP\ likes */
2464 @ One of \MP's most common operations is the calculation of
2465 $\lfloor{a+b\over2}\rfloor$,
2466 the midpoint of two given integers |a| and~|b|. The most decent way to do
2467 this is to write `|(a+b)/2|'; but on many machines it is more efficient
2468 to calculate `|(a+b)>>1|'.
2470 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2471 in this program. If \MP\ is being implemented with languages that permit
2472 binary shifting, the |half| macro should be changed to make this operation
2473 as efficient as possible. Since some systems have shift operators that can
2474 only be trusted to work on positive numbers, there is also a macro |halfp|
2475 that is used only when the quantity being halved is known to be positive
2478 @d half(A) ((A) / 2)
2479 @d halfp(A) ((unsigned)(A) >> 1)
2481 @ A single computation might use several subroutine calls, and it is
2482 desirable to avoid producing multiple error messages in case of arithmetic
2483 overflow. So the routines below set the global variable |arith_error| to |true|
2484 instead of reporting errors directly to the user.
2485 @^overflow in arithmetic@>
2488 boolean arith_error; /* has arithmetic overflow occurred recently? */
2490 @ @<Allocate or ...@>=
2491 mp->arith_error=false;
2493 @ At crucial points the program will say |check_arith|, to test if
2494 an arithmetic error has been detected.
2496 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2499 void mp_clear_arith (MP mp) {
2500 print_err("Arithmetic overflow");
2501 @.Arithmetic overflow@>
2502 help4("Uh, oh. A little while ago one of the quantities that I was",
2503 "computing got too large, so I'm afraid your answers will be",
2504 "somewhat askew. You'll probably have to adopt different",
2505 "tactics next time. But I shall try to carry on anyway.");
2507 mp->arith_error=false;
2510 @ Addition is not always checked to make sure that it doesn't overflow,
2511 but in places where overflow isn't too unlikely the |slow_add| routine
2514 @c integer mp_slow_add (MP mp,integer x, integer y) {
2516 if ( y<=el_gordo-x ) {
2519 mp->arith_error=true;
2522 } else if ( -y<=el_gordo+x ) {
2525 mp->arith_error=true;
2530 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2531 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2532 positions from the right end of a binary computer word.
2534 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2535 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2536 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2537 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2538 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2539 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2542 typedef integer scaled; /* this type is used for scaled integers */
2544 @ The following function is used to create a scaled integer from a given decimal
2545 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2546 given in |dig[i]|, and the calculation produces a correctly rounded result.
2549 scaled mp_round_decimals (MP mp,quarterword k) {
2550 /* converts a decimal fraction */
2551 unsigned a = 0; /* the accumulator */
2553 a=(a+mp->dig[k]*two) / 10;
2558 @ Conversely, here is a procedure analogous to |print_int|. If the output
2559 of this procedure is subsequently read by \MP\ and converted by the
2560 |round_decimals| routine above, it turns out that the original value will
2561 be reproduced exactly. A decimal point is printed only if the value is
2562 not an integer. If there is more than one way to print the result with
2563 the optimum number of digits following the decimal point, the closest
2564 possible value is given.
2566 The invariant relation in the \&{repeat} loop is that a sequence of
2567 decimal digits yet to be printed will yield the original number if and only if
2568 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2569 We can stop if and only if $f=0$ satisfies this condition; the loop will
2570 terminate before $s$ can possibly become zero.
2572 @<Basic printing...@>=
2573 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2574 scaled delta; /* amount of allowable inaccuracy */
2576 mp_print_char(mp, xord('-'));
2577 negate(s); /* print the sign, if negative */
2579 mp_print_int(mp, s / unity); /* print the integer part */
2583 mp_print_char(mp, xord('.'));
2586 s=s+0100000-(delta / 2); /* round the final digit */
2587 mp_print_char(mp, xord('0'+(s / unity)));
2594 @ We often want to print two scaled quantities in parentheses,
2595 separated by a comma.
2597 @<Basic printing...@>=
2598 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2599 mp_print_char(mp, xord('('));
2600 mp_print_scaled(mp, x);
2601 mp_print_char(mp, xord(','));
2602 mp_print_scaled(mp, y);
2603 mp_print_char(mp, xord(')'));
2606 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2607 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2608 arithmetic with 28~significant bits of precision. A |fraction| denotes
2609 a scaled integer whose binary point is assumed to be 28 bit positions
2612 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2613 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2614 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2615 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2616 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2619 typedef integer fraction; /* this type is used for scaled fractions */
2621 @ In fact, the two sorts of scaling discussed above aren't quite
2622 sufficient; \MP\ has yet another, used internally to keep track of angles
2623 in units of $2^{-20}$ degrees.
2625 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2626 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2627 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2628 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2631 typedef integer angle; /* this type is used for scaled angles */
2633 @ The |make_fraction| routine produces the |fraction| equivalent of
2634 |p/q|, given integers |p| and~|q|; it computes the integer
2635 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2636 positive. If |p| and |q| are both of the same scaled type |t|,
2637 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2638 and it's also possible to use the subroutine ``backwards,'' using
2639 the relation |make_fraction(t,fraction)=t| between scaled types.
2641 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2642 sets |arith_error:=true|. Most of \MP's internal computations have
2643 been designed to avoid this sort of error.
2645 If this subroutine were programmed in assembly language on a typical
2646 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2647 double-precision product can often be input to a fixed-point division
2648 instruction. But when we are restricted to int-eger arithmetic it
2649 is necessary either to resort to multiple-precision maneuvering
2650 or to use a simple but slow iteration. The multiple-precision technique
2651 would be about three times faster than the code adopted here, but it
2652 would be comparatively long and tricky, involving about sixteen
2653 additional multiplications and divisions.
2655 This operation is part of \MP's ``inner loop''; indeed, it will
2656 consume nearly 10\pct! of the running time (exclusive of input and output)
2657 if the code below is left unchanged. A machine-dependent recoding
2658 will therefore make \MP\ run faster. The present implementation
2659 is highly portable, but slow; it avoids multiplication and division
2660 except in the initial stage. System wizards should be careful to
2661 replace it with a routine that is guaranteed to produce identical
2662 results in all cases.
2663 @^system dependencies@>
2665 As noted below, a few more routines should also be replaced by machine-dependent
2666 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2667 such changes aren't advisable; simplicity and robustness are
2668 preferable to trickery, unless the cost is too high.
2672 fraction mp_make_fraction (MP mp,integer p, integer q);
2673 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2675 @ If FIXPT is not defined, we need these preprocessor values
2677 @d TWEXP31 2147483648.0
2678 @d TWEXP28 268435456.0
2680 @d TWEXP_16 (1.0/65536.0)
2681 @d TWEXP_28 (1.0/268435456.0)
2685 fraction mp_make_fraction (MP mp,integer p, integer q) {
2687 if ( q==0 ) mp_confusion(mp, "/");
2688 @:this can't happen /}{\quad \./@>
2691 integer f; /* the fraction bits, with a leading 1 bit */
2692 integer n; /* the integer part of $\vert p/q\vert$ */
2693 boolean negative = false; /* should the result be negated? */
2695 negate(p); negative=true;
2698 negate(q); negative = ! negative;
2702 mp->arith_error=true;
2703 i= ( negative ? -el_gordo : el_gordo);
2705 n=(n-1)*fraction_one;
2706 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2707 i = (negative ? (-(f+n)) : (f+n));
2713 d = TWEXP28 * (double)p /(double)q;
2716 if (d>=TWEXP31) {mp->arith_error=true; return el_gordo;}
2718 if (d==(double)i && ( ((q>0 ? -q : q)&077777)
2719 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2722 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2724 if (d==(double)i && ( ((q>0 ? q : -q)&077777)
2725 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2732 @ The |repeat| loop here preserves the following invariant relations
2733 between |f|, |p|, and~|q|:
2734 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2735 $p_0$ is the original value of~$p$.
2737 Notice that the computation specifies
2738 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2739 Let us hope that optimizing compilers do not miss this point; a
2740 special variable |be_careful| is used to emphasize the necessary
2741 order of computation. Optimizing compilers should keep |be_careful|
2742 in a register, not store it in memory.
2745 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2747 integer be_careful; /* disables certain compiler optimizations */
2750 be_careful=p-q; p=be_careful+p;
2756 } while (f<fraction_one);
2758 if ( be_careful+p>=0 ) incr(f);
2761 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2762 given integer~|q| by a fraction~|f|. When the operands are positive, it
2763 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2766 This routine is even more ``inner loopy'' than |make_fraction|;
2767 the present implementation consumes almost 20\pct! of \MP's computation
2768 time during typical jobs, so a machine-language substitute is advisable.
2769 @^inner loop@> @^system dependencies@>
2772 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2776 integer mp_take_fraction (MP mp,integer q, fraction f) {
2777 integer p; /* the fraction so far */
2778 boolean negative; /* should the result be negated? */
2779 integer n; /* additional multiple of $q$ */
2780 integer be_careful; /* disables certain compiler optimizations */
2781 @<Reduce to the case that |f>=0| and |q>=0|@>;
2782 if ( f<fraction_one ) {
2785 n=f / fraction_one; f=f % fraction_one;
2786 if ( q<=el_gordo / n ) {
2789 mp->arith_error=true; n=el_gordo;
2793 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2794 be_careful=n-el_gordo;
2795 if ( be_careful+p>0 ){
2796 mp->arith_error=true; n=el_gordo-p;
2803 integer mp_take_fraction (MP mp,integer p, fraction q) {
2806 d = (double)p * (double)q * TWEXP_28;
2810 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2811 mp->arith_error = true;
2815 if (d==(double)i && (((p&077777)*(q&077777))&040000)!=0) --i;
2819 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2820 mp->arith_error = true;
2824 if (d==(double)i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2830 @ @<Reduce to the case that |f>=0| and |q>=0|@>=
2834 negate( f); negative=true;
2837 negate(q); negative=! negative;
2840 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2841 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2842 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2845 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2846 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2847 if ( q<fraction_four ) {
2849 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2854 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2860 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2861 analogous to |take_fraction| but with a different scaling.
2862 Given positive operands, |take_scaled|
2863 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2865 Once again it is a good idea to use a machine-language replacement if
2866 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2867 when the Computer Modern fonts are being generated.
2872 integer mp_take_scaled (MP mp,integer q, scaled f) {
2873 integer p; /* the fraction so far */
2874 boolean negative; /* should the result be negated? */
2875 integer n; /* additional multiple of $q$ */
2876 integer be_careful; /* disables certain compiler optimizations */
2877 @<Reduce to the case that |f>=0| and |q>=0|@>;
2881 n=f / unity; f=f % unity;
2882 if ( q<=el_gordo / n ) {
2885 mp->arith_error=true; n=el_gordo;
2889 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2890 be_careful=n-el_gordo;
2891 if ( be_careful+p>0 ) {
2892 mp->arith_error=true; n=el_gordo-p;
2894 return ( negative ?(-(n+p)) :(n+p));
2896 integer mp_take_scaled (MP mp,integer p, scaled q) {
2899 d = (double)p * (double)q * TWEXP_16;
2903 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2904 mp->arith_error = true;
2908 if (d==(double)i && (((p&077777)*(q&077777))&040000)!=0) --i;
2912 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2913 mp->arith_error = true;
2917 if (d==(double)i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2923 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
2924 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
2926 if ( q<fraction_four ) {
2928 p = (odd(f) ? halfp(p+q) : halfp(p));
2933 p = (odd(f) ? p+halfp(q-p) : halfp(p));
2938 @ For completeness, there's also |make_scaled|, which computes a
2939 quotient as a |scaled| number instead of as a |fraction|.
2940 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
2941 operands are positive. \ (This procedure is not used especially often,
2942 so it is not part of \MP's inner loop.)
2944 @<Internal library ...@>=
2945 scaled mp_make_scaled (MP mp,integer p, integer q) ;
2948 scaled mp_make_scaled (MP mp,integer p, integer q) {
2950 if ( q==0 ) mp_confusion(mp, "/");
2951 @:this can't happen /}{\quad \./@>
2954 integer f; /* the fraction bits, with a leading 1 bit */
2955 integer n; /* the integer part of $\vert p/q\vert$ */
2956 boolean negative; /* should the result be negated? */
2957 integer be_careful; /* disables certain compiler optimizations */
2958 if ( p>=0 ) negative=false;
2959 else { negate(p); negative=true; };
2961 negate(q); negative=! negative;
2965 mp->arith_error=true;
2966 return (negative ? (-el_gordo) : el_gordo);
2969 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
2970 i = (negative ? (-(f+n)) :(f+n));
2974 d = TWEXP16 * (double)p /(double)q;
2977 if (d>=TWEXP31) {mp->arith_error=true; return el_gordo;}
2979 if (d==(double)i && ( ((q>0 ? -q : q)&077777)
2980 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2983 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2985 if (d==(double)i && ( ((q>0 ? q : -q)&077777)
2986 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2993 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
2996 be_careful=p-q; p=be_careful+p;
2997 if ( p>=0 ) f=f+f+1;
2998 else { f+=f; p=p+q; };
3001 if ( be_careful+p>=0 ) incr(f)
3003 @ Here is a typical example of how the routines above can be used.
3004 It computes the function
3005 $${1\over3\tau}f(\theta,\phi)=
3006 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3007 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3008 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3009 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3010 fudge factor for placing the first control point of a curve that starts
3011 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3012 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3014 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3015 (It's a sum of eight terms whose absolute values can be bounded using
3016 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3017 is positive; and since the tension $\tau$ is constrained to be at least
3018 $3\over4$, the numerator is less than $16\over3$. The denominator is
3019 nonnegative and at most~6. Hence the fixed-point calculations below
3020 are guaranteed to stay within the bounds of a 32-bit computer word.
3022 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3023 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3024 $\sin\phi$, and $\cos\phi$, respectively.
3027 fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3028 fraction cf, scaled t) {
3029 integer acc,num,denom; /* registers for intermediate calculations */
3030 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3031 acc=mp_take_fraction(mp, acc,ct-cf);
3032 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3033 /* $2^{28}\sqrt2\approx379625062.497$ */
3034 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3035 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3036 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3037 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3038 /* |make_scaled(fraction,scaled)=fraction| */
3039 if ( num / 4>=denom )
3040 return fraction_four;
3042 return mp_make_fraction(mp, num, denom);
3045 @ The following somewhat different subroutine tests rigorously if $ab$ is
3046 greater than, equal to, or less than~$cd$,
3047 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3048 The result is $+1$, 0, or~$-1$ in the three respective cases.
3050 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3053 integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3054 integer q,r; /* temporary registers */
3055 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3057 q = a / d; r = c / b;
3059 return ( q>r ? 1 : -1);
3060 q = a % d; r = c % b;
3063 if ( q==0 ) return -1;
3065 } /* now |a>d>0| and |c>b>0| */
3068 @ @<Reduce to the case that |a...@>=
3069 if ( a<0 ) { negate(a); negate(b); };
3070 if ( c<0 ) { negate(c); negate(d); };
3073 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3077 return ( a==0 ? 0 : -1);
3078 q=a; a=c; c=q; q=-b; b=-d; d=q;
3079 } else if ( b<=0 ) {
3080 if ( b<0 ) if ( a>0 ) return -1;
3081 return (c==0 ? 0 : -1);
3084 @ We conclude this set of elementary routines with some simple rounding
3085 and truncation operations.
3087 @<Internal library declarations@>=
3088 #define mp_floor_scaled(M,i) ((i)&(-65536))
3089 #define mp_round_unscaled(M,i) (((i/32768)+1)/2)
3090 #define mp_round_fraction(M,i) (((i/2048)+1)/2)
3093 @* \[8] Algebraic and transcendental functions.
3094 \MP\ computes all of the necessary special functions from scratch, without
3095 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3097 @ To get the square root of a |scaled| number |x|, we want to calculate
3098 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3099 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3100 determines $s$ by an iterative method that maintains the invariant
3101 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3102 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3103 might, however, be zero at the start of the first iteration.
3106 scaled mp_square_rt (MP mp,scaled x) ;
3109 scaled mp_square_rt (MP mp,scaled x) {
3110 quarterword k; /* iteration control counter */
3111 integer y; /* register for intermediate calculations */
3112 unsigned q; /* register for intermediate calculations */
3114 @<Handle square root of zero or negative argument@>;
3117 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3120 if ( x<fraction_four ) y=0;
3121 else { x=x-fraction_four; y=1; };
3123 @<Decrease |k| by 1, maintaining the invariant
3124 relations between |x|, |y|, and~|q|@>;
3130 @ @<Handle square root of zero...@>=
3133 print_err("Square root of ");
3134 @.Square root...replaced by 0@>
3135 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3136 help2("Since I don't take square roots of negative numbers,",
3137 "I'm zeroing this one. Proceed, with fingers crossed.");
3143 @ @<Decrease |k| by 1, maintaining...@>=
3145 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3146 x=x-fraction_four; incr(y);
3148 x+=x; y=y+y-q; q+=q;
3149 if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
3150 if ( y>(int)q ){ y=y-q; q=q+2; }
3151 else if ( y<=0 ) { q=q-2; y=y+q; };
3154 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3155 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3156 @^Moler, Cleve Barry@>
3157 @^Morrison, Donald Ross@>
3158 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3159 in such a way that their Pythagorean sum remains invariant, while the
3160 smaller argument decreases.
3162 @<Internal library ...@>=
3163 integer mp_pyth_add (MP mp,integer a, integer b);
3167 integer mp_pyth_add (MP mp,integer a, integer b) {
3168 fraction r; /* register used to transform |a| and |b| */
3169 boolean big; /* is the result dangerously near $2^{31}$? */
3171 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3173 if ( a<fraction_two ) {
3176 a=a / 4; b=b / 4; big=true;
3177 }; /* we reduced the precision to avoid arithmetic overflow */
3178 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3180 if ( a<fraction_two ) {
3183 mp->arith_error=true; a=el_gordo;
3190 @ The key idea here is to reflect the vector $(a,b)$ about the
3191 line through $(a,b/2)$.
3193 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3195 r=mp_make_fraction(mp, b,a);
3196 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3198 r=mp_make_fraction(mp, r,fraction_four+r);
3199 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3203 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3204 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3207 integer mp_pyth_sub (MP mp,integer a, integer b) {
3208 fraction r; /* register used to transform |a| and |b| */
3209 boolean big; /* is the input dangerously near $2^{31}$? */
3212 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3214 if ( a<fraction_four ) {
3217 a=halfp(a); b=halfp(b); big=true;
3219 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3220 if ( big ) double(a);
3225 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3227 r=mp_make_fraction(mp, b,a);
3228 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3230 r=mp_make_fraction(mp, r,fraction_four-r);
3231 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3234 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3237 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3238 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3239 mp_print(mp, " has been replaced by 0");
3241 help2("Since I don't take square roots of negative numbers,",
3242 "I'm zeroing this one. Proceed, with fingers crossed.");
3248 @ The subroutines for logarithm and exponential involve two tables.
3249 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3250 a bit more calculation, which the author claims to have done correctly:
3251 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3252 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3255 @d two_to_the(A) (1<<(unsigned)(A))
3258 static const integer spec_log[29] = { 0, /* special logarithms */
3259 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3260 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3261 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3263 @ @<Local variables for initialization@>=
3264 integer k; /* all-purpose loop index */
3267 @ Here is the routine that calculates $2^8$ times the natural logarithm
3268 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3269 when |x| is a given positive integer.
3271 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3272 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3273 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3274 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3275 during the calculation, and sixteen auxiliary bits to extend |y| are
3276 kept in~|z| during the initial argument reduction. (We add
3277 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3278 not become negative; also, the actual amount subtracted from~|y| is~96,
3279 not~100, because we want to add~4 for rounding before the final division by~8.)
3282 scaled mp_m_log (MP mp,scaled x) {
3283 integer y,z; /* auxiliary registers */
3284 integer k; /* iteration counter */
3286 @<Handle non-positive logarithm@>;
3288 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3289 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3290 while ( x<fraction_four ) {
3291 double(x); y-=93032639; z-=48782;
3292 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3293 y=y+(z / unity); k=2;
3294 while ( x>fraction_four+4 ) {
3295 @<Increase |k| until |x| can be multiplied by a
3296 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3302 @ @<Increase |k| until |x| can...@>=
3304 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3305 while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
3306 y+=spec_log[k]; x-=z;
3309 @ @<Handle non-positive logarithm@>=
3311 print_err("Logarithm of ");
3312 @.Logarithm...replaced by 0@>
3313 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3314 help2("Since I don't take logs of non-positive numbers,",
3315 "I'm zeroing this one. Proceed, with fingers crossed.");
3320 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3321 when |x| is |scaled|. The result is an integer approximation to
3322 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3325 scaled mp_m_exp (MP mp,scaled x) {
3326 quarterword k; /* loop control index */
3327 integer y,z; /* auxiliary registers */
3328 if ( x>174436200 ) {
3329 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3330 mp->arith_error=true;
3332 } else if ( x<-197694359 ) {
3333 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3337 z=-8*x; y=04000000; /* $y=2^{20}$ */
3339 if ( x<=127919879 ) {
3341 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3343 z=8*(174436200-x); /* |z| is always nonnegative */
3347 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3349 return ((y+8) / 16);
3355 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3356 to multiplying |y| by $1-2^{-k}$.
3358 A subtle point (which had to be checked) was that if $x=127919879$, the
3359 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3360 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3361 and by~16 when |k=27|.
3363 @<Multiply |y| by...@>=
3366 while ( z>=spec_log[k] ) {
3368 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3373 @ The trigonometric subroutines use an auxiliary table such that
3374 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3375 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3378 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3379 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3380 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3382 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3383 returns the |angle| whose tangent points in the direction $(x,y)$.
3384 This subroutine first determines the correct octant, then solves the
3385 problem for |0<=y<=x|, then converts the result appropriately to
3386 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3387 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3388 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3390 The octants are represented in a ``Gray code,'' since that turns out
3391 to be computationally simplest.
3397 @d second_octant (first_octant+switch_x_and_y)
3398 @d third_octant (first_octant+switch_x_and_y+negate_x)
3399 @d fourth_octant (first_octant+negate_x)
3400 @d fifth_octant (first_octant+negate_x+negate_y)
3401 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3402 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3403 @d eighth_octant (first_octant+negate_y)
3406 angle mp_n_arg (MP mp,integer x, integer y) {
3407 angle z; /* auxiliary register */
3408 integer t; /* temporary storage */
3409 quarterword k; /* loop counter */
3410 int octant; /* octant code */
3412 octant=first_octant;
3414 negate(x); octant=first_octant+negate_x;
3417 negate(y); octant=octant+negate_y;
3420 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3423 @<Handle undefined arg@>;
3425 @<Set variable |z| to the arg of $(x,y)$@>;
3426 @<Return an appropriate answer based on |z| and |octant|@>;
3430 @ @<Handle undefined arg@>=
3432 print_err("angle(0,0) is taken as zero");
3433 @.angle(0,0)...zero@>
3434 help2("The `angle' between two identical points is undefined.",
3435 "I'm zeroing this one. Proceed, with fingers crossed.");
3440 @ @<Return an appropriate answer...@>=
3442 case first_octant: return z;
3443 case second_octant: return (ninety_deg-z);
3444 case third_octant: return (ninety_deg+z);
3445 case fourth_octant: return (one_eighty_deg-z);
3446 case fifth_octant: return (z-one_eighty_deg);
3447 case sixth_octant: return (-z-ninety_deg);
3448 case seventh_octant: return (z-ninety_deg);
3449 case eighth_octant: return (-z);
3450 }; /* there are no other cases */
3453 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3454 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3457 @<Set variable |z| to the arg...@>=
3458 while ( x>=fraction_two ) {
3459 x=halfp(x); y=halfp(y);
3463 while ( x<fraction_one ) {
3466 @<Increase |z| to the arg of $(x,y)$@>;
3469 @ During the calculations of this section, variables |x| and~|y|
3470 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3471 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3472 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3473 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3474 coordinates whose angle has decreased by~$\phi$; in the special case
3475 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3476 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3477 @^Meggitt, John E.@>
3478 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3480 The initial value of |x| will be multiplied by at most
3481 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3482 there is no chance of integer overflow.
3484 @<Increase |z|...@>=
3489 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3494 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3497 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3498 and cosine of that angle. The results of this routine are
3499 stored in global integer variables |n_sin| and |n_cos|.
3502 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3504 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3505 the purpose of |n_sin_cos(z)| is to set
3506 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3507 for some rather large number~|r|. The maximum of |x| and |y|
3508 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3509 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3512 void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3514 quarterword k; /* loop control variable */
3515 int q; /* specifies the quadrant */
3516 fraction r; /* magnitude of |(x,y)| */
3517 integer x,y,t; /* temporary registers */
3518 while ( z<0 ) z=z+three_sixty_deg;
3519 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3520 q=z / forty_five_deg; z=z % forty_five_deg;
3521 x=fraction_one; y=x;
3522 if ( ! odd(q) ) z=forty_five_deg-z;
3523 @<Subtract angle |z| from |(x,y)|@>;
3524 @<Convert |(x,y)| to the octant determined by~|q|@>;
3525 r=mp_pyth_add(mp, x,y);
3526 mp->n_cos=mp_make_fraction(mp, x,r);
3527 mp->n_sin=mp_make_fraction(mp, y,r);
3530 @ In this case the octants are numbered sequentially.
3532 @<Convert |(x,...@>=
3535 case 1: t=x; x=y; y=t; break;
3536 case 2: t=x; x=-y; y=t; break;
3537 case 3: negate(x); break;
3538 case 4: negate(x); negate(y); break;
3539 case 5: t=x; x=-y; y=-t; break;
3540 case 6: t=x; x=y; y=-t; break;
3541 case 7: negate(y); break;
3542 } /* there are no other cases */
3544 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3545 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3546 that this loop is guaranteed to terminate before the (nonexistent) value
3547 |spec_atan[27]| would be required.
3549 @<Subtract angle |z|...@>=
3552 if ( z>=spec_atan[k] ) {
3553 z=z-spec_atan[k]; t=x;
3554 x=t+y / two_to_the(k);
3555 y=y-t / two_to_the(k);
3559 if ( y<0 ) y=0 /* this precaution may never be needed */
3561 @ And now let's complete our collection of numeric utility routines
3562 by considering random number generation.
3563 \MP\ generates pseudo-random numbers with the additive scheme recommended
3564 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3565 results are random fractions between 0 and |fraction_one-1|, inclusive.
3567 There's an auxiliary array |randoms| that contains 55 pseudo-random
3568 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3569 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3570 The global variable |j_random| tells which element has most recently
3572 The global variable |random_seed| was introduced in version 0.9,
3573 for the sole reason of stressing the fact that the initial value of the
3574 random seed is system-dependant. The initialization code below will initialize
3575 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3576 is not good enough on modern fast machines that are capable of running
3577 multiple MetaPost processes within the same second.
3578 @^system dependencies@>
3581 fraction randoms[55]; /* the last 55 random values generated */
3582 int j_random; /* the number of unused |randoms| */
3584 @ @<Option variables@>=
3585 int random_seed; /* the default random seed */
3587 @ @<Allocate or initialize ...@>=
3588 mp->random_seed = (scaled)opt->random_seed;
3590 @ To consume a random fraction, the program below will say `|next_random|'
3591 and then it will fetch |randoms[j_random]|.
3593 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3594 else decr(mp->j_random); }
3597 void mp_new_randoms (MP mp) {
3598 int k; /* index into |randoms| */
3599 fraction x; /* accumulator */
3600 for (k=0;k<=23;k++) {
3601 x=mp->randoms[k]-mp->randoms[k+31];
3602 if ( x<0 ) x=x+fraction_one;
3605 for (k=24;k<= 54;k++){
3606 x=mp->randoms[k]-mp->randoms[k-24];
3607 if ( x<0 ) x=x+fraction_one;
3614 void mp_init_randoms (MP mp,scaled seed);
3616 @ To initialize the |randoms| table, we call the following routine.
3619 void mp_init_randoms (MP mp,scaled seed) {
3620 fraction j,jj,k; /* more or less random integers */
3621 int i; /* index into |randoms| */
3623 while ( j>=fraction_one ) j=halfp(j);
3625 for (i=0;i<=54;i++ ){
3627 if ( k<0 ) k=k+fraction_one;
3628 mp->randoms[(i*21)% 55]=j;
3632 mp_new_randoms(mp); /* ``warm up'' the array */
3635 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3636 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3638 Note that the call of |take_fraction| will produce the values 0 and~|x|
3639 with about half the probability that it will produce any other particular
3640 values between 0 and~|x|, because it rounds its answers.
3643 scaled mp_unif_rand (MP mp,scaled x) {
3644 scaled y; /* trial value */
3645 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3646 if ( y==abs(x) ) return 0;
3647 else if ( x>0 ) return y;
3651 @ Finally, a normal deviate with mean zero and unit standard deviation
3652 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3653 {\sl The Art of Computer Programming\/}).
3656 scaled mp_norm_rand (MP mp) {
3657 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3661 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3662 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3663 next_random; u=mp->randoms[mp->j_random];
3664 } while (abs(x)>=u);
3665 x=mp_make_fraction(mp, x,u);
3666 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3667 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3671 @* \[9] Packed data.
3672 In order to make efficient use of storage space, \MP\ bases its major data
3673 structures on a |memory_word|, which contains either a (signed) integer,
3674 possibly scaled, or a small number of fields that are one half or one
3675 quarter of the size used for storing integers.
3677 If |x| is a variable of type |memory_word|, it contains up to four
3678 fields that can be referred to as follows:
3679 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3680 |x|&.|int|&(an |integer|)\cr
3681 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3682 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3683 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3685 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3686 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3687 This is somewhat cumbersome to write, and not very readable either, but
3688 macros will be used to make the notation shorter and more transparent.
3689 The code below gives a formal definition of |memory_word| and
3690 its subsidiary types, using packed variant records. \MP\ makes no
3691 assumptions about the relative positions of the fields within a word.
3693 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3694 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3696 @ Here are the inequalities that the quarterword and halfword values
3697 must satisfy (or rather, the inequalities that they mustn't satisfy):
3699 @<Check the ``constant''...@>=
3700 if (mp->ini_version) {
3701 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3703 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3705 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3706 if ( mp->max_strings>max_halfword ) mp->bad=13;
3708 @ The macros |qi| and |qo| are used for input to and output
3709 from quarterwords. These are legacy macros.
3710 @^system dependencies@>
3712 @d qo(A) (A) /* to read eight bits from a quarterword */
3713 @d qi(A) (quarterword)(A) /* to store eight bits in a quarterword */
3715 @ The reader should study the following definitions closely:
3716 @^system dependencies@>
3718 @d sc cint /* |scaled| data is equivalent to |integer| */
3721 typedef short quarterword; /* 1/4 of a word */
3722 typedef int halfword; /* 1/2 of a word */
3727 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3734 quarterword B2, B3, B0, B1;
3749 @ When debugging, we may want to print a |memory_word| without knowing
3750 what type it is; so we print it in all modes.
3754 void mp_print_word (MP mp,memory_word w) {
3755 /* prints |w| in all ways */
3756 mp_print_int(mp, w.cint); mp_print_char(mp, xord(' '));
3757 mp_print_scaled(mp, w.sc); mp_print_char(mp, xord(' '));
3758 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3759 mp_print_int(mp, w.hh.lh); mp_print_char(mp, xord('='));
3760 mp_print_int(mp, w.hh.b0); mp_print_char(mp, xord(':'));
3761 mp_print_int(mp, w.hh.b1); mp_print_char(mp, xord(';'));
3762 mp_print_int(mp, w.hh.rh); mp_print_char(mp, xord(' '));
3763 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, xord(':'));
3764 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, xord(':'));
3765 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, xord(':'));
3766 mp_print_int(mp, w.qqqq.b3);
3770 @* \[10] Dynamic memory allocation.
3772 The \MP\ system does nearly all of its own memory allocation, so that it
3773 can readily be transported into environments that do not have automatic
3774 facilities for strings, garbage collection, etc., and so that it can be in
3775 control of what error messages the user receives. The dynamic storage
3776 requirements of \MP\ are handled by providing a large array |mem| in
3777 which consecutive blocks of words are used as nodes by the \MP\ routines.
3779 Pointer variables are indices into this array, or into another array
3780 called |eqtb| that will be explained later. A pointer variable might
3781 also be a special flag that lies outside the bounds of |mem|, so we
3782 allow pointers to assume any |halfword| value. The minimum memory
3783 index represents a null pointer.
3785 @d null 0 /* the null pointer */
3786 @d mp_void (null+1) /* a null pointer different from |null| */
3790 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3792 @ The |mem| array is divided into two regions that are allocated separately,
3793 but the dividing line between these two regions is not fixed; they grow
3794 together until finding their ``natural'' size in a particular job.
3795 Locations less than or equal to |lo_mem_max| are used for storing
3796 variable-length records consisting of two or more words each. This region
3797 is maintained using an algorithm similar to the one described in exercise
3798 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3799 appears in the allocated nodes; the program is responsible for knowing the
3800 relevant size when a node is freed. Locations greater than or equal to
3801 |hi_mem_min| are used for storing one-word records; a conventional
3802 \.{AVAIL} stack is used for allocation in this region.
3804 Locations of |mem| between |0| and |mem_top| may be dumped as part
3805 of preloaded mem files, by the \.{INIMP} preprocessor.
3807 Production versions of \MP\ may extend the memory at the top end in order to
3808 provide more space; these locations, between |mem_top| and |mem_max|,
3809 are always used for single-word nodes.
3811 The key pointers that govern |mem| allocation have a prescribed order:
3812 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3815 memory_word *mem; /* the big dynamic storage area */
3816 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3817 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3821 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3822 @d xrealloc(P,A,B) mp_xrealloc(mp,P,(size_t)A,B)
3823 @d xmalloc(A,B) mp_xmalloc(mp,(size_t)A,B)
3824 @d xstrdup(A) mp_xstrdup(mp,A)
3825 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3827 @<Declare helpers@>=
3828 void mp_xfree (void *x);
3829 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3830 void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3831 char *mp_xstrdup(MP mp, const char *s);
3832 void mp_do_snprintf(char *str, int size, const char *fmt, ...);
3834 @ The |max_size_test| guards against overflow, on the assumption that
3835 |size_t| is at least 31bits wide.
3837 @d max_size_test 0x7FFFFFFF
3840 void mp_xfree (void *x) {
3841 if (x!=NULL) free(x);
3843 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3845 if ((max_size_test/size)<nmem) {
3846 do_fprintf(mp->err_out,"Memory size overflow!\n");
3847 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3849 w = realloc (p,(nmem*size));
3851 do_fprintf(mp->err_out,"Out of memory!\n");
3852 mp->history =mp_system_error_stop; mp_jump_out(mp);
3856 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
3858 if ((max_size_test/size)<nmem) {
3859 do_fprintf(mp->err_out,"Memory size overflow!\n");
3860 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3862 w = malloc (nmem*size);
3864 do_fprintf(mp->err_out,"Out of memory!\n");
3865 mp->history =mp_system_error_stop; mp_jump_out(mp);
3869 char *mp_xstrdup(MP mp, const char *s) {
3875 do_fprintf(mp->err_out,"Out of memory!\n");
3876 mp->history =mp_system_error_stop; mp_jump_out(mp);
3881 @ @<Internal library declarations@>=
3882 #ifdef HAVE_SNPRINTF
3883 #define mp_snprintf (void)snprintf
3885 #define mp_snprintf mp_do_snprintf
3888 @ This internal version is rather stupid, but good enough for its purpose.
3891 void mp_do_snprintf (char *str, int size, const char *format, ...) {
3896 work = (char *)workbuf;
3897 va_start(ap, format);
3899 for (fmt=format;*fmt!='\0';fmt++) {
3905 char *s = va_arg(ap, char *);
3908 if (size-->0) res++;
3915 mp_snprintf(work,32,"%i",va_arg(ap, int));
3918 if (size-->0) res++;
3924 mp_snprintf(work,32,"%g",va_arg(ap, double));
3927 if (size-->0) res++;
3933 if (size-->0) res++;
3937 if (size-->0) res++;
3939 if (size-->0) res++;
3944 if (size-->0) res++;
3952 @<Allocate or initialize ...@>=
3953 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
3954 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
3956 @ @<Dealloc variables@>=
3959 @ Users who wish to study the memory requirements of particular applications can
3960 can use optional special features that keep track of current and
3961 maximum memory usage. When code between the delimiters |stat| $\ldots$
3962 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
3963 report these statistics when |mp_tracing_stats| is positive.
3966 integer var_used; integer dyn_used; /* how much memory is in use */
3968 @ Let's consider the one-word memory region first, since it's the
3969 simplest. The pointer variable |mem_end| holds the highest-numbered location
3970 of |mem| that has ever been used. The free locations of |mem| that
3971 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
3972 |two_halves|, and we write |info(p)| and |mp_link(p)| for the |lh|
3973 and |rh| fields of |mem[p]| when it is of this type. The single-word
3974 free locations form a linked list
3975 $$|avail|,\;\hbox{|mp_link(avail)|},\;\hbox{|mp_link(mp_link(avail))|},\;\ldots$$
3976 terminated by |null|.
3978 @d mp_link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
3979 @d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
3982 pointer avail; /* head of the list of available one-word nodes */
3983 pointer mem_end; /* the last one-word node used in |mem| */
3985 @ If one-word memory is exhausted, it might mean that the user has forgotten
3986 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
3987 later that try to help pinpoint the trouble.
3990 @<Declare the procedure called |show_token_list|@>
3991 @<Declare the procedure called |runaway|@>
3993 @ The function |get_avail| returns a pointer to a new one-word node whose
3994 |link| field is null. However, \MP\ will halt if there is no more room left.
3998 pointer mp_get_avail (MP mp) { /* single-word node allocation */
3999 pointer p; /* the new node being got */
4000 p=mp->avail; /* get top location in the |avail| stack */
4002 mp->avail=mp_link(mp->avail); /* and pop it off */
4003 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
4004 incr(mp->mem_end); p=mp->mem_end;
4006 decr(mp->hi_mem_min); p=mp->hi_mem_min;
4007 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
4008 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
4009 mp_overflow(mp, "main memory size",mp->mem_max);
4010 /* quit; all one-word nodes are busy */
4011 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4014 mp_link(p)=null; /* provide an oft-desired initialization of the new node */
4015 incr(mp->dyn_used);/* maintain statistics */
4019 @ Conversely, a one-word node is recycled by calling |free_avail|.
4021 @d free_avail(A) /* single-word node liberation */
4022 { mp_link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
4024 @ There's also a |fast_get_avail| routine, which saves the procedure-call
4025 overhead at the expense of extra programming. This macro is used in
4026 the places that would otherwise account for the most calls of |get_avail|.
4029 @d fast_get_avail(A) {
4030 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
4031 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4032 else { mp->avail=mp_link((A)); mp_link((A))=null; incr(mp->dyn_used); }
4035 @ The available-space list that keeps track of the variable-size portion
4036 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4037 pointed to by the roving pointer |rover|.
4039 Each empty node has size 2 or more; the first word contains the special
4040 value |max_halfword| in its |link| field and the size in its |info| field;
4041 the second word contains the two pointers for double linking.
4043 Each nonempty node also has size 2 or more. Its first word is of type
4044 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4045 Otherwise there is complete flexibility with respect to the contents
4046 of its other fields and its other words.
4048 (We require |mem_max<max_halfword| because terrible things can happen
4049 when |max_halfword| appears in the |link| field of a nonempty node.)
4051 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4052 @d is_empty(A) (mp_link((A))==empty_flag) /* tests for empty node */
4053 @d node_size info /* the size field in empty variable-size nodes */
4054 @d lmp_link(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
4055 @d rmp_link(A) mp_link((A)+1) /* right link in doubly-linked list of empty nodes */
4058 pointer rover; /* points to some node in the list of empties */
4060 @ A call to |get_node| with argument |s| returns a pointer to a new node
4061 of size~|s|, which must be 2~or more. The |link| field of the first word
4062 of this new node is set to null. An overflow stop occurs if no suitable
4065 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4066 areas and returns the value |max_halfword|.
4068 @<Internal library declarations@>=
4069 pointer mp_get_node (MP mp,integer s) ;
4072 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4073 pointer p; /* the node currently under inspection */
4074 pointer q; /* the node physically after node |p| */
4075 integer r; /* the newly allocated node, or a candidate for this honor */
4076 integer t,tt; /* temporary registers */
4079 p=mp->rover; /* start at some free node in the ring */
4081 @<Try to allocate within node |p| and its physical successors,
4082 and |goto found| if allocation was possible@>;
4083 if (rmp_link(p)==null || (rmp_link(p)==p && p!=mp->rover)) {
4084 print_err("Free list garbled");
4085 help3("I found an entry in the list of free nodes that links",
4086 "badly. I will try to ignore the broken link, but something",
4087 "is seriously amiss. It is wise to warn the maintainers.")
4089 rmp_link(p)=mp->rover;
4091 p=rmp_link(p); /* move to the next node in the ring */
4092 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4093 if ( s==010000000000 ) {
4094 return max_halfword;
4096 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4097 if ( mp->lo_mem_max+2<=max_halfword ) {
4098 @<Grow more variable-size memory and |goto restart|@>;
4101 mp_overflow(mp, "main memory size",mp->mem_max);
4102 /* sorry, nothing satisfactory is left */
4103 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4105 mp_link(r)=null; /* this node is now nonempty */
4106 mp->var_used+=s; /* maintain usage statistics */
4110 @ The lower part of |mem| grows by 1000 words at a time, unless
4111 we are very close to going under. When it grows, we simply link
4112 a new node into the available-space list. This method of controlled
4113 growth helps to keep the |mem| usage consecutive when \MP\ is
4114 implemented on ``virtual memory'' systems.
4117 @<Grow more variable-size memory and |goto restart|@>=
4119 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4120 t=mp->lo_mem_max+1000;
4122 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4123 /* |lo_mem_max+2<=t<hi_mem_min| */
4125 if ( t>max_halfword ) t=max_halfword;
4126 p=lmp_link(mp->rover); q=mp->lo_mem_max; rmp_link(p)=q; lmp_link(mp->rover)=q;
4127 rmp_link(q)=mp->rover; lmp_link(q)=p; mp_link(q)=empty_flag;
4128 node_size(q)=t-mp->lo_mem_max;
4129 mp->lo_mem_max=t; mp_link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4134 @ @<Try to allocate...@>=
4135 q=p+node_size(p); /* find the physical successor */
4136 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4137 t=rmp_link(q); tt=lmp_link(q);
4139 if ( q==mp->rover ) mp->rover=t;
4140 lmp_link(t)=tt; rmp_link(tt)=t;
4145 @<Allocate from the top of node |p| and |goto found|@>;
4148 if ( rmp_link(p)!=p ) {
4149 @<Allocate entire node |p| and |goto found|@>;
4152 node_size(p)=q-p /* reset the size in case it grew */
4154 @ @<Allocate from the top...@>=
4156 node_size(p)=r-p; /* store the remaining size */
4157 mp->rover=p; /* start searching here next time */
4161 @ Here we delete node |p| from the ring, and let |rover| rove around.
4163 @<Allocate entire...@>=
4165 mp->rover=rmp_link(p); t=lmp_link(p);
4166 lmp_link(mp->rover)=t; rmp_link(t)=mp->rover;
4170 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4171 the operation |free_node(p,s)| will make its words available, by inserting
4172 |p| as a new empty node just before where |rover| now points.
4174 @<Internal library declarations@>=
4175 void mp_free_node (MP mp, pointer p, halfword s) ;
4178 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4180 pointer q; /* |lmp_link(rover)| */
4181 node_size(p)=s; mp_link(p)=empty_flag;
4183 q=lmp_link(mp->rover); lmp_link(p)=q; rmp_link(p)=mp->rover; /* set both links */
4184 lmp_link(mp->rover)=p; rmp_link(q)=p; /* insert |p| into the ring */
4185 mp->var_used-=s; /* maintain statistics */
4188 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4189 available space list. The list is probably very short at such times, so a
4190 simple insertion sort is used. The smallest available location will be
4191 pointed to by |rover|, the next-smallest by |rmp_link(rover)|, etc.
4194 void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4196 pointer p,q,r; /* indices into |mem| */
4197 pointer old_rover; /* initial |rover| setting */
4198 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4199 p=rmp_link(mp->rover); rmp_link(mp->rover)=max_halfword; old_rover=mp->rover;
4200 while ( p!=old_rover ) {
4201 @<Sort |p| into the list starting at |rover|
4202 and advance |p| to |rmp_link(p)|@>;
4205 while ( rmp_link(p)!=max_halfword ) {
4206 lmp_link(rmp_link(p))=p; p=rmp_link(p);
4208 rmp_link(p)=mp->rover; lmp_link(mp->rover)=p;
4211 @ The following |while| loop is guaranteed to
4212 terminate, since the list that starts at
4213 |rover| ends with |max_halfword| during the sorting procedure.
4216 if ( p<mp->rover ) {
4217 q=p; p=rmp_link(q); rmp_link(q)=mp->rover; mp->rover=q;
4220 while ( rmp_link(q)<p ) q=rmp_link(q);
4221 r=rmp_link(p); rmp_link(p)=rmp_link(q); rmp_link(q)=p; p=r;
4224 @* \[11] Memory layout.
4225 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4226 more efficient than dynamic allocation when we can get away with it. For
4227 example, locations |0| to |1| are always used to store a
4228 two-word dummy token whose second word is zero.
4229 The following macro definitions accomplish the static allocation by giving
4230 symbolic names to the fixed positions. Static variable-size nodes appear
4231 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4232 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4234 @d null_dash (2) /* the first two words are reserved for a null value */
4235 @d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4236 @d zero_val (dep_head+2) /* two words for a permanently zero value */
4237 @d temp_val (zero_val+2) /* two words for a temporary value node */
4238 @d end_attr temp_val /* we use |end_attr+2| only */
4239 @d inf_val (end_attr+2) /* and |inf_val+1| only */
4240 @d test_pen (inf_val+2)
4241 /* nine words for a pen used when testing the turning number */
4242 @d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
4243 @d lo_mem_stat_max (bad_vardef+1) /* largest statically
4244 allocated word in the variable-size |mem| */
4246 @d sentinel mp->mem_top /* end of sorted lists */
4247 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4248 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4249 @d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4250 @d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4251 the one-word |mem| */
4253 @ The following code gets the dynamic part of |mem| off to a good start,
4254 when \MP\ is initializing itself the slow way.
4256 @<Initialize table entries (done by \.{INIMP} only)@>=
4257 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4258 mp_link(mp->rover)=empty_flag;
4259 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4260 lmp_link(mp->rover)=mp->rover; rmp_link(mp->rover)=mp->rover;
4261 mp->lo_mem_max=mp->rover+1000;
4262 mp_link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4263 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4264 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4266 mp->avail=null; mp->mem_end=mp->mem_top;
4267 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4268 mp->var_used=lo_mem_stat_max+1;
4269 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4270 @<Initialize a pen at |test_pen| so that it fits in nine words@>;
4272 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4273 nodes that starts at a given position, until coming to |sentinel| or a
4274 pointer that is not in the one-word region. Another procedure,
4275 |flush_node_list|, frees an entire linked list of one-word and two-word
4276 nodes, until coming to a |null| pointer.
4280 void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4281 pointer q,r; /* list traversers */
4282 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4287 if ( r<mp->hi_mem_min ) break;
4288 } while (r!=sentinel);
4289 /* now |q| is the last node on the list */
4290 mp_link(q)=mp->avail; mp->avail=p;
4294 void mp_flush_node_list (MP mp,pointer p) {
4295 pointer q; /* the node being recycled */
4298 if ( q<mp->hi_mem_min )
4299 mp_free_node(mp, q,2);
4305 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4306 For example, some pointers might be wrong, or some ``dead'' nodes might not
4307 have been freed when the last reference to them disappeared. Procedures
4308 |check_mem| and |search_mem| are available to help diagnose such
4309 problems. These procedures make use of two arrays called |free| and
4310 |was_free| that are present only if \MP's debugging routines have
4311 been included. (You may want to decrease the size of |mem| while you
4315 Because |boolean|s are typedef-d as ints, it is better to use
4316 unsigned chars here.
4319 unsigned char *free; /* free cells */
4320 unsigned char *was_free; /* previously free cells */
4321 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4322 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4323 boolean panicking; /* do we want to check memory constantly? */
4325 @ @<Allocate or initialize ...@>=
4326 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4327 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4329 @ @<Dealloc variables@>=
4331 xfree(mp->was_free);
4333 @ @<Allocate or ...@>=
4334 mp->was_hi_min=mp->mem_max;
4335 mp->panicking=false;
4337 @ @<Declare |mp_reallocate| functions@>=
4338 void mp_reallocate_memory(MP mp, int l) ;
4341 void mp_reallocate_memory(MP mp, int l) {
4342 XREALLOC(mp->free, l, unsigned char);
4343 XREALLOC(mp->was_free, l, unsigned char);
4345 int newarea = l-mp->mem_max;
4346 XREALLOC(mp->mem, l, memory_word);
4347 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4349 XREALLOC(mp->mem, l, memory_word);
4350 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4353 if (mp->ini_version)
4359 @ Procedure |check_mem| makes sure that the available space lists of
4360 |mem| are well formed, and it optionally prints out all locations
4361 that are reserved now but were free the last time this procedure was called.
4364 void mp_check_mem (MP mp,boolean print_locs ) {
4365 pointer p,q,r; /* current locations of interest in |mem| */
4366 boolean clobbered; /* is something amiss? */
4367 for (p=0;p<=mp->lo_mem_max;p++) {
4368 mp->free[p]=false; /* you can probably do this faster */
4370 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4371 mp->free[p]=false; /* ditto */
4373 @<Check single-word |avail| list@>;
4374 @<Check variable-size |avail| list@>;
4375 @<Check flags of unavailable nodes@>;
4376 @<Check the list of linear dependencies@>;
4378 @<Print newly busy locations@>;
4380 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4381 mp->was_mem_end=mp->mem_end;
4382 mp->was_lo_max=mp->lo_mem_max;
4383 mp->was_hi_min=mp->hi_mem_min;
4386 @ @<Check single-word...@>=
4387 p=mp->avail; q=null; clobbered=false;
4389 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4390 else if ( mp->free[p] ) clobbered=true;
4392 mp_print_nl(mp, "AVAIL list clobbered at ");
4393 @.AVAIL list clobbered...@>
4394 mp_print_int(mp, q); break;
4396 mp->free[p]=true; q=p; p=mp_link(q);
4399 @ @<Check variable-size...@>=
4400 p=mp->rover; q=null; clobbered=false;
4402 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4403 else if ( (rmp_link(p)>=mp->lo_mem_max)||(rmp_link(p)<0) ) clobbered=true;
4404 else if ( !(is_empty(p))||(node_size(p)<2)||
4405 (p+node_size(p)>mp->lo_mem_max)|| (lmp_link(rmp_link(p))!=p) ) clobbered=true;
4407 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4408 @.Double-AVAIL list clobbered...@>
4409 mp_print_int(mp, q); break;
4411 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4412 if ( mp->free[q] ) {
4413 mp_print_nl(mp, "Doubly free location at ");
4414 @.Doubly free location...@>
4415 mp_print_int(mp, q); break;
4420 } while (p!=mp->rover)
4423 @ @<Check flags...@>=
4425 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4426 if ( is_empty(p) ) {
4427 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4430 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
4431 while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
4434 @ @<Print newly busy...@>=
4436 @<Do intialization required before printing new busy locations@>;
4437 mp_print_nl(mp, "New busy locs:");
4439 for (p=0;p<= mp->lo_mem_max;p++ ) {
4440 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4441 @<Indicate that |p| is a new busy location@>;
4444 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4445 if ( ! mp->free[p] &&
4446 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4447 @<Indicate that |p| is a new busy location@>;
4450 @<Finish printing new busy locations@>;
4453 @ There might be many new busy locations so we are careful to print contiguous
4454 blocks compactly. During this operation |q| is the last new busy location and
4455 |r| is the start of the block containing |q|.
4457 @<Indicate that |p| is a new busy location@>=
4461 mp_print(mp, ".."); mp_print_int(mp, q);
4463 mp_print_char(mp, xord(' ')); mp_print_int(mp, p);
4469 @ @<Do intialization required before printing new busy locations@>=
4470 q=mp->mem_max; r=mp->mem_max
4472 @ @<Finish printing new busy locations@>=
4474 mp_print(mp, ".."); mp_print_int(mp, q);
4477 @ The |search_mem| procedure attempts to answer the question ``Who points
4478 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4479 that might not be of type |two_halves|. Strictly speaking, this is
4480 undefined, and it can lead to ``false drops'' (words that seem to
4481 point to |p| purely by coincidence). But for debugging purposes, we want
4482 to rule out the places that do {\sl not\/} point to |p|, so a few false
4483 drops are tolerable.
4486 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4487 integer q; /* current position being searched */
4488 for (q=0;q<=mp->lo_mem_max;q++) {
4489 if ( mp_link(q)==p ){
4490 mp_print_nl(mp, "MP_LINK("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4493 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4496 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4497 if ( mp_link(q)==p ) {
4498 mp_print_nl(mp, "MP_LINK("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4501 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4504 @<Search |eqtb| for equivalents equal to |p|@>;
4507 @* \[12] The command codes.
4508 Before we can go much further, we need to define symbolic names for the internal
4509 code numbers that represent the various commands obeyed by \MP. These codes
4510 are somewhat arbitrary, but not completely so. For example,
4511 some codes have been made adjacent so that |case| statements in the
4512 program need not consider cases that are widely spaced, or so that |case|
4513 statements can be replaced by |if| statements. A command can begin an
4514 expression if and only if its code lies between |min_primary_command| and
4515 |max_primary_command|, inclusive. The first token of a statement that doesn't
4516 begin with an expression has a command code between |min_command| and
4517 |max_statement_command|, inclusive. Anything less than |min_command| is
4518 eliminated during macro expansions, and anything no more than |max_pre_command|
4519 is eliminated when expanding \TeX\ material. Ranges such as
4520 |min_secondary_command..max_secondary_command| are used when parsing
4521 expressions, but the relative ordering within such a range is generally not
4524 The ordering of the highest-numbered commands
4525 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4526 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4527 for the smallest two commands. The ordering is also important in the ranges
4528 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4530 At any rate, here is the list, for future reference.
4532 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4533 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4534 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4535 @d max_pre_command mpx_break
4536 @d if_test 4 /* conditional text (\&{if}) */
4537 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
4538 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4539 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4540 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4541 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4542 @d relax 10 /* do nothing (\.{\char`\\}) */
4543 @d scan_tokens 11 /* put a string into the input buffer */
4544 @d expand_after 12 /* look ahead one token */
4545 @d defined_macro 13 /* a macro defined by the user */
4546 @d min_command (defined_macro+1)
4547 @d save_command 14 /* save a list of tokens (\&{save}) */
4548 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4549 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4550 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4551 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4552 @d ship_out_command 19 /* output a character (\&{shipout}) */
4553 @d add_to_command 20 /* add to edges (\&{addto}) */
4554 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4555 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4556 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4557 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4558 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4559 @d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
4560 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4561 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4562 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4563 @d special_command 30 /* output special info (\&{special})
4564 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4565 @d write_command 31 /* write text to a file (\&{write}) */
4566 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
4567 @d max_statement_command type_name
4568 @d min_primary_command type_name
4569 @d left_delimiter 33 /* the left delimiter of a matching pair */
4570 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4571 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4572 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4573 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4574 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4575 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4576 @d capsule_token 40 /* a value that has been put into a token list */
4577 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4578 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4579 @d min_suffix_token internal_quantity
4580 @d tag_token 43 /* a symbolic token without a primitive meaning */
4581 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4582 @d max_suffix_token numeric_token
4583 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4584 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4585 @d min_tertiary_command plus_or_minus
4586 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4587 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4588 @d max_tertiary_command tertiary_binary
4589 @d left_brace 48 /* the operator `\.{\char`\{}' */
4590 @d min_expression_command left_brace
4591 @d path_join 49 /* the operator `\.{..}' */
4592 @d ampersand 50 /* the operator `\.\&' */
4593 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4594 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4595 @d equals 53 /* the operator `\.=' */
4596 @d max_expression_command equals
4597 @d and_command 54 /* the operator `\&{and}' */
4598 @d min_secondary_command and_command
4599 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4600 @d slash 56 /* the operator `\./' */
4601 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4602 @d max_secondary_command secondary_binary
4603 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4604 @d controls 59 /* specify control points explicitly (\&{controls}) */
4605 @d tension 60 /* specify tension between knots (\&{tension}) */
4606 @d at_least 61 /* bounded tension value (\&{atleast}) */
4607 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4608 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4609 @d right_delimiter 64 /* the right delimiter of a matching pair */
4610 @d left_bracket 65 /* the operator `\.[' */
4611 @d right_bracket 66 /* the operator `\.]' */
4612 @d right_brace 67 /* the operator `\.{\char`\}}' */
4613 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4615 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4616 @d of_token 70 /* the operator `\&{of}' */
4617 @d to_token 71 /* the operator `\&{to}' */
4618 @d step_token 72 /* the operator `\&{step}' */
4619 @d until_token 73 /* the operator `\&{until}' */
4620 @d within_token 74 /* the operator `\&{within}' */
4621 @d lig_kern_token 75
4622 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
4623 @d assignment 76 /* the operator `\.{:=}' */
4624 @d skip_to 77 /* the operation `\&{skipto}' */
4625 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4626 @d double_colon 79 /* the operator `\.{::}' */
4627 @d colon 80 /* the operator `\.:' */
4629 @d comma 81 /* the operator `\.,', must be |colon+1| */
4630 @d end_of_statement (mp->cur_cmd>comma)
4631 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4632 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4633 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4634 @d max_command_code stop
4635 @d outer_tag (max_command_code+1) /* protection code added to command code */
4638 typedef int command_code;
4640 @ Variables and capsules in \MP\ have a variety of ``types,''
4641 distinguished by the code numbers defined here. These numbers are also
4642 not completely arbitrary. Things that get expanded must have types
4643 |>mp_independent|; a type remaining after expansion is numeric if and only if
4644 its code number is at least |numeric_type|; objects containing numeric
4645 parts must have types between |transform_type| and |pair_type|;
4646 all other types must be smaller than |transform_type|; and among the types
4647 that are not unknown or vacuous, the smallest two must be |boolean_type|
4648 and |string_type| in that order.
4650 @d undefined 0 /* no type has been declared */
4651 @d unknown_tag 1 /* this constant is added to certain type codes below */
4652 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4653 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4656 enum mp_variable_type {
4657 mp_vacuous=1, /* no expression was present */
4658 mp_boolean_type, /* \&{boolean} with a known value */
4660 mp_string_type, /* \&{string} with a known value */
4662 mp_pen_type, /* \&{pen} with a known value */
4664 mp_path_type, /* \&{path} with a known value */
4666 mp_picture_type, /* \&{picture} with a known value */
4668 mp_transform_type, /* \&{transform} variable or capsule */
4669 mp_color_type, /* \&{color} variable or capsule */
4670 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4671 mp_pair_type, /* \&{pair} variable or capsule */
4672 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4673 mp_known, /* \&{numeric} with a known value */
4674 mp_dependent, /* a linear combination with |fraction| coefficients */
4675 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4676 mp_independent, /* \&{numeric} with unknown value */
4677 mp_token_list, /* variable name or suffix argument or text argument */
4678 mp_structured, /* variable with subscripts and attributes */
4679 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4680 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4684 void mp_print_type (MP mp,quarterword t) ;
4686 @ @<Basic printing procedures@>=
4687 void mp_print_type (MP mp,quarterword t) {
4689 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4690 case mp_boolean_type:mp_print(mp, "boolean"); break;
4691 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4692 case mp_string_type:mp_print(mp, "string"); break;
4693 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4694 case mp_pen_type:mp_print(mp, "pen"); break;
4695 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4696 case mp_path_type:mp_print(mp, "path"); break;
4697 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4698 case mp_picture_type:mp_print(mp, "picture"); break;
4699 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4700 case mp_transform_type:mp_print(mp, "transform"); break;
4701 case mp_color_type:mp_print(mp, "color"); break;
4702 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4703 case mp_pair_type:mp_print(mp, "pair"); break;
4704 case mp_known:mp_print(mp, "known numeric"); break;
4705 case mp_dependent:mp_print(mp, "dependent"); break;
4706 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4707 case mp_numeric_type:mp_print(mp, "numeric"); break;
4708 case mp_independent:mp_print(mp, "independent"); break;
4709 case mp_token_list:mp_print(mp, "token list"); break;
4710 case mp_structured:mp_print(mp, "mp_structured"); break;
4711 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4712 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4713 default: mp_print(mp, "undefined"); break;
4717 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4718 as well as a |type|. The possibilities for |name_type| are defined
4719 here; they will be explained in more detail later.
4723 mp_root=0, /* |name_type| at the top level of a variable */
4724 mp_saved_root, /* same, when the variable has been saved */
4725 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4726 mp_subscr, /* |name_type| in a subscript node */
4727 mp_attr, /* |name_type| in an attribute node */
4728 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4729 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4730 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4731 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4732 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4733 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4734 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4735 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4736 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4737 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4738 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4739 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4740 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4741 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4742 mp_capsule, /* |name_type| in stashed-away subexpressions */
4743 mp_token /* |name_type| in a numeric token or string token */
4746 @ Primitive operations that produce values have a secondary identification
4747 code in addition to their command code; it's something like genera and species.
4748 For example, `\.*' has the command code |primary_binary|, and its
4749 secondary identification is |times|. The secondary codes start at 30 so that
4750 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4751 are used as operators as well as type identifications. The relative values
4752 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4753 and |filled_op..bounded_op|. The restrictions are that
4754 |and_op-false_code=or_op-true_code|, that the ordering of
4755 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4756 and the ordering of |filled_op..bounded_op| must match that of the code
4757 values they test for.
4759 @d true_code 30 /* operation code for \.{true} */
4760 @d false_code 31 /* operation code for \.{false} */
4761 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4762 @d null_pen_code 33 /* operation code for \.{nullpen} */
4763 @d job_name_op 34 /* operation code for \.{jobname} */
4764 @d read_string_op 35 /* operation code for \.{readstring} */
4765 @d pen_circle 36 /* operation code for \.{pencircle} */
4766 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4767 @d read_from_op 38 /* operation code for \.{readfrom} */
4768 @d close_from_op 39 /* operation code for \.{closefrom} */
4769 @d odd_op 40 /* operation code for \.{odd} */
4770 @d known_op 41 /* operation code for \.{known} */
4771 @d unknown_op 42 /* operation code for \.{unknown} */
4772 @d not_op 43 /* operation code for \.{not} */
4773 @d decimal 44 /* operation code for \.{decimal} */
4774 @d reverse 45 /* operation code for \.{reverse} */
4775 @d make_path_op 46 /* operation code for \.{makepath} */
4776 @d make_pen_op 47 /* operation code for \.{makepen} */
4777 @d oct_op 48 /* operation code for \.{oct} */
4778 @d hex_op 49 /* operation code for \.{hex} */
4779 @d ASCII_op 50 /* operation code for \.{ASCII} */
4780 @d char_op 51 /* operation code for \.{char} */
4781 @d length_op 52 /* operation code for \.{length} */
4782 @d turning_op 53 /* operation code for \.{turningnumber} */
4783 @d color_model_part 54 /* operation code for \.{colormodel} */
4784 @d x_part 55 /* operation code for \.{xpart} */
4785 @d y_part 56 /* operation code for \.{ypart} */
4786 @d xx_part 57 /* operation code for \.{xxpart} */
4787 @d xy_part 58 /* operation code for \.{xypart} */
4788 @d yx_part 59 /* operation code for \.{yxpart} */
4789 @d yy_part 60 /* operation code for \.{yypart} */
4790 @d red_part 61 /* operation code for \.{redpart} */
4791 @d green_part 62 /* operation code for \.{greenpart} */
4792 @d blue_part 63 /* operation code for \.{bluepart} */
4793 @d cyan_part 64 /* operation code for \.{cyanpart} */
4794 @d magenta_part 65 /* operation code for \.{magentapart} */
4795 @d yellow_part 66 /* operation code for \.{yellowpart} */
4796 @d black_part 67 /* operation code for \.{blackpart} */
4797 @d grey_part 68 /* operation code for \.{greypart} */
4798 @d font_part 69 /* operation code for \.{fontpart} */
4799 @d text_part 70 /* operation code for \.{textpart} */
4800 @d path_part 71 /* operation code for \.{pathpart} */
4801 @d pen_part 72 /* operation code for \.{penpart} */
4802 @d dash_part 73 /* operation code for \.{dashpart} */
4803 @d sqrt_op 74 /* operation code for \.{sqrt} */
4804 @d mp_m_exp_op 75 /* operation code for \.{mexp} */
4805 @d mp_m_log_op 76 /* operation code for \.{mlog} */
4806 @d sin_d_op 77 /* operation code for \.{sind} */
4807 @d cos_d_op 78 /* operation code for \.{cosd} */
4808 @d floor_op 79 /* operation code for \.{floor} */
4809 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4810 @d char_exists_op 81 /* operation code for \.{charexists} */
4811 @d font_size 82 /* operation code for \.{fontsize} */
4812 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4813 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4814 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4815 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4816 @d arc_length 87 /* operation code for \.{arclength} */
4817 @d angle_op 88 /* operation code for \.{angle} */
4818 @d cycle_op 89 /* operation code for \.{cycle} */
4819 @d filled_op 90 /* operation code for \.{filled} */
4820 @d stroked_op 91 /* operation code for \.{stroked} */
4821 @d textual_op 92 /* operation code for \.{textual} */
4822 @d clipped_op 93 /* operation code for \.{clipped} */
4823 @d bounded_op 94 /* operation code for \.{bounded} */
4824 @d plus 95 /* operation code for \.+ */
4825 @d minus 96 /* operation code for \.- */
4826 @d times 97 /* operation code for \.* */
4827 @d over 98 /* operation code for \./ */
4828 @d pythag_add 99 /* operation code for \.{++} */
4829 @d pythag_sub 100 /* operation code for \.{+-+} */
4830 @d or_op 101 /* operation code for \.{or} */
4831 @d and_op 102 /* operation code for \.{and} */
4832 @d less_than 103 /* operation code for \.< */
4833 @d less_or_equal 104 /* operation code for \.{<=} */
4834 @d greater_than 105 /* operation code for \.> */
4835 @d greater_or_equal 106 /* operation code for \.{>=} */
4836 @d equal_to 107 /* operation code for \.= */
4837 @d unequal_to 108 /* operation code for \.{<>} */
4838 @d concatenate 109 /* operation code for \.\& */
4839 @d rotated_by 110 /* operation code for \.{rotated} */
4840 @d slanted_by 111 /* operation code for \.{slanted} */
4841 @d scaled_by 112 /* operation code for \.{scaled} */
4842 @d shifted_by 113 /* operation code for \.{shifted} */
4843 @d transformed_by 114 /* operation code for \.{transformed} */
4844 @d x_scaled 115 /* operation code for \.{xscaled} */
4845 @d y_scaled 116 /* operation code for \.{yscaled} */
4846 @d z_scaled 117 /* operation code for \.{zscaled} */
4847 @d in_font 118 /* operation code for \.{infont} */
4848 @d intersect 119 /* operation code for \.{intersectiontimes} */
4849 @d double_dot 120 /* operation code for improper \.{..} */
4850 @d substring_of 121 /* operation code for \.{substring} */
4851 @d min_of substring_of
4852 @d subpath_of 122 /* operation code for \.{subpath} */
4853 @d direction_time_of 123 /* operation code for \.{directiontime} */
4854 @d point_of 124 /* operation code for \.{point} */
4855 @d precontrol_of 125 /* operation code for \.{precontrol} */
4856 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4857 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4858 @d arc_time_of 128 /* operation code for \.{arctime} */
4859 @d mp_version 129 /* operation code for \.{mpversion} */
4860 @d envelope_of 130 /* operation code for \.{envelope} */
4862 @c void mp_print_op (MP mp,quarterword c) {
4863 if (c<=mp_numeric_type ) {
4864 mp_print_type(mp, c);
4867 case true_code:mp_print(mp, "true"); break;
4868 case false_code:mp_print(mp, "false"); break;
4869 case null_picture_code:mp_print(mp, "nullpicture"); break;
4870 case null_pen_code:mp_print(mp, "nullpen"); break;
4871 case job_name_op:mp_print(mp, "jobname"); break;
4872 case read_string_op:mp_print(mp, "readstring"); break;
4873 case pen_circle:mp_print(mp, "pencircle"); break;
4874 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4875 case read_from_op:mp_print(mp, "readfrom"); break;
4876 case close_from_op:mp_print(mp, "closefrom"); break;
4877 case odd_op:mp_print(mp, "odd"); break;
4878 case known_op:mp_print(mp, "known"); break;
4879 case unknown_op:mp_print(mp, "unknown"); break;
4880 case not_op:mp_print(mp, "not"); break;
4881 case decimal:mp_print(mp, "decimal"); break;
4882 case reverse:mp_print(mp, "reverse"); break;
4883 case make_path_op:mp_print(mp, "makepath"); break;
4884 case make_pen_op:mp_print(mp, "makepen"); break;
4885 case oct_op:mp_print(mp, "oct"); break;
4886 case hex_op:mp_print(mp, "hex"); break;
4887 case ASCII_op:mp_print(mp, "ASCII"); break;
4888 case char_op:mp_print(mp, "char"); break;
4889 case length_op:mp_print(mp, "length"); break;
4890 case turning_op:mp_print(mp, "turningnumber"); break;
4891 case x_part:mp_print(mp, "xpart"); break;
4892 case y_part:mp_print(mp, "ypart"); break;
4893 case xx_part:mp_print(mp, "xxpart"); break;
4894 case xy_part:mp_print(mp, "xypart"); break;
4895 case yx_part:mp_print(mp, "yxpart"); break;
4896 case yy_part:mp_print(mp, "yypart"); break;
4897 case red_part:mp_print(mp, "redpart"); break;
4898 case green_part:mp_print(mp, "greenpart"); break;
4899 case blue_part:mp_print(mp, "bluepart"); break;
4900 case cyan_part:mp_print(mp, "cyanpart"); break;
4901 case magenta_part:mp_print(mp, "magentapart"); break;
4902 case yellow_part:mp_print(mp, "yellowpart"); break;
4903 case black_part:mp_print(mp, "blackpart"); break;
4904 case grey_part:mp_print(mp, "greypart"); break;
4905 case color_model_part:mp_print(mp, "colormodel"); break;
4906 case font_part:mp_print(mp, "fontpart"); break;
4907 case text_part:mp_print(mp, "textpart"); break;
4908 case path_part:mp_print(mp, "pathpart"); break;
4909 case pen_part:mp_print(mp, "penpart"); break;
4910 case dash_part:mp_print(mp, "dashpart"); break;
4911 case sqrt_op:mp_print(mp, "sqrt"); break;
4912 case mp_m_exp_op:mp_print(mp, "mexp"); break;
4913 case mp_m_log_op:mp_print(mp, "mlog"); break;
4914 case sin_d_op:mp_print(mp, "sind"); break;
4915 case cos_d_op:mp_print(mp, "cosd"); break;
4916 case floor_op:mp_print(mp, "floor"); break;
4917 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4918 case char_exists_op:mp_print(mp, "charexists"); break;
4919 case font_size:mp_print(mp, "fontsize"); break;
4920 case ll_corner_op:mp_print(mp, "llcorner"); break;
4921 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4922 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4923 case ur_corner_op:mp_print(mp, "urcorner"); break;
4924 case arc_length:mp_print(mp, "arclength"); break;
4925 case angle_op:mp_print(mp, "angle"); break;
4926 case cycle_op:mp_print(mp, "cycle"); break;
4927 case filled_op:mp_print(mp, "filled"); break;
4928 case stroked_op:mp_print(mp, "stroked"); break;
4929 case textual_op:mp_print(mp, "textual"); break;
4930 case clipped_op:mp_print(mp, "clipped"); break;
4931 case bounded_op:mp_print(mp, "bounded"); break;
4932 case plus:mp_print_char(mp, xord('+')); break;
4933 case minus:mp_print_char(mp, xord('-')); break;
4934 case times:mp_print_char(mp, xord('*')); break;
4935 case over:mp_print_char(mp, xord('/')); break;
4936 case pythag_add:mp_print(mp, "++"); break;
4937 case pythag_sub:mp_print(mp, "+-+"); break;
4938 case or_op:mp_print(mp, "or"); break;
4939 case and_op:mp_print(mp, "and"); break;
4940 case less_than:mp_print_char(mp, xord('<')); break;
4941 case less_or_equal:mp_print(mp, "<="); break;
4942 case greater_than:mp_print_char(mp, xord('>')); break;
4943 case greater_or_equal:mp_print(mp, ">="); break;
4944 case equal_to:mp_print_char(mp, xord('=')); break;
4945 case unequal_to:mp_print(mp, "<>"); break;
4946 case concatenate:mp_print(mp, "&"); break;
4947 case rotated_by:mp_print(mp, "rotated"); break;
4948 case slanted_by:mp_print(mp, "slanted"); break;
4949 case scaled_by:mp_print(mp, "scaled"); break;
4950 case shifted_by:mp_print(mp, "shifted"); break;
4951 case transformed_by:mp_print(mp, "transformed"); break;
4952 case x_scaled:mp_print(mp, "xscaled"); break;
4953 case y_scaled:mp_print(mp, "yscaled"); break;
4954 case z_scaled:mp_print(mp, "zscaled"); break;
4955 case in_font:mp_print(mp, "infont"); break;
4956 case intersect:mp_print(mp, "intersectiontimes"); break;
4957 case substring_of:mp_print(mp, "substring"); break;
4958 case subpath_of:mp_print(mp, "subpath"); break;
4959 case direction_time_of:mp_print(mp, "directiontime"); break;
4960 case point_of:mp_print(mp, "point"); break;
4961 case precontrol_of:mp_print(mp, "precontrol"); break;
4962 case postcontrol_of:mp_print(mp, "postcontrol"); break;
4963 case pen_offset_of:mp_print(mp, "penoffset"); break;
4964 case arc_time_of:mp_print(mp, "arctime"); break;
4965 case mp_version:mp_print(mp, "mpversion"); break;
4966 case envelope_of:mp_print(mp, "envelope"); break;
4967 default: mp_print(mp, ".."); break;
4972 @ \MP\ also has a bunch of internal parameters that a user might want to
4973 fuss with. Every such parameter has an identifying code number, defined here.
4976 enum mp_given_internal {
4977 mp_tracing_titles=1, /* show titles online when they appear */
4978 mp_tracing_equations, /* show each variable when it becomes known */
4979 mp_tracing_capsules, /* show capsules too */
4980 mp_tracing_choices, /* show the control points chosen for paths */
4981 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
4982 mp_tracing_commands, /* show commands and operations before they are performed */
4983 mp_tracing_restores, /* show when a variable or internal is restored */
4984 mp_tracing_macros, /* show macros before they are expanded */
4985 mp_tracing_output, /* show digitized edges as they are output */
4986 mp_tracing_stats, /* show memory usage at end of job */
4987 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
4988 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
4989 mp_year, /* the current year (e.g., 1984) */
4990 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
4991 mp_day, /* the current day of the month */
4992 mp_time, /* the number of minutes past midnight when this job started */
4993 mp_char_code, /* the number of the next character to be output */
4994 mp_char_ext, /* the extension code of the next character to be output */
4995 mp_char_wd, /* the width of the next character to be output */
4996 mp_char_ht, /* the height of the next character to be output */
4997 mp_char_dp, /* the depth of the next character to be output */
4998 mp_char_ic, /* the italic correction of the next character to be output */
4999 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
5000 mp_pausing, /* positive to display lines on the terminal before they are read */
5001 mp_showstopping, /* positive to stop after each \&{show} command */
5002 mp_fontmaking, /* positive if font metric output is to be produced */
5003 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
5004 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
5005 mp_miterlimit, /* controls miter length as in \ps */
5006 mp_warning_check, /* controls error message when variable value is large */
5007 mp_boundary_char, /* the right boundary character for ligatures */
5008 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
5009 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
5010 mp_default_color_model, /* the default color model for unspecified items */
5011 mp_restore_clip_color,
5012 mp_procset, /* wether or not create PostScript command shortcuts */
5013 mp_gtroffmode /* whether the user specified |-troff| on the command line */
5018 @d max_given_internal mp_gtroffmode
5021 scaled *internal; /* the values of internal quantities */
5022 char **int_name; /* their names */
5023 int int_ptr; /* the maximum internal quantity defined so far */
5024 int max_internal; /* current maximum number of internal quantities */
5026 @ @<Option variables@>=
5029 @ @<Allocate or initialize ...@>=
5030 mp->max_internal=2*max_given_internal;
5031 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
5032 memset(mp->internal,0,(mp->max_internal+1)* sizeof(scaled));
5033 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
5034 memset(mp->int_name,0,(mp->max_internal+1) * sizeof(char *));
5035 mp->troff_mode=(opt->troff_mode>0 ? true : false);
5037 @ @<Exported function ...@>=
5038 int mp_troff_mode(MP mp);
5041 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5043 @ @<Set initial ...@>=
5044 mp->int_ptr=max_given_internal;
5046 @ The symbolic names for internal quantities are put into \MP's hash table
5047 by using a routine called |primitive|, which will be defined later. Let us
5048 enter them now, so that we don't have to list all those names again
5051 @<Put each of \MP's primitives into the hash table@>=
5052 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5053 @:tracingtitles_}{\&{tracingtitles} primitive@>
5054 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5055 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5056 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5057 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5058 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5059 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5060 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5061 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5062 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5063 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5064 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5065 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5066 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5067 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5068 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5069 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5070 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5071 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5072 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5073 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5074 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5075 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5076 mp_primitive(mp, "year",internal_quantity,mp_year);
5077 @:mp_year_}{\&{year} primitive@>
5078 mp_primitive(mp, "month",internal_quantity,mp_month);
5079 @:mp_month_}{\&{month} primitive@>
5080 mp_primitive(mp, "day",internal_quantity,mp_day);
5081 @:mp_day_}{\&{day} primitive@>
5082 mp_primitive(mp, "time",internal_quantity,mp_time);
5083 @:time_}{\&{time} primitive@>
5084 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5085 @:mp_char_code_}{\&{charcode} primitive@>
5086 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5087 @:mp_char_ext_}{\&{charext} primitive@>
5088 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5089 @:mp_char_wd_}{\&{charwd} primitive@>
5090 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5091 @:mp_char_ht_}{\&{charht} primitive@>
5092 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5093 @:mp_char_dp_}{\&{chardp} primitive@>
5094 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5095 @:mp_char_ic_}{\&{charic} primitive@>
5096 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5097 @:mp_design_size_}{\&{designsize} primitive@>
5098 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5099 @:mp_pausing_}{\&{pausing} primitive@>
5100 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5101 @:mp_showstopping_}{\&{showstopping} primitive@>
5102 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5103 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5104 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5105 @:mp_linejoin_}{\&{linejoin} primitive@>
5106 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5107 @:mp_linecap_}{\&{linecap} primitive@>
5108 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5109 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5110 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5111 @:mp_warning_check_}{\&{warningcheck} primitive@>
5112 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5113 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5114 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5115 @:mp_prologues_}{\&{prologues} primitive@>
5116 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5117 @:mp_true_corners_}{\&{truecorners} primitive@>
5118 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5119 @:mp_procset_}{\&{mpprocset} primitive@>
5120 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5121 @:troffmode_}{\&{troffmode} primitive@>
5122 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5123 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5124 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5125 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5127 @ Colors can be specified in four color models. In the special
5128 case of |no_model|, MetaPost does not output any color operator to
5129 the postscript output.
5131 Note: these values are passed directly on to |with_option|. This only
5132 works because the other possible values passed to |with_option| are
5133 8 and 10 respectively (from |with_pen| and |with_picture|).
5135 There is a first state, that is only used for |gs_colormodel|. It flags
5136 the fact that there has not been any kind of color specification by
5137 the user so far in the game.
5140 enum mp_color_model {
5145 mp_uninitialized_model=9
5149 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5150 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5151 mp->internal[mp_restore_clip_color]=unity;
5153 @ Well, we do have to list the names one more time, for use in symbolic
5156 @<Initialize table...@>=
5157 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5158 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5159 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5160 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5161 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5162 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5163 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5164 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5165 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5166 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5167 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5168 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5169 mp->int_name[mp_year]=xstrdup("year");
5170 mp->int_name[mp_month]=xstrdup("month");
5171 mp->int_name[mp_day]=xstrdup("day");
5172 mp->int_name[mp_time]=xstrdup("time");
5173 mp->int_name[mp_char_code]=xstrdup("charcode");
5174 mp->int_name[mp_char_ext]=xstrdup("charext");
5175 mp->int_name[mp_char_wd]=xstrdup("charwd");
5176 mp->int_name[mp_char_ht]=xstrdup("charht");
5177 mp->int_name[mp_char_dp]=xstrdup("chardp");
5178 mp->int_name[mp_char_ic]=xstrdup("charic");
5179 mp->int_name[mp_design_size]=xstrdup("designsize");
5180 mp->int_name[mp_pausing]=xstrdup("pausing");
5181 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5182 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5183 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5184 mp->int_name[mp_linecap]=xstrdup("linecap");
5185 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5186 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5187 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5188 mp->int_name[mp_prologues]=xstrdup("prologues");
5189 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5190 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5191 mp->int_name[mp_procset]=xstrdup("mpprocset");
5192 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5193 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5195 @ The following procedure, which is called just before \MP\ initializes its
5196 input and output, establishes the initial values of the date and time.
5197 @^system dependencies@>
5199 Note that the values are |scaled| integers. Hence \MP\ can no longer
5200 be used after the year 32767.
5203 void mp_fix_date_and_time (MP mp) {
5204 time_t aclock = time ((time_t *) 0);
5205 struct tm *tmptr = localtime (&aclock);
5206 mp->internal[mp_time]=
5207 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5208 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5209 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5210 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5214 void mp_fix_date_and_time (MP mp) ;
5216 @ \MP\ is occasionally supposed to print diagnostic information that
5217 goes only into the transcript file, unless |mp_tracing_online| is positive.
5218 Now that we have defined |mp_tracing_online| we can define
5219 two routines that adjust the destination of print commands:
5222 void mp_begin_diagnostic (MP mp) ;
5223 void mp_end_diagnostic (MP mp,boolean blank_line);
5224 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
5226 @ @<Basic printing...@>=
5227 @<Declare a function called |true_line|@>
5228 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5229 mp->old_setting=mp->selector;
5230 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5232 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5236 void mp_end_diagnostic (MP mp,boolean blank_line) {
5237 /* restore proper conditions after tracing */
5238 mp_print_nl(mp, "");
5239 if ( blank_line ) mp_print_ln(mp);
5240 mp->selector=mp->old_setting;
5246 unsigned int old_setting;
5248 @ We will occasionally use |begin_diagnostic| in connection with line-number
5249 printing, as follows. (The parameter |s| is typically |"Path"| or
5250 |"Cycle spec"|, etc.)
5252 @<Basic printing...@>=
5253 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
5254 mp_begin_diagnostic(mp);
5255 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5256 mp_print(mp, " at line ");
5257 mp_print_int(mp, mp_true_line(mp));
5258 mp_print(mp, t); mp_print_char(mp, xord(':'));
5261 @ The 256 |ASCII_code| characters are grouped into classes by means of
5262 the |char_class| table. Individual class numbers have no semantic
5263 or syntactic significance, except in a few instances defined here.
5264 There's also |max_class|, which can be used as a basis for additional
5265 class numbers in nonstandard extensions of \MP.
5267 @d digit_class 0 /* the class number of \.{0123456789} */
5268 @d period_class 1 /* the class number of `\..' */
5269 @d space_class 2 /* the class number of spaces and nonstandard characters */
5270 @d percent_class 3 /* the class number of `\.\%' */
5271 @d string_class 4 /* the class number of `\."' */
5272 @d right_paren_class 8 /* the class number of `\.)' */
5273 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5274 @d letter_class 9 /* letters and the underline character */
5275 @d left_bracket_class 17 /* `\.[' */
5276 @d right_bracket_class 18 /* `\.]' */
5277 @d invalid_class 20 /* bad character in the input */
5278 @d max_class 20 /* the largest class number */
5281 int char_class[256]; /* the class numbers */
5283 @ If changes are made to accommodate non-ASCII character sets, they should
5284 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5285 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5286 @^system dependencies@>
5288 @<Set initial ...@>=
5289 for (k='0';k<='9';k++)
5290 mp->char_class[k]=digit_class;
5291 mp->char_class['.']=period_class;
5292 mp->char_class[' ']=space_class;
5293 mp->char_class['%']=percent_class;
5294 mp->char_class['"']=string_class;
5295 mp->char_class[',']=5;
5296 mp->char_class[';']=6;
5297 mp->char_class['(']=7;
5298 mp->char_class[')']=right_paren_class;
5299 for (k='A';k<= 'Z';k++ )
5300 mp->char_class[k]=letter_class;
5301 for (k='a';k<='z';k++)
5302 mp->char_class[k]=letter_class;
5303 mp->char_class['_']=letter_class;
5304 mp->char_class['<']=10;
5305 mp->char_class['=']=10;
5306 mp->char_class['>']=10;
5307 mp->char_class[':']=10;
5308 mp->char_class['|']=10;
5309 mp->char_class['`']=11;
5310 mp->char_class['\'']=11;
5311 mp->char_class['+']=12;
5312 mp->char_class['-']=12;
5313 mp->char_class['/']=13;
5314 mp->char_class['*']=13;
5315 mp->char_class['\\']=13;
5316 mp->char_class['!']=14;
5317 mp->char_class['?']=14;
5318 mp->char_class['#']=15;
5319 mp->char_class['&']=15;
5320 mp->char_class['@@']=15;
5321 mp->char_class['$']=15;
5322 mp->char_class['^']=16;
5323 mp->char_class['~']=16;
5324 mp->char_class['[']=left_bracket_class;
5325 mp->char_class[']']=right_bracket_class;
5326 mp->char_class['{']=19;
5327 mp->char_class['}']=19;
5329 mp->char_class[k]=invalid_class;
5330 mp->char_class['\t']=space_class;
5331 mp->char_class['\f']=space_class;
5332 for (k=127;k<=255;k++)
5333 mp->char_class[k]=invalid_class;
5335 @* \[13] The hash table.
5336 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5337 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5338 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5339 table, it is never removed.
5341 The actual sequence of characters forming a symbolic token is
5342 stored in the |str_pool| array together with all the other strings. An
5343 auxiliary array |hash| consists of items with two halfword fields per
5344 word. The first of these, called |next(p)|, points to the next identifier
5345 belonging to the same coalesced list as the identifier corresponding to~|p|;
5346 and the other, called |text(p)|, points to the |str_start| entry for
5347 |p|'s identifier. If position~|p| of the hash table is empty, we have
5348 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5349 hash list, we have |next(p)=0|.
5351 An auxiliary pointer variable called |hash_used| is maintained in such a
5352 way that all locations |p>=hash_used| are nonempty. The global variable
5353 |st_count| tells how many symbolic tokens have been defined, if statistics
5356 The first 256 locations of |hash| are reserved for symbols of length one.
5358 There's a parallel array called |eqtb| that contains the current equivalent
5359 values of each symbolic token. The entries of this array consist of
5360 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5361 piece of information that qualifies the |eq_type|).
5363 @d next(A) mp->hash[(A)].lh /* link for coalesced lists */
5364 @d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5365 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5366 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5367 @d hash_base 257 /* hashing actually starts here */
5368 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5371 pointer hash_used; /* allocation pointer for |hash| */
5372 integer st_count; /* total number of known identifiers */
5374 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5375 since they are used in error recovery.
5377 @d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
5378 @d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5379 @d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5380 @d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5381 @d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5382 @d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5383 @d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5384 @d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5385 @d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5386 @d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5387 @d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5388 @d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5389 @d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5390 @d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5391 @d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5392 @d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5393 @d hash_end (integer)(hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5396 two_halves *hash; /* the hash table */
5397 two_halves *eqtb; /* the equivalents */
5399 @ @<Allocate or initialize ...@>=
5400 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5401 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5403 @ @<Dealloc variables@>=
5408 next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5409 for (k=2;k<=hash_end;k++) {
5410 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5413 @ @<Initialize table entries...@>=
5414 mp->hash_used=frozen_inaccessible; /* nothing is used */
5416 text(frozen_bad_vardef)=intern("a bad variable");
5417 text(frozen_etex)=intern("etex");
5418 text(frozen_mpx_break)=intern("mpxbreak");
5419 text(frozen_fi)=intern("fi");
5420 text(frozen_end_group)=intern("endgroup");
5421 text(frozen_end_def)=intern("enddef");
5422 text(frozen_end_for)=intern("endfor");
5423 text(frozen_semicolon)=intern(";");
5424 text(frozen_colon)=intern(":");
5425 text(frozen_slash)=intern("/");
5426 text(frozen_left_bracket)=intern("[");
5427 text(frozen_right_delimiter)=intern(")");
5428 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5429 eq_type(frozen_right_delimiter)=right_delimiter;
5431 @ @<Check the ``constant'' values...@>=
5432 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5434 @ Here is the subroutine that searches the hash table for an identifier
5435 that matches a given string of length~|l| appearing in |buffer[j..
5436 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5437 will always be found, and the corresponding hash table address
5441 pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5442 integer h; /* hash code */
5443 pointer p; /* index in |hash| array */
5444 pointer k; /* index in |buffer| array */
5446 @<Treat special case of length 1 and |break|@>;
5448 @<Compute the hash code |h|@>;
5449 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5451 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5454 @<Insert a new symbolic token after |p|, then
5455 make |p| point to it and |break|@>;
5462 @ @<Treat special case of length 1...@>=
5463 p=mp->buffer[j]+1; text(p)=p-1; return p;
5466 @ @<Insert a new symbolic...@>=
5471 mp_overflow(mp, "hash size",mp->hash_size);
5472 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5473 decr(mp->hash_used);
5474 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5475 next(p)=mp->hash_used;
5479 for (k=j;k<=j+l-1;k++) {
5480 append_char(mp->buffer[k]);
5482 text(p)=mp_make_string(mp);
5483 mp->str_ref[text(p)]=max_str_ref;
5489 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5490 should be a prime number. The theory of hashing tells us to expect fewer
5491 than two table probes, on the average, when the search is successful.
5492 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5493 @^Vitter, Jeffrey Scott@>
5495 @<Compute the hash code |h|@>=
5497 for (k=j+1;k<=j+l-1;k++){
5498 h=h+h+mp->buffer[k];
5499 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5502 @ @<Search |eqtb| for equivalents equal to |p|@>=
5503 for (q=1;q<=hash_end;q++) {
5504 if ( equiv(q)==p ) {
5505 mp_print_nl(mp, "EQUIV(");
5506 mp_print_int(mp, q);
5507 mp_print_char(mp, xord(')'));
5511 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5512 table, together with their command code (which will be the |eq_type|)
5513 and an operand (which will be the |equiv|). The |primitive| procedure
5514 does this, in a way that no \MP\ user can. The global value |cur_sym|
5515 contains the new |eqtb| pointer after |primitive| has acted.
5518 void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
5519 pool_pointer k; /* index into |str_pool| */
5520 quarterword j; /* index into |buffer| */
5521 quarterword l; /* length of the string */
5524 k=mp->str_start[s]; l=str_stop(s)-k;
5525 /* we will move |s| into the (empty) |buffer| */
5526 for (j=0;j<=l-1;j++) {
5527 mp->buffer[j]=mp->str_pool[k+j];
5529 mp->cur_sym=mp_id_lookup(mp, 0,l);
5530 if ( s>=256 ) { /* we don't want to have the string twice */
5531 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5533 eq_type(mp->cur_sym)=c;
5534 equiv(mp->cur_sym)=o;
5538 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5539 by their |eq_type| alone. These primitives are loaded into the hash table
5542 @<Put each of \MP's primitives into the hash table@>=
5543 mp_primitive(mp, "..",path_join,0);
5544 @:.._}{\.{..} primitive@>
5545 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5546 @:[ }{\.{[} primitive@>
5547 mp_primitive(mp, "]",right_bracket,0);
5548 @:] }{\.{]} primitive@>
5549 mp_primitive(mp, "}",right_brace,0);
5550 @:]]}{\.{\char`\}} primitive@>
5551 mp_primitive(mp, "{",left_brace,0);
5552 @:][}{\.{\char`\{} primitive@>
5553 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5554 @:: }{\.{:} primitive@>
5555 mp_primitive(mp, "::",double_colon,0);
5556 @::: }{\.{::} primitive@>
5557 mp_primitive(mp, "||:",bchar_label,0);
5558 @:::: }{\.{\char'174\char'174:} primitive@>
5559 mp_primitive(mp, ":=",assignment,0);
5560 @::=_}{\.{:=} primitive@>
5561 mp_primitive(mp, ",",comma,0);
5562 @:, }{\., primitive@>
5563 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5564 @:; }{\.; primitive@>
5565 mp_primitive(mp, "\\",relax,0);
5566 @:]]\\}{\.{\char`\\} primitive@>
5568 mp_primitive(mp, "addto",add_to_command,0);
5569 @:add_to_}{\&{addto} primitive@>
5570 mp_primitive(mp, "atleast",at_least,0);
5571 @:at_least_}{\&{atleast} primitive@>
5572 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5573 @:begin_group_}{\&{begingroup} primitive@>
5574 mp_primitive(mp, "controls",controls,0);
5575 @:controls_}{\&{controls} primitive@>
5576 mp_primitive(mp, "curl",curl_command,0);
5577 @:curl_}{\&{curl} primitive@>
5578 mp_primitive(mp, "delimiters",delimiters,0);
5579 @:delimiters_}{\&{delimiters} primitive@>
5580 mp_primitive(mp, "endgroup",end_group,0);
5581 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5582 @:endgroup_}{\&{endgroup} primitive@>
5583 mp_primitive(mp, "everyjob",every_job_command,0);
5584 @:every_job_}{\&{everyjob} primitive@>
5585 mp_primitive(mp, "exitif",exit_test,0);
5586 @:exit_if_}{\&{exitif} primitive@>
5587 mp_primitive(mp, "expandafter",expand_after,0);
5588 @:expand_after_}{\&{expandafter} primitive@>
5589 mp_primitive(mp, "interim",interim_command,0);
5590 @:interim_}{\&{interim} primitive@>
5591 mp_primitive(mp, "let",let_command,0);
5592 @:let_}{\&{let} primitive@>
5593 mp_primitive(mp, "newinternal",new_internal,0);
5594 @:new_internal_}{\&{newinternal} primitive@>
5595 mp_primitive(mp, "of",of_token,0);
5596 @:of_}{\&{of} primitive@>
5597 mp_primitive(mp, "randomseed",mp_random_seed,0);
5598 @:mp_random_seed_}{\&{randomseed} primitive@>
5599 mp_primitive(mp, "save",save_command,0);
5600 @:save_}{\&{save} primitive@>
5601 mp_primitive(mp, "scantokens",scan_tokens,0);
5602 @:scan_tokens_}{\&{scantokens} primitive@>
5603 mp_primitive(mp, "shipout",ship_out_command,0);
5604 @:ship_out_}{\&{shipout} primitive@>
5605 mp_primitive(mp, "skipto",skip_to,0);
5606 @:skip_to_}{\&{skipto} primitive@>
5607 mp_primitive(mp, "special",special_command,0);
5608 @:special}{\&{special} primitive@>
5609 mp_primitive(mp, "fontmapfile",special_command,1);
5610 @:fontmapfile}{\&{fontmapfile} primitive@>
5611 mp_primitive(mp, "fontmapline",special_command,2);
5612 @:fontmapline}{\&{fontmapline} primitive@>
5613 mp_primitive(mp, "step",step_token,0);
5614 @:step_}{\&{step} primitive@>
5615 mp_primitive(mp, "str",str_op,0);
5616 @:str_}{\&{str} primitive@>
5617 mp_primitive(mp, "tension",tension,0);
5618 @:tension_}{\&{tension} primitive@>
5619 mp_primitive(mp, "to",to_token,0);
5620 @:to_}{\&{to} primitive@>
5621 mp_primitive(mp, "until",until_token,0);
5622 @:until_}{\&{until} primitive@>
5623 mp_primitive(mp, "within",within_token,0);
5624 @:within_}{\&{within} primitive@>
5625 mp_primitive(mp, "write",write_command,0);
5626 @:write_}{\&{write} primitive@>
5628 @ Each primitive has a corresponding inverse, so that it is possible to
5629 display the cryptic numeric contents of |eqtb| in symbolic form.
5630 Every call of |primitive| in this program is therefore accompanied by some
5631 straightforward code that forms part of the |print_cmd_mod| routine
5634 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5635 case add_to_command:mp_print(mp, "addto"); break;
5636 case assignment:mp_print(mp, ":="); break;
5637 case at_least:mp_print(mp, "atleast"); break;
5638 case bchar_label:mp_print(mp, "||:"); break;
5639 case begin_group:mp_print(mp, "begingroup"); break;
5640 case colon:mp_print(mp, ":"); break;
5641 case comma:mp_print(mp, ","); break;
5642 case controls:mp_print(mp, "controls"); break;
5643 case curl_command:mp_print(mp, "curl"); break;
5644 case delimiters:mp_print(mp, "delimiters"); break;
5645 case double_colon:mp_print(mp, "::"); break;
5646 case end_group:mp_print(mp, "endgroup"); break;
5647 case every_job_command:mp_print(mp, "everyjob"); break;
5648 case exit_test:mp_print(mp, "exitif"); break;
5649 case expand_after:mp_print(mp, "expandafter"); break;
5650 case interim_command:mp_print(mp, "interim"); break;
5651 case left_brace:mp_print(mp, "{"); break;
5652 case left_bracket:mp_print(mp, "["); break;
5653 case let_command:mp_print(mp, "let"); break;
5654 case new_internal:mp_print(mp, "newinternal"); break;
5655 case of_token:mp_print(mp, "of"); break;
5656 case path_join:mp_print(mp, ".."); break;
5657 case mp_random_seed:mp_print(mp, "randomseed"); break;
5658 case relax:mp_print_char(mp, xord('\\')); break;
5659 case right_brace:mp_print_char(mp, xord('}')); break;
5660 case right_bracket:mp_print_char(mp, xord(']')); break;
5661 case save_command:mp_print(mp, "save"); break;
5662 case scan_tokens:mp_print(mp, "scantokens"); break;
5663 case semicolon:mp_print_char(mp, xord(';')); break;
5664 case ship_out_command:mp_print(mp, "shipout"); break;
5665 case skip_to:mp_print(mp, "skipto"); break;
5666 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5667 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5668 mp_print(mp, "special"); break;
5669 case step_token:mp_print(mp, "step"); break;
5670 case str_op:mp_print(mp, "str"); break;
5671 case tension:mp_print(mp, "tension"); break;
5672 case to_token:mp_print(mp, "to"); break;
5673 case until_token:mp_print(mp, "until"); break;
5674 case within_token:mp_print(mp, "within"); break;
5675 case write_command:mp_print(mp, "write"); break;
5677 @ We will deal with the other primitives later, at some point in the program
5678 where their |eq_type| and |equiv| values are more meaningful. For example,
5679 the primitives for macro definitions will be loaded when we consider the
5680 routines that define macros.
5681 It is easy to find where each particular
5682 primitive was treated by looking in the index at the end; for example, the
5683 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5685 @* \[14] Token lists.
5686 A \MP\ token is either symbolic or numeric or a string, or it denotes
5687 a macro parameter or capsule; so there are five corresponding ways to encode it
5689 internally: (1)~A symbolic token whose hash code is~|p|
5690 is represented by the number |p|, in the |info| field of a single-word
5691 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5692 represented in a two-word node of~|mem|; the |type| field is |known|,
5693 the |name_type| field is |token|, and the |value| field holds~|v|.
5694 The fact that this token appears in a two-word node rather than a
5695 one-word node is, of course, clear from the node address.
5696 (3)~A string token is also represented in a two-word node; the |type|
5697 field is |mp_string_type|, the |name_type| field is |token|, and the
5698 |value| field holds the corresponding |str_number|. (4)~Capsules have
5699 |name_type=capsule|, and their |type| and |value| fields represent
5700 arbitrary values (in ways to be explained later). (5)~Macro parameters
5701 are like symbolic tokens in that they appear in |info| fields of
5702 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5703 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5704 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5705 Actual values of these parameters are kept in a separate stack, as we will
5706 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5707 of course, chosen so that there will be no confusion between symbolic
5708 tokens and parameters of various types.
5711 the `\\{type}' field of a node has nothing to do with ``type'' in a
5712 printer's sense. It's curious that the same word is used in such different ways.
5714 @d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5715 @d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5716 @d token_node_size 2 /* the number of words in a large token node */
5717 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5718 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5719 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5720 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5721 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5723 @<Check the ``constant''...@>=
5724 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5726 @ We have set aside a two word node beginning at |null| so that we can have
5727 |value(null)=0|. We will make use of this coincidence later.
5729 @<Initialize table entries...@>=
5730 mp_link(null)=null; value(null)=0;
5732 @ A numeric token is created by the following trivial routine.
5735 pointer mp_new_num_tok (MP mp,scaled v) {
5736 pointer p; /* the new node */
5737 p=mp_get_node(mp, token_node_size); value(p)=v;
5738 type(p)=mp_known; name_type(p)=mp_token;
5742 @ A token list is a singly linked list of nodes in |mem|, where
5743 each node contains a token and a link. Here's a subroutine that gets rid
5744 of a token list when it is no longer needed.
5746 @c void mp_flush_token_list (MP mp,pointer p) {
5747 pointer q; /* the node being recycled */
5750 if ( q>=mp->hi_mem_min ) {
5754 case mp_vacuous: case mp_boolean_type: case mp_known:
5756 case mp_string_type:
5757 delete_str_ref(value(q));
5759 case unknown_types: case mp_pen_type: case mp_path_type:
5760 case mp_picture_type: case mp_pair_type: case mp_color_type:
5761 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5762 case mp_proto_dependent: case mp_independent:
5763 mp_recycle_value(mp,q);
5765 default: mp_confusion(mp, "token");
5766 @:this can't happen token}{\quad token@>
5768 mp_free_node(mp, q,token_node_size);
5773 @ The procedure |show_token_list|, which prints a symbolic form of
5774 the token list that starts at a given node |p|, illustrates these
5775 conventions. The token list being displayed should not begin with a reference
5776 count. However, the procedure is intended to be fairly robust, so that if the
5777 memory links are awry or if |p| is not really a pointer to a token list,
5778 almost nothing catastrophic can happen.
5780 An additional parameter |q| is also given; this parameter is either null
5781 or it points to a node in the token list where a certain magic computation
5782 takes place that will be explained later. (Basically, |q| is non-null when
5783 we are printing the two-line context information at the time of an error
5784 message; |q| marks the place corresponding to where the second line
5787 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5788 of printing exceeds a given limit~|l|; the length of printing upon entry is
5789 assumed to be a given amount called |null_tally|. (Note that
5790 |show_token_list| sometimes uses itself recursively to print
5791 variable names within a capsule.)
5794 Unusual entries are printed in the form of all-caps tokens
5795 preceded by a space, e.g., `\.{\char`\ BAD}'.
5797 @<Declare the procedure called |show_token_list|@>=
5798 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5799 integer null_tally) ;
5802 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5803 integer null_tally) {
5804 quarterword class,c; /* the |char_class| of previous and new tokens */
5805 integer r,v; /* temporary registers */
5806 class=percent_class;
5807 mp->tally=null_tally;
5808 while ( (p!=null) && (mp->tally<l) ) {
5810 @<Do magic computation@>;
5811 @<Display token |p| and set |c| to its class;
5812 but |return| if there are problems@>;
5813 class=c; p=mp_link(p);
5816 mp_print(mp, " ETC.");
5821 @ @<Display token |p| and set |c| to its class...@>=
5822 c=letter_class; /* the default */
5823 if ( (p<0)||(p>mp->mem_end) ) {
5824 mp_print(mp, " CLOBBERED"); return;
5827 if ( p<mp->hi_mem_min ) {
5828 @<Display two-word token@>;
5831 if ( r>=expr_base ) {
5832 @<Display a parameter token@>;
5836 @<Display a collective subscript@>
5838 mp_print(mp, " IMPOSSIBLE");
5843 if ( (r<0)||(r>mp->max_str_ptr) ) {
5844 mp_print(mp, " NONEXISTENT");
5847 @<Print string |r| as a symbolic token
5848 and set |c| to its class@>;
5854 @ @<Display two-word token@>=
5855 if ( name_type(p)==mp_token ) {
5856 if ( type(p)==mp_known ) {
5857 @<Display a numeric token@>;
5858 } else if ( type(p)!=mp_string_type ) {
5859 mp_print(mp, " BAD");
5862 mp_print_char(mp, xord('"')); mp_print_str(mp, value(p)); mp_print_char(mp, xord('"'));
5865 } else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
5866 mp_print(mp, " BAD");
5868 mp_print_capsule(mp,p); c=right_paren_class;
5871 @ @<Display a numeric token@>=
5872 if ( class==digit_class )
5873 mp_print_char(mp, xord(' '));
5876 if ( class==left_bracket_class )
5877 mp_print_char(mp, xord(' '));
5878 mp_print_char(mp, xord('[')); mp_print_scaled(mp, v); mp_print_char(mp, xord(']'));
5879 c=right_bracket_class;
5881 mp_print_scaled(mp, v); c=digit_class;
5885 @ Strictly speaking, a genuine token will never have |info(p)=0|.
5886 But we will see later (in the |print_variable_name| routine) that
5887 it is convenient to let |info(p)=0| stand for `\.{[]}'.
5889 @<Display a collective subscript@>=
5891 if ( class==left_bracket_class )
5892 mp_print_char(mp, xord(' '));
5893 mp_print(mp, "[]"); c=right_bracket_class;
5896 @ @<Display a parameter token@>=
5898 if ( r<suffix_base ) {
5899 mp_print(mp, "(EXPR"); r=r-(expr_base);
5901 } else if ( r<text_base ) {
5902 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5905 mp_print(mp, "(TEXT"); r=r-(text_base);
5908 mp_print_int(mp, r); mp_print_char(mp, xord(')')); c=right_paren_class;
5912 @ @<Print string |r| as a symbolic token...@>=
5914 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5917 case letter_class:mp_print_char(mp, xord('.')); break;
5918 case isolated_classes: break;
5919 default: mp_print_char(mp, xord(' ')); break;
5922 mp_print_str(mp, r);
5926 void mp_print_capsule (MP mp, pointer p);
5928 @ @<Declare miscellaneous procedures that were declared |forward|@>=
5929 void mp_print_capsule (MP mp, pointer p) {
5930 mp_print_char(mp, xord('(')); mp_print_exp(mp,p,0); mp_print_char(mp, xord(')'));
5933 @ Macro definitions are kept in \MP's memory in the form of token lists
5934 that have a few extra one-word nodes at the beginning.
5936 The first node contains a reference count that is used to tell when the
5937 list is no longer needed. To emphasize the fact that a reference count is
5938 present, we shall refer to the |info| field of this special node as the
5940 @^reference counts@>
5942 The next node or nodes after the reference count serve to describe the
5943 formal parameters. They consist of zero or more parameter tokens followed
5944 by a code for the type of macro.
5947 /* reference count preceding a macro definition or picture header */
5948 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
5949 @d general_macro 0 /* preface to a macro defined with a parameter list */
5950 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
5951 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
5952 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
5953 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
5954 @d of_macro 5 /* preface to a macro with
5955 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
5956 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
5957 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
5960 void mp_delete_mac_ref (MP mp,pointer p) {
5961 /* |p| points to the reference count of a macro list that is
5962 losing one reference */
5963 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
5964 else decr(ref_count(p));
5967 @ The following subroutine displays a macro, given a pointer to its
5971 @<Declare the procedure called |print_cmd_mod|@>
5972 void mp_show_macro (MP mp, pointer p, integer q, integer l) {
5973 pointer r; /* temporary storage */
5974 p=mp_link(p); /* bypass the reference count */
5975 while ( info(p)>text_macro ){
5976 r=mp_link(p); mp_link(p)=null;
5977 mp_show_token_list(mp, p,null,l,0); mp_link(p)=r; p=r;
5978 if ( l>0 ) l=l-mp->tally; else return;
5979 } /* control printing of `\.{ETC.}' */
5983 case general_macro:mp_print(mp, "->"); break;
5985 case primary_macro: case secondary_macro: case tertiary_macro:
5986 mp_print_char(mp, xord('<'));
5987 mp_print_cmd_mod(mp, param_type,info(p));
5988 mp_print(mp, ">->");
5990 case expr_macro:mp_print(mp, "<expr>->"); break;
5991 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
5992 case suffix_macro:mp_print(mp, "<suffix>->"); break;
5993 case text_macro:mp_print(mp, "<text>->"); break;
5994 } /* there are no other cases */
5995 mp_show_token_list(mp, mp_link(p),q,l-mp->tally,0);
5998 @* \[15] Data structures for variables.
5999 The variables of \MP\ programs can be simple, like `\.x', or they can
6000 combine the structural properties of arrays and records, like `\.{x20a.b}'.
6001 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
6002 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
6003 things are represented inside of the computer.
6005 Each variable value occupies two consecutive words, either in a two-word
6006 node called a value node, or as a two-word subfield of a larger node. One
6007 of those two words is called the |value| field; it is an integer,
6008 containing either a |scaled| numeric value or the representation of some
6009 other type of quantity. (It might also be subdivided into halfwords, in
6010 which case it is referred to by other names instead of |value|.) The other
6011 word is broken into subfields called |type|, |name_type|, and |link|. The
6012 |type| field is a quarterword that specifies the variable's type, and
6013 |name_type| is a quarterword from which \MP\ can reconstruct the
6014 variable's name (sometimes by using the |link| field as well). Thus, only
6015 1.25 words are actually devoted to the value itself; the other
6016 three-quarters of a word are overhead, but they aren't wasted because they
6017 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6019 In this section we shall be concerned only with the structural aspects of
6020 variables, not their values. Later parts of the program will change the
6021 |type| and |value| fields, but we shall treat those fields as black boxes
6022 whose contents should not be touched.
6024 However, if the |type| field is |mp_structured|, there is no |value| field,
6025 and the second word is broken into two pointer fields called |attr_head|
6026 and |subscr_head|. Those fields point to additional nodes that
6027 contain structural information, as we shall see.
6029 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6030 @d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
6031 @d subscr_head(A) mp_link(subscr_head_loc((A))) /* pointer to subscript info */
6032 @d value_node_size 2 /* the number of words in a value node */
6034 @ An attribute node is three words long. Two of these words contain |type|
6035 and |value| fields as described above, and the third word contains
6036 additional information: There is an |attr_loc| field, which contains the
6037 hash address of the token that names this attribute; and there's also a
6038 |parent| field, which points to the value node of |mp_structured| type at the
6039 next higher level (i.e., at the level to which this attribute is
6040 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6041 |link| field points to the next attribute with the same parent; these are
6042 arranged in increasing order, so that |attr_loc(mp_link(p))>attr_loc(p)|. The
6043 final attribute node links to the constant |end_attr|, whose |attr_loc|
6044 field is greater than any legal hash address. The |attr_head| in the
6045 parent points to a node whose |name_type| is |mp_structured_root|; this
6046 node represents the null attribute, i.e., the variable that is relevant
6047 when no attributes are attached to the parent. The |attr_head| node
6048 has the fields of either
6049 a value node, a subscript node, or an attribute node, depending on what
6050 the parent would be if it were not structured; but the subscript and
6051 attribute fields are ignored, so it effectively contains only the data of
6052 a value node. The |link| field in this special node points to an attribute
6053 node whose |attr_loc| field is zero; the latter node represents a collective
6054 subscript `\.{[]}' attached to the parent, and its |link| field points to
6055 the first non-special attribute node (or to |end_attr| if there are none).
6057 A subscript node likewise occupies three words, with |type| and |value| fields
6058 plus extra information; its |name_type| is |subscr|. In this case the
6059 third word is called the |subscript| field, which is a |scaled| integer.
6060 The |link| field points to the subscript node with the next larger
6061 subscript, if any; otherwise the |link| points to the attribute node
6062 for collective subscripts at this level. We have seen that the latter node
6063 contains an upward pointer, so that the parent can be deduced.
6065 The |name_type| in a parent-less value node is |root|, and the |link|
6066 is the hash address of the token that names this value.
6068 In other words, variables have a hierarchical structure that includes
6069 enough threads running around so that the program is able to move easily
6070 between siblings, parents, and children. An example should be helpful:
6071 (The reader is advised to draw a picture while reading the following
6072 description, since that will help to firm up the ideas.)
6073 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6074 and `\.{x20b}' have been mentioned in a user's program, where
6075 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6076 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6077 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6078 node with |name_type(p)=root| and |mp_link(p)=h(x)|. We have |type(p)=mp_structured|,
6079 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6080 node and |r| to a subscript node. (Are you still following this? Use
6081 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6082 |type(q)| and |value(q)|; furthermore
6083 |name_type(q)=mp_structured_root| and |mp_link(q)=q1|, where |q1| points
6084 to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
6085 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6086 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6087 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
6088 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
6089 with no further attributes), |name_type(qq)=structured_root|,
6090 |attr_loc(qq)=0|, |parent(qq)=p|, and
6091 |mp_link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6092 an attribute node representing `\.{x[][]}', which has never yet
6093 occurred; its |type| field is |undefined|, and its |value| field is
6094 undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6095 |parent(qq1)=q1|, and |mp_link(qq1)=qq2|. Since |qq2| represents
6096 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6097 |parent(qq2)=q1|, |name_type(qq2)=attr|, |mp_link(qq2)=end_attr|.
6098 (Maybe colored lines will help untangle your picture.)
6099 Node |r| is a subscript node with |type| and |value|
6100 representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
6101 and |mp_link(r)=r1| is another subscript node. To complete the picture,
6102 see if you can guess what |mp_link(r1)| is; give up? It's~|q1|.
6103 Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
6104 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6105 and we finish things off with three more nodes
6106 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6107 with a larger sheet of paper.) The value of variable \.{x20b}
6108 appears in node~|qqq2|, as you can well imagine.
6110 If the example in the previous paragraph doesn't make things crystal
6111 clear, a glance at some of the simpler subroutines below will reveal how
6112 things work out in practice.
6114 The only really unusual thing about these conventions is the use of
6115 collective subscript attributes. The idea is to avoid repeating a lot of
6116 type information when many elements of an array are identical macros
6117 (for which distinct values need not be stored) or when they don't have
6118 all of the possible attributes. Branches of the structure below collective
6119 subscript attributes do not carry actual values except for macro identifiers;
6120 branches of the structure below subscript nodes do not carry significant
6121 information in their collective subscript attributes.
6123 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6124 @d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
6125 @d parent(A) mp_link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6126 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6127 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6128 @d attr_node_size 3 /* the number of words in an attribute node */
6129 @d subscr_node_size 3 /* the number of words in a subscript node */
6130 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6132 @<Initialize table...@>=
6133 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6135 @ Variables of type \&{pair} will have values that point to four-word
6136 nodes containing two numeric values. The first of these values has
6137 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6138 the |link| in the first points back to the node whose |value| points
6139 to this four-word node.
6141 Variables of type \&{transform} are similar, but in this case their
6142 |value| points to a 12-word node containing six values, identified by
6143 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6144 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6145 Finally, variables of type \&{color} have 3~values in 6~words
6146 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6148 When an entire structured variable is saved, the |root| indication
6149 is temporarily replaced by |saved_root|.
6151 Some variables have no name; they just are used for temporary storage
6152 while expressions are being evaluated. We call them {\sl capsules}.
6154 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6155 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6156 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6157 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6158 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6159 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6160 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6161 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6162 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6163 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6164 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6165 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6166 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6167 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6169 @d pair_node_size 4 /* the number of words in a pair node */
6170 @d transform_node_size 12 /* the number of words in a transform node */
6171 @d color_node_size 6 /* the number of words in a color node */
6172 @d cmykcolor_node_size 8 /* the number of words in a color node */
6175 quarterword big_node_size[mp_pair_type+1];
6176 quarterword sector0[mp_pair_type+1];
6177 quarterword sector_offset[mp_black_part_sector+1];
6179 @ The |sector0| array gives for each big node type, |name_type| values
6180 for its first subfield; the |sector_offset| array gives for each
6181 |name_type| value, the offset from the first subfield in words;
6182 and the |big_node_size| array gives the size in words for each type of
6186 mp->big_node_size[mp_transform_type]=transform_node_size;
6187 mp->big_node_size[mp_pair_type]=pair_node_size;
6188 mp->big_node_size[mp_color_type]=color_node_size;
6189 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6190 mp->sector0[mp_transform_type]=mp_x_part_sector;
6191 mp->sector0[mp_pair_type]=mp_x_part_sector;
6192 mp->sector0[mp_color_type]=mp_red_part_sector;
6193 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6194 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6195 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6197 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6198 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6200 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6201 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6204 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6205 procedure call |init_big_node(p)| will allocate a pair or transform node
6206 for~|p|. The individual parts of such nodes are initially of type
6210 void mp_init_big_node (MP mp,pointer p) {
6211 pointer q; /* the new node */
6212 quarterword s; /* its size */
6213 s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
6216 @<Make variable |q+s| newly independent@>;
6217 name_type(q+s)=halfp(s)+mp->sector0[type(p)];
6220 mp_link(q)=p; value(p)=q;
6223 @ The |id_transform| function creates a capsule for the
6224 identity transformation.
6227 pointer mp_id_transform (MP mp) {
6228 pointer p,q,r; /* list manipulation registers */
6229 p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
6230 name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6231 r=q+transform_node_size;
6234 type(r)=mp_known; value(r)=0;
6236 value(xx_part_loc(q))=unity;
6237 value(yy_part_loc(q))=unity;
6241 @ Tokens are of type |tag_token| when they first appear, but they point
6242 to |null| until they are first used as the root of a variable.
6243 The following subroutine establishes the root node on such grand occasions.
6246 void mp_new_root (MP mp,pointer x) {
6247 pointer p; /* the new node */
6248 p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
6249 mp_link(p)=x; equiv(x)=p;
6252 @ These conventions for variable representation are illustrated by the
6253 |print_variable_name| routine, which displays the full name of a
6254 variable given only a pointer to its two-word value packet.
6257 void mp_print_variable_name (MP mp, pointer p);
6260 void mp_print_variable_name (MP mp, pointer p) {
6261 pointer q; /* a token list that will name the variable's suffix */
6262 pointer r; /* temporary for token list creation */
6263 while ( name_type(p)>=mp_x_part_sector ) {
6264 @<Preface the output with a part specifier; |return| in the
6265 case of a capsule@>;
6268 while ( name_type(p)>mp_saved_root ) {
6269 @<Ascend one level, pushing a token onto list |q|
6270 and replacing |p| by its parent@>;
6272 r=mp_get_avail(mp); info(r)=mp_link(p); mp_link(r)=q;
6273 if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6275 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6276 mp_flush_token_list(mp, r);
6279 @ @<Ascend one level, pushing a token onto list |q|...@>=
6281 if ( name_type(p)==mp_subscr ) {
6282 r=mp_new_num_tok(mp, subscript(p));
6285 } while (name_type(p)!=mp_attr);
6286 } else if ( name_type(p)==mp_structured_root ) {
6287 p=mp_link(p); goto FOUND;
6289 if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6290 @:this can't happen var}{\quad var@>
6291 r=mp_get_avail(mp); info(r)=attr_loc(p);
6298 @ @<Preface the output with a part specifier...@>=
6299 { switch (name_type(p)) {
6300 case mp_x_part_sector: mp_print_char(mp, xord('x')); break;
6301 case mp_y_part_sector: mp_print_char(mp, xord('y')); break;
6302 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6303 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6304 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6305 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6306 case mp_red_part_sector: mp_print(mp, "red"); break;
6307 case mp_green_part_sector: mp_print(mp, "green"); break;
6308 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6309 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6310 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6311 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6312 case mp_black_part_sector: mp_print(mp, "black"); break;
6313 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6315 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6318 } /* there are no other cases */
6319 mp_print(mp, "part ");
6320 p=mp_link(p-mp->sector_offset[name_type(p)]);
6323 @ The |interesting| function returns |true| if a given variable is not
6324 in a capsule, or if the user wants to trace capsules.
6327 boolean mp_interesting (MP mp,pointer p) {
6328 quarterword t; /* a |name_type| */
6329 if ( mp->internal[mp_tracing_capsules]>0 ) {
6333 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6334 t=name_type(mp_link(p-mp->sector_offset[t]));
6335 return (t!=mp_capsule);
6339 @ Now here is a subroutine that converts an unstructured type into an
6340 equivalent structured type, by inserting a |mp_structured| node that is
6341 capable of growing. This operation is done only when |name_type(p)=root|,
6342 |subscr|, or |attr|.
6344 The procedure returns a pointer to the new node that has taken node~|p|'s
6345 place in the structure. Node~|p| itself does not move, nor are its
6346 |value| or |type| fields changed in any way.
6349 pointer mp_new_structure (MP mp,pointer p) {
6350 pointer q,r=0; /* list manipulation registers */
6351 switch (name_type(p)) {
6353 q=mp_link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6356 @<Link a new subscript node |r| in place of node |p|@>;
6359 @<Link a new attribute node |r| in place of node |p|@>;
6362 mp_confusion(mp, "struct");
6363 @:this can't happen struct}{\quad struct@>
6366 mp_link(r)=mp_link(p); type(r)=mp_structured; name_type(r)=name_type(p);
6367 attr_head(r)=p; name_type(p)=mp_structured_root;
6368 q=mp_get_node(mp, attr_node_size); mp_link(p)=q; subscr_head(r)=q;
6369 parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; mp_link(q)=end_attr;
6370 attr_loc(q)=collective_subscript;
6374 @ @<Link a new subscript node |r| in place of node |p|@>=
6379 } while (name_type(q)!=mp_attr);
6380 q=parent(q); r=subscr_head_loc(q); /* |mp_link(r)=subscr_head(q)| */
6384 r=mp_get_node(mp, subscr_node_size);
6385 mp_link(q)=r; subscript(r)=subscript(p);
6388 @ If the attribute is |collective_subscript|, there are two pointers to
6389 node~|p|, so we must change both of them.
6391 @<Link a new attribute node |r| in place of node |p|@>=
6393 q=parent(p); r=attr_head(q);
6397 r=mp_get_node(mp, attr_node_size); mp_link(q)=r;
6398 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6399 if ( attr_loc(p)==collective_subscript ) {
6400 q=subscr_head_loc(parent(p));
6401 while ( mp_link(q)!=p ) q=mp_link(q);
6406 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6407 list of suffixes; it returns a pointer to the corresponding two-word
6408 value. For example, if |t| points to token \.x followed by a numeric
6409 token containing the value~7, |find_variable| finds where the value of
6410 \.{x7} is stored in memory. This may seem a simple task, and it
6411 usually is, except when \.{x7} has never been referenced before.
6412 Indeed, \.x may never have even been subscripted before; complexities
6413 arise with respect to updating the collective subscript information.
6415 If a macro type is detected anywhere along path~|t|, or if the first
6416 item on |t| isn't a |tag_token|, the value |null| is returned.
6417 Otherwise |p| will be a non-null pointer to a node such that
6418 |undefined<type(p)<mp_structured|.
6420 @d abort_find { return null; }
6423 pointer mp_find_variable (MP mp,pointer t) {
6424 pointer p,q,r,s; /* nodes in the ``value'' line */
6425 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6426 integer n; /* subscript or attribute */
6427 memory_word save_word; /* temporary storage for a word of |mem| */
6429 p=info(t); t=mp_link(t);
6430 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6431 if ( equiv(p)==null ) mp_new_root(mp, p);
6434 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6435 if ( t<mp->hi_mem_min ) {
6436 @<Descend one level for the subscript |value(t)|@>
6438 @<Descend one level for the attribute |info(t)|@>;
6442 if ( type(pp)>=mp_structured ) {
6443 if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6445 if ( type(p)==mp_structured ) p=attr_head(p);
6446 if ( type(p)==undefined ) {
6447 if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
6448 type(p)=type(pp); value(p)=null;
6453 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6454 |pp|~stays in the collective line while |p|~goes through actual subscript
6457 @<Make sure that both nodes |p| and |pp|...@>=
6458 if ( type(pp)!=mp_structured ) {
6459 if ( type(pp)>mp_structured ) abort_find;
6460 ss=mp_new_structure(mp, pp);
6463 }; /* now |type(pp)=mp_structured| */
6464 if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6465 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6467 @ We want this part of the program to be reasonably fast, in case there are
6469 lots of subscripts at the same level of the data structure. Therefore
6470 we store an ``infinite'' value in the word that appears at the end of the
6471 subscript list, even though that word isn't part of a subscript node.
6473 @<Descend one level for the subscript |value(t)|@>=
6476 pp=mp_link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6477 q=mp_link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6478 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |mp_link(s)=subscr_head(p)| */
6481 } while (n>subscript(s));
6482 if ( n==subscript(s) ) {
6485 p=mp_get_node(mp, subscr_node_size); mp_link(r)=p; mp_link(p)=s;
6486 subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
6488 mp->mem[subscript_loc(q)]=save_word;
6491 @ @<Descend one level for the attribute |info(t)|@>=
6496 rr=ss; ss=mp_link(ss);
6497 } while (n>attr_loc(ss));
6498 if ( n<attr_loc(ss) ) {
6499 qq=mp_get_node(mp, attr_node_size); mp_link(rr)=qq; mp_link(qq)=ss;
6500 attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
6501 parent(qq)=pp; ss=qq;
6506 pp=ss; s=attr_head(p);
6509 } while (n>attr_loc(s));
6510 if ( n==attr_loc(s) ) {
6513 q=mp_get_node(mp, attr_node_size); mp_link(r)=q; mp_link(q)=s;
6514 attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
6520 @ Variables lose their former values when they appear in a type declaration,
6521 or when they are defined to be macros or \&{let} equal to something else.
6522 A subroutine will be defined later that recycles the storage associated
6523 with any particular |type| or |value|; our goal now is to study a higher
6524 level process called |flush_variable|, which selectively frees parts of a
6527 This routine has some complexity because of examples such as
6528 `\hbox{\tt numeric x[]a[]b}'
6529 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6530 `\hbox{\tt vardef x[]a[]=...}'
6531 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6532 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6533 to handle such examples is to use recursion; so that's what we~do.
6536 Parameter |p| points to the root information of the variable;
6537 parameter |t| points to a list of one-word nodes that represent
6538 suffixes, with |info=collective_subscript| for subscripts.
6541 @<Declare subroutines for printing expressions@>
6542 @<Declare basic dependency-list subroutines@>
6543 @<Declare the recycling subroutines@>
6544 void mp_flush_cur_exp (MP mp,scaled v) ;
6545 @<Declare the procedure called |flush_below_variable|@>
6548 void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6549 pointer q,r; /* list manipulation */
6550 halfword n; /* attribute to match */
6552 if ( type(p)!=mp_structured ) return;
6553 n=info(t); t=mp_link(t);
6554 if ( n==collective_subscript ) {
6555 r=subscr_head_loc(p); q=mp_link(r); /* |q=subscr_head(p)| */
6556 while ( name_type(q)==mp_subscr ){
6557 mp_flush_variable(mp, q,t,discard_suffixes);
6559 if ( type(q)==mp_structured ) r=q;
6560 else { mp_link(r)=mp_link(q); mp_free_node(mp, q,subscr_node_size); }
6570 } while (attr_loc(p)<n);
6571 if ( attr_loc(p)!=n ) return;
6573 if ( discard_suffixes ) {
6574 mp_flush_below_variable(mp, p);
6576 if ( type(p)==mp_structured ) p=attr_head(p);
6577 mp_recycle_value(mp, p);
6581 @ The next procedure is simpler; it wipes out everything but |p| itself,
6582 which becomes undefined.
6584 @<Declare the procedure called |flush_below_variable|@>=
6585 void mp_flush_below_variable (MP mp, pointer p);
6588 void mp_flush_below_variable (MP mp,pointer p) {
6589 pointer q,r; /* list manipulation registers */
6590 if ( type(p)!=mp_structured ) {
6591 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6594 while ( name_type(q)==mp_subscr ) {
6595 mp_flush_below_variable(mp, q); r=q; q=mp_link(q);
6596 mp_free_node(mp, r,subscr_node_size);
6598 r=attr_head(p); q=mp_link(r); mp_recycle_value(mp, r);
6599 if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6600 else mp_free_node(mp, r,subscr_node_size);
6601 /* we assume that |subscr_node_size=attr_node_size| */
6603 mp_flush_below_variable(mp, q); r=q; q=mp_link(q); mp_free_node(mp, r,attr_node_size);
6604 } while (q!=end_attr);
6609 @ Just before assigning a new value to a variable, we will recycle the
6610 old value and make the old value undefined. The |und_type| routine
6611 determines what type of undefined value should be given, based on
6612 the current type before recycling.
6615 quarterword mp_und_type (MP mp,pointer p) {
6617 case undefined: case mp_vacuous:
6619 case mp_boolean_type: case mp_unknown_boolean:
6620 return mp_unknown_boolean;
6621 case mp_string_type: case mp_unknown_string:
6622 return mp_unknown_string;
6623 case mp_pen_type: case mp_unknown_pen:
6624 return mp_unknown_pen;
6625 case mp_path_type: case mp_unknown_path:
6626 return mp_unknown_path;
6627 case mp_picture_type: case mp_unknown_picture:
6628 return mp_unknown_picture;
6629 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6630 case mp_pair_type: case mp_numeric_type:
6632 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6633 return mp_numeric_type;
6634 } /* there are no other cases */
6638 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6639 of a symbolic token. It must remove any variable structure or macro
6640 definition that is currently attached to that symbol. If the |saving|
6641 parameter is true, a subsidiary structure is saved instead of destroyed.
6644 void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6645 pointer q; /* |equiv(p)| */
6647 switch (eq_type(p) % outer_tag) {
6649 case secondary_primary_macro:
6650 case tertiary_secondary_macro:
6651 case expression_tertiary_macro:
6652 if ( ! saving ) mp_delete_mac_ref(mp, q);
6657 name_type(q)=mp_saved_root;
6659 mp_flush_below_variable(mp, q);
6660 mp_free_node(mp,q,value_node_size);
6667 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6670 @* \[16] Saving and restoring equivalents.
6671 The nested structure given by \&{begingroup} and \&{endgroup}
6672 allows |eqtb| entries to be saved and restored, so that temporary changes
6673 can be made without difficulty. When the user requests a current value to
6674 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6675 \&{endgroup} ultimately causes the old values to be removed from the save
6676 stack and put back in their former places.
6678 The save stack is a linked list containing three kinds of entries,
6679 distinguished by their |info| fields. If |p| points to a saved item,
6683 |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6684 such an item to the save stack and each \&{endgroup} cuts back the stack
6685 until the most recent such entry has been removed.
6688 |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6689 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6693 |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6694 integer to be restored to internal parameter number~|q|. Such entries
6695 are generated by \&{interim} commands.
6698 The global variable |save_ptr| points to the top item on the save stack.
6700 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6701 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6702 @d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
6703 mp_link((A))=mp->save_ptr; mp->save_ptr=(A);
6707 pointer save_ptr; /* the most recently saved item */
6709 @ @<Set init...@>=mp->save_ptr=null;
6711 @ The |save_variable| routine is given a hash address |q|; it salts this
6712 address in the save stack, together with its current equivalent,
6713 then makes token~|q| behave as though it were brand new.
6715 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6716 things from the stack when the program is not inside a group, so there's
6717 no point in wasting the space.
6719 @c void mp_save_variable (MP mp,pointer q) {
6720 pointer p; /* temporary register */
6721 if ( mp->save_ptr!=null ){
6722 p=mp_get_node(mp, save_node_size); info(p)=q; mp_link(p)=mp->save_ptr;
6723 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6725 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6728 @ Similarly, |save_internal| is given the location |q| of an internal
6729 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6732 @c void mp_save_internal (MP mp,halfword q) {
6733 pointer p; /* new item for the save stack */
6734 if ( mp->save_ptr!=null ){
6735 p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
6736 mp_link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6740 @ At the end of a group, the |unsave| routine restores all of the saved
6741 equivalents in reverse order. This routine will be called only when there
6742 is at least one boundary item on the save stack.
6745 void mp_unsave (MP mp) {
6746 pointer q; /* index to saved item */
6747 pointer p; /* temporary register */
6748 while ( info(mp->save_ptr)!=0 ) {
6749 q=info(mp->save_ptr);
6751 if ( mp->internal[mp_tracing_restores]>0 ) {
6752 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6753 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, xord('='));
6754 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, xord('}'));
6755 mp_end_diagnostic(mp, false);
6757 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6759 if ( mp->internal[mp_tracing_restores]>0 ) {
6760 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6761 mp_print_text(q); mp_print_char(mp, xord('}'));
6762 mp_end_diagnostic(mp, false);
6764 mp_clear_symbol(mp, q,false);
6765 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6766 if ( eq_type(q) % outer_tag==tag_token ) {
6768 if ( p!=null ) name_type(p)=mp_root;
6771 p=mp_link(mp->save_ptr);
6772 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6774 p=mp_link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6777 @* \[17] Data structures for paths.
6778 When a \MP\ user specifies a path, \MP\ will create a list of knots
6779 and control points for the associated cubic spline curves. If the
6780 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6781 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6782 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6783 @:Bezier}{B\'ezier, Pierre Etienne@>
6784 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6785 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6788 There is a 8-word node for each knot $z_k$, containing one word of
6789 control information and six words for the |x| and |y| coordinates of
6790 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6791 |left_type| and |right_type| fields, which each occupy a quarter of
6792 the first word in the node; they specify properties of the curve as it
6793 enters and leaves the knot. There's also a halfword |link| field,
6794 which points to the following knot, and a final supplementary word (of
6795 which only a quarter is used).
6797 If the path is a closed contour, knots 0 and |n| are identical;
6798 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6799 is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
6800 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6801 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6803 @d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6804 @d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6805 @d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6806 @d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6807 @d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6808 @d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6809 @d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6810 @d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6811 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6812 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6813 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6814 @d left_coord(A) mp->mem[(A)+2].sc
6815 /* coordinate of previous control point given |x_loc| or |y_loc| */
6816 @d right_coord(A) mp->mem[(A)+4].sc
6817 /* coordinate of next control point given |x_loc| or |y_loc| */
6818 @d knot_node_size 8 /* number of words in a knot node */
6822 mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
6823 mp_explicit, /* |left_type| or |right_type| when control points are known */
6824 mp_given, /* |left_type| or |right_type| when a direction is given */
6825 mp_curl, /* |left_type| or |right_type| when a curl is desired */
6826 mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
6830 @ Before the B\'ezier control points have been calculated, the memory
6831 space they will ultimately occupy is taken up by information that can be
6832 used to compute them. There are four cases:
6835 \textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
6836 the knot in the same direction it entered; \MP\ will figure out a
6840 \textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
6841 knot in a direction depending on the angle at which it enters the next
6842 knot and on the curl parameter stored in |right_curl|.
6845 \textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
6846 knot in a nonzero direction stored as an |angle| in |right_given|.
6849 \textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
6850 point for leaving this knot has already been computed; it is in the
6851 |right_x| and |right_y| fields.
6854 The rules for |left_type| are similar, but they refer to the curve entering
6855 the knot, and to \\{left} fields instead of \\{right} fields.
6857 Non-|explicit| control points will be chosen based on ``tension'' parameters
6858 in the |left_tension| and |right_tension| fields. The
6859 `\&{atleast}' option is represented by negative tension values.
6860 @:at_least_}{\&{atleast} primitive@>
6862 For example, the \MP\ path specification
6863 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6865 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6867 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6868 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6869 |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
6871 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6872 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6873 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6874 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6875 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6876 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6877 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6878 Of course, this example is more complicated than anything a normal user
6881 These types must satisfy certain restrictions because of the form of \MP's
6883 (i)~|open| type never appears in the same node together with |endpoint|,
6885 (ii)~The |right_type| of a node is |explicit| if and only if the
6886 |left_type| of the following node is |explicit|.
6887 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6889 @d left_curl left_x /* curl information when entering this knot */
6890 @d left_given left_x /* given direction when entering this knot */
6891 @d left_tension left_y /* tension information when entering this knot */
6892 @d right_curl right_x /* curl information when leaving this knot */
6893 @d right_given right_x /* given direction when leaving this knot */
6894 @d right_tension right_y /* tension information when leaving this knot */
6896 @ Knots can be user-supplied, or they can be created by program code,
6897 like the |split_cubic| function, or |copy_path|. The distinction is
6898 needed for the cleanup routine that runs after |split_cubic|, because
6899 it should only delete knots it has previously inserted, and never
6900 anything that was user-supplied. In order to be able to differentiate
6901 one knot from another, we will set |originator(p):=mp_metapost_user| when
6902 it appeared in the actual metapost program, and
6903 |originator(p):=mp_program_code| in all other cases.
6905 @d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6909 mp_program_code=0, /* not created by a user */
6910 mp_metapost_user /* created by a user */
6913 @ Here is a routine that prints a given knot list
6914 in symbolic form. It illustrates the conventions discussed above,
6915 and checks for anomalies that might arise while \MP\ is being debugged.
6917 @<Declare subroutines for printing expressions@>=
6918 void mp_pr_path (MP mp,pointer h);
6921 void mp_pr_path (MP mp,pointer h) {
6922 pointer p,q; /* for list traversal */
6926 if ( (p==null)||(q==null) ) {
6927 mp_print_nl(mp, "???"); return; /* this won't happen */
6930 @<Print information for adjacent knots |p| and |q|@>;
6933 if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
6934 @<Print two dots, followed by |given| or |curl| if present@>;
6937 if ( left_type(h)!=mp_endpoint )
6938 mp_print(mp, "cycle");
6941 @ @<Print information for adjacent knots...@>=
6942 mp_print_two(mp, x_coord(p),y_coord(p));
6943 switch (right_type(p)) {
6945 if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
6947 if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
6951 @<Print control points between |p| and |q|, then |goto done1|@>;
6954 @<Print information for a curve that begins |open|@>;
6958 @<Print information for a curve that begins |curl| or |given|@>;
6961 mp_print(mp, "???"); /* can't happen */
6965 if ( left_type(q)<=mp_explicit ) {
6966 mp_print(mp, "..control?"); /* can't happen */
6968 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
6969 @<Print tension between |p| and |q|@>;
6972 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
6973 were |scaled|, the magnitude of a |given| direction vector will be~4096.
6975 @<Print two dots...@>=
6977 mp_print_nl(mp, " ..");
6978 if ( left_type(p)==mp_given ) {
6979 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, xord('{'));
6980 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, xord(','));
6981 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, xord('}'));
6982 } else if ( left_type(p)==mp_curl ){
6983 mp_print(mp, "{curl ");
6984 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, xord('}'));
6988 @ @<Print tension between |p| and |q|@>=
6990 mp_print(mp, "..tension ");
6991 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
6992 mp_print_scaled(mp, abs(right_tension(p)));
6993 if ( right_tension(p)!=left_tension(q) ){
6994 mp_print(mp, " and ");
6995 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
6996 mp_print_scaled(mp, abs(left_tension(q)));
7000 @ @<Print control points between |p| and |q|, then |goto done1|@>=
7002 mp_print(mp, "..controls ");
7003 mp_print_two(mp, right_x(p),right_y(p));
7004 mp_print(mp, " and ");
7005 if ( left_type(q)!=mp_explicit ) {
7006 mp_print(mp, "??"); /* can't happen */
7009 mp_print_two(mp, left_x(q),left_y(q));
7014 @ @<Print information for a curve that begins |open|@>=
7015 if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
7016 mp_print(mp, "{open?}"); /* can't happen */
7020 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7021 \MP's default curl is present.
7023 @<Print information for a curve that begins |curl|...@>=
7025 if ( left_type(p)==mp_open )
7026 mp_print(mp, "??"); /* can't happen */
7028 if ( right_type(p)==mp_curl ) {
7029 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7031 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, xord('{'));
7032 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, xord(','));
7033 mp_print_scaled(mp, mp->n_sin);
7035 mp_print_char(mp, xord('}'));
7038 @ It is convenient to have another version of |pr_path| that prints the path
7039 as a diagnostic message.
7041 @<Declare subroutines for printing expressions@>=
7042 void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
7043 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7046 mp_end_diagnostic(mp, true);
7049 @ If we want to duplicate a knot node, we can say |copy_knot|:
7052 pointer mp_copy_knot (MP mp,pointer p) {
7053 pointer q; /* the copy */
7054 int k; /* runs through the words of a knot node */
7055 q=mp_get_node(mp, knot_node_size);
7056 for (k=0;k<knot_node_size;k++) {
7057 mp->mem[q+k]=mp->mem[p+k];
7059 originator(q)=originator(p);
7063 @ The |copy_path| routine makes a clone of a given path.
7066 pointer mp_copy_path (MP mp, pointer p) {
7067 pointer q,pp,qq; /* for list manipulation */
7068 q=mp_copy_knot(mp, p);
7069 qq=q; pp=mp_link(p);
7071 mp_link(qq)=mp_copy_knot(mp, pp);
7080 @ Just before |ship_out|, knot lists are exported for printing.
7082 The |gr_XXXX| macros are defined in |mppsout.h|.
7085 mp_knot *mp_export_knot (MP mp,pointer p) {
7086 mp_knot *q; /* the copy */
7089 q = xmalloc(1, sizeof (mp_knot));
7090 memset(q,0,sizeof (mp_knot));
7091 gr_left_type(q) = (unsigned short)left_type(p);
7092 gr_right_type(q) = (unsigned short)right_type(p);
7093 gr_x_coord(q) = x_coord(p);
7094 gr_y_coord(q) = y_coord(p);
7095 gr_left_x(q) = left_x(p);
7096 gr_left_y(q) = left_y(p);
7097 gr_right_x(q) = right_x(p);
7098 gr_right_y(q) = right_y(p);
7099 gr_originator(q) = (unsigned char)originator(p);
7103 @ The |export_knot_list| routine therefore also makes a clone
7107 mp_knot *mp_export_knot_list (MP mp, pointer p) {
7108 mp_knot *q, *qq; /* for list manipulation */
7109 pointer pp; /* for list manipulation */
7112 q=mp_export_knot(mp, p);
7113 qq=q; pp=mp_link(p);
7115 gr_next_knot(qq)=mp_export_knot(mp, pp);
7116 qq=gr_next_knot(qq);
7124 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7125 returns a pointer to the first node of the copy, if the path is a cycle,
7126 but to the final node of a non-cyclic copy. The global
7127 variable |path_tail| will point to the final node of the original path;
7128 this trick makes it easier to implement `\&{doublepath}'.
7130 All node types are assumed to be |endpoint| or |explicit| only.
7133 pointer mp_htap_ypoc (MP mp,pointer p) {
7134 pointer q,pp,qq,rr; /* for list manipulation */
7135 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7138 right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
7139 x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
7140 right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
7141 left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
7142 originator(qq)=originator(pp);
7143 if ( mp_link(pp)==p ) {
7144 mp_link(q)=qq; mp->path_tail=pp; return q;
7146 rr=mp_get_node(mp, knot_node_size); mp_link(rr)=qq; qq=rr; pp=mp_link(pp);
7151 pointer path_tail; /* the node that links to the beginning of a path */
7153 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7154 calling the following subroutine.
7156 @<Declare the recycling subroutines@>=
7157 void mp_toss_knot_list (MP mp,pointer p) ;
7160 void mp_toss_knot_list (MP mp,pointer p) {
7161 pointer q; /* the node being freed */
7162 pointer r; /* the next node */
7166 mp_free_node(mp, q,knot_node_size); q=r;
7170 @* \[18] Choosing control points.
7171 Now we must actually delve into one of \MP's more difficult routines,
7172 the |make_choices| procedure that chooses angles and control points for
7173 the splines of a curve when the user has not specified them explicitly.
7174 The parameter to |make_choices| points to a list of knots and
7175 path information, as described above.
7177 A path decomposes into independent segments at ``breakpoint'' knots,
7178 which are knots whose left and right angles are both prespecified in
7179 some way (i.e., their |left_type| and |right_type| aren't both open).
7182 @<Declare the procedure called |solve_choices|@>
7183 void mp_make_choices (MP mp,pointer knots) {
7184 pointer h; /* the first breakpoint */
7185 pointer p,q; /* consecutive breakpoints being processed */
7186 @<Other local variables for |make_choices|@>;
7187 check_arith; /* make sure that |arith_error=false| */
7188 if ( mp->internal[mp_tracing_choices]>0 )
7189 mp_print_path(mp, knots,", before choices",true);
7190 @<If consecutive knots are equal, join them explicitly@>;
7191 @<Find the first breakpoint, |h|, on the path;
7192 insert an artificial breakpoint if the path is an unbroken cycle@>;
7195 @<Fill in the control points between |p| and the next breakpoint,
7196 then advance |p| to that breakpoint@>;
7198 if ( mp->internal[mp_tracing_choices]>0 )
7199 mp_print_path(mp, knots,", after choices",true);
7200 if ( mp->arith_error ) {
7201 @<Report an unexpected problem during the choice-making@>;
7205 @ @<Report an unexpected problem during the choice...@>=
7207 print_err("Some number got too big");
7208 @.Some number got too big@>
7209 help2("The path that I just computed is out of range.",
7210 "So it will probably look funny. Proceed, for a laugh.");
7211 mp_put_get_error(mp); mp->arith_error=false;
7214 @ Two knots in a row with the same coordinates will always be joined
7215 by an explicit ``curve'' whose control points are identical with the
7218 @<If consecutive knots are equal, join them explicitly@>=
7222 if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
7223 right_type(p)=mp_explicit;
7224 if ( left_type(p)==mp_open ) {
7225 left_type(p)=mp_curl; left_curl(p)=unity;
7227 left_type(q)=mp_explicit;
7228 if ( right_type(q)==mp_open ) {
7229 right_type(q)=mp_curl; right_curl(q)=unity;
7231 right_x(p)=x_coord(p); left_x(q)=x_coord(p);
7232 right_y(p)=y_coord(p); left_y(q)=y_coord(p);
7237 @ If there are no breakpoints, it is necessary to compute the direction
7238 angles around an entire cycle. In this case the |left_type| of the first
7239 node is temporarily changed to |end_cycle|.
7241 @<Find the first breakpoint, |h|, on the path...@>=
7244 if ( left_type(h)!=mp_open ) break;
7245 if ( right_type(h)!=mp_open ) break;
7248 left_type(h)=mp_end_cycle; break;
7252 @ If |right_type(p)<given| and |q=mp_link(p)|, we must have
7253 |right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
7255 @<Fill in the control points between |p| and the next breakpoint...@>=
7257 if ( right_type(p)>=mp_given ) {
7258 while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=mp_link(q);
7259 @<Fill in the control information between
7260 consecutive breakpoints |p| and |q|@>;
7261 } else if ( right_type(p)==mp_endpoint ) {
7262 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7266 @ This step makes it possible to transform an explicitly computed path without
7267 checking the |left_type| and |right_type| fields.
7269 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7271 right_x(p)=x_coord(p); right_y(p)=y_coord(p);
7272 left_x(q)=x_coord(q); left_y(q)=y_coord(q);
7275 @ Before we can go further into the way choices are made, we need to
7276 consider the underlying theory. The basic ideas implemented in |make_choices|
7277 are due to John Hobby, who introduced the notion of ``mock curvature''
7278 @^Hobby, John Douglas@>
7279 at a knot. Angles are chosen so that they preserve mock curvature when
7280 a knot is passed, and this has been found to produce excellent results.
7282 It is convenient to introduce some notations that simplify the necessary
7283 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7284 between knots |k| and |k+1|; and let
7285 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7286 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7287 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7288 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7289 $$\eqalign{z_k^+&=z_k+
7290 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7292 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7293 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7294 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7295 corresponding ``offset angles.'' These angles satisfy the condition
7296 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7297 whenever the curve leaves an intermediate knot~|k| in the direction that
7300 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7301 the curve at its beginning and ending points. This means that
7302 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7303 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7304 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7305 z\k^-,z\k^{\phantom+};t)$
7308 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7309 \qquad{\rm and}\qquad
7310 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7311 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7313 approximation to this true curvature that arises in the limit for
7314 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7315 The standard velocity function satisfies
7316 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7317 hence the mock curvatures are respectively
7318 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7319 \qquad{\rm and}\qquad
7320 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7322 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7323 determines $\phi_k$ when $\theta_k$ is known, so the task of
7324 angle selection is essentially to choose appropriate values for each
7325 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7326 from $(**)$, we obtain a system of linear equations of the form
7327 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7329 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7330 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7331 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7332 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7333 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7334 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7335 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7336 hence they have a unique solution. Moreover, in most cases the tensions
7337 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7338 solution numerically stable, and there is an exponential damping
7339 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7340 a factor of~$O(2^{-j})$.
7342 @ However, we still must consider the angles at the starting and ending
7343 knots of a non-cyclic path. These angles might be given explicitly, or
7344 they might be specified implicitly in terms of an amount of ``curl.''
7346 Let's assume that angles need to be determined for a non-cyclic path
7347 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7348 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7349 have been given for $0<k<n$, and it will be convenient to introduce
7350 equations of the same form for $k=0$ and $k=n$, where
7351 $$A_0=B_0=C_n=D_n=0.$$
7352 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7353 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7354 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7355 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7356 mock curvature at $z_1$; i.e.,
7357 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7358 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7359 This equation simplifies to
7360 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7361 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7362 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7363 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7364 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7365 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7366 hence the linear equations remain nonsingular.
7368 Similar considerations apply at the right end, when the final angle $\phi_n$
7369 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7370 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7372 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7373 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7374 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7376 When |make_choices| chooses angles, it must compute the coefficients of
7377 these linear equations, then solve the equations. To compute the coefficients,
7378 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7379 When the equations are solved, the chosen directions $\theta_k$ are put
7380 back into the form of control points by essentially computing sines and
7383 @ OK, we are ready to make the hard choices of |make_choices|.
7384 Most of the work is relegated to an auxiliary procedure
7385 called |solve_choices|, which has been introduced to keep
7386 |make_choices| from being extremely long.
7388 @<Fill in the control information between...@>=
7389 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7390 set $n$ to the length of the path@>;
7391 @<Remove |open| types at the breakpoints@>;
7392 mp_solve_choices(mp, p,q,n)
7394 @ It's convenient to precompute quantities that will be needed several
7395 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7396 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7397 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7398 and $z\k-z_k$ will be stored in |psi[k]|.
7401 int path_size; /* maximum number of knots between breakpoints of a path */
7404 scaled *delta; /* knot differences */
7405 angle *psi; /* turning angles */
7407 @ @<Dealloc variables@>=
7413 @ @<Other local variables for |make_choices|@>=
7414 int k,n; /* current and final knot numbers */
7415 pointer s,t; /* registers for list traversal */
7416 scaled delx,dely; /* directions where |open| meets |explicit| */
7417 fraction sine,cosine; /* trig functions of various angles */
7419 @ @<Calculate the turning angles...@>=
7422 k=0; s=p; n=mp->path_size;
7425 mp->delta_x[k]=x_coord(t)-x_coord(s);
7426 mp->delta_y[k]=y_coord(t)-y_coord(s);
7427 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7429 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7430 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7431 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7432 mp_take_fraction(mp, mp->delta_y[k],sine),
7433 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7434 mp_take_fraction(mp, mp->delta_x[k],sine));
7437 if ( k==mp->path_size ) {
7438 mp_reallocate_paths(mp, mp->path_size+(mp->path_size/4));
7439 goto RESTART; /* retry, loop size has changed */
7442 } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
7443 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7446 @ When we get to this point of the code, |right_type(p)| is either
7447 |given| or |curl| or |open|. If it is |open|, we must have
7448 |left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
7449 case, the |open| type is converted to |given|; however, if the
7450 velocity coming into this knot is zero, the |open| type is
7451 converted to a |curl|, since we don't know the incoming direction.
7453 Similarly, |left_type(q)| is either |given| or |curl| or |open| or
7454 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7456 @<Remove |open| types at the breakpoints@>=
7457 if ( left_type(q)==mp_open ) {
7458 delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
7459 if ( (delx==0)&&(dely==0) ) {
7460 left_type(q)=mp_curl; left_curl(q)=unity;
7462 left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7465 if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
7466 delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
7467 if ( (delx==0)&&(dely==0) ) {
7468 right_type(p)=mp_curl; right_curl(p)=unity;
7470 right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7474 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7475 and exactly one of the breakpoints involves a curl. The simplest case occurs
7476 when |n=1| and there is a curl at both breakpoints; then we simply draw
7479 But before coding up the simple cases, we might as well face the general case,
7480 since we must deal with it sooner or later, and since the general case
7481 is likely to give some insight into the way simple cases can be handled best.
7483 When there is no cycle, the linear equations to be solved form a tridiagonal
7484 system, and we can apply the standard technique of Gaussian elimination
7485 to convert that system to a sequence of equations of the form
7486 $$\theta_0+u_0\theta_1=v_0,\quad
7487 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7488 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7490 It is possible to do this diagonalization while generating the equations.
7491 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7492 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7494 The procedure is slightly more complex when there is a cycle, but the
7495 basic idea will be nearly the same. In the cyclic case the right-hand
7496 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7497 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7498 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7499 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7500 eliminate the $w$'s from the system, after which the solution can be
7503 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7504 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7505 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7506 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7509 angle *theta; /* values of $\theta_k$ */
7510 fraction *uu; /* values of $u_k$ */
7511 angle *vv; /* values of $v_k$ */
7512 fraction *ww; /* values of $w_k$ */
7514 @ @<Dealloc variables@>=
7520 @ @<Declare |mp_reallocate| functions@>=
7521 void mp_reallocate_paths (MP mp, int l);
7524 void mp_reallocate_paths (MP mp, int l) {
7525 XREALLOC (mp->delta_x, l, scaled);
7526 XREALLOC (mp->delta_y, l, scaled);
7527 XREALLOC (mp->delta, l, scaled);
7528 XREALLOC (mp->psi, l, angle);
7529 XREALLOC (mp->theta, l, angle);
7530 XREALLOC (mp->uu, l, fraction);
7531 XREALLOC (mp->vv, l, angle);
7532 XREALLOC (mp->ww, l, fraction);
7536 @ Our immediate problem is to get the ball rolling by setting up the
7537 first equation or by realizing that no equations are needed, and to fit
7538 this initialization into a framework suitable for the overall computation.
7540 @<Declare the procedure called |solve_choices|@>=
7541 @<Declare subroutines needed by |solve_choices|@>
7542 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7543 int k; /* current knot number */
7544 pointer r,s,t; /* registers for list traversal */
7545 @<Other local variables for |solve_choices|@>;
7550 @<Get the linear equations started; or |return|
7551 with the control points in place, if linear equations
7554 switch (left_type(s)) {
7555 case mp_end_cycle: case mp_open:
7556 @<Set up equation to match mock curvatures
7557 at $z_k$; then |goto found| with $\theta_n$
7558 adjusted to equal $\theta_0$, if a cycle has ended@>;
7561 @<Set up equation for a curl at $\theta_n$
7565 @<Calculate the given value of $\theta_n$
7568 } /* there are no other cases */
7573 @<Finish choosing angles and assigning control points@>;
7576 @ On the first time through the loop, we have |k=0| and |r| is not yet
7577 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7579 @<Get the linear equations started...@>=
7580 switch (right_type(s)) {
7582 if ( left_type(t)==mp_given ) {
7583 @<Reduce to simple case of two givens and |return|@>
7585 @<Set up the equation for a given value of $\theta_0$@>;
7589 if ( left_type(t)==mp_curl ) {
7590 @<Reduce to simple case of straight line and |return|@>
7592 @<Set up the equation for a curl at $\theta_0$@>;
7596 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7597 /* this begins a cycle */
7599 } /* there are no other cases */
7601 @ The general equation that specifies equality of mock curvature at $z_k$ is
7602 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7603 as derived above. We want to combine this with the already-derived equation
7604 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7606 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7608 $$(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}
7609 -A_kw_{k-1}\theta_0$$
7610 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7611 fixed-point arithmetic, avoiding the chance of overflow while retaining
7614 The calculations will be performed in several registers that
7615 provide temporary storage for intermediate quantities.
7617 @<Other local variables for |solve_choices|@>=
7618 fraction aa,bb,cc,ff,acc; /* temporary registers */
7619 scaled dd,ee; /* likewise, but |scaled| */
7620 scaled lt,rt; /* tension values */
7622 @ @<Set up equation to match mock curvatures...@>=
7623 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7624 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7625 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7626 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7627 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7628 @<Calculate the values of $v_k$ and $w_k$@>;
7629 if ( left_type(s)==mp_end_cycle ) {
7630 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7634 @ Since tension values are never less than 3/4, the values |aa| and
7635 |bb| computed here are never more than 4/5.
7637 @<Calculate the values $\\{aa}=...@>=
7638 if ( abs(right_tension(r))==unity) {
7639 aa=fraction_half; dd=2*mp->delta[k];
7641 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7642 dd=mp_take_fraction(mp, mp->delta[k],
7643 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7645 if ( abs(left_tension(t))==unity ){
7646 bb=fraction_half; ee=2*mp->delta[k-1];
7648 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7649 ee=mp_take_fraction(mp, mp->delta[k-1],
7650 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7652 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7654 @ The ratio to be calculated in this step can be written in the form
7655 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7656 \\{cc}\cdot\\{dd},$$
7657 because of the quantities just calculated. The values of |dd| and |ee|
7658 will not be needed after this step has been performed.
7660 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7661 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7662 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7664 ff=mp_make_fraction(mp, lt,rt);
7665 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7666 dd=mp_take_fraction(mp, dd,ff);
7668 ff=mp_make_fraction(mp, rt,lt);
7669 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7670 ee=mp_take_fraction(mp, ee,ff);
7673 ff=mp_make_fraction(mp, ee,ee+dd)
7675 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7676 equation was specified by a curl. In that case we must use a special
7677 method of computation to prevent overflow.
7679 Fortunately, the calculations turn out to be even simpler in this ``hard''
7680 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7681 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7683 @<Calculate the values of $v_k$ and $w_k$@>=
7684 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7685 if ( right_type(r)==mp_curl ) {
7687 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7689 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7690 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7691 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7692 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7693 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7694 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7695 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7698 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7699 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7700 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7701 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7704 The idea in the following code is to observe that
7705 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7706 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7707 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7708 so we can solve for $\theta_n=\theta_0$.
7710 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7712 aa=0; bb=fraction_one; /* we have |k=n| */
7715 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7716 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7717 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7718 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7719 mp->theta[n]=aa; mp->vv[0]=aa;
7720 for (k=1;k<=n-1;k++) {
7721 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7726 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7727 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7729 @<Calculate the given value of $\theta_n$...@>=
7731 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7732 reduce_angle(mp->theta[n]);
7736 @ @<Set up the equation for a given value of $\theta_0$@>=
7738 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7739 reduce_angle(mp->vv[0]);
7740 mp->uu[0]=0; mp->ww[0]=0;
7743 @ @<Set up the equation for a curl at $\theta_0$@>=
7744 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7745 if ( (rt==unity)&&(lt==unity) )
7746 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7748 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7749 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7752 @ @<Set up equation for a curl at $\theta_n$...@>=
7753 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7754 if ( (rt==unity)&&(lt==unity) )
7755 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7757 ff=mp_curl_ratio(mp, cc,lt,rt);
7758 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7759 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7763 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7764 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7765 a somewhat tedious program to calculate
7766 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7767 \alpha^3\gamma+(3-\beta)\beta^2},$$
7768 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7769 is necessary only if the curl and tension are both large.)
7770 The values of $\alpha$ and $\beta$ will be at most~4/3.
7772 @<Declare subroutines needed by |solve_choices|@>=
7773 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7775 fraction alpha,beta,num,denom,ff; /* registers */
7776 alpha=mp_make_fraction(mp, unity,a_tension);
7777 beta=mp_make_fraction(mp, unity,b_tension);
7778 if ( alpha<=beta ) {
7779 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7780 gamma=mp_take_fraction(mp, gamma,ff);
7781 beta=beta / 010000; /* convert |fraction| to |scaled| */
7782 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7783 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7785 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7786 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7787 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7788 /* $1365\approx 2^{12}/3$ */
7789 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7791 if ( num>=denom+denom+denom+denom ) return fraction_four;
7792 else return mp_make_fraction(mp, num,denom);
7795 @ We're in the home stretch now.
7797 @<Finish choosing angles and assigning control points@>=
7798 for (k=n-1;k>=0;k--) {
7799 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7804 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7805 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7806 mp_set_controls(mp, s,t,k);
7810 @ The |set_controls| routine actually puts the control points into
7811 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7812 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7813 $\cos\phi$ needed in this calculation.
7819 fraction cf; /* sines and cosines */
7821 @ @<Declare subroutines needed by |solve_choices|@>=
7822 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7823 fraction rr,ss; /* velocities, divided by thrice the tension */
7824 scaled lt,rt; /* tensions */
7825 fraction sine; /* $\sin(\theta+\phi)$ */
7826 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7827 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7828 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7829 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7830 @<Decrease the velocities,
7831 if necessary, to stay inside the bounding triangle@>;
7833 right_x(p)=x_coord(p)+mp_take_fraction(mp,
7834 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7835 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7836 right_y(p)=y_coord(p)+mp_take_fraction(mp,
7837 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7838 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7839 left_x(q)=x_coord(q)-mp_take_fraction(mp,
7840 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7841 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7842 left_y(q)=y_coord(q)-mp_take_fraction(mp,
7843 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7844 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7845 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7848 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7849 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7850 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7851 there is no ``bounding triangle.''
7853 @<Decrease the velocities, if necessary...@>=
7854 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7855 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7856 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7858 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7859 if ( right_tension(p)<0 )
7860 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7861 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7862 if ( left_tension(q)<0 )
7863 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7864 ss=mp_make_fraction(mp, abs(mp->st),sine);
7868 @ Only the simple cases remain to be handled.
7870 @<Reduce to simple case of two givens and |return|@>=
7872 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7873 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7874 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7875 mp_set_controls(mp, p,q,0); return;
7878 @ @<Reduce to simple case of straight line and |return|@>=
7880 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7881 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7883 if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
7884 else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
7885 if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
7886 else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
7888 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7889 right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7890 right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7893 if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
7894 else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
7895 if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
7896 else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
7898 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7899 left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7900 left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7905 @* \[19] Measuring paths.
7906 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7907 allow the user to measure the bounding box of anything that can go into a
7908 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7909 by just finding the bounding box of the knots and the control points. We
7910 need a more accurate version of the bounding box, but we can still use the
7911 easy estimate to save time by focusing on the interesting parts of the path.
7913 @ Computing an accurate bounding box involves a theme that will come up again
7914 and again. Given a Bernshte{\u\i}n polynomial
7915 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
7916 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
7917 we can conveniently bisect its range as follows:
7920 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
7923 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
7924 |0<=k<n-j|, for |0<=j<n|.
7928 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
7929 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
7930 This formula gives us the coefficients of polynomials to use over the ranges
7931 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
7933 @ Now here's a subroutine that's handy for all sorts of path computations:
7934 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
7935 returns the unique |fraction| value |t| between 0 and~1 at which
7936 $B(a,b,c;t)$ changes from positive to negative, or returns
7937 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
7938 is already negative at |t=0|), |crossing_point| returns the value zero.
7940 @d no_crossing { return (fraction_one+1); }
7941 @d one_crossing { return fraction_one; }
7942 @d zero_crossing { return 0; }
7943 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
7945 @c fraction mp_do_crossing_point (integer a, integer b, integer c) {
7946 integer d; /* recursive counter */
7947 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
7948 if ( a<0 ) zero_crossing;
7951 if ( c>0 ) { no_crossing; }
7952 else if ( (a==0)&&(b==0) ) { no_crossing;}
7953 else { one_crossing; }
7955 if ( a==0 ) zero_crossing;
7956 } else if ( a==0 ) {
7957 if ( b<=0 ) zero_crossing;
7959 @<Use bisection to find the crossing point, if one exists@>;
7962 @ The general bisection method is quite simple when $n=2$, hence
7963 |crossing_point| does not take much time. At each stage in the
7964 recursion we have a subinterval defined by |l| and~|j| such that
7965 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
7966 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
7968 It is convenient for purposes of calculation to combine the values
7969 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
7970 of bisection then corresponds simply to doubling $d$ and possibly
7971 adding~1. Furthermore it proves to be convenient to modify
7972 our previous conventions for bisection slightly, maintaining the
7973 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
7974 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
7975 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
7977 The following code maintains the invariant relations
7978 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
7979 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
7980 it has been constructed in such a way that no arithmetic overflow
7981 will occur if the inputs satisfy
7982 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
7984 @<Use bisection to find the crossing point...@>=
7985 d=1; x0=a; x1=a-b; x2=b-c;
7996 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
8000 } while (d<fraction_one);
8001 return (d-fraction_one)
8003 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
8004 a cubic corresponding to the |fraction| value~|t|.
8006 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
8007 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
8009 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
8011 @c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
8012 scaled x1,x2,x3; /* intermediate values */
8013 x1=t_of_the_way(knot_coord(p),right_coord(p));
8014 x2=t_of_the_way(right_coord(p),left_coord(q));
8015 x3=t_of_the_way(left_coord(q),knot_coord(q));
8016 x1=t_of_the_way(x1,x2);
8017 x2=t_of_the_way(x2,x3);
8018 return t_of_the_way(x1,x2);
8021 @ The actual bounding box information is stored in global variables.
8022 Since it is convenient to address the $x$ and $y$ information
8023 separately, we define arrays indexed by |x_code..y_code| and use
8024 macros to give them more convenient names.
8028 mp_x_code=0, /* index for |minx| and |maxx| */
8029 mp_y_code /* index for |miny| and |maxy| */
8033 @d minx mp->bbmin[mp_x_code]
8034 @d maxx mp->bbmax[mp_x_code]
8035 @d miny mp->bbmin[mp_y_code]
8036 @d maxy mp->bbmax[mp_y_code]
8039 scaled bbmin[mp_y_code+1];
8040 scaled bbmax[mp_y_code+1];
8041 /* the result of procedures that compute bounding box information */
8043 @ Now we're ready for the key part of the bounding box computation.
8044 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
8045 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
8046 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8048 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8049 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8050 The |c| parameter is |x_code| or |y_code|.
8052 @c void mp_bound_cubic (MP mp,pointer p, pointer q, quarterword c) {
8053 boolean wavy; /* whether we need to look for extremes */
8054 scaled del1,del2,del3,del,dmax; /* proportional to the control
8055 points of a quadratic derived from a cubic */
8056 fraction t,tt; /* where a quadratic crosses zero */
8057 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8059 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8060 @<Check the control points against the bounding box and set |wavy:=true|
8061 if any of them lie outside@>;
8063 del1=right_coord(p)-knot_coord(p);
8064 del2=left_coord(q)-right_coord(p);
8065 del3=knot_coord(q)-left_coord(q);
8066 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8067 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8069 negate(del1); negate(del2); negate(del3);
8071 t=mp_crossing_point(mp, del1,del2,del3);
8072 if ( t<fraction_one ) {
8073 @<Test the extremes of the cubic against the bounding box@>;
8078 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8079 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8080 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8082 @ @<Check the control points against the bounding box and set...@>=
8084 if ( mp->bbmin[c]<=right_coord(p) )
8085 if ( right_coord(p)<=mp->bbmax[c] )
8086 if ( mp->bbmin[c]<=left_coord(q) )
8087 if ( left_coord(q)<=mp->bbmax[c] )
8090 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8091 section. We just set |del=0| in that case.
8093 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8094 if ( del1!=0 ) del=del1;
8095 else if ( del2!=0 ) del=del2;
8099 if ( abs(del2)>dmax ) dmax=abs(del2);
8100 if ( abs(del3)>dmax ) dmax=abs(del3);
8101 while ( dmax<fraction_half ) {
8102 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8106 @ Since |crossing_point| has tried to choose |t| so that
8107 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8108 slope, the value of |del2| computed below should not be positive.
8109 But rounding error could make it slightly positive in which case we
8110 must cut it to zero to avoid confusion.
8112 @<Test the extremes of the cubic against the bounding box@>=
8114 x=mp_eval_cubic(mp, p,q,t);
8115 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8116 del2=t_of_the_way(del2,del3);
8117 /* now |0,del2,del3| represent the derivative on the remaining interval */
8118 if ( del2>0 ) del2=0;
8119 tt=mp_crossing_point(mp, 0,-del2,-del3);
8120 if ( tt<fraction_one ) {
8121 @<Test the second extreme against the bounding box@>;
8125 @ @<Test the second extreme against the bounding box@>=
8127 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8128 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8131 @ Finding the bounding box of a path is basically a matter of applying
8132 |bound_cubic| twice for each pair of adjacent knots.
8134 @c void mp_path_bbox (MP mp,pointer h) {
8135 pointer p,q; /* a pair of adjacent knots */
8136 minx=x_coord(h); miny=y_coord(h);
8137 maxx=minx; maxy=miny;
8140 if ( right_type(p)==mp_endpoint ) return;
8142 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8143 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8148 @ Another important way to measure a path is to find its arc length. This
8149 is best done by using the general bisection algorithm to subdivide the path
8150 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8153 Since the arc length is the integral with respect to time of the magnitude of
8154 the velocity, it is natural to use Simpson's rule for the approximation.
8156 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8157 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8158 for the arc length of a path of length~1. For a cubic spline
8159 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8160 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8162 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8164 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8165 is the result of the bisection algorithm.
8167 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8168 This could be done via the theoretical error bound for Simpson's rule,
8170 but this is impractical because it requires an estimate of the fourth
8171 derivative of the quantity being integrated. It is much easier to just perform
8172 a bisection step and see how much the arc length estimate changes. Since the
8173 error for Simpson's rule is proportional to the fourth power of the sample
8174 spacing, the remaining error is typically about $1\over16$ of the amount of
8175 the change. We say ``typically'' because the error has a pseudo-random behavior
8176 that could cause the two estimates to agree when each contain large errors.
8178 To protect against disasters such as undetected cusps, the bisection process
8179 should always continue until all the $dz_i$ vectors belong to a single
8180 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8181 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8182 If such a spline happens to produce an erroneous arc length estimate that
8183 is little changed by bisection, the amount of the error is likely to be fairly
8184 small. We will try to arrange things so that freak accidents of this type do
8185 not destroy the inverse relationship between the \&{arclength} and
8186 \&{arctime} operations.
8187 @:arclength_}{\&{arclength} primitive@>
8188 @:arctime_}{\&{arctime} primitive@>
8190 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8192 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8193 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8194 returns the time when the arc length reaches |a_goal| if there is such a time.
8195 Thus the return value is either an arc length less than |a_goal| or, if the
8196 arc length would be at least |a_goal|, it returns a time value decreased by
8197 |two|. This allows the caller to use the sign of the result to distinguish
8198 between arc lengths and time values. On certain types of overflow, it is
8199 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8200 Otherwise, the result is always less than |a_goal|.
8202 Rather than halving the control point coordinates on each recursive call to
8203 |arc_test|, it is better to keep them proportional to velocity on the original
8204 curve and halve the results instead. This means that recursive calls can
8205 potentially use larger error tolerances in their arc length estimates. How
8206 much larger depends on to what extent the errors behave as though they are
8207 independent of each other. To save computing time, we use optimistic assumptions
8208 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8211 In addition to the tolerance parameter, |arc_test| should also have parameters
8212 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8213 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8214 and they are needed in different instances of |arc_test|.
8216 @c @<Declare subroutines needed by |arc_test|@>
8217 scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8218 scaled dx2, scaled dy2, scaled v0, scaled v02,
8219 scaled v2, scaled a_goal, scaled tol) {
8220 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8221 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8223 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8224 scaled arc; /* best arc length estimate before recursion */
8225 @<Other local variables in |arc_test|@>;
8226 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8228 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8229 set |arc_test| and |return|@>;
8230 @<Test if the control points are confined to one quadrant or rotating them
8231 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8232 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8233 if ( arc < a_goal ) {
8236 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8237 that time minus |two|@>;
8240 @<Use one or two recursive calls to compute the |arc_test| function@>;
8244 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8245 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8246 |make_fraction| in this inner loop.
8249 @<Use one or two recursive calls to compute the |arc_test| function@>=
8251 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8252 large as possible@>;
8253 tol = tol + halfp(tol);
8254 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8255 halfp(v02), a_new, tol);
8257 return (-halfp(two-a));
8259 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8260 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8261 halfp(v02), v022, v2, a_new, tol);
8263 return (-halfp(-b) - half_unit);
8265 return (a + half(b-a));
8269 @ @<Other local variables in |arc_test|@>=
8270 scaled a,b; /* results of recursive calls */
8271 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8273 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8274 a_aux = el_gordo - a_goal;
8275 if ( a_goal > a_aux ) {
8276 a_aux = a_goal - a_aux;
8279 a_new = a_goal + a_goal;
8283 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8284 to force the additions and subtractions to be done in an order that avoids
8287 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8290 a_new = a_new + a_aux;
8293 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8294 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8295 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8296 this bound. Note that recursive calls will maintain this invariant.
8298 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8299 dx01 = half(dx0 + dx1);
8300 dx12 = half(dx1 + dx2);
8301 dx02 = half(dx01 + dx12);
8302 dy01 = half(dy0 + dy1);
8303 dy12 = half(dy1 + dy2);
8304 dy02 = half(dy01 + dy12)
8306 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8307 |a_goal=el_gordo| is guaranteed to yield the arc length.
8309 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8310 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8311 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8313 arc1 = v002 + half(halfp(v0+tmp) - v002);
8314 arc = v022 + half(halfp(v2+tmp) - v022);
8315 if ( (arc < el_gordo-arc1) ) {
8318 mp->arith_error = true;
8319 if ( a_goal==el_gordo ) return (el_gordo);
8323 @ @<Other local variables in |arc_test|@>=
8324 scaled tmp, tmp2; /* all purpose temporary registers */
8325 scaled arc1; /* arc length estimate for the first half */
8327 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8328 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8329 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8331 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8332 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8334 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8335 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8337 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8338 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8341 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8343 it is appropriate to use the same approximation to decide when the integral
8344 reaches the intermediate value |a_goal|. At this point
8346 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8347 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8348 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8349 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8350 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8354 $$ {\vb\dot B(t)\vb\over 3} \approx
8355 \cases{B\left(\hbox{|v0|},
8356 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8357 {1\over 2}\hbox{|v02|}; 2t \right)&
8358 if $t\le{1\over 2}$\cr
8359 B\left({1\over 2}\hbox{|v02|},
8360 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8361 \hbox{|v2|}; 2t-1 \right)&
8362 if $t\ge{1\over 2}$.\cr}
8365 We can integrate $\vb\dot B(t)\vb$ by using
8366 $$\int 3B(a,b,c;\tau)\,dt =
8367 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8370 This construction allows us to find the time when the arc length reaches
8371 |a_goal| by solving a cubic equation of the form
8372 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8373 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8374 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8375 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8376 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8377 $\tau$ given $a$, $b$, $c$, and $x$.
8379 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8381 tmp = (v02 + 2) / 4;
8382 if ( a_goal<=arc1 ) {
8385 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8388 return ((half_unit - two) +
8389 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8393 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8394 $$ B(0, a, a+b, a+b+c; t) = x. $$
8395 This routine is based on |crossing_point| but is simplified by the
8396 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8397 If rounding error causes this condition to be violated slightly, we just ignore
8398 it and proceed with binary search. This finds a time when the function value
8399 reaches |x| and the slope is positive.
8401 @<Declare subroutines needed by |arc_test|@>=
8402 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8403 scaled ab, bc, ac; /* bisection results */
8404 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8405 integer xx; /* temporary for updating |x| */
8406 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8407 @:this can't happen rising?}{\quad rising?@>
8410 } else if ( x >= a+b+c ) {
8414 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8418 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8419 xx = x - a - ab - ac;
8420 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8421 else { x = x + xx; a=ac; b=bc; t = t+1; };
8422 } while (t < unity);
8427 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8432 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8434 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8435 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8442 @ It is convenient to have a simpler interface to |arc_test| that requires no
8443 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8444 length less than |fraction_four|.
8446 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8448 @c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8449 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8450 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8451 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8452 v0 = mp_pyth_add(mp, dx0,dy0);
8453 v1 = mp_pyth_add(mp, dx1,dy1);
8454 v2 = mp_pyth_add(mp, dx2,dy2);
8455 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8456 mp->arith_error = true;
8457 if ( a_goal==el_gordo ) return el_gordo;
8460 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8461 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8462 v0, v02, v2, a_goal, arc_tol));
8466 @ Now it is easy to find the arc length of an entire path.
8468 @c scaled mp_get_arc_length (MP mp,pointer h) {
8469 pointer p,q; /* for traversing the path */
8470 scaled a,a_tot; /* current and total arc lengths */
8473 while ( right_type(p)!=mp_endpoint ){
8475 a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8476 left_x(q)-right_x(p), left_y(q)-right_y(p),
8477 x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
8478 a_tot = mp_slow_add(mp, a, a_tot);
8479 if ( q==h ) break; else p=q;
8485 @ The inverse operation of finding the time on a path~|h| when the arc length
8486 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8487 is required to handle very large times or negative times on cyclic paths. For
8488 non-cyclic paths, |arc0| values that are negative or too large cause
8489 |get_arc_time| to return 0 or the length of path~|h|.
8491 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8492 time value greater than the length of the path. Since it could be much greater,
8493 we must be prepared to compute the arc length of path~|h| and divide this into
8494 |arc0| to find how many multiples of the length of path~|h| to add.
8496 @c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8497 pointer p,q; /* for traversing the path */
8498 scaled t_tot; /* accumulator for the result */
8499 scaled t; /* the result of |do_arc_test| */
8500 scaled arc; /* portion of |arc0| not used up so far */
8501 integer n; /* number of extra times to go around the cycle */
8503 @<Deal with a negative |arc0| value and |return|@>;
8505 if ( arc0==el_gordo ) decr(arc0);
8509 while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
8511 t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8512 left_x(q)-right_x(p), left_y(q)-right_y(p),
8513 x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
8514 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8516 @<Update |t_tot| and |arc| to avoid going around the cyclic
8517 path too many times but set |arith_error:=true| and |goto done| on
8526 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8527 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8528 else { t_tot = t_tot + unity; arc = arc - t; }
8530 @ @<Deal with a negative |arc0| value and |return|@>=
8532 if ( left_type(h)==mp_endpoint ) {
8535 p = mp_htap_ypoc(mp, h);
8536 t_tot = -mp_get_arc_time(mp, p, -arc0);
8537 mp_toss_knot_list(mp, p);
8543 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8545 n = arc / (arc0 - arc);
8546 arc = arc - n*(arc0 - arc);
8547 if ( t_tot > (el_gordo / (n+1)) ) {
8550 t_tot = (n + 1)*t_tot;
8553 @* \[20] Data structures for pens.
8554 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8555 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8556 @:stroke}{\&{stroke} command@>
8557 converted into an area fill as described in the next part of this program.
8558 The mathematics behind this process is based on simple aspects of the theory
8559 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8560 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8561 Foundations of Computer Science {\bf 24} (1983), 100--111].
8563 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8564 @:makepen_}{\&{makepen} primitive@>
8565 This path representation is almost sufficient for our purposes except that
8566 a pen path should always be a convex polygon with the vertices in
8567 counter-clockwise order.
8568 Since we will need to scan pen polygons both forward and backward, a pen
8569 should be represented as a doubly linked ring of knot nodes. There is
8570 room for the extra back pointer because we do not need the
8571 |left_type| or |right_type| fields. In fact, we don't need the |left_x|,
8572 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
8573 so that certain procedures can operate on both pens and paths. In particular,
8574 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8577 /* this replaces the |left_type| and |right_type| fields in a pen knot */
8579 @ The |make_pen| procedure turns a path into a pen by initializing
8580 the |knil| pointers and making sure the knots form a convex polygon.
8581 Thus each cubic in the given path becomes a straight line and the control
8582 points are ignored. If the path is not cyclic, the ends are connected by a
8585 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8587 @c @<Declare a function called |convex_hull|@>
8588 pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8589 pointer p,q; /* two consecutive knots */
8596 h=mp_convex_hull(mp, h);
8597 @<Make sure |h| isn't confused with an elliptical pen@>;
8602 @ The only information required about an elliptical pen is the overall
8603 transformation that has been applied to the original \&{pencircle}.
8604 @:pencircle_}{\&{pencircle} primitive@>
8605 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8606 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8607 knot node and transformed as if it were a path.
8609 @d pen_is_elliptical(A) ((A)==mp_link((A)))
8611 @c pointer mp_get_pen_circle (MP mp,scaled diam) {
8612 pointer h; /* the knot node to return */
8613 h=mp_get_node(mp, knot_node_size);
8614 mp_link(h)=h; knil(h)=h;
8615 originator(h)=mp_program_code;
8616 x_coord(h)=0; y_coord(h)=0;
8617 left_x(h)=diam; left_y(h)=0;
8618 right_x(h)=0; right_y(h)=diam;
8622 @ If the polygon being returned by |make_pen| has only one vertex, it will
8623 be interpreted as an elliptical pen. This is no problem since a degenerate
8624 polygon can equally well be thought of as a degenerate ellipse. We need only
8625 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
8627 @<Make sure |h| isn't confused with an elliptical pen@>=
8628 if ( pen_is_elliptical( h) ){
8629 left_x(h)=x_coord(h); left_y(h)=y_coord(h);
8630 right_x(h)=x_coord(h); right_y(h)=y_coord(h);
8633 @ We have to cheat a little here but most operations on pens only use
8634 the first three words in each knot node.
8635 @^data structure assumptions@>
8637 @<Initialize a pen at |test_pen| so that it fits in nine words@>=
8638 x_coord(test_pen)=-half_unit;
8639 y_coord(test_pen)=0;
8640 x_coord(test_pen+3)=half_unit;
8641 y_coord(test_pen+3)=0;
8642 x_coord(test_pen+6)=0;
8643 y_coord(test_pen+6)=unity;
8644 mp_link(test_pen)=test_pen+3;
8645 mp_link(test_pen+3)=test_pen+6;
8646 mp_link(test_pen+6)=test_pen;
8647 knil(test_pen)=test_pen+6;
8648 knil(test_pen+3)=test_pen;
8649 knil(test_pen+6)=test_pen+3
8651 @ Printing a polygonal pen is very much like printing a path
8653 @<Declare subroutines for printing expressions@>=
8654 void mp_pr_pen (MP mp,pointer h) {
8655 pointer p,q; /* for list traversal */
8656 if ( pen_is_elliptical(h) ) {
8657 @<Print the elliptical pen |h|@>;
8661 mp_print_two(mp, x_coord(p),y_coord(p));
8662 mp_print_nl(mp, " .. ");
8663 @<Advance |p| making sure the links are OK and |return| if there is
8666 mp_print(mp, "cycle");
8670 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8672 if ( (q==null) || (knil(q)!=p) ) {
8673 mp_print_nl(mp, "???"); return; /* this won't happen */
8678 @ @<Print the elliptical pen |h|@>=
8680 mp_print(mp, "pencircle transformed (");
8681 mp_print_scaled(mp, x_coord(h));
8682 mp_print_char(mp, xord(','));
8683 mp_print_scaled(mp, y_coord(h));
8684 mp_print_char(mp, xord(','));
8685 mp_print_scaled(mp, left_x(h)-x_coord(h));
8686 mp_print_char(mp, xord(','));
8687 mp_print_scaled(mp, right_x(h)-x_coord(h));
8688 mp_print_char(mp, xord(','));
8689 mp_print_scaled(mp, left_y(h)-y_coord(h));
8690 mp_print_char(mp, xord(','));
8691 mp_print_scaled(mp, right_y(h)-y_coord(h));
8692 mp_print_char(mp, xord(')'));
8695 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8698 @<Declare subroutines for printing expressions@>=
8699 void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
8700 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8703 mp_end_diagnostic(mp, true);
8706 @ Making a polygonal pen into a path involves restoring the |left_type| and
8707 |right_type| fields and setting the control points so as to make a polygonal
8711 void mp_make_path (MP mp,pointer h) {
8712 pointer p; /* for traversing the knot list */
8713 quarterword k; /* a loop counter */
8714 @<Other local variables in |make_path|@>;
8715 if ( pen_is_elliptical(h) ) {
8716 @<Make the elliptical pen |h| into a path@>;
8720 left_type(p)=mp_explicit;
8721 right_type(p)=mp_explicit;
8722 @<copy the coordinates of knot |p| into its control points@>;
8728 @ @<copy the coordinates of knot |p| into its control points@>=
8729 left_x(p)=x_coord(p);
8730 left_y(p)=y_coord(p);
8731 right_x(p)=x_coord(p);
8732 right_y(p)=y_coord(p)
8734 @ We need an eight knot path to get a good approximation to an ellipse.
8736 @<Make the elliptical pen |h| into a path@>=
8738 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8740 for (k=0;k<=7;k++ ) {
8741 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8742 transforming it appropriately@>;
8743 if ( k==7 ) mp_link(p)=h; else mp_link(p)=mp_get_node(mp, knot_node_size);
8748 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8749 center_x=x_coord(h);
8750 center_y=y_coord(h);
8751 width_x=left_x(h)-center_x;
8752 width_y=left_y(h)-center_y;
8753 height_x=right_x(h)-center_x;
8754 height_y=right_y(h)-center_y
8756 @ @<Other local variables in |make_path|@>=
8757 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8758 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8759 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8760 scaled dx,dy; /* the vector from knot |p| to its right control point */
8762 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8764 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8765 find the point $k/8$ of the way around the circle and the direction vector
8768 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8770 x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8771 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8772 y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8773 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8774 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8775 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8776 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8777 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8778 right_x(p)=x_coord(p)+dx;
8779 right_y(p)=y_coord(p)+dy;
8780 left_x(p)=x_coord(p)-dx;
8781 left_y(p)=y_coord(p)-dy;
8782 left_type(p)=mp_explicit;
8783 right_type(p)=mp_explicit;
8784 originator(p)=mp_program_code
8787 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8788 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8790 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8791 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8792 function for $\theta=\phi=22.5^\circ$. This comes out to be
8793 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8794 \approx 0.132608244919772.
8798 mp->half_cos[0]=fraction_half;
8799 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8801 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8802 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8804 for (k=3;k<= 4;k++ ) {
8805 mp->half_cos[k]=-mp->half_cos[4-k];
8806 mp->d_cos[k]=-mp->d_cos[4-k];
8808 for (k=5;k<= 7;k++ ) {
8809 mp->half_cos[k]=mp->half_cos[8-k];
8810 mp->d_cos[k]=mp->d_cos[8-k];
8813 @ The |convex_hull| function forces a pen polygon to be convex when it is
8814 returned by |make_pen| and after any subsequent transformation where rounding
8815 error might allow the convexity to be lost.
8816 The convex hull algorithm used here is described by F.~P. Preparata and
8817 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8819 @<Declare a function called |convex_hull|@>=
8820 @<Declare a procedure called |move_knot|@>
8821 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8822 pointer l,r; /* the leftmost and rightmost knots */
8823 pointer p,q; /* knots being scanned */
8824 pointer s; /* the starting point for an upcoming scan */
8825 scaled dx,dy; /* a temporary pointer */
8826 if ( pen_is_elliptical(h) ) {
8829 @<Set |l| to the leftmost knot in polygon~|h|@>;
8830 @<Set |r| to the rightmost knot in polygon~|h|@>;
8833 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8834 move them past~|r|@>;
8835 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8836 move them past~|l|@>;
8837 @<Sort the path from |l| to |r| by increasing $x$@>;
8838 @<Sort the path from |r| to |l| by decreasing $x$@>;
8840 if ( l!=mp_link(l) ) {
8841 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8847 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8849 @<Set |l| to the leftmost knot in polygon~|h|@>=
8853 if ( x_coord(p)<=x_coord(l) )
8854 if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
8859 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8863 if ( x_coord(p)>=x_coord(r) )
8864 if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
8869 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8870 dx=x_coord(r)-x_coord(l);
8871 dy=y_coord(r)-y_coord(l);
8875 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
8876 mp_move_knot(mp, p, r);
8880 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8883 @ @<Declare a procedure called |move_knot|@>=
8884 void mp_move_knot (MP mp,pointer p, pointer q) {
8885 mp_link(knil(p))=mp_link(p);
8886 knil(mp_link(p))=knil(p);
8888 mp_link(p)=mp_link(q);
8893 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8897 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
8898 mp_move_knot(mp, p,l);
8902 @ The list is likely to be in order already so we just do linear insertions.
8903 Secondary comparisons on $y$ ensure that the sort is consistent with the
8904 choice of |l| and |r|.
8906 @<Sort the path from |l| to |r| by increasing $x$@>=
8910 while ( x_coord(q)>x_coord(p) ) q=knil(q);
8911 while ( x_coord(q)==x_coord(p) ) {
8912 if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
8914 if ( q==knil(p) ) p=mp_link(p);
8915 else { p=mp_link(p); mp_move_knot(mp, knil(p),q); };
8918 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
8922 while ( x_coord(q)<x_coord(p) ) q=knil(q);
8923 while ( x_coord(q)==x_coord(p) ) {
8924 if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
8926 if ( q==knil(p) ) p=mp_link(p);
8927 else { p=mp_link(p); mp_move_knot(mp, knil(p),q); };
8930 @ The condition involving |ab_vs_cd| tests if there is not a left turn
8931 at knot |q|. There usually will be a left turn so we streamline the case
8932 where the |then| clause is not executed.
8934 @<Do a Gramm scan and remove vertices where there...@>=
8938 dx=x_coord(q)-x_coord(p);
8939 dy=y_coord(q)-y_coord(p);
8943 if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
8944 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
8949 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
8952 mp_free_node(mp, p,knot_node_size);
8953 mp_link(s)=q; knil(q)=s;
8955 else { p=knil(s); q=s; };
8958 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
8959 offset associated with the given direction |(x,y)|. If two different offsets
8960 apply, it chooses one of them.
8963 void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
8964 pointer p,q; /* consecutive knots */
8966 /* the transformation matrix for an elliptical pen */
8967 fraction xx,yy; /* untransformed offset for an elliptical pen */
8968 fraction d; /* a temporary register */
8969 if ( pen_is_elliptical(h) ) {
8970 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
8975 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
8978 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
8979 mp->cur_x=x_coord(p);
8980 mp->cur_y=y_coord(p);
8986 scaled cur_y; /* all-purpose return value registers */
8988 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
8989 if ( (x==0) && (y==0) ) {
8990 mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
8992 @<Find the non-constant part of the transformation for |h|@>;
8993 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
8996 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
8997 untransformed version of |(x,y)|@>;
8998 mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
8999 mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
9002 @ @<Find the non-constant part of the transformation for |h|@>=
9003 wx=left_x(h)-x_coord(h);
9004 wy=left_y(h)-y_coord(h);
9005 hx=right_x(h)-x_coord(h);
9006 hy=right_y(h)-y_coord(h)
9008 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
9009 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
9010 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
9011 d=mp_pyth_add(mp, xx,yy);
9013 xx=half(mp_make_fraction(mp, xx,d));
9014 yy=half(mp_make_fraction(mp, yy,d));
9017 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
9018 But we can handle that case by just calling |find_offset| twice. The answer
9019 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
9022 void mp_pen_bbox (MP mp,pointer h) {
9023 pointer p; /* for scanning the knot list */
9024 if ( pen_is_elliptical(h) ) {
9025 @<Find the bounding box of an elliptical pen@>;
9027 minx=x_coord(h); maxx=minx;
9028 miny=y_coord(h); maxy=miny;
9031 if ( x_coord(p)<minx ) minx=x_coord(p);
9032 if ( y_coord(p)<miny ) miny=y_coord(p);
9033 if ( x_coord(p)>maxx ) maxx=x_coord(p);
9034 if ( y_coord(p)>maxy ) maxy=y_coord(p);
9040 @ @<Find the bounding box of an elliptical pen@>=
9042 mp_find_offset(mp, 0,fraction_one,h);
9044 minx=2*x_coord(h)-mp->cur_x;
9045 mp_find_offset(mp, -fraction_one,0,h);
9047 miny=2*y_coord(h)-mp->cur_y;
9050 @* \[21] Edge structures.
9051 Now we come to \MP's internal scheme for representing pictures.
9052 The representation is very different from \MF's edge structures
9053 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9054 images. However, the basic idea is somewhat similar in that shapes
9055 are represented via their boundaries.
9057 The main purpose of edge structures is to keep track of graphical objects
9058 until it is time to translate them into \ps. Since \MP\ does not need to
9059 know anything about an edge structure other than how to translate it into
9060 \ps\ and how to find its bounding box, edge structures can be just linked
9061 lists of graphical objects. \MP\ has no easy way to determine whether
9062 two such objects overlap, but it suffices to draw the first one first and
9063 let the second one overwrite it if necessary.
9066 enum mp_graphical_object_code {
9067 @<Graphical object codes@>
9071 @ Let's consider the types of graphical objects one at a time.
9072 First of all, a filled contour is represented by a eight-word node. The first
9073 word contains |type| and |link| fields, and the next six words contain a
9074 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9075 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9076 give the relevant information.
9078 @d path_p(A) mp_link((A)+1)
9079 /* a pointer to the path that needs filling */
9080 @d pen_p(A) info((A)+1)
9081 /* a pointer to the pen to fill or stroke with */
9082 @d color_model(A) type((A)+2) /* the color model */
9083 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9084 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9085 @d obj_grey_loc obj_red_loc /* the location for the color */
9086 @d red_val(A) mp->mem[(A)+3].sc
9087 /* the red component of the color in the range $0\ldots1$ */
9090 @d green_val(A) mp->mem[(A)+4].sc
9091 /* the green component of the color in the range $0\ldots1$ */
9092 @d magenta_val green_val
9093 @d blue_val(A) mp->mem[(A)+5].sc
9094 /* the blue component of the color in the range $0\ldots1$ */
9095 @d yellow_val blue_val
9096 @d black_val(A) mp->mem[(A)+6].sc
9097 /* the blue component of the color in the range $0\ldots1$ */
9098 @d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
9099 @:mp_linejoin_}{\&{linejoin} primitive@>
9100 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9101 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9102 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9103 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9104 @d pre_script(A) mp->mem[(A)+8].hh.lh
9105 @d post_script(A) mp->mem[(A)+8].hh.rh
9108 @ @<Graphical object codes@>=
9112 pointer mp_new_fill_node (MP mp,pointer p) {
9113 /* make a fill node for cyclic path |p| and color black */
9114 pointer t; /* the new node */
9115 t=mp_get_node(mp, fill_node_size);
9116 type(t)=mp_fill_code;
9118 pen_p(t)=null; /* |null| means don't use a pen */
9123 color_model(t)=mp_uninitialized_model;
9125 post_script(t)=null;
9126 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9130 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9131 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9132 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9133 else ljoin_val(t)=0;
9134 if ( mp->internal[mp_miterlimit]<unity )
9135 miterlim_val(t)=unity;
9137 miterlim_val(t)=mp->internal[mp_miterlimit]
9139 @ A stroked path is represented by an eight-word node that is like a filled
9140 contour node except that it contains the current \&{linecap} value, a scale
9141 factor for the dash pattern, and a pointer that is non-null if the stroke
9142 is to be dashed. The purpose of the scale factor is to allow a picture to
9143 be transformed without touching the picture that |dash_p| points to.
9145 @d dash_p(A) mp_link((A)+9)
9146 /* a pointer to the edge structure that gives the dash pattern */
9147 @d lcap_val(A) type((A)+9)
9148 /* the value of \&{linecap} */
9149 @:mp_linecap_}{\&{linecap} primitive@>
9150 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9151 @d stroked_node_size 11
9153 @ @<Graphical object codes@>=
9157 pointer mp_new_stroked_node (MP mp,pointer p) {
9158 /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
9159 pointer t; /* the new node */
9160 t=mp_get_node(mp, stroked_node_size);
9161 type(t)=mp_stroked_code;
9162 path_p(t)=p; pen_p(t)=null;
9164 dash_scale(t)=unity;
9169 color_model(t)=mp_uninitialized_model;
9171 post_script(t)=null;
9172 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9173 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9174 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9179 @ When a dashed line is computed in a transformed coordinate system, the dash
9180 lengths get scaled like the pen shape and we need to compensate for this. Since
9181 there is no unique scale factor for an arbitrary transformation, we use the
9182 the square root of the determinant. The properties of the determinant make it
9183 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9184 except for the initialization of the scale factor |s|. The factor of 64 is
9185 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9186 to counteract the effect of |take_fraction|.
9188 @<Declare subroutines needed by |print_edges|@>=
9189 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9190 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9191 unsigned s; /* amount by which the result of |square_rt| needs to be scaled */
9192 @<Initialize |maxabs|@>;
9194 while ( (maxabs<fraction_one) && (s>1) ){
9195 a+=a; b+=b; c+=c; d+=d;
9196 maxabs+=maxabs; s=halfp(s);
9198 return (scaled)(s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c))));
9201 scaled mp_get_pen_scale (MP mp,pointer p) {
9202 return mp_sqrt_det(mp,
9203 left_x(p)-x_coord(p), right_x(p)-x_coord(p),
9204 left_y(p)-y_coord(p), right_y(p)-y_coord(p));
9207 @ @<Internal library ...@>=
9208 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9211 @ @<Initialize |maxabs|@>=
9213 if ( abs(b)>maxabs ) maxabs=abs(b);
9214 if ( abs(c)>maxabs ) maxabs=abs(c);
9215 if ( abs(d)>maxabs ) maxabs=abs(d)
9217 @ When a picture contains text, this is represented by a fourteen-word node
9218 where the color information and |type| and |link| fields are augmented by
9219 additional fields that describe the text and how it is transformed.
9220 The |path_p| and |pen_p| pointers are replaced by a number that identifies
9221 the font and a string number that gives the text to be displayed.
9222 The |width|, |height|, and |depth| fields
9223 give the dimensions of the text at its design size, and the remaining six
9224 words give a transformation to be applied to the text. The |new_text_node|
9225 function initializes everything to default values so that the text comes out
9226 black with its reference point at the origin.
9228 @d text_p(A) mp_link((A)+1) /* a string pointer for the text to display */
9229 @d font_n(A) info((A)+1) /* the font number */
9230 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9231 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9232 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9233 @d text_tx_loc(A) ((A)+11)
9234 /* the first of six locations for transformation parameters */
9235 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9236 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9237 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9238 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9239 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9240 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9241 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9242 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9243 @d text_node_size 17
9245 @ @<Graphical object codes@>=
9248 @ @c @<Declare text measuring subroutines@>
9249 pointer mp_new_text_node (MP mp,char *f,str_number s) {
9250 /* make a text node for font |f| and text string |s| */
9251 pointer t; /* the new node */
9252 t=mp_get_node(mp, text_node_size);
9253 type(t)=mp_text_code;
9255 font_n(t)=(halfword)mp_find_font(mp, f); /* this identifies the font */
9260 color_model(t)=mp_uninitialized_model;
9262 post_script(t)=null;
9263 tx_val(t)=0; ty_val(t)=0;
9264 txx_val(t)=unity; txy_val(t)=0;
9265 tyx_val(t)=0; tyy_val(t)=unity;
9266 mp_set_text_box(mp, t); /* this finds the bounding box */
9270 @ The last two types of graphical objects that can occur in an edge structure
9271 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9272 @:set_bounds_}{\&{setbounds} primitive@>
9273 to implement because we must keep track of exactly what is being clipped or
9274 bounded when pictures get merged together. For this reason, each clipping or
9275 \&{setbounds} operation is represented by a pair of nodes: first comes a
9276 two-word node whose |path_p| gives the relevant path, then there is the list
9277 of objects to clip or bound followed by a two-word node whose second word is
9280 Using at least two words for each graphical object node allows them all to be
9281 allocated and deallocated similarly with a global array |gr_object_size| to
9282 give the size in words for each object type.
9284 @d start_clip_size 2
9285 @d start_bounds_size 2
9286 @d stop_clip_size 2 /* the second word is not used here */
9287 @d stop_bounds_size 2 /* the second word is not used here */
9289 @d stop_type(A) ((A)+2)
9290 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9291 @d has_color(A) (type((A))<mp_start_clip_code)
9292 /* does a graphical object have color fields? */
9293 @d has_pen(A) (type((A))<mp_text_code)
9294 /* does a graphical object have a |pen_p| field? */
9295 @d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
9296 @d is_stop(A) (type((A))>=mp_stop_clip_code)
9298 @ @<Graphical object codes@>=
9299 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9300 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9301 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9302 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9305 pointer mp_new_bounds_node (MP mp,pointer p, quarterword c) {
9306 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9307 pointer t; /* the new node */
9308 t=mp_get_node(mp, mp->gr_object_size[c]);
9314 @ We need an array to keep track of the sizes of graphical objects.
9317 quarterword gr_object_size[mp_stop_bounds_code+1];
9320 mp->gr_object_size[mp_fill_code]=fill_node_size;
9321 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9322 mp->gr_object_size[mp_text_code]=text_node_size;
9323 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9324 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9325 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9326 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9328 @ All the essential information in an edge structure is encoded as a linked list
9329 of graphical objects as we have just seen, but it is helpful to add some
9330 redundant information. A single edge structure might be used as a dash pattern
9331 many times, and it would be nice to avoid scanning the same structure
9332 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9333 has a header that gives a list of dashes in a sorted order designed for rapid
9334 translation into \ps.
9336 Each dash is represented by a three-word node containing the initial and final
9337 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9338 the dash node with the next higher $x$-coordinates and the final link points
9339 to a special location called |null_dash|. (There should be no overlap between
9340 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9341 the period of repetition, this needs to be stored in the edge header along
9342 with a pointer to the list of dash nodes.
9344 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9345 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9347 @d dash_list mp_link
9348 /* in an edge header this points to the first dash node */
9349 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9351 @ It is also convenient for an edge header to contain the bounding
9352 box information needed by the \&{llcorner} and \&{urcorner} operators
9353 so that this does not have to be recomputed unnecessarily. This is done by
9354 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9355 how far the bounding box computation has gotten. Thus if the user asks for
9356 the bounding box and then adds some more text to the picture before asking
9357 for more bounding box information, the second computation need only look at
9358 the additional text.
9360 When the bounding box has not been computed, the |bblast| pointer points
9361 to a dummy link at the head of the graphical object list while the |minx_val|
9362 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9363 fields contain |-el_gordo|.
9365 Since the bounding box of pictures containing objects of type
9366 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9367 @:mp_true_corners_}{\&{truecorners} primitive@>
9368 data might not be valid for all values of this parameter. Hence, the |bbtype|
9369 field is needed to keep track of this.
9371 @d minx_val(A) mp->mem[(A)+2].sc
9372 @d miny_val(A) mp->mem[(A)+3].sc
9373 @d maxx_val(A) mp->mem[(A)+4].sc
9374 @d maxy_val(A) mp->mem[(A)+5].sc
9375 @d bblast(A) mp_link((A)+6) /* last item considered in bounding box computation */
9376 @d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9377 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9379 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9381 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9383 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9386 void mp_init_bbox (MP mp,pointer h) {
9387 /* Initialize the bounding box information in edge structure |h| */
9388 bblast(h)=dummy_loc(h);
9389 bbtype(h)=no_bounds;
9390 minx_val(h)=el_gordo;
9391 miny_val(h)=el_gordo;
9392 maxx_val(h)=-el_gordo;
9393 maxy_val(h)=-el_gordo;
9396 @ The only other entries in an edge header are a reference count in the first
9397 word and a pointer to the tail of the object list in the last word.
9399 @d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
9400 @d edge_header_size 8
9403 void mp_init_edges (MP mp,pointer h) {
9404 /* initialize an edge header to null values */
9405 dash_list(h)=null_dash;
9406 obj_tail(h)=dummy_loc(h);
9407 mp_link(dummy_loc(h))=null;
9409 mp_init_bbox(mp, h);
9412 @ Here is how edge structures are deleted. The process can be recursive because
9413 of the need to dereference edge structures that are used as dash patterns.
9416 @d add_edge_ref(A) incr(ref_count(A))
9417 @d delete_edge_ref(A) {
9418 if ( ref_count((A))==null )
9419 mp_toss_edges(mp, A);
9424 @<Declare the recycling subroutines@>=
9425 void mp_flush_dash_list (MP mp,pointer h);
9426 pointer mp_toss_gr_object (MP mp,pointer p) ;
9427 void mp_toss_edges (MP mp,pointer h) ;
9429 @ @c void mp_toss_edges (MP mp,pointer h) {
9430 pointer p,q; /* pointers that scan the list being recycled */
9431 pointer r; /* an edge structure that object |p| refers to */
9432 mp_flush_dash_list(mp, h);
9433 q=mp_link(dummy_loc(h));
9434 while ( (q!=null) ) {
9436 r=mp_toss_gr_object(mp, p);
9437 if ( r!=null ) delete_edge_ref(r);
9439 mp_free_node(mp, h,edge_header_size);
9441 void mp_flush_dash_list (MP mp,pointer h) {
9442 pointer p,q; /* pointers that scan the list being recycled */
9444 while ( q!=null_dash ) {
9446 mp_free_node(mp, p,dash_node_size);
9448 dash_list(h)=null_dash;
9450 pointer mp_toss_gr_object (MP mp,pointer p) {
9451 /* returns an edge structure that needs to be dereferenced */
9452 pointer e; /* the edge structure to return */
9454 @<Prepare to recycle graphical object |p|@>;
9455 mp_free_node(mp, p,mp->gr_object_size[type(p)]);
9459 @ @<Prepare to recycle graphical object |p|@>=
9462 mp_toss_knot_list(mp, path_p(p));
9463 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9464 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9465 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9467 case mp_stroked_code:
9468 mp_toss_knot_list(mp, path_p(p));
9469 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9470 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9471 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9475 delete_str_ref(text_p(p));
9476 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9477 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9479 case mp_start_clip_code:
9480 case mp_start_bounds_code:
9481 mp_toss_knot_list(mp, path_p(p));
9483 case mp_stop_clip_code:
9484 case mp_stop_bounds_code:
9486 } /* there are no other cases */
9488 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9489 to be done before making a significant change to an edge structure. Much of
9490 the work is done in a separate routine |copy_objects| that copies a list of
9491 graphical objects into a new edge header.
9493 @c @<Declare a function called |copy_objects|@>
9494 pointer mp_private_edges (MP mp,pointer h) {
9495 /* make a private copy of the edge structure headed by |h| */
9496 pointer hh; /* the edge header for the new copy */
9497 pointer p,pp; /* pointers for copying the dash list */
9498 if ( ref_count(h)==null ) {
9502 hh=mp_copy_objects(mp, mp_link(dummy_loc(h)),null);
9503 @<Copy the dash list from |h| to |hh|@>;
9504 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9505 point into the new object list@>;
9510 @ Here we use the fact that |dash_list(hh)=mp_link(hh)|.
9511 @^data structure assumptions@>
9513 @<Copy the dash list from |h| to |hh|@>=
9514 pp=hh; p=dash_list(h);
9515 while ( (p!=null_dash) ) {
9516 mp_link(pp)=mp_get_node(mp, dash_node_size);
9518 start_x(pp)=start_x(p);
9519 stop_x(pp)=stop_x(p);
9522 mp_link(pp)=null_dash;
9523 dash_y(hh)=dash_y(h)
9526 @ |h| is an edge structure
9529 mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
9532 scaled scf; /* scale factor */
9536 if (h==null || dash_list(h)==null_dash)
9539 scf=mp_get_pen_scale(mp, pen_p(q));
9541 if (*w==0) scf = dash_scale(q); else return NULL;
9543 scf=mp_make_scaled(mp, *w,scf);
9544 scf=mp_take_scaled(mp, scf,dash_scale(q));
9547 d = xmalloc(1,sizeof(mp_dash_object));
9548 start_x(null_dash)=start_x(p)+dash_y(h);
9549 while (p != null_dash) {
9550 dashes = xrealloc(dashes, (num_dashes+2), sizeof(scaled));
9551 dashes[(num_dashes-1)] =
9552 mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
9553 dashes[(num_dashes)] =
9554 mp_take_scaled(mp,(start_x(mp_link(p))-stop_x(p)),scf);
9555 dashes[(num_dashes+1)] = -1; /* terminus */
9559 d->array_field = dashes;
9561 mp_take_scaled(mp,mp_dash_offset(mp, h),scf);
9567 @ @<Copy the bounding box information from |h| to |hh|...@>=
9568 minx_val(hh)=minx_val(h);
9569 miny_val(hh)=miny_val(h);
9570 maxx_val(hh)=maxx_val(h);
9571 maxy_val(hh)=maxy_val(h);
9572 bbtype(hh)=bbtype(h);
9573 p=dummy_loc(h); pp=dummy_loc(hh);
9574 while ((p!=bblast(h)) ) {
9575 if ( p==null ) mp_confusion(mp, "bblast");
9576 @:this can't happen bblast}{\quad bblast@>
9577 p=mp_link(p); pp=mp_link(pp);
9581 @ Here is the promised routine for copying graphical objects into a new edge
9582 structure. It starts copying at object~|p| and stops just before object~|q|.
9583 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9584 structure requires further initialization by |init_bbox|.
9586 @<Declare a function called |copy_objects|@>=
9587 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9588 pointer hh; /* the new edge header */
9589 pointer pp; /* the last newly copied object */
9590 quarterword k; /* temporary register */
9591 hh=mp_get_node(mp, edge_header_size);
9592 dash_list(hh)=null_dash;
9596 @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9603 @ @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9604 { k=mp->gr_object_size[type(p)];
9605 mp_link(pp)=mp_get_node(mp, k);
9607 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9608 @<Fix anything in graphical object |pp| that should differ from the
9609 corresponding field in |p|@>;
9613 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9615 case mp_start_clip_code:
9616 case mp_start_bounds_code:
9617 path_p(pp)=mp_copy_path(mp, path_p(p));
9620 path_p(pp)=mp_copy_path(mp, path_p(p));
9621 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9622 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9623 if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
9625 case mp_stroked_code:
9626 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9627 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9628 path_p(pp)=mp_copy_path(mp, path_p(p));
9629 pen_p(pp)=copy_pen(pen_p(p));
9630 if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
9633 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9634 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9635 add_str_ref(text_p(pp));
9637 case mp_stop_clip_code:
9638 case mp_stop_bounds_code:
9640 } /* there are no other cases */
9642 @ Here is one way to find an acceptable value for the second argument to
9643 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9644 skips past one picture component, where a ``picture component'' is a single
9645 graphical object, or a start bounds or start clip object and everything up
9646 through the matching stop bounds or stop clip object. The macro version avoids
9647 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9648 unless |p| points to a stop bounds or stop clip node, in which case it executes
9651 @d skip_component(A)
9652 if ( ! is_start_or_stop((A)) ) (A)=mp_link((A));
9653 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9657 pointer mp_skip_1component (MP mp,pointer p) {
9658 integer lev; /* current nesting level */
9661 if ( is_start_or_stop(p) ) {
9662 if ( is_stop(p) ) decr(lev); else incr(lev);
9669 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9671 @<Declare subroutines for printing expressions@>=
9672 @<Declare subroutines needed by |print_edges|@>
9673 void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
9674 pointer p; /* a graphical object to be printed */
9675 pointer hh,pp; /* temporary pointers */
9676 scaled scf; /* a scale factor for the dash pattern */
9677 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9678 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9680 while ( mp_link(p)!=null ) {
9684 @<Cases for printing graphical object node |p|@>;
9686 mp_print(mp, "[unknown object type!]");
9690 mp_print_nl(mp, "End edges");
9691 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9693 mp_end_diagnostic(mp, true);
9696 @ @<Cases for printing graphical object node |p|@>=
9698 mp_print(mp, "Filled contour ");
9699 mp_print_obj_color(mp, p);
9700 mp_print_char(mp, xord(':')); mp_print_ln(mp);
9701 mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
9702 if ( (pen_p(p)!=null) ) {
9703 @<Print join type for graphical object |p|@>;
9704 mp_print(mp, " with pen"); mp_print_ln(mp);
9705 mp_pr_pen(mp, pen_p(p));
9709 @ @<Print join type for graphical object |p|@>=
9710 switch (ljoin_val(p)) {
9712 mp_print(mp, "mitered joins limited ");
9713 mp_print_scaled(mp, miterlim_val(p));
9716 mp_print(mp, "round joins");
9719 mp_print(mp, "beveled joins");
9722 mp_print(mp, "?? joins");
9727 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9729 @<Print join and cap types for stroked node |p|@>=
9730 switch (lcap_val(p)) {
9731 case 0:mp_print(mp, "butt"); break;
9732 case 1:mp_print(mp, "round"); break;
9733 case 2:mp_print(mp, "square"); break;
9734 default: mp_print(mp, "??"); break;
9737 mp_print(mp, " ends, ");
9738 @<Print join type for graphical object |p|@>
9740 @ Here is a routine that prints the color of a graphical object if it isn't
9741 black (the default color).
9743 @<Declare subroutines needed by |print_edges|@>=
9744 @<Declare a procedure called |print_compact_node|@>
9745 void mp_print_obj_color (MP mp,pointer p) {
9746 if ( color_model(p)==mp_grey_model ) {
9747 if ( grey_val(p)>0 ) {
9748 mp_print(mp, "greyed ");
9749 mp_print_compact_node(mp, obj_grey_loc(p),1);
9751 } else if ( color_model(p)==mp_cmyk_model ) {
9752 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9753 (yellow_val(p)>0) || (black_val(p)>0) ) {
9754 mp_print(mp, "processcolored ");
9755 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9757 } else if ( color_model(p)==mp_rgb_model ) {
9758 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9759 mp_print(mp, "colored ");
9760 mp_print_compact_node(mp, obj_red_loc(p),3);
9765 @ We also need a procedure for printing consecutive scaled values as if they
9766 were a known big node.
9768 @<Declare a procedure called |print_compact_node|@>=
9769 void mp_print_compact_node (MP mp,pointer p, quarterword k) {
9770 pointer q; /* last location to print */
9772 mp_print_char(mp, xord('('));
9774 mp_print_scaled(mp, mp->mem[p].sc);
9775 if ( p<q ) mp_print_char(mp, xord(','));
9778 mp_print_char(mp, xord(')'));
9781 @ @<Cases for printing graphical object node |p|@>=
9782 case mp_stroked_code:
9783 mp_print(mp, "Filled pen stroke ");
9784 mp_print_obj_color(mp, p);
9785 mp_print_char(mp, xord(':')); mp_print_ln(mp);
9786 mp_pr_path(mp, path_p(p));
9787 if ( dash_p(p)!=null ) {
9788 mp_print_nl(mp, "dashed (");
9789 @<Finish printing the dash pattern that |p| refers to@>;
9792 @<Print join and cap types for stroked node |p|@>;
9793 mp_print(mp, " with pen"); mp_print_ln(mp);
9794 if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9796 else mp_pr_pen(mp, pen_p(p));
9799 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9800 when it is not known to define a suitable dash pattern. This is disallowed
9801 here because the |dash_p| field should never point to such an edge header.
9802 Note that memory is allocated for |start_x(null_dash)| and we are free to
9803 give it any convenient value.
9805 @<Finish printing the dash pattern that |p| refers to@>=
9806 ok_to_dash=pen_is_elliptical(pen_p(p));
9807 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9810 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9811 mp_print(mp, " ??");
9812 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9813 while ( pp!=null_dash ) {
9814 mp_print(mp, "on ");
9815 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9816 mp_print(mp, " off ");
9817 mp_print_scaled(mp, mp_take_scaled(mp, start_x(mp_link(pp))-stop_x(pp),scf));
9819 if ( pp!=null_dash ) mp_print_char(mp, xord(' '));
9821 mp_print(mp, ") shifted ");
9822 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9823 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9826 @ @<Declare subroutines needed by |print_edges|@>=
9827 scaled mp_dash_offset (MP mp,pointer h) {
9828 scaled x; /* the answer */
9829 if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
9830 @:this can't happen dash0}{\quad dash0@>
9831 if ( dash_y(h)==0 ) {
9834 x=-(start_x(dash_list(h)) % dash_y(h));
9835 if ( x<0 ) x=x+dash_y(h);
9840 @ @<Cases for printing graphical object node |p|@>=
9842 mp_print_char(mp, xord('"')); mp_print_str(mp,text_p(p));
9843 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
9844 mp_print_char(mp, xord('"')); mp_print_ln(mp);
9845 mp_print_obj_color(mp, p);
9846 mp_print(mp, "transformed ");
9847 mp_print_compact_node(mp, text_tx_loc(p),6);
9850 @ @<Cases for printing graphical object node |p|@>=
9851 case mp_start_clip_code:
9852 mp_print(mp, "clipping path:");
9854 mp_pr_path(mp, path_p(p));
9856 case mp_stop_clip_code:
9857 mp_print(mp, "stop clipping");
9860 @ @<Cases for printing graphical object node |p|@>=
9861 case mp_start_bounds_code:
9862 mp_print(mp, "setbounds path:");
9864 mp_pr_path(mp, path_p(p));
9866 case mp_stop_bounds_code:
9867 mp_print(mp, "end of setbounds");
9870 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9871 subroutine that scans an edge structure and tries to interpret it as a dash
9872 pattern. This can only be done when there are no filled regions or clipping
9873 paths and all the pen strokes have the same color. The first step is to let
9874 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9875 project all the pen stroke paths onto the line $y=y_0$ and require that there
9876 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9877 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9878 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9880 @c @<Declare a procedure called |x_retrace_error|@>
9881 pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9882 pointer p; /* this scans the stroked nodes in the object list */
9883 pointer p0; /* if not |null| this points to the first stroked node */
9884 pointer pp,qq,rr; /* pointers into |path_p(p)| */
9885 pointer d,dd; /* pointers used to create the dash list */
9887 @<Other local variables in |make_dashes|@>;
9888 y0=0; /* the initial $y$ coordinate */
9889 if ( dash_list(h)!=null_dash )
9892 p=mp_link(dummy_loc(h));
9894 if ( type(p)!=mp_stroked_code ) {
9895 @<Compain that the edge structure contains a node of the wrong type
9896 and |goto not_found|@>;
9899 if ( p0==null ){ p0=p; y0=y_coord(pp); };
9900 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9901 or |goto not_found| if there is an error@>;
9902 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9905 if ( dash_list(h)==null_dash )
9906 goto NOT_FOUND; /* No error message */
9907 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9908 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
9911 @<Flush the dash list, recycle |h| and return |null|@>;
9914 @ @<Compain that the edge structure contains a node of the wrong type...@>=
9916 print_err("Picture is too complicated to use as a dash pattern");
9917 help3("When you say `dashed p', picture p should not contain any",
9918 "text, filled regions, or clipping paths. This time it did",
9919 "so I'll just make it a solid line instead.");
9920 mp_put_get_error(mp);
9924 @ A similar error occurs when monotonicity fails.
9926 @<Declare a procedure called |x_retrace_error|@>=
9927 void mp_x_retrace_error (MP mp) {
9928 print_err("Picture is too complicated to use as a dash pattern");
9929 help3("When you say `dashed p', every path in p should be monotone",
9930 "in x and there must be no overlapping. This failed",
9931 "so I'll just make it a solid line instead.");
9932 mp_put_get_error(mp);
9935 @ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
9936 handle the case where the pen stroke |p| is itself dashed.
9938 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
9939 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
9942 if ( mp_link(pp)!=pp ) {
9944 qq=rr; rr=mp_link(rr);
9945 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
9946 if there is a problem@>;
9947 } while (right_type(rr)!=mp_endpoint);
9949 d=mp_get_node(mp, dash_node_size);
9950 if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
9951 if ( x_coord(pp)<x_coord(rr) ) {
9952 start_x(d)=x_coord(pp);
9953 stop_x(d)=x_coord(rr);
9955 start_x(d)=x_coord(rr);
9956 stop_x(d)=x_coord(pp);
9959 @ We also need to check for the case where the segment from |qq| to |rr| is
9960 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
9962 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
9967 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
9968 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
9969 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
9970 mp_x_retrace_error(mp); goto NOT_FOUND;
9974 if ( (x_coord(pp)>x0) || (x0>x3) ) {
9975 if ( (x_coord(pp)<x0) || (x0<x3) ) {
9976 mp_x_retrace_error(mp); goto NOT_FOUND;
9980 @ @<Other local variables in |make_dashes|@>=
9981 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
9983 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
9984 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
9985 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
9986 print_err("Picture is too complicated to use as a dash pattern");
9987 help3("When you say `dashed p', everything in picture p should",
9988 "be the same color. I can\'t handle your color changes",
9989 "so I'll just make it a solid line instead.");
9990 mp_put_get_error(mp);
9994 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
9995 start_x(null_dash)=stop_x(d);
9996 dd=h; /* this makes |mp_link(dd)=dash_list(h)| */
9997 while ( start_x(mp_link(dd))<stop_x(d) )
10000 if ( (stop_x(dd)>start_x(d)) )
10001 { mp_x_retrace_error(mp); goto NOT_FOUND; };
10003 mp_link(d)=mp_link(dd);
10006 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
10008 while ( (mp_link(d)!=null_dash) )
10011 dash_y(h)=stop_x(d)-start_x(dd);
10012 if ( abs(y0)>dash_y(h) ) {
10014 } else if ( d!=dd ) {
10015 dash_list(h)=mp_link(dd);
10016 stop_x(d)=stop_x(dd)+dash_y(h);
10017 mp_free_node(mp, dd,dash_node_size);
10020 @ We get here when the argument is a null picture or when there is an error.
10021 Recovering from an error involves making |dash_list(h)| empty to indicate
10022 that |h| is not known to be a valid dash pattern. We also dereference |h|
10023 since it is not being used for the return value.
10025 @<Flush the dash list, recycle |h| and return |null|@>=
10026 mp_flush_dash_list(mp, h);
10027 delete_edge_ref(h);
10030 @ Having carefully saved the dashed stroked nodes in the
10031 corresponding dash nodes, we must be prepared to break up these dashes into
10034 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
10035 d=h; /* now |mp_link(d)=dash_list(h)| */
10036 while ( mp_link(d)!=null_dash ) {
10037 ds=info(mp_link(d));
10042 hsf=dash_scale(ds);
10043 if ( (hh==null) ) mp_confusion(mp, "dash1");
10044 @:this can't happen dash0}{\quad dash1@>
10045 if ( dash_y(hh)==0 ) {
10048 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
10049 @:this can't happen dash0}{\quad dash1@>
10050 @<Replace |mp_link(d)| by a dashed version as determined by edge header
10051 |hh| and scale factor |ds|@>;
10056 @ @<Other local variables in |make_dashes|@>=
10057 pointer dln; /* |mp_link(d)| */
10058 pointer hh; /* an edge header that tells how to break up |dln| */
10059 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
10060 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
10061 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
10063 @ @<Replace |mp_link(d)| by a dashed version as determined by edge header...@>=
10066 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
10067 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
10068 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
10069 +mp_take_scaled(mp, hsf,dash_y(hh));
10070 stop_x(null_dash)=start_x(null_dash);
10071 @<Advance |dd| until finding the first dash that overlaps |dln| when
10072 offset by |xoff|@>;
10073 while ( start_x(dln)<=stop_x(dln) ) {
10074 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
10075 @<Insert a dash between |d| and |dln| for the overlap with the offset version
10078 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10080 mp_link(d)=mp_link(dln);
10081 mp_free_node(mp, dln,dash_node_size)
10083 @ The name of this module is a bit of a lie because we just find the
10084 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
10085 overlap possible. It could be that the unoffset version of dash |dln| falls
10086 in the gap between |dd| and its predecessor.
10088 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
10089 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
10093 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
10094 if ( dd==null_dash ) {
10096 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10099 @ At this point we already know that
10100 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10102 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10103 if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
10104 mp_link(d)=mp_get_node(mp, dash_node_size);
10107 if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
10108 start_x(d)=start_x(dln);
10110 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10111 if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
10112 stop_x(d)=stop_x(dln);
10114 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10117 @ The next major task is to update the bounding box information in an edge
10118 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10119 header's bounding box to accommodate the box computed by |path_bbox| or
10120 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10123 @c void mp_adjust_bbox (MP mp,pointer h) {
10124 if ( minx<minx_val(h) ) minx_val(h)=minx;
10125 if ( miny<miny_val(h) ) miny_val(h)=miny;
10126 if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
10127 if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
10130 @ Here is a special routine for updating the bounding box information in
10131 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10132 that is to be stroked with the pen~|pp|.
10134 @c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10135 pointer q; /* a knot node adjacent to knot |p| */
10136 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10137 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10138 scaled z; /* a coordinate being tested against the bounding box */
10139 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10140 integer i; /* a loop counter */
10141 if ( right_type(p)!=mp_endpoint ) {
10144 @<Make |(dx,dy)| the final direction for the path segment from
10145 |q| to~|p|; set~|d|@>;
10146 d=mp_pyth_add(mp, dx,dy);
10148 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10149 for (i=1;i<= 2;i++) {
10150 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10151 update the bounding box to accommodate it@>;
10155 if ( right_type(p)==mp_endpoint ) {
10158 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10164 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10165 if ( q==mp_link(p) ) {
10166 dx=x_coord(p)-right_x(p);
10167 dy=y_coord(p)-right_y(p);
10168 if ( (dx==0)&&(dy==0) ) {
10169 dx=x_coord(p)-left_x(q);
10170 dy=y_coord(p)-left_y(q);
10173 dx=x_coord(p)-left_x(p);
10174 dy=y_coord(p)-left_y(p);
10175 if ( (dx==0)&&(dy==0) ) {
10176 dx=x_coord(p)-right_x(q);
10177 dy=y_coord(p)-right_y(q);
10180 dx=x_coord(p)-x_coord(q);
10181 dy=y_coord(p)-y_coord(q)
10183 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10184 dx=mp_make_fraction(mp, dx,d);
10185 dy=mp_make_fraction(mp, dy,d);
10186 mp_find_offset(mp, -dy,dx,pp);
10187 xx=mp->cur_x; yy=mp->cur_y
10189 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10190 mp_find_offset(mp, dx,dy,pp);
10191 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10192 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10193 mp_confusion(mp, "box_ends");
10194 @:this can't happen box ends}{\quad\\{box\_ends}@>
10195 z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10196 if ( z<minx_val(h) ) minx_val(h)=z;
10197 if ( z>maxx_val(h) ) maxx_val(h)=z;
10198 z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10199 if ( z<miny_val(h) ) miny_val(h)=z;
10200 if ( z>maxy_val(h) ) maxy_val(h)=z
10202 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10206 } while (right_type(p)!=mp_endpoint)
10208 @ The major difficulty in finding the bounding box of an edge structure is the
10209 effect of clipping paths. We treat them conservatively by only clipping to the
10210 clipping path's bounding box, but this still
10211 requires recursive calls to |set_bbox| in order to find the bounding box of
10213 the objects to be clipped. Such calls are distinguished by the fact that the
10214 boolean parameter |top_level| is false.
10216 @c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10217 pointer p; /* a graphical object being considered */
10218 scaled sminx,sminy,smaxx,smaxy;
10219 /* for saving the bounding box during recursive calls */
10220 scaled x0,x1,y0,y1; /* temporary registers */
10221 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10222 @<Wipe out any existing bounding box information if |bbtype(h)| is
10223 incompatible with |internal[mp_true_corners]|@>;
10224 while ( mp_link(bblast(h))!=null ) {
10225 p=mp_link(bblast(h));
10228 case mp_stop_clip_code:
10229 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10230 @:this can't happen bbox}{\quad bbox@>
10232 @<Other cases for updating the bounding box based on the type of object |p|@>;
10233 } /* all cases are enumerated above */
10235 if ( ! top_level ) mp_confusion(mp, "bbox");
10238 @ @<Internal library declarations@>=
10239 void mp_set_bbox (MP mp,pointer h, boolean top_level);
10241 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10242 switch (bbtype(h)) {
10246 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10249 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10251 } /* there are no other cases */
10253 @ @<Other cases for updating the bounding box...@>=
10255 mp_path_bbox(mp, path_p(p));
10256 if ( pen_p(p)!=null ) {
10259 mp_pen_bbox(mp, pen_p(p));
10265 mp_adjust_bbox(mp, h);
10268 @ @<Other cases for updating the bounding box...@>=
10269 case mp_start_bounds_code:
10270 if ( mp->internal[mp_true_corners]>0 ) {
10271 bbtype(h)=bounds_unset;
10273 bbtype(h)=bounds_set;
10274 mp_path_bbox(mp, path_p(p));
10275 mp_adjust_bbox(mp, h);
10276 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10280 case mp_stop_bounds_code:
10281 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10282 @:this can't happen bbox2}{\quad bbox2@>
10285 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10288 if ( mp_link(p)==null ) mp_confusion(mp, "bbox2");
10289 @:this can't happen bbox2}{\quad bbox2@>
10291 if ( type(p)==mp_start_bounds_code ) incr(lev);
10292 else if ( type(p)==mp_stop_bounds_code ) decr(lev);
10296 @ It saves a lot of grief here to be slightly conservative and not account for
10297 omitted parts of dashed lines. We also don't worry about the material omitted
10298 when using butt end caps. The basic computation is for round end caps and
10299 |box_ends| augments it for square end caps.
10301 @<Other cases for updating the bounding box...@>=
10302 case mp_stroked_code:
10303 mp_path_bbox(mp, path_p(p));
10306 mp_pen_bbox(mp, pen_p(p));
10311 mp_adjust_bbox(mp, h);
10312 if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10313 mp_box_ends(mp, path_p(p), pen_p(p), h);
10316 @ The height width and depth information stored in a text node determines a
10317 rectangle that needs to be transformed according to the transformation
10318 parameters stored in the text node.
10320 @<Other cases for updating the bounding box...@>=
10322 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10323 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10324 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10327 if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
10328 else { minx=minx+y1; maxx=maxx+y0; }
10329 if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
10330 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10331 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10332 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10335 if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
10336 else { miny=miny+y1; maxy=maxy+y0; }
10337 if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
10338 mp_adjust_bbox(mp, h);
10341 @ This case involves a recursive call that advances |bblast(h)| to the node of
10342 type |mp_stop_clip_code| that matches |p|.
10344 @<Other cases for updating the bounding box...@>=
10345 case mp_start_clip_code:
10346 mp_path_bbox(mp, path_p(p));
10349 sminx=minx_val(h); sminy=miny_val(h);
10350 smaxx=maxx_val(h); smaxy=maxy_val(h);
10351 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10352 starting at |mp_link(p)|@>;
10353 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10355 minx=sminx; miny=sminy;
10356 maxx=smaxx; maxy=smaxy;
10357 mp_adjust_bbox(mp, h);
10360 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10361 minx_val(h)=el_gordo;
10362 miny_val(h)=el_gordo;
10363 maxx_val(h)=-el_gordo;
10364 maxy_val(h)=-el_gordo;
10365 mp_set_bbox(mp, h,false)
10367 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10368 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10369 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10370 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10371 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10373 @* \[22] Finding an envelope.
10374 When \MP\ has a path and a polygonal pen, it needs to express the desired
10375 shape in terms of things \ps\ can understand. The present task is to compute
10376 a new path that describes the region to be filled. It is convenient to
10377 define this as a two step process where the first step is determining what
10378 offset to use for each segment of the path.
10380 @ Given a pointer |c| to a cyclic path,
10381 and a pointer~|h| to the first knot of a pen polygon,
10382 the |offset_prep| routine changes the path into cubics that are
10383 associated with particular pen offsets. Thus if the cubic between |p|
10384 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10385 has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
10386 to because |l-k| could be negative.)
10388 After overwriting the type information with offset differences, we no longer
10389 have a true path so we refer to the knot list returned by |offset_prep| as an
10392 Since an envelope spec only determines relative changes in pen offsets,
10393 |offset_prep| sets a global variable |spec_offset| to the relative change from
10394 |h| to the first offset.
10396 @d zero_off 16384 /* added to offset changes to make them positive */
10399 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10401 @ @c @<Declare subroutines needed by |offset_prep|@>
10402 pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10403 halfword n; /* the number of vertices in the pen polygon */
10404 pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
10405 integer k_needed; /* amount to be added to |info(p)| when it is computed */
10406 pointer w0; /* a pointer to pen offset to use just before |p| */
10407 scaled dxin,dyin; /* the direction into knot |p| */
10408 integer turn_amt; /* change in pen offsets for the current cubic */
10409 @<Other local variables for |offset_prep|@>;
10411 @<Initialize the pen size~|n|@>;
10412 @<Initialize the incoming direction and pen offset at |c|@>;
10413 p=c; c0=c; k_needed=0;
10416 @<Split the cubic between |p| and |q|, if necessary, into cubics
10417 associated with single offsets, after which |q| should
10418 point to the end of the final such cubic@>;
10420 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10421 might have been introduced by the splitting process@>;
10423 @<Fix the offset change in |info(c)| and set |c| to the return value of
10428 @ We shall want to keep track of where certain knots on the cyclic path
10429 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10430 knot nodes because some nodes are deleted while removing dead cubics. Thus
10431 |offset_prep| updates the following pointers
10435 pointer spec_p2; /* pointers to distinguished knots */
10438 mp->spec_p1=null; mp->spec_p2=null;
10440 @ @<Initialize the pen size~|n|@>=
10447 @ Since the true incoming direction isn't known yet, we just pick a direction
10448 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10451 @<Initialize the incoming direction and pen offset at |c|@>=
10452 dxin=x_coord(mp_link(h))-x_coord(knil(h));
10453 dyin=y_coord(mp_link(h))-y_coord(knil(h));
10454 if ( (dxin==0)&&(dyin==0) ) {
10455 dxin=y_coord(knil(h))-y_coord(h);
10456 dyin=x_coord(h)-x_coord(knil(h));
10460 @ We must be careful not to remove the only cubic in a cycle.
10462 But we must also be careful for another reason. If the user-supplied
10463 path starts with a set of degenerate cubics, the target node |q| can
10464 be collapsed to the initial node |p| which might be the same as the
10465 initial node |c| of the curve. This would cause the |offset_prep| routine
10466 to bail out too early, causing distress later on. (See for example
10467 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10470 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10474 if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
10475 x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
10476 x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
10478 @<Remove the cubic following |p| and update the data structures
10479 to merge |r| into |p|@>;
10483 /* Check if we removed too much */
10484 if ((q!=q0)&&(q!=c||c==c0))
10487 @ @<Remove the cubic following |p| and update the data structures...@>=
10488 { k_needed=info(p)-zero_off;
10492 info(p)=k_needed+info(r);
10495 if ( r==c ) { info(p)=info(c); c=p; };
10496 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10497 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10498 r=p; mp_remove_cubic(mp, p);
10501 @ Not setting the |info| field of the newly created knot allows the splitting
10502 routine to work for paths.
10504 @<Declare subroutines needed by |offset_prep|@>=
10505 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10506 scaled v; /* an intermediate value */
10507 pointer q,r; /* for list manipulation */
10508 q=mp_link(p); r=mp_get_node(mp, knot_node_size); mp_link(p)=r; mp_link(r)=q;
10509 originator(r)=mp_program_code;
10510 left_type(r)=mp_explicit; right_type(r)=mp_explicit;
10511 v=t_of_the_way(right_x(p),left_x(q));
10512 right_x(p)=t_of_the_way(x_coord(p),right_x(p));
10513 left_x(q)=t_of_the_way(left_x(q),x_coord(q));
10514 left_x(r)=t_of_the_way(right_x(p),v);
10515 right_x(r)=t_of_the_way(v,left_x(q));
10516 x_coord(r)=t_of_the_way(left_x(r),right_x(r));
10517 v=t_of_the_way(right_y(p),left_y(q));
10518 right_y(p)=t_of_the_way(y_coord(p),right_y(p));
10519 left_y(q)=t_of_the_way(left_y(q),y_coord(q));
10520 left_y(r)=t_of_the_way(right_y(p),v);
10521 right_y(r)=t_of_the_way(v,left_y(q));
10522 y_coord(r)=t_of_the_way(left_y(r),right_y(r));
10525 @ This does not set |info(p)| or |right_type(p)|.
10527 @<Declare subroutines needed by |offset_prep|@>=
10528 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10529 pointer q; /* the node that disappears */
10530 q=mp_link(p); mp_link(p)=mp_link(q);
10531 right_x(p)=right_x(q); right_y(p)=right_y(q);
10532 mp_free_node(mp, q,knot_node_size);
10535 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10536 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10537 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10538 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10539 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10540 When listed by increasing $k$, these directions occur in counter-clockwise
10541 order so that $d_k\preceq d\k$ for all~$k$.
10542 The goal of |offset_prep| is to find an offset index~|k| to associate with
10543 each cubic, such that the direction $d(t)$ of the cubic satisfies
10544 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10545 We may have to split a cubic into many pieces before each
10546 piece corresponds to a unique offset.
10548 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10549 info(p)=zero_off+k_needed;
10551 @<Prepare for derivative computations;
10552 |goto not_found| if the current cubic is dead@>;
10553 @<Find the initial direction |(dx,dy)|@>;
10554 @<Update |info(p)| and find the offset $w_k$ such that
10555 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10556 the direction change at |p|@>;
10557 @<Find the final direction |(dxin,dyin)|@>;
10558 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10559 @<Complete the offset splitting process@>;
10560 w0=mp_pen_walk(mp, w0,turn_amt)
10562 @ @<Declare subroutines needed by |offset_prep|@>=
10563 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10564 /* walk |k| steps around a pen from |w| */
10565 while ( k>0 ) { w=mp_link(w); decr(k); };
10566 while ( k<0 ) { w=knil(w); incr(k); };
10570 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10571 calculated from the quadratic polynomials
10572 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10573 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10574 Since we may be calculating directions from several cubics
10575 split from the current one, it is desirable to do these calculations
10576 without losing too much precision. ``Scaled up'' values of the
10577 derivatives, which will be less tainted by accumulated errors than
10578 derivatives found from the cubics themselves, are maintained in
10579 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10580 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10581 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)$.
10583 @<Other local variables for |offset_prep|@>=
10584 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10585 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10586 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10587 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10588 integer max_coef; /* used while scaling */
10589 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10590 fraction t; /* where the derivative passes through zero */
10591 fraction s; /* a temporary value */
10593 @ @<Prepare for derivative computations...@>=
10594 x0=right_x(p)-x_coord(p);
10595 x2=x_coord(q)-left_x(q);
10596 x1=left_x(q)-right_x(p);
10597 y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
10598 y1=left_y(q)-right_y(p);
10600 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10601 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10602 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10603 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10604 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10605 if ( max_coef==0 ) goto NOT_FOUND;
10606 while ( max_coef<fraction_half ) {
10608 double(x0); double(x1); double(x2);
10609 double(y0); double(y1); double(y2);
10612 @ Let us first solve a special case of the problem: Suppose we
10613 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10614 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10615 $d(0)\succ d_{k-1}$.
10616 Then, in a sense, we're halfway done, since one of the two relations
10617 in $(*)$ is satisfied, and the other couldn't be satisfied for
10618 any other value of~|k|.
10620 Actually, the conditions can be relaxed somewhat since a relation such as
10621 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10622 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10623 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10624 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10625 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10626 counterclockwise direction.
10628 The |fin_offset_prep| subroutine solves the stated subproblem.
10629 It has a parameter called |rise| that is |1| in
10630 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10631 the derivative of the cubic following |p|.
10632 The |w| parameter should point to offset~$w_k$ and |info(p)| should already
10633 be set properly. The |turn_amt| parameter gives the absolute value of the
10634 overall net change in pen offsets.
10636 @<Declare subroutines needed by |offset_prep|@>=
10637 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10638 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10639 integer rise, integer turn_amt) {
10640 pointer ww; /* for list manipulation */
10641 scaled du,dv; /* for slope calculation */
10642 integer t0,t1,t2; /* test coefficients */
10643 fraction t; /* place where the derivative passes a critical slope */
10644 fraction s; /* slope or reciprocal slope */
10645 integer v; /* intermediate value for updating |x0..y2| */
10646 pointer q; /* original |mp_link(p)| */
10649 if ( rise>0 ) ww=mp_link(w); /* a pointer to $w\k$ */
10650 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10651 @<Compute test coefficients |(t0,t1,t2)|
10652 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10653 t=mp_crossing_point(mp, t0,t1,t2);
10654 if ( t>=fraction_one ) {
10655 if ( turn_amt>0 ) t=fraction_one; else return;
10657 @<Split the cubic at $t$,
10658 and split off another cubic if the derivative crosses back@>;
10663 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10664 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10665 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10668 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10669 du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
10670 if ( abs(du)>=abs(dv) ) {
10671 s=mp_make_fraction(mp, dv,du);
10672 t0=mp_take_fraction(mp, x0,s)-y0;
10673 t1=mp_take_fraction(mp, x1,s)-y1;
10674 t2=mp_take_fraction(mp, x2,s)-y2;
10675 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10677 s=mp_make_fraction(mp, du,dv);
10678 t0=x0-mp_take_fraction(mp, y0,s);
10679 t1=x1-mp_take_fraction(mp, y1,s);
10680 t2=x2-mp_take_fraction(mp, y2,s);
10681 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10683 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10685 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10686 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
10687 respectively, yielding another solution of $(*)$.
10689 @<Split the cubic at $t$, and split off another...@>=
10691 mp_split_cubic(mp, p,t); p=mp_link(p); info(p)=zero_off+rise;
10693 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10694 x0=t_of_the_way(v,x1);
10695 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10696 y0=t_of_the_way(v,y1);
10697 if ( turn_amt<0 ) {
10698 t1=t_of_the_way(t1,t2);
10699 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10700 t=mp_crossing_point(mp, 0,-t1,-t2);
10701 if ( t>fraction_one ) t=fraction_one;
10703 if ( (t==fraction_one)&&(mp_link(p)!=q) ) {
10704 info(mp_link(p))=info(mp_link(p))-rise;
10706 mp_split_cubic(mp, p,t); info(mp_link(p))=zero_off-rise;
10707 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10708 x2=t_of_the_way(x1,v);
10709 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10710 y2=t_of_the_way(y1,v);
10715 @ Now we must consider the general problem of |offset_prep|, when
10716 nothing is known about a given cubic. We start by finding its
10717 direction in the vicinity of |t=0|.
10719 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10720 has not yet introduced any more numerical errors. Thus we can compute
10721 the true initial direction for the given cubic, even if it is almost
10724 @<Find the initial direction |(dx,dy)|@>=
10726 if ( dx==0 && dy==0 ) {
10728 if ( dx==0 && dy==0 ) {
10732 if ( p==c ) { dx0=dx; dy0=dy; }
10734 @ @<Find the final direction |(dxin,dyin)|@>=
10736 if ( dxin==0 && dyin==0 ) {
10738 if ( dxin==0 && dyin==0 ) {
10743 @ The next step is to bracket the initial direction between consecutive
10744 edges of the pen polygon. We must be careful to turn clockwise only if
10745 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10746 counter-clockwise in order to make \&{doublepath} envelopes come out
10747 @:double_path_}{\&{doublepath} primitive@>
10748 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10750 @<Update |info(p)| and find the offset $w_k$ such that...@>=
10751 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10752 w=mp_pen_walk(mp, w0, turn_amt);
10754 info(p)=info(p)+turn_amt
10756 @ Decide how many pen offsets to go away from |w| in order to find the offset
10757 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10758 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10759 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10761 If the pen polygon has only two edges, they could both be parallel
10762 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10763 such edge in order to avoid an infinite loop.
10765 @<Declare subroutines needed by |offset_prep|@>=
10766 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10767 scaled dy, boolean ccw) {
10768 pointer ww; /* a neighbor of knot~|w| */
10769 integer s; /* turn amount so far */
10770 integer t; /* |ab_vs_cd| result */
10775 t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
10776 dx,(y_coord(ww)-y_coord(w)));
10779 w=ww; ww=mp_link(ww);
10783 while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
10784 dx,(y_coord(w)-y_coord(ww))) < 0) {
10792 @ When we're all done, the final offset is |w0| and the final curve direction
10793 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10794 can correct |info(c)| which was erroneously based on an incoming offset
10797 @d fix_by(A) info(c)=info(c)+(A)
10799 @<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
10800 mp->spec_offset=info(c)-zero_off;
10801 if ( mp_link(c)==c ) {
10802 info(c)=zero_off+n;
10805 while ( w0!=h ) { fix_by(1); w0=mp_link(w0); };
10806 while ( info(c)<=zero_off-n ) fix_by(n);
10807 while ( info(c)>zero_off ) fix_by(-n);
10808 if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10811 @ Finally we want to reduce the general problem to situations that
10812 |fin_offset_prep| can handle. We split the cubic into at most three parts
10813 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10815 @<Complete the offset splitting process@>=
10817 @<Compute test coeff...@>;
10818 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10819 |t:=fraction_one+1|@>;
10820 if ( t>fraction_one ) {
10821 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10823 mp_split_cubic(mp, p,t); r=mp_link(p);
10824 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10825 x2a=t_of_the_way(x1a,x1);
10826 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10827 y2a=t_of_the_way(y1a,y1);
10828 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10829 info(r)=zero_off-1;
10830 if ( turn_amt>=0 ) {
10831 t1=t_of_the_way(t1,t2);
10833 t=mp_crossing_point(mp, 0,-t1,-t2);
10834 if ( t>fraction_one ) t=fraction_one;
10835 @<Split off another rising cubic for |fin_offset_prep|@>;
10836 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10838 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10842 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10843 mp_split_cubic(mp, r,t); info(mp_link(r))=zero_off+1;
10844 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10845 x0a=t_of_the_way(x1,x1a);
10846 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10847 y0a=t_of_the_way(y1,y1a);
10848 mp_fin_offset_prep(mp, mp_link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10851 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10852 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10853 need to decide whether the directions are parallel or antiparallel. We
10854 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10855 should be avoided when the value of |turn_amt| already determines the
10856 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10857 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10858 crossing and the first crossing cannot be antiparallel.
10860 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10861 t=mp_crossing_point(mp, t0,t1,t2);
10862 if ( turn_amt>=0 ) {
10866 u0=t_of_the_way(x0,x1);
10867 u1=t_of_the_way(x1,x2);
10868 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10869 v0=t_of_the_way(y0,y1);
10870 v1=t_of_the_way(y1,y2);
10871 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10872 if ( ss<0 ) t=fraction_one+1;
10874 } else if ( t>fraction_one ) {
10878 @ @<Other local variables for |offset_prep|@>=
10879 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10880 integer ss = 0; /* the part of the dot product computed so far */
10881 int d_sign; /* sign of overall change in direction for this cubic */
10883 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10884 problem to decide which way it loops around but that's OK as long we're
10885 consistent. To make \&{doublepath} envelopes work properly, reversing
10886 the path should always change the sign of |turn_amt|.
10888 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10889 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10891 @<Check rotation direction based on node position@>
10895 if ( dy>0 ) d_sign=1; else d_sign=-1;
10897 if ( dx>0 ) d_sign=1; else d_sign=-1;
10900 @<Make |ss| negative if and only if the total change in direction is
10901 more than $180^\circ$@>;
10902 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10903 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
10905 @ We check rotation direction by looking at the vector connecting the current
10906 node with the next. If its angle with incoming and outgoing tangents has the
10907 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
10908 Otherwise we proceed to the cusp code.
10910 @<Check rotation direction based on node position@>=
10911 u0=x_coord(q)-x_coord(p);
10912 u1=y_coord(q)-y_coord(p);
10913 d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
10914 mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
10916 @ In order to be invariant under path reversal, the result of this computation
10917 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
10918 then swapped with |(x2,y2)|. We make use of the identities
10919 |take_fraction(-a,-b)=take_fraction(a,b)| and
10920 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
10922 @<Make |ss| negative if and only if the total change in direction is...@>=
10923 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
10924 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
10925 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
10927 t=mp_crossing_point(mp, t0,t1,-t0);
10928 u0=t_of_the_way(x0,x1);
10929 u1=t_of_the_way(x1,x2);
10930 v0=t_of_the_way(y0,y1);
10931 v1=t_of_the_way(y1,y2);
10933 t=mp_crossing_point(mp, -t0,t1,t0);
10934 u0=t_of_the_way(x2,x1);
10935 u1=t_of_the_way(x1,x0);
10936 v0=t_of_the_way(y2,y1);
10937 v1=t_of_the_way(y1,y0);
10939 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
10940 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
10942 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
10943 that the |cur_pen| has not been walked around to the first offset.
10946 void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
10947 pointer p,q; /* list traversal */
10948 pointer w; /* the current pen offset */
10949 mp_print_diagnostic(mp, "Envelope spec",s,true);
10950 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
10952 mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
10953 mp_print(mp, " % beginning with offset ");
10954 mp_print_two(mp, x_coord(w),y_coord(w));
10958 @<Print the cubic between |p| and |q|@>;
10960 if ((p==cur_spec) || (info(p)!=zero_off))
10963 if ( info(p)!=zero_off ) {
10964 @<Update |w| as indicated by |info(p)| and print an explanation@>;
10966 } while (p!=cur_spec);
10967 mp_print_nl(mp, " & cycle");
10968 mp_end_diagnostic(mp, true);
10971 @ @<Update |w| as indicated by |info(p)| and print an explanation@>=
10973 w=mp_pen_walk(mp, w, (info(p)-zero_off));
10974 mp_print(mp, " % ");
10975 if ( info(p)>zero_off ) mp_print(mp, "counter");
10976 mp_print(mp, "clockwise to offset ");
10977 mp_print_two(mp, x_coord(w),y_coord(w));
10980 @ @<Print the cubic between |p| and |q|@>=
10982 mp_print_nl(mp, " ..controls ");
10983 mp_print_two(mp, right_x(p),right_y(p));
10984 mp_print(mp, " and ");
10985 mp_print_two(mp, left_x(q),left_y(q));
10986 mp_print_nl(mp, " ..");
10987 mp_print_two(mp, x_coord(q),y_coord(q));
10990 @ Once we have an envelope spec, the remaining task to construct the actual
10991 envelope by offsetting each cubic as determined by the |info| fields in
10992 the knots. First we use |offset_prep| to convert the |c| into an envelope
10993 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
10996 The |ljoin| and |miterlim| parameters control the treatment of points where the
10997 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
10998 The endpoints are easily located because |c| is given in undoubled form
10999 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
11000 track of the endpoints and treat them like very sharp corners.
11001 Butt end caps are treated like beveled joins; round end caps are treated like
11002 round joins; and square end caps are achieved by setting |join_type:=3|.
11004 None of these parameters apply to inside joins where the convolution tracing
11005 has retrograde lines. In such cases we use a simple connect-the-endpoints
11006 approach that is achieved by setting |join_type:=2|.
11008 @c @<Declare a function called |insert_knot|@>
11009 pointer mp_make_envelope (MP mp,pointer c, pointer h, quarterword ljoin,
11010 quarterword lcap, scaled miterlim) {
11011 pointer p,q,r,q0; /* for manipulating the path */
11012 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
11013 pointer w,w0; /* the pen knot for the current offset */
11014 scaled qx,qy; /* unshifted coordinates of |q| */
11015 halfword k,k0; /* controls pen edge insertion */
11016 @<Other local variables for |make_envelope|@>;
11017 dxin=0; dyin=0; dxout=0; dyout=0;
11018 mp->spec_p1=null; mp->spec_p2=null;
11019 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
11020 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
11021 the initial offset@>;
11025 q=mp_link(p); q0=q;
11026 qx=x_coord(q); qy=y_coord(q);
11029 if ( k!=zero_off ) {
11030 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
11032 @<Add offset |w| to the cubic from |p| to |q|@>;
11033 while ( k!=zero_off ) {
11034 @<Step |w| and move |k| one step closer to |zero_off|@>;
11035 if ( (join_type==1)||(k==zero_off) )
11036 q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
11038 if ( q!=mp_link(p) ) {
11039 @<Set |p=mp_link(p)| and add knots between |p| and |q| as
11040 required by |join_type|@>;
11047 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
11048 c=mp_offset_prep(mp, c,h);
11049 if ( mp->internal[mp_tracing_specs]>0 )
11050 mp_print_spec(mp, c,h,"");
11051 h=mp_pen_walk(mp, h,mp->spec_offset)
11053 @ Mitered and squared-off joins depend on path directions that are difficult to
11054 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
11055 have degenerate cubics only if the entire cycle collapses to a single
11056 degenerate cubic. Setting |join_type:=2| in this case makes the computed
11057 envelope degenerate as well.
11059 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
11060 if ( k<zero_off ) {
11063 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
11064 else if ( lcap==2 ) join_type=3;
11065 else join_type=2-lcap;
11066 if ( (join_type==0)||(join_type==3) ) {
11067 @<Set the incoming and outgoing directions at |q|; in case of
11068 degeneracy set |join_type:=2|@>;
11069 if ( join_type==0 ) {
11070 @<If |miterlim| is less than the secant of half the angle at |q|
11071 then set |join_type:=2|@>;
11076 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
11078 tmp=mp_take_fraction(mp, miterlim,fraction_half+
11079 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
11081 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
11084 @ @<Other local variables for |make_envelope|@>=
11085 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
11086 scaled tmp; /* a temporary value */
11088 @ The coordinates of |p| have already been shifted unless |p| is the first
11089 knot in which case they get shifted at the very end.
11091 @<Add offset |w| to the cubic from |p| to |q|@>=
11092 right_x(p)=right_x(p)+x_coord(w);
11093 right_y(p)=right_y(p)+y_coord(w);
11094 left_x(q)=left_x(q)+x_coord(w);
11095 left_y(q)=left_y(q)+y_coord(w);
11096 x_coord(q)=x_coord(q)+x_coord(w);
11097 y_coord(q)=y_coord(q)+y_coord(w);
11098 left_type(q)=mp_explicit;
11099 right_type(q)=mp_explicit
11101 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
11102 if ( k>zero_off ){ w=mp_link(w); decr(k); }
11103 else { w=knil(w); incr(k); }
11105 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
11106 the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
11107 case the cubic containing these control points is ``yet to be examined.''
11109 @<Declare a function called |insert_knot|@>=
11110 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
11111 /* returns the inserted knot */
11112 pointer r; /* the new knot */
11113 r=mp_get_node(mp, knot_node_size);
11114 mp_link(r)=mp_link(q); mp_link(q)=r;
11115 right_x(r)=right_x(q);
11116 right_y(r)=right_y(q);
11119 right_x(q)=x_coord(q);
11120 right_y(q)=y_coord(q);
11121 left_x(r)=x_coord(r);
11122 left_y(r)=y_coord(r);
11123 left_type(r)=mp_explicit;
11124 right_type(r)=mp_explicit;
11125 originator(r)=mp_program_code;
11129 @ After setting |p:=mp_link(p)|, either |join_type=1| or |q=mp_link(p)|.
11131 @<Set |p=mp_link(p)| and add knots between |p| and |q| as...@>=
11134 if ( (join_type==0)||(join_type==3) ) {
11135 if ( join_type==0 ) {
11136 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11138 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11142 right_x(r)=x_coord(r);
11143 right_y(r)=y_coord(r);
11148 @ For very small angles, adding a knot is unnecessary and would cause numerical
11149 problems, so we just set |r:=null| in that case.
11151 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11153 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11154 if ( abs(det)<26844 ) {
11155 r=null; /* sine $<10^{-4}$ */
11157 tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
11158 mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
11159 tmp=mp_make_fraction(mp, tmp,det);
11160 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11161 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11165 @ @<Other local variables for |make_envelope|@>=
11166 fraction det; /* a determinant used for mitered join calculations */
11168 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11170 ht_x=y_coord(w)-y_coord(w0);
11171 ht_y=x_coord(w0)-x_coord(w);
11172 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11173 ht_x+=ht_x; ht_y+=ht_y;
11175 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11176 product with |(ht_x,ht_y)|@>;
11177 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11178 mp_take_fraction(mp, dyin,ht_y));
11179 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11180 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11181 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11182 mp_take_fraction(mp, dyout,ht_y));
11183 r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11184 y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11187 @ @<Other local variables for |make_envelope|@>=
11188 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11189 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11190 halfword kk; /* keeps track of the pen vertices being scanned */
11191 pointer ww; /* the pen vertex being tested */
11193 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11194 from zero to |max_ht|.
11196 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11201 @<Step |ww| and move |kk| one step closer to |k0|@>;
11202 if ( kk==k0 ) break;
11203 tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
11204 mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
11205 if ( tmp>max_ht ) max_ht=tmp;
11209 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11210 if ( kk>k0 ) { ww=mp_link(ww); decr(kk); }
11211 else { ww=knil(ww); incr(kk); }
11213 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11214 if ( left_type(c)==mp_endpoint ) {
11215 mp->spec_p1=mp_htap_ypoc(mp, c);
11216 mp->spec_p2=mp->path_tail;
11217 originator(mp->spec_p1)=mp_program_code;
11218 mp_link(mp->spec_p2)=mp_link(mp->spec_p1);
11219 mp_link(mp->spec_p1)=c;
11220 mp_remove_cubic(mp, mp->spec_p1);
11222 if ( c!=mp_link(c) ) {
11223 originator(mp->spec_p2)=mp_program_code;
11224 mp_remove_cubic(mp, mp->spec_p2);
11226 @<Make |c| look like a cycle of length one@>;
11230 @ @<Make |c| look like a cycle of length one@>=
11232 left_type(c)=mp_explicit; right_type(c)=mp_explicit;
11233 left_x(c)=x_coord(c); left_y(c)=y_coord(c);
11234 right_x(c)=x_coord(c); right_y(c)=y_coord(c);
11237 @ In degenerate situations we might have to look at the knot preceding~|q|.
11238 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11240 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11241 dxin=x_coord(q)-left_x(q);
11242 dyin=y_coord(q)-left_y(q);
11243 if ( (dxin==0)&&(dyin==0) ) {
11244 dxin=x_coord(q)-right_x(p);
11245 dyin=y_coord(q)-right_y(p);
11246 if ( (dxin==0)&&(dyin==0) ) {
11247 dxin=x_coord(q)-x_coord(p);
11248 dyin=y_coord(q)-y_coord(p);
11249 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11250 dxin=dxin+x_coord(w);
11251 dyin=dyin+y_coord(w);
11255 tmp=mp_pyth_add(mp, dxin,dyin);
11259 dxin=mp_make_fraction(mp, dxin,tmp);
11260 dyin=mp_make_fraction(mp, dyin,tmp);
11261 @<Set the outgoing direction at |q|@>;
11264 @ If |q=c| then the coordinates of |r| and the control points between |q|
11265 and~|r| have already been offset by |h|.
11267 @<Set the outgoing direction at |q|@>=
11268 dxout=right_x(q)-x_coord(q);
11269 dyout=right_y(q)-y_coord(q);
11270 if ( (dxout==0)&&(dyout==0) ) {
11272 dxout=left_x(r)-x_coord(q);
11273 dyout=left_y(r)-y_coord(q);
11274 if ( (dxout==0)&&(dyout==0) ) {
11275 dxout=x_coord(r)-x_coord(q);
11276 dyout=y_coord(r)-y_coord(q);
11280 dxout=dxout-x_coord(h);
11281 dyout=dyout-y_coord(h);
11283 tmp=mp_pyth_add(mp, dxout,dyout);
11284 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11285 @:this can't happen degerate spec}{\quad degenerate spec@>
11286 dxout=mp_make_fraction(mp, dxout,tmp);
11287 dyout=mp_make_fraction(mp, dyout,tmp)
11289 @* \[23] Direction and intersection times.
11290 A path of length $n$ is defined parametrically by functions $x(t)$ and
11291 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11292 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11293 we shall consider operations that determine special times associated with
11294 given paths: the first time that a path travels in a given direction, and
11295 a pair of times at which two paths cross each other.
11297 @ Let's start with the easier task. The function |find_direction_time| is
11298 given a direction |(x,y)| and a path starting at~|h|. If the path never
11299 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11300 it will be nonnegative.
11302 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11303 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11304 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11305 assumed to match any given direction at time~|t|.
11307 The routine solves this problem in nondegenerate cases by rotating the path
11308 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11309 to find when a given path first travels ``due east.''
11312 scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11313 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11314 pointer p,q; /* for list traversal */
11315 scaled n; /* the direction time at knot |p| */
11316 scaled tt; /* the direction time within a cubic */
11317 @<Other local variables for |find_direction_time|@>;
11318 @<Normalize the given direction for better accuracy;
11319 but |return| with zero result if it's zero@>;
11322 if ( right_type(p)==mp_endpoint ) break;
11324 @<Rotate the cubic between |p| and |q|; then
11325 |goto found| if the rotated cubic travels due east at some time |tt|;
11326 but |break| if an entire cyclic path has been traversed@>;
11334 @ @<Normalize the given direction for better accuracy...@>=
11335 if ( abs(x)<abs(y) ) {
11336 x=mp_make_fraction(mp, x,abs(y));
11337 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11338 } else if ( x==0 ) {
11341 y=mp_make_fraction(mp, y,abs(x));
11342 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11345 @ Since we're interested in the tangent directions, we work with the
11346 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
11347 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11348 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11349 in order to achieve better accuracy.
11351 The given path may turn abruptly at a knot, and it might pass the critical
11352 tangent direction at such a time. Therefore we remember the direction |phi|
11353 in which the previous rotated cubic was traveling. (The value of |phi| will be
11354 undefined on the first cubic, i.e., when |n=0|.)
11356 @<Rotate the cubic between |p| and |q|; then...@>=
11358 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11359 points of the rotated derivatives@>;
11360 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11362 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11365 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11366 @<Exit to |found| if the curve whose derivatives are specified by
11367 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11369 @ @<Other local variables for |find_direction_time|@>=
11370 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11371 angle theta,phi; /* angles of exit and entry at a knot */
11372 fraction t; /* temp storage */
11374 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11375 x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
11376 x3=x_coord(q)-left_x(q);
11377 y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
11378 y3=y_coord(q)-left_y(q);
11380 if ( abs(x2)>max ) max=abs(x2);
11381 if ( abs(x3)>max ) max=abs(x3);
11382 if ( abs(y1)>max ) max=abs(y1);
11383 if ( abs(y2)>max ) max=abs(y2);
11384 if ( abs(y3)>max ) max=abs(y3);
11385 if ( max==0 ) goto FOUND;
11386 while ( max<fraction_half ){
11387 max+=max; x1+=x1; x2+=x2; x3+=x3;
11388 y1+=y1; y2+=y2; y3+=y3;
11390 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11391 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11392 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11393 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11394 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11395 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11397 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11398 theta=mp_n_arg(mp, x1,y1);
11399 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11400 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11402 @ In this step we want to use the |crossing_point| routine to find the
11403 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11404 Several complications arise: If the quadratic equation has a double root,
11405 the curve never crosses zero, and |crossing_point| will find nothing;
11406 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11407 equation has simple roots, or only one root, we may have to negate it
11408 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11409 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11412 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11413 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11414 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11415 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11416 either |goto found| or |goto done|@>;
11419 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11420 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11422 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11423 $B(x_1,x_2,x_3;t)\ge0$@>;
11426 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11427 two roots, because we know that it isn't identically zero.
11429 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11430 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11431 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11432 subject to rounding errors. Yet this code optimistically tries to
11433 do the right thing.
11435 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11437 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11438 t=mp_crossing_point(mp, y1,y2,y3);
11439 if ( t>fraction_one ) goto DONE;
11440 y2=t_of_the_way(y2,y3);
11441 x1=t_of_the_way(x1,x2);
11442 x2=t_of_the_way(x2,x3);
11443 x1=t_of_the_way(x1,x2);
11444 if ( x1>=0 ) we_found_it;
11446 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11447 if ( t>fraction_one ) goto DONE;
11448 x1=t_of_the_way(x1,x2);
11449 x2=t_of_the_way(x2,x3);
11450 if ( t_of_the_way(x1,x2)>=0 ) {
11451 t=t_of_the_way(tt,fraction_one); we_found_it;
11454 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11455 either |goto found| or |goto done|@>=
11457 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11458 t=mp_make_fraction(mp, y1,y1-y2);
11459 x1=t_of_the_way(x1,x2);
11460 x2=t_of_the_way(x2,x3);
11461 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11462 } else if ( y3==0 ) {
11464 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11465 } else if ( x3>=0 ) {
11466 tt=unity; goto FOUND;
11472 @ At this point we know that the derivative of |y(t)| is identically zero,
11473 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11476 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11478 t=mp_crossing_point(mp, -x1,-x2,-x3);
11479 if ( t<=fraction_one ) we_found_it;
11480 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11481 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11485 @ The intersection of two cubics can be found by an interesting variant
11486 of the general bisection scheme described in the introduction to
11488 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)$,
11489 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11490 if an intersection exists. First we find the smallest rectangle that
11491 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11492 the smallest rectangle that encloses
11493 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11494 But if the rectangles do overlap, we bisect the intervals, getting
11495 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11496 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11497 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11498 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11499 levels of bisection we will have determined the intersection times $t_1$
11500 and~$t_2$ to $l$~bits of accuracy.
11502 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11503 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11504 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11505 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11506 to determine when the enclosing rectangles overlap. Here's why:
11507 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11508 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11509 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11510 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11511 overlap if and only if $u\submin\L x\submax$ and
11512 $x\submin\L u\submax$. Letting
11513 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11514 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11515 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11517 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11518 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11519 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11520 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11521 because of the overlap condition; i.e., we know that $X\submin$,
11522 $X\submax$, and their relatives are bounded, hence $X\submax-
11523 U\submin$ and $X\submin-U\submax$ are bounded.
11525 @ Incidentally, if the given cubics intersect more than once, the process
11526 just sketched will not necessarily find the lexicographically smallest pair
11527 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11528 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11529 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11530 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11531 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11532 Shuffled order agrees with lexicographic order if all pairs of solutions
11533 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11534 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11535 and the bisection algorithm would be substantially less efficient if it were
11536 constrained by lexicographic order.
11538 For example, suppose that an overlap has been found for $l=3$ and
11539 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11540 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11541 Then there is probably an intersection in one of the subintervals
11542 $(.1011,.011x)$; but lexicographic order would require us to explore
11543 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11544 want to store all of the subdivision data for the second path, so the
11545 subdivisions would have to be regenerated many times. Such inefficiencies
11546 would be associated with every `1' in the binary representation of~$t_1$.
11548 @ The subdivision process introduces rounding errors, hence we need to
11549 make a more liberal test for overlap. It is not hard to show that the
11550 computed values of $U_i$ differ from the truth by at most~$l$, on
11551 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11552 If $\beta$ is an upper bound on the absolute error in the computed
11553 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11554 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11555 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11557 More accuracy is obtained if we try the algorithm first with |tol=0|;
11558 the more liberal tolerance is used only if an exact approach fails.
11559 It is convenient to do this double-take by letting `3' in the preceding
11560 paragraph be a parameter, which is first 0, then 3.
11563 unsigned int tol_step; /* either 0 or 3, usually */
11565 @ We shall use an explicit stack to implement the recursive bisection
11566 method described above. The |bisect_stack| array will contain numerous 5-word
11567 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11568 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11570 The following macros define the allocation of stack positions to
11571 the quantities needed for bisection-intersection.
11573 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11574 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11575 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11576 @d stack_min(A) mp->bisect_stack[(A)+3]
11577 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11578 @d stack_max(A) mp->bisect_stack[(A)+4]
11579 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11580 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11582 @d u_packet(A) ((A)-5)
11583 @d v_packet(A) ((A)-10)
11584 @d x_packet(A) ((A)-15)
11585 @d y_packet(A) ((A)-20)
11586 @d l_packets (mp->bisect_ptr-int_packets)
11587 @d r_packets mp->bisect_ptr
11588 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11589 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11590 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11591 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11592 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11593 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11594 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11595 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11597 @d u1l stack_1(ul_packet) /* $U'_1$ */
11598 @d u2l stack_2(ul_packet) /* $U'_2$ */
11599 @d u3l stack_3(ul_packet) /* $U'_3$ */
11600 @d v1l stack_1(vl_packet) /* $V'_1$ */
11601 @d v2l stack_2(vl_packet) /* $V'_2$ */
11602 @d v3l stack_3(vl_packet) /* $V'_3$ */
11603 @d x1l stack_1(xl_packet) /* $X'_1$ */
11604 @d x2l stack_2(xl_packet) /* $X'_2$ */
11605 @d x3l stack_3(xl_packet) /* $X'_3$ */
11606 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11607 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11608 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11609 @d u1r stack_1(ur_packet) /* $U''_1$ */
11610 @d u2r stack_2(ur_packet) /* $U''_2$ */
11611 @d u3r stack_3(ur_packet) /* $U''_3$ */
11612 @d v1r stack_1(vr_packet) /* $V''_1$ */
11613 @d v2r stack_2(vr_packet) /* $V''_2$ */
11614 @d v3r stack_3(vr_packet) /* $V''_3$ */
11615 @d x1r stack_1(xr_packet) /* $X''_1$ */
11616 @d x2r stack_2(xr_packet) /* $X''_2$ */
11617 @d x3r stack_3(xr_packet) /* $X''_3$ */
11618 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11619 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11620 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11622 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11623 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11624 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11625 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11626 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11627 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11630 integer *bisect_stack;
11631 integer bisect_ptr;
11633 @ @<Allocate or initialize ...@>=
11634 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11636 @ @<Dealloc variables@>=
11637 xfree(mp->bisect_stack);
11639 @ @<Check the ``constant''...@>=
11640 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11642 @ Computation of the min and max is a tedious but fairly fast sequence of
11643 instructions; exactly four comparisons are made in each branch.
11646 if ( stack_1((A))<0 ) {
11647 if ( stack_3((A))>=0 ) {
11648 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11649 else stack_min((A))=stack_1((A));
11650 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11651 if ( stack_max((A))<0 ) stack_max((A))=0;
11653 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11654 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11655 stack_max((A))=stack_1((A))+stack_2((A));
11656 if ( stack_max((A))<0 ) stack_max((A))=0;
11658 } else if ( stack_3((A))<=0 ) {
11659 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11660 else stack_max((A))=stack_1((A));
11661 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11662 if ( stack_min((A))>0 ) stack_min((A))=0;
11664 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11665 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11666 stack_min((A))=stack_1((A))+stack_2((A));
11667 if ( stack_min((A))>0 ) stack_min((A))=0;
11670 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11671 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11672 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11673 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11674 plus the |scaled| values of $t_1$ and~$t_2$.
11676 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11677 finds no intersection. The routine gives up and gives an approximate answer
11678 if it has backtracked
11679 more than 5000 times (otherwise there are cases where several minutes
11680 of fruitless computation would be possible).
11682 @d max_patience 5000
11685 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11686 integer time_to_go; /* this many backtracks before giving up */
11687 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11689 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11690 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,mp_link(p))|
11691 and |(pp,mp_link(pp))|, respectively.
11693 @c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11694 pointer q,qq; /* |mp_link(p)|, |mp_link(pp)| */
11695 mp->time_to_go=max_patience; mp->max_t=2;
11696 @<Initialize for intersections at level zero@>;
11699 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11700 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11701 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11702 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11704 if ( mp->cur_t>=mp->max_t ){
11705 if ( mp->max_t==two ) { /* we've done 17 bisections */
11706 mp->cur_t=halfp(mp->cur_t+1);
11707 mp->cur_tt=halfp(mp->cur_tt+1);
11710 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11712 @<Subdivide for a new level of intersection@>;
11715 if ( mp->time_to_go>0 ) {
11716 decr(mp->time_to_go);
11718 while ( mp->appr_t<unity ) {
11719 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11721 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11723 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11727 @ The following variables are global, although they are used only by
11728 |cubic_intersection|, because it is necessary on some machines to
11729 split |cubic_intersection| up into two procedures.
11732 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11733 integer tol; /* bound on the uncertainty in the overlap test */
11735 integer xy; /* pointers to the current packets of interest */
11736 integer three_l; /* |tol_step| times the bisection level */
11737 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11739 @ We shall assume that the coordinates are sufficiently non-extreme that
11740 integer overflow will not occur.
11741 @^overflow in arithmetic@>
11743 @<Initialize for intersections at level zero@>=
11744 q=mp_link(p); qq=mp_link(pp); mp->bisect_ptr=int_packets;
11745 u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
11746 u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
11747 v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
11748 v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
11749 x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
11750 x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
11751 y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
11752 y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
11753 mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
11754 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11755 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11757 @ @<Subdivide for a new level of intersection@>=
11758 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11759 stack_uv=mp->uv; stack_xy=mp->xy;
11760 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11761 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11762 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11763 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11764 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11765 u3l=half(u2l+u2r); u1r=u3l;
11766 set_min_max(ul_packet); set_min_max(ur_packet);
11767 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11768 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11769 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11770 v3l=half(v2l+v2r); v1r=v3l;
11771 set_min_max(vl_packet); set_min_max(vr_packet);
11772 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11773 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11774 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11775 x3l=half(x2l+x2r); x1r=x3l;
11776 set_min_max(xl_packet); set_min_max(xr_packet);
11777 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11778 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11779 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11780 y3l=half(y2l+y2r); y1r=y3l;
11781 set_min_max(yl_packet); set_min_max(yr_packet);
11782 mp->uv=l_packets; mp->xy=l_packets;
11783 mp->delx+=mp->delx; mp->dely+=mp->dely;
11784 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11785 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11787 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11789 if ( odd(mp->cur_tt) ) {
11790 if ( odd(mp->cur_t) ) {
11791 @<Descend to the previous level and |goto not_found|@>;
11794 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11795 +stack_3(u_packet(mp->uv));
11796 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11797 +stack_3(v_packet(mp->uv));
11798 mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
11799 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11800 /* switch from |r_packets| to |l_packets| */
11801 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11802 +stack_3(x_packet(mp->xy));
11803 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11804 +stack_3(y_packet(mp->xy));
11807 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11808 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11809 -stack_3(x_packet(mp->xy));
11810 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11811 -stack_3(y_packet(mp->xy));
11812 mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
11815 @ @<Descend to the previous level...@>=
11817 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11818 if ( mp->cur_t==0 ) return;
11819 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11820 mp->three_l=mp->three_l-mp->tol_step;
11821 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11822 mp->uv=stack_uv; mp->xy=stack_xy;
11826 @ The |path_intersection| procedure is much simpler.
11827 It invokes |cubic_intersection| in lexicographic order until finding a
11828 pair of cubics that intersect. The final intersection times are placed in
11829 |cur_t| and~|cur_tt|.
11831 @c void mp_path_intersection (MP mp,pointer h, pointer hh) {
11832 pointer p,pp; /* link registers that traverse the given paths */
11833 integer n,nn; /* integer parts of intersection times, minus |unity| */
11834 @<Change one-point paths into dead cycles@>;
11839 if ( right_type(p)!=mp_endpoint ) {
11842 if ( right_type(pp)!=mp_endpoint ) {
11843 mp_cubic_intersection(mp, p,pp);
11844 if ( mp->cur_t>0 ) {
11845 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11849 nn=nn+unity; pp=mp_link(pp);
11852 n=n+unity; p=mp_link(p);
11854 mp->tol_step=mp->tol_step+3;
11855 } while (mp->tol_step<=3);
11856 mp->cur_t=-unity; mp->cur_tt=-unity;
11859 @ @<Change one-point paths...@>=
11860 if ( right_type(h)==mp_endpoint ) {
11861 right_x(h)=x_coord(h); left_x(h)=x_coord(h);
11862 right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
11864 if ( right_type(hh)==mp_endpoint ) {
11865 right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
11866 right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
11869 @* \[24] Dynamic linear equations.
11870 \MP\ users define variables implicitly by stating equations that should be
11871 satisfied; the computer is supposed to be smart enough to solve those equations.
11872 And indeed, the computer tries valiantly to do so, by distinguishing five
11873 different types of numeric values:
11876 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11877 of the variable whose address is~|p|.
11880 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11881 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11882 as a |scaled| number plus a sum of independent variables with |fraction|
11886 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11887 number'' reflecting the time this variable was first used in an equation;
11888 also |0<=m<64|, and each dependent variable
11889 that refers to this one is actually referring to the future value of
11890 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11891 scaling are sometimes needed to keep the coefficients in dependency lists
11892 from getting too large. The value of~|m| will always be even.)
11895 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11896 equation before, but it has been explicitly declared to be numeric.
11899 |type(p)=undefined| means that variable |p| hasn't appeared before.
11901 \smallskip\noindent
11902 We have actually discussed these five types in the reverse order of their
11903 history during a computation: Once |known|, a variable never again
11904 becomes |dependent|; once |dependent|, it almost never again becomes
11905 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
11906 and once |mp_numeric_type|, it never again becomes |undefined| (except
11907 of course when the user specifically decides to scrap the old value
11908 and start again). A backward step may, however, take place: Sometimes
11909 a |dependent| variable becomes |mp_independent| again, when one of the
11910 independent variables it depends on is reverting to |undefined|.
11913 The next patch detects overflow of independent-variable serial
11914 numbers. Diagnosed and patched by Thorsten Dahlheimer.
11916 @d s_scale 64 /* the serial numbers are multiplied by this factor */
11917 @d new_indep(A) /* create a new independent variable */
11918 { if ( mp->serial_no>el_gordo-s_scale )
11919 mp_fatal_error(mp, "variable instance identifiers exhausted");
11920 type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
11921 value((A))=mp->serial_no;
11925 integer serial_no; /* the most recent serial number, times |s_scale| */
11927 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
11929 @ But how are dependency lists represented? It's simple: The linear combination
11930 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
11931 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
11932 @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
11933 of $\alpha_1$; and |mp_link(p)| points to the dependency list
11934 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
11935 then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
11936 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
11937 they appear in decreasing order of their |value| fields (i.e., of
11938 their serial numbers). \ (It is convenient to use decreasing order,
11939 since |value(null)=0|. If the independent variables were not sorted by
11940 serial number but by some other criterion, such as their location in |mem|,
11941 the equation-solving mechanism would be too system-dependent, because
11942 the ordering can affect the computed results.)
11944 The |link| field in the node that contains the constant term $\beta$ is
11945 called the {\sl final link\/} of the dependency list. \MP\ maintains
11946 a doubly-linked master list of all dependency lists, in terms of a permanently
11948 in |mem| called |dep_head|. If there are no dependencies, we have
11949 |mp_link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
11950 otherwise |mp_link(dep_head)| points to the first dependent variable, say~|p|,
11951 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
11952 points to its dependency list. If the final link of that dependency list
11953 occurs in location~|q|, then |mp_link(q)| points to the next dependent
11954 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
11956 @d dep_list(A) mp_link(value_loc((A)))
11957 /* half of the |value| field in a |dependent| variable */
11958 @d prev_dep(A) info(value_loc((A)))
11959 /* the other half; makes a doubly linked list */
11960 @d dep_node_size 2 /* the number of words per dependency node */
11962 @<Initialize table entries...@>= mp->serial_no=0;
11963 mp_link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
11964 info(dep_head)=null; dep_list(dep_head)=null;
11966 @ Actually the description above contains a little white lie. There's
11967 another kind of variable called |mp_proto_dependent|, which is
11968 just like a |dependent| one except that the $\alpha$ coefficients
11969 in its dependency list are |scaled| instead of being fractions.
11970 Proto-dependency lists are mixed with dependency lists in the
11971 nodes reachable from |dep_head|.
11973 @ Here is a procedure that prints a dependency list in symbolic form.
11974 The second parameter should be either |dependent| or |mp_proto_dependent|,
11975 to indicate the scaling of the coefficients.
11977 @<Declare subroutines for printing expressions@>=
11978 void mp_print_dependency (MP mp,pointer p, quarterword t) {
11979 integer v; /* a coefficient */
11980 pointer pp,q; /* for list manipulation */
11983 v=abs(value(p)); q=info(p);
11984 if ( q==null ) { /* the constant term */
11985 if ( (v!=0)||(p==pp) ) {
11986 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, xord('+'));
11987 mp_print_scaled(mp, value(p));
11991 @<Print the coefficient, unless it's $\pm1.0$@>;
11992 if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
11993 @:this can't happen dep}{\quad dep@>
11994 mp_print_variable_name(mp, q); v=value(q) % s_scale;
11995 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
12000 @ @<Print the coefficient, unless it's $\pm1.0$@>=
12001 if ( value(p)<0 ) mp_print_char(mp, xord('-'));
12002 else if ( p!=pp ) mp_print_char(mp, xord('+'));
12003 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
12004 if ( v!=unity ) mp_print_scaled(mp, v)
12006 @ The maximum absolute value of a coefficient in a given dependency list
12007 is returned by the following simple function.
12009 @c fraction mp_max_coef (MP mp,pointer p) {
12010 fraction x; /* the maximum so far */
12012 while ( info(p)!=null ) {
12013 if ( abs(value(p))>x ) x=abs(value(p));
12019 @ One of the main operations needed on dependency lists is to add a multiple
12020 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
12021 to dependency lists and |f| is a fraction.
12023 If the coefficient of any independent variable becomes |coef_bound| or
12024 more, in absolute value, this procedure changes the type of that variable
12025 to `|independent_needing_fix|', and sets the global variable |fix_needed|
12026 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
12027 $\mu^2+\mu<8$; this means that the numbers we deal with won't
12028 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
12029 2.3723$, the safer value 7/3 is taken as the threshold.)
12031 The changes mentioned in the preceding paragraph are actually done only if
12032 the global variable |watch_coefs| is |true|. But it usually is; in fact,
12033 it is |false| only when \MP\ is making a dependency list that will soon
12034 be equated to zero.
12036 Several procedures that act on dependency lists, including |p_plus_fq|,
12037 set the global variable |dep_final| to the final (constant term) node of
12038 the dependency list that they produce.
12040 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
12041 @d independent_needing_fix 0
12044 boolean fix_needed; /* does at least one |independent| variable need scaling? */
12045 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
12046 pointer dep_final; /* location of the constant term and final link */
12049 mp->fix_needed=false; mp->watch_coefs=true;
12051 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
12052 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
12053 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
12054 should be |mp_proto_dependent| if |q| is a proto-dependency list.
12056 List |q| is unchanged by the operation; but list |p| is totally destroyed.
12058 The final link of the dependency list or proto-dependency list returned
12059 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
12060 constant term of the result will be located in the same |mem| location
12061 as the original constant term of~|p|.
12063 Coefficients of the result are assumed to be zero if they are less than
12064 a certain threshold. This compensates for inevitable rounding errors,
12065 and tends to make more variables `|known|'. The threshold is approximately
12066 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
12067 proto-dependencies.
12069 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
12070 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
12071 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
12072 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
12074 @<Declare basic dependency-list subroutines@>=
12075 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12076 pointer q, quarterword t, quarterword tt) ;
12079 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12080 pointer q, quarterword t, quarterword tt) {
12081 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12082 pointer r,s; /* for list manipulation */
12083 integer threshold; /* defines a neighborhood of zero */
12084 integer v; /* temporary register */
12085 if ( t==mp_dependent ) threshold=fraction_threshold;
12086 else threshold=scaled_threshold;
12087 r=temp_head; pp=info(p); qq=info(q);
12093 @<Contribute a term from |p|, plus |f| times the
12094 corresponding term from |q|@>
12096 } else if ( value(pp)<value(qq) ) {
12097 @<Contribute a term from |q|, multiplied by~|f|@>
12099 mp_link(r)=p; r=p; p=mp_link(p); pp=info(p);
12102 if ( t==mp_dependent )
12103 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
12105 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
12106 mp_link(r)=p; mp->dep_final=p;
12107 return mp_link(temp_head);
12110 @ @<Contribute a term from |p|, plus |f|...@>=
12112 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
12113 else v=value(p)+mp_take_scaled(mp, f,value(q));
12114 value(p)=v; s=p; p=mp_link(p);
12115 if ( abs(v)<threshold ) {
12116 mp_free_node(mp, s,dep_node_size);
12118 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12119 type(qq)=independent_needing_fix; mp->fix_needed=true;
12123 pp=info(p); q=mp_link(q); qq=info(q);
12126 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12128 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12129 else v=mp_take_scaled(mp, f,value(q));
12130 if ( (unsigned)abs(v)>halfp(threshold) ) {
12131 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
12132 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12133 type(qq)=independent_needing_fix; mp->fix_needed=true;
12137 q=mp_link(q); qq=info(q);
12140 @ It is convenient to have another subroutine for the special case
12141 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12142 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12144 @c pointer mp_p_plus_q (MP mp,pointer p, pointer q, quarterword t) {
12145 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12146 pointer r,s; /* for list manipulation */
12147 integer threshold; /* defines a neighborhood of zero */
12148 integer v; /* temporary register */
12149 if ( t==mp_dependent ) threshold=fraction_threshold;
12150 else threshold=scaled_threshold;
12151 r=temp_head; pp=info(p); qq=info(q);
12157 @<Contribute a term from |p|, plus the
12158 corresponding term from |q|@>
12161 if ( value(pp)<value(qq) ) {
12162 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
12163 q=mp_link(q); qq=info(q); mp_link(r)=s; r=s;
12165 mp_link(r)=p; r=p; p=mp_link(p); pp=info(p);
12169 value(p)=mp_slow_add(mp, value(p),value(q));
12170 mp_link(r)=p; mp->dep_final=p;
12171 return mp_link(temp_head);
12174 @ @<Contribute a term from |p|, plus the...@>=
12176 v=value(p)+value(q);
12177 value(p)=v; s=p; p=mp_link(p); pp=info(p);
12178 if ( abs(v)<threshold ) {
12179 mp_free_node(mp, s,dep_node_size);
12181 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12182 type(qq)=independent_needing_fix; mp->fix_needed=true;
12186 q=mp_link(q); qq=info(q);
12189 @ A somewhat simpler routine will multiply a dependency list
12190 by a given constant~|v|. The constant is either a |fraction| less than
12191 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12192 convert a dependency list to a proto-dependency list.
12193 Parameters |t0| and |t1| are the list types before and after;
12194 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12195 and |v_is_scaled=true|.
12197 @c pointer mp_p_times_v (MP mp,pointer p, integer v, quarterword t0,
12198 quarterword t1, boolean v_is_scaled) {
12199 pointer r,s; /* for list manipulation */
12200 integer w; /* tentative coefficient */
12202 boolean scaling_down;
12203 if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
12204 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12205 else threshold=half_scaled_threshold;
12207 while ( info(p)!=null ) {
12208 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12209 else w=mp_take_scaled(mp, v,value(p));
12210 if ( abs(w)<=threshold ) {
12211 s=mp_link(p); mp_free_node(mp, p,dep_node_size); p=s;
12213 if ( abs(w)>=coef_bound ) {
12214 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12216 mp_link(r)=p; r=p; value(p)=w; p=mp_link(p);
12220 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12221 else value(p)=mp_take_fraction(mp, value(p),v);
12222 return mp_link(temp_head);
12225 @ Similarly, we sometimes need to divide a dependency list
12226 by a given |scaled| constant.
12228 @<Declare basic dependency-list subroutines@>=
12229 pointer mp_p_over_v (MP mp,pointer p, scaled v, quarterword
12230 t0, quarterword t1) ;
12233 pointer mp_p_over_v (MP mp,pointer p, scaled v, quarterword
12234 t0, quarterword t1) {
12235 pointer r,s; /* for list manipulation */
12236 integer w; /* tentative coefficient */
12238 boolean scaling_down;
12239 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12240 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12241 else threshold=half_scaled_threshold;
12243 while ( info( p)!=null ) {
12244 if ( scaling_down ) {
12245 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12246 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12248 w=mp_make_scaled(mp, value(p),v);
12250 if ( abs(w)<=threshold ) {
12251 s=mp_link(p); mp_free_node(mp, p,dep_node_size); p=s;
12253 if ( abs(w)>=coef_bound ) {
12254 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12256 mp_link(r)=p; r=p; value(p)=w; p=mp_link(p);
12259 mp_link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12260 return mp_link(temp_head);
12263 @ Here's another utility routine for dependency lists. When an independent
12264 variable becomes dependent, we want to remove it from all existing
12265 dependencies. The |p_with_x_becoming_q| function computes the
12266 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12268 This procedure has basically the same calling conventions as |p_plus_fq|:
12269 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12270 final link are inherited from~|p|; and the fourth parameter tells whether
12271 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12272 is not altered if |x| does not occur in list~|p|.
12274 @c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12275 pointer x, pointer q, quarterword t) {
12276 pointer r,s; /* for list manipulation */
12277 integer v; /* coefficient of |x| */
12278 integer sx; /* serial number of |x| */
12279 s=p; r=temp_head; sx=value(x);
12280 while ( value(info(s))>sx ) { r=s; s=mp_link(s); };
12281 if ( info(s)!=x ) {
12284 mp_link(temp_head)=p; mp_link(r)=mp_link(s); v=value(s);
12285 mp_free_node(mp, s,dep_node_size);
12286 return mp_p_plus_fq(mp, mp_link(temp_head),v,q,t,mp_dependent);
12290 @ Here's a simple procedure that reports an error when a variable
12291 has just received a known value that's out of the required range.
12293 @<Declare basic dependency-list subroutines@>=
12294 void mp_val_too_big (MP mp,scaled x) ;
12296 @ @c void mp_val_too_big (MP mp,scaled x) {
12297 if ( mp->internal[mp_warning_check]>0 ) {
12298 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, xord(')'));
12299 @.Value is too large@>
12300 help4("The equation I just processed has given some variable",
12301 "a value of 4096 or more. Continue and I'll try to cope",
12302 "with that big value; but it might be dangerous.",
12303 "(Set warningcheck:=0 to suppress this message.)");
12308 @ When a dependent variable becomes known, the following routine
12309 removes its dependency list. Here |p| points to the variable, and
12310 |q| points to the dependency list (which is one node long).
12312 @<Declare basic dependency-list subroutines@>=
12313 void mp_make_known (MP mp,pointer p, pointer q) ;
12315 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12316 int t; /* the previous type */
12317 prev_dep(mp_link(q))=prev_dep(p);
12318 mp_link(prev_dep(p))=mp_link(q); t=type(p);
12319 type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12320 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12321 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12322 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12323 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12324 mp_print_variable_name(mp, p);
12325 mp_print_char(mp, xord('=')); mp_print_scaled(mp, value(p));
12326 mp_end_diagnostic(mp, false);
12328 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12329 mp->cur_type=mp_known; mp->cur_exp=value(p);
12330 mp_free_node(mp, p,value_node_size);
12334 @ The |fix_dependencies| routine is called into action when |fix_needed|
12335 has been triggered. The program keeps a list~|s| of independent variables
12336 whose coefficients must be divided by~4.
12338 In unusual cases, this fixup process might reduce one or more coefficients
12339 to zero, so that a variable will become known more or less by default.
12341 @<Declare basic dependency-list subroutines@>=
12342 void mp_fix_dependencies (MP mp);
12344 @ @c void mp_fix_dependencies (MP mp) {
12345 pointer p,q,r,s,t; /* list manipulation registers */
12346 pointer x; /* an independent variable */
12347 r=mp_link(dep_head); s=null;
12348 while ( r!=dep_head ){
12350 @<Run through the dependency list for variable |t|, fixing
12351 all nodes, and ending with final link~|q|@>;
12353 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12355 while ( s!=null ) {
12356 p=mp_link(s); x=info(s); free_avail(s); s=p;
12357 type(x)=mp_independent; value(x)=value(x)+2;
12359 mp->fix_needed=false;
12362 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12364 @<Run through the dependency list for variable |t|...@>=
12365 r=value_loc(t); /* |mp_link(r)=dep_list(t)| */
12367 q=mp_link(r); x=info(q);
12368 if ( x==null ) break;
12369 if ( type(x)<=independent_being_fixed ) {
12370 if ( type(x)<independent_being_fixed ) {
12371 p=mp_get_avail(mp); mp_link(p)=s; s=p;
12372 info(s)=x; type(x)=independent_being_fixed;
12374 value(q)=value(q) / 4;
12375 if ( value(q)==0 ) {
12376 mp_link(r)=mp_link(q); mp_free_node(mp, q,dep_node_size); q=r;
12383 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12384 linking it into the list of all known dependencies. We assume that
12385 |dep_final| points to the final node of list~|p|.
12387 @c void mp_new_dep (MP mp,pointer q, pointer p) {
12388 pointer r; /* what used to be the first dependency */
12389 dep_list(q)=p; prev_dep(q)=dep_head;
12390 r=mp_link(dep_head); mp_link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12391 mp_link(dep_head)=q;
12394 @ Here is one of the ways a dependency list gets started.
12395 The |const_dependency| routine produces a list that has nothing but
12398 @c pointer mp_const_dependency (MP mp, scaled v) {
12399 mp->dep_final=mp_get_node(mp, dep_node_size);
12400 value(mp->dep_final)=v; info(mp->dep_final)=null;
12401 return mp->dep_final;
12404 @ And here's a more interesting way to start a dependency list from scratch:
12405 The parameter to |single_dependency| is the location of an
12406 independent variable~|x|, and the result is the simple dependency list
12409 In the unlikely event that the given independent variable has been doubled so
12410 often that we can't refer to it with a nonzero coefficient,
12411 |single_dependency| returns the simple list `0'. This case can be
12412 recognized by testing that the returned list pointer is equal to
12415 @c pointer mp_single_dependency (MP mp,pointer p) {
12416 pointer q; /* the new dependency list */
12417 integer m; /* the number of doublings */
12418 m=value(p) % s_scale;
12420 return mp_const_dependency(mp, 0);
12422 q=mp_get_node(mp, dep_node_size);
12423 value(q)=two_to_the(28-m); info(q)=p;
12424 mp_link(q)=mp_const_dependency(mp, 0);
12429 @ We sometimes need to make an exact copy of a dependency list.
12431 @c pointer mp_copy_dep_list (MP mp,pointer p) {
12432 pointer q; /* the new dependency list */
12433 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12435 info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
12436 if ( info(mp->dep_final)==null ) break;
12437 mp_link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12438 mp->dep_final=mp_link(mp->dep_final); p=mp_link(p);
12443 @ But how do variables normally become known? Ah, now we get to the heart of the
12444 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12445 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12446 appears. It equates this list to zero, by choosing an independent variable
12447 with the largest coefficient and making it dependent on the others. The
12448 newly dependent variable is eliminated from all current dependencies,
12449 thereby possibly making other dependent variables known.
12451 The given list |p| is, of course, totally destroyed by all this processing.
12453 @c void mp_linear_eq (MP mp, pointer p, quarterword t) {
12454 pointer q,r,s; /* for link manipulation */
12455 pointer x; /* the variable that loses its independence */
12456 integer n; /* the number of times |x| had been halved */
12457 integer v; /* the coefficient of |x| in list |p| */
12458 pointer prev_r; /* lags one step behind |r| */
12459 pointer final_node; /* the constant term of the new dependency list */
12460 integer w; /* a tentative coefficient */
12461 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12462 x=info(q); n=value(x) % s_scale;
12463 @<Divide list |p| by |-v|, removing node |q|@>;
12464 if ( mp->internal[mp_tracing_equations]>0 ) {
12465 @<Display the new dependency@>;
12467 @<Simplify all existing dependencies by substituting for |x|@>;
12468 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12469 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12472 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12473 q=p; r=mp_link(p); v=value(q);
12474 while ( info(r)!=null ) {
12475 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12479 @ Here we want to change the coefficients from |scaled| to |fraction|,
12480 except in the constant term. In the common case of a trivial equation
12481 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12483 @<Divide list |p| by |-v|, removing node |q|@>=
12484 s=temp_head; mp_link(s)=p; r=p;
12487 mp_link(s)=mp_link(r); mp_free_node(mp, r,dep_node_size);
12489 w=mp_make_fraction(mp, value(r),v);
12490 if ( abs(w)<=half_fraction_threshold ) {
12491 mp_link(s)=mp_link(r); mp_free_node(mp, r,dep_node_size);
12497 } while (info(r)!=null);
12498 if ( t==mp_proto_dependent ) {
12499 value(r)=-mp_make_scaled(mp, value(r),v);
12500 } else if ( v!=-fraction_one ) {
12501 value(r)=-mp_make_fraction(mp, value(r),v);
12503 final_node=r; p=mp_link(temp_head)
12505 @ @<Display the new dependency@>=
12506 if ( mp_interesting(mp, x) ) {
12507 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12508 mp_print_variable_name(mp, x);
12509 @:]]]\#\#_}{\.{\#\#}@>
12511 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12512 mp_print_char(mp, xord('=')); mp_print_dependency(mp, p,mp_dependent);
12513 mp_end_diagnostic(mp, false);
12516 @ @<Simplify all existing dependencies by substituting for |x|@>=
12517 prev_r=dep_head; r=mp_link(dep_head);
12518 while ( r!=dep_head ) {
12519 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
12520 if ( info(q)==null ) {
12521 mp_make_known(mp, r,q);
12524 do { q=mp_link(q); } while (info(q)!=null);
12530 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12531 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12532 if ( info(p)==null ) {
12535 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12536 mp_free_node(mp, p,dep_node_size);
12537 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12538 mp->cur_exp=value(x); mp->cur_type=mp_known;
12539 mp_free_node(mp, x,value_node_size);
12542 type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12543 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12546 @ @<Divide list |p| by $2^n$@>=
12548 s=temp_head; mp_link(temp_head)=p; r=p;
12551 else w=value(r) / two_to_the(n);
12552 if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
12553 mp_link(s)=mp_link(r);
12554 mp_free_node(mp, r,dep_node_size);
12559 } while (info(s)!=null);
12560 p=mp_link(temp_head);
12563 @ The |check_mem| procedure, which is used only when \MP\ is being
12564 debugged, makes sure that the current dependency lists are well formed.
12566 @<Check the list of linear dependencies@>=
12567 q=dep_head; p=mp_link(q);
12568 while ( p!=dep_head ) {
12569 if ( prev_dep(p)!=q ) {
12570 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12575 r=info(p); q=p; p=mp_link(q);
12576 if ( r==null ) break;
12577 if ( value(info(p))>=value(r) ) {
12578 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12579 @.Out of order...@>
12584 @* \[25] Dynamic nonlinear equations.
12585 Variables of numeric type are maintained by the general scheme of
12586 independent, dependent, and known values that we have just studied;
12587 and the components of pair and transform variables are handled in the
12588 same way. But \MP\ also has five other types of values: \&{boolean},
12589 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12591 Equations are allowed between nonlinear quantities, but only in a
12592 simple form. Two variables that haven't yet been assigned values are
12593 either equal to each other, or they're not.
12595 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12596 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12597 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12598 |null| (which means that no other variables are equivalent to this one), or
12599 it points to another variable of the same undefined type. The pointers in the
12600 latter case form a cycle of nodes, which we shall call a ``ring.''
12601 Rings of undefined variables may include capsules, which arise as
12602 intermediate results within expressions or as \&{expr} parameters to macros.
12604 When one member of a ring receives a value, the same value is given to
12605 all the other members. In the case of paths and pictures, this implies
12606 making separate copies of a potentially large data structure; users should
12607 restrain their enthusiasm for such generality, unless they have lots and
12608 lots of memory space.
12610 @ The following procedure is called when a capsule node is being
12611 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12613 @c pointer mp_new_ring_entry (MP mp,pointer p) {
12614 pointer q; /* the new capsule node */
12615 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
12617 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12622 @ Conversely, we might delete a capsule or a variable before it becomes known.
12623 The following procedure simply detaches a quantity from its ring,
12624 without recycling the storage.
12626 @<Declare the recycling subroutines@>=
12627 void mp_ring_delete (MP mp,pointer p) {
12630 if ( q!=null ) if ( q!=p ){
12631 while ( value(q)!=p ) q=value(q);
12636 @ Eventually there might be an equation that assigns values to all of the
12637 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12638 propagation of values.
12640 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12641 value, it will soon be recycled.
12643 @c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12644 quarterword t; /* the type of ring |p| */
12645 pointer q,r; /* link manipulation registers */
12646 t=type(p)-unknown_tag; q=value(p);
12647 if ( flush_p ) type(p)=mp_vacuous; else p=q;
12649 r=value(q); type(q)=t;
12651 case mp_boolean_type: value(q)=v; break;
12652 case mp_string_type: value(q)=v; add_str_ref(v); break;
12653 case mp_pen_type: value(q)=copy_pen(v); break;
12654 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12655 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12656 } /* there ain't no more cases */
12661 @ If two members of rings are equated, and if they have the same type,
12662 the |ring_merge| procedure is called on to make them equivalent.
12664 @c void mp_ring_merge (MP mp,pointer p, pointer q) {
12665 pointer r; /* traverses one list */
12669 @<Exclaim about a redundant equation@>;
12674 r=value(p); value(p)=value(q); value(q)=r;
12677 @ @<Exclaim about a redundant equation@>=
12679 print_err("Redundant equation");
12680 @.Redundant equation@>
12681 help2("I already knew that this equation was true.",
12682 "But perhaps no harm has been done; let's continue.");
12683 mp_put_get_error(mp);
12686 @* \[26] Introduction to the syntactic routines.
12687 Let's pause a moment now and try to look at the Big Picture.
12688 The \MP\ program consists of three main parts: syntactic routines,
12689 semantic routines, and output routines. The chief purpose of the
12690 syntactic routines is to deliver the user's input to the semantic routines,
12691 while parsing expressions and locating operators and operands. The
12692 semantic routines act as an interpreter responding to these operators,
12693 which may be regarded as commands. And the output routines are
12694 periodically called on to produce compact font descriptions that can be
12695 used for typesetting or for making interim proof drawings. We have
12696 discussed the basic data structures and many of the details of semantic
12697 operations, so we are good and ready to plunge into the part of \MP\ that
12698 actually controls the activities.
12700 Our current goal is to come to grips with the |get_next| procedure,
12701 which is the keystone of \MP's input mechanism. Each call of |get_next|
12702 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12703 representing the next input token.
12704 $$\vbox{\halign{#\hfil\cr
12705 \hbox{|cur_cmd| denotes a command code from the long list of codes
12707 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12708 \hbox{|cur_sym| is the hash address of the symbolic token that was
12710 \hbox{\qquad or zero in the case of a numeric or string
12711 or capsule token.}\cr}}$$
12712 Underlying this external behavior of |get_next| is all the machinery
12713 necessary to convert from character files to tokens. At a given time we
12714 may be only partially finished with the reading of several files (for
12715 which \&{input} was specified), and partially finished with the expansion
12716 of some user-defined macros and/or some macro parameters, and partially
12717 finished reading some text that the user has inserted online,
12718 and so on. When reading a character file, the characters must be
12719 converted to tokens; comments and blank spaces must
12720 be removed, numeric and string tokens must be evaluated.
12722 To handle these situations, which might all be present simultaneously,
12723 \MP\ uses various stacks that hold information about the incomplete
12724 activities, and there is a finite state control for each level of the
12725 input mechanism. These stacks record the current state of an implicitly
12726 recursive process, but the |get_next| procedure is not recursive.
12729 integer cur_cmd; /* current command set by |get_next| */
12730 integer cur_mod; /* operand of current command */
12731 halfword cur_sym; /* hash address of current symbol */
12733 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12734 command code and its modifier.
12735 It consists of a rather tedious sequence of print
12736 commands, and most of it is essentially an inverse to the |primitive|
12737 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12738 all of this procedure appears elsewhere in the program, together with the
12739 corresponding |primitive| calls.
12741 @<Declare the procedure called |print_cmd_mod|@>=
12742 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12744 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12745 default: mp_print(mp, "[unknown command code!]"); break;
12749 @ Here is a procedure that displays a given command in braces, in the
12750 user's transcript file.
12752 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12755 void mp_show_cmd_mod (MP mp,integer c, integer m) {
12756 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12757 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, xord('}'));
12758 mp_end_diagnostic(mp, false);
12761 @* \[27] Input stacks and states.
12762 The state of \MP's input mechanism appears in the input stack, whose
12763 entries are records with five fields, called |index|, |start|, |loc|,
12764 |limit|, and |name|. The top element of this stack is maintained in a
12765 global variable for which no subscripting needs to be done; the other
12766 elements of the stack appear in an array. Hence the stack is declared thus:
12770 quarterword index_field;
12771 halfword start_field, loc_field, limit_field, name_field;
12775 in_state_record *input_stack;
12776 integer input_ptr; /* first unused location of |input_stack| */
12777 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12778 in_state_record cur_input; /* the ``top'' input state */
12779 int stack_size; /* maximum number of simultaneous input sources */
12781 @ @<Allocate or initialize ...@>=
12782 mp->stack_size = 300;
12783 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12785 @ @<Dealloc variables@>=
12786 xfree(mp->input_stack);
12788 @ We've already defined the special variable |loc==cur_input.loc_field|
12789 in our discussion of basic input-output routines. The other components of
12790 |cur_input| are defined in the same way:
12792 @d iindex mp->cur_input.index_field /* reference for buffer information */
12793 @d start mp->cur_input.start_field /* starting position in |buffer| */
12794 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12795 @d name mp->cur_input.name_field /* name of the current file */
12797 @ Let's look more closely now at the five control variables
12798 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12799 assuming that \MP\ is reading a line of characters that have been input
12800 from some file or from the user's terminal. There is an array called
12801 |buffer| that acts as a stack of all lines of characters that are
12802 currently being read from files, including all lines on subsidiary
12803 levels of the input stack that are not yet completed. \MP\ will return to
12804 the other lines when it is finished with the present input file.
12806 (Incidentally, on a machine with byte-oriented addressing, it would be
12807 appropriate to combine |buffer| with the |str_pool| array,
12808 letting the buffer entries grow downward from the top of the string pool
12809 and checking that these two tables don't bump into each other.)
12811 The line we are currently working on begins in position |start| of the
12812 buffer; the next character we are about to read is |buffer[loc]|; and
12813 |limit| is the location of the last character present. We always have
12814 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12815 that the end of a line is easily sensed.
12817 The |name| variable is a string number that designates the name of
12818 the current file, if we are reading an ordinary text file. Special codes
12819 |is_term..max_spec_src| indicate other sources of input text.
12821 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12822 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12823 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12824 @d max_spec_src is_scantok
12826 @ Additional information about the current line is available via the
12827 |index| variable, which counts how many lines of characters are present
12828 in the buffer below the current level. We have |index=0| when reading
12829 from the terminal and prompting the user for each line; then if the user types,
12830 e.g., `\.{input figs}', we will have |index=1| while reading
12831 the file \.{figs.mp}. However, it does not follow that |index| is the
12832 same as the input stack pointer, since many of the levels on the input
12833 stack may come from token lists and some |index| values may correspond
12834 to \.{MPX} files that are not currently on the stack.
12836 The global variable |in_open| is equal to the highest |index| value counting
12837 \.{MPX} files but excluding token-list input levels. Thus, the number of
12838 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12839 when we are not reading a token list.
12841 If we are not currently reading from the terminal,
12842 we are reading from the file variable |input_file[index]|. We use
12843 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12844 and |cur_file| as an abbreviation for |input_file[index]|.
12846 When \MP\ is not reading from the terminal, the global variable |line| contains
12847 the line number in the current file, for use in error messages. More precisely,
12848 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12849 the line number for each file in the |input_file| array.
12851 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12852 array so that the name doesn't get lost when the file is temporarily removed
12853 from the input stack.
12854 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12855 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12856 Since this is not an \.{MPX} file, we have
12857 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12858 This |name| field is set to |finished| when |input_file[k]| is completely
12861 If more information about the input state is needed, it can be
12862 included in small arrays like those shown here. For example,
12863 the current page or segment number in the input file might be put
12864 into a variable |page|, that is really a macro for the current entry
12865 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12866 by analogy with |line_stack|.
12867 @^system dependencies@>
12869 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12870 @d cur_file mp->input_file[iindex] /* the current |void *| variable */
12871 @d line mp->line_stack[iindex] /* current line number in the current source file */
12872 @d in_name mp->iname_stack[iindex] /* a string used to construct \.{MPX} file names */
12873 @d in_area mp->iarea_stack[iindex] /* another string for naming \.{MPX} files */
12874 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12875 @d mpx_reading (mp->mpx_name[iindex]>absent)
12876 /* when reading a file, is it an \.{MPX} file? */
12878 /* |name_field| value when the corresponding \.{MPX} file is finished */
12881 integer in_open; /* the number of lines in the buffer, less one */
12882 unsigned int open_parens; /* the number of open text files */
12883 void * *input_file ;
12884 integer *line_stack ; /* the line number for each file */
12885 char * *iname_stack; /* used for naming \.{MPX} files */
12886 char * *iarea_stack; /* used for naming \.{MPX} files */
12887 halfword*mpx_name ;
12889 @ @<Allocate or ...@>=
12890 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
12891 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
12892 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12893 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12894 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
12897 for (k=0;k<=mp->max_in_open;k++) {
12898 mp->iname_stack[k] =NULL;
12899 mp->iarea_stack[k] =NULL;
12903 @ @<Dealloc variables@>=
12906 for (l=0;l<=mp->max_in_open;l++) {
12907 xfree(mp->iname_stack[l]);
12908 xfree(mp->iarea_stack[l]);
12911 xfree(mp->input_file);
12912 xfree(mp->line_stack);
12913 xfree(mp->iname_stack);
12914 xfree(mp->iarea_stack);
12915 xfree(mp->mpx_name);
12918 @ However, all this discussion about input state really applies only to the
12919 case that we are inputting from a file. There is another important case,
12920 namely when we are currently getting input from a token list. In this case
12921 |iindex>max_in_open|, and the conventions about the other state variables
12924 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
12925 the node that will be read next. If |loc=null|, the token list has been
12928 \yskip\hang|start| points to the first node of the token list; this node
12929 may or may not contain a reference count, depending on the type of token
12932 \yskip\hang|token_type|, which takes the place of |iindex| in the
12933 discussion above, is a code number that explains what kind of token list
12936 \yskip\hang|name| points to the |eqtb| address of the control sequence
12937 being expanded, if the current token list is a macro not defined by
12938 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
12939 can be deduced by looking at their first two parameters.
12941 \yskip\hang|param_start|, which takes the place of |limit|, tells where
12942 the parameters of the current macro or loop text begin in the |param_stack|.
12944 \yskip\noindent The |token_type| can take several values, depending on
12945 where the current token list came from:
12948 \indent|forever_text|, if the token list being scanned is the body of
12949 a \&{forever} loop;
12951 \indent|loop_text|, if the token list being scanned is the body of
12952 a \&{for} or \&{forsuffixes} loop;
12954 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
12956 \indent|backed_up|, if the token list being scanned has been inserted as
12957 `to be read again'.
12959 \indent|inserted|, if the token list being scanned has been inserted as
12960 part of error recovery;
12962 \indent|macro|, if the expansion of a user-defined symbolic token is being
12966 The token list begins with a reference count if and only if |token_type=
12968 @^reference counts@>
12970 @d token_type iindex /* type of current token list */
12971 @d token_state (iindex>(int)mp->max_in_open) /* are we scanning a token list? */
12972 @d file_state (iindex<=(int)mp->max_in_open) /* are we scanning a file line? */
12973 @d param_start limit /* base of macro parameters in |param_stack| */
12974 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
12975 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
12976 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
12977 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
12978 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
12979 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
12981 @ The |param_stack| is an auxiliary array used to hold pointers to the token
12982 lists for parameters at the current level and subsidiary levels of input.
12983 This stack grows at a different rate from the others.
12986 pointer *param_stack; /* token list pointers for parameters */
12987 integer param_ptr; /* first unused entry in |param_stack| */
12988 integer max_param_stack; /* largest value of |param_ptr| */
12990 @ @<Allocate or initialize ...@>=
12991 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
12993 @ @<Dealloc variables@>=
12994 xfree(mp->param_stack);
12996 @ Notice that the |line| isn't valid when |token_state| is true because it
12997 depends on |iindex|. If we really need to know the line number for the
12998 topmost file in the iindex stack we use the following function. If a page
12999 number or other information is needed, this routine should be modified to
13000 compute it as well.
13001 @^system dependencies@>
13003 @<Declare a function called |true_line|@>=
13004 integer mp_true_line (MP mp) {
13005 int k; /* an index into the input stack */
13006 if ( file_state && (name>max_spec_src) ) {
13011 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
13012 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
13015 return (k>0 ? mp->line_stack[(k-1)] : 0 );
13019 @ Thus, the ``current input state'' can be very complicated indeed; there
13020 can be many levels and each level can arise in a variety of ways. The
13021 |show_context| procedure, which is used by \MP's error-reporting routine to
13022 print out the current input state on all levels down to the most recent
13023 line of characters from an input file, illustrates most of these conventions.
13024 The global variable |file_ptr| contains the lowest level that was
13025 displayed by this procedure.
13028 integer file_ptr; /* shallowest level shown by |show_context| */
13030 @ The status at each level is indicated by printing two lines, where the first
13031 line indicates what was read so far and the second line shows what remains
13032 to be read. The context is cropped, if necessary, so that the first line
13033 contains at most |half_error_line| characters, and the second contains
13034 at most |error_line|. Non-current input levels whose |token_type| is
13035 `|backed_up|' are shown only if they have not been fully read.
13037 @c void mp_show_context (MP mp) { /* prints where the scanner is */
13038 unsigned old_setting; /* saved |selector| setting */
13039 @<Local variables for formatting calculations@>
13040 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
13041 /* store current state */
13043 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
13044 @<Display the current context@>;
13046 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
13047 decr(mp->file_ptr);
13049 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
13052 @ @<Display the current context@>=
13053 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
13054 (token_type!=backed_up) || (loc!=null) ) {
13055 /* we omit backed-up token lists that have already been read */
13056 mp->tally=0; /* get ready to count characters */
13057 old_setting=mp->selector;
13058 if ( file_state ) {
13059 @<Print location of current line@>;
13060 @<Pseudoprint the line@>;
13062 @<Print type of token list@>;
13063 @<Pseudoprint the token list@>;
13065 mp->selector=old_setting; /* stop pseudoprinting */
13066 @<Print two lines using the tricky pseudoprinted information@>;
13069 @ This routine should be changed, if necessary, to give the best possible
13070 indication of where the current line resides in the input file.
13071 For example, on some systems it is best to print both a page and line number.
13072 @^system dependencies@>
13074 @<Print location of current line@>=
13075 if ( name>max_spec_src ) {
13076 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
13077 } else if ( terminal_input ) {
13078 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
13079 else mp_print_nl(mp, "<insert>");
13080 } else if ( name==is_scantok ) {
13081 mp_print_nl(mp, "<scantokens>");
13083 mp_print_nl(mp, "<read>");
13085 mp_print_char(mp, xord(' '))
13087 @ Can't use case statement here because the |token_type| is not
13088 a constant expression.
13090 @<Print type of token list@>=
13092 if(token_type==forever_text) {
13093 mp_print_nl(mp, "<forever> ");
13094 } else if (token_type==loop_text) {
13095 @<Print the current loop value@>;
13096 } else if (token_type==parameter) {
13097 mp_print_nl(mp, "<argument> ");
13098 } else if (token_type==backed_up) {
13099 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
13100 else mp_print_nl(mp, "<to be read again> ");
13101 } else if (token_type==inserted) {
13102 mp_print_nl(mp, "<inserted text> ");
13103 } else if (token_type==macro) {
13105 if ( name!=null ) mp_print_text(name);
13106 else @<Print the name of a \&{vardef}'d macro@>;
13107 mp_print(mp, "->");
13109 mp_print_nl(mp, "?");/* this should never happen */
13114 @ The parameter that corresponds to a loop text is either a token list
13115 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13116 We'll discuss capsules later; for now, all we need to know is that
13117 the |link| field in a capsule parameter is |void| and that
13118 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13120 @<Print the current loop value@>=
13121 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13123 if ( mp_link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13124 else mp_show_token_list(mp, p,null,20,mp->tally);
13126 mp_print(mp, ")> ");
13129 @ The first two parameters of a macro defined by \&{vardef} will be token
13130 lists representing the macro's prefix and ``at point.'' By putting these
13131 together, we get the macro's full name.
13133 @<Print the name of a \&{vardef}'d macro@>=
13134 { p=mp->param_stack[param_start];
13136 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13139 while ( mp_link(q)!=null ) q=mp_link(q);
13140 mp_link(q)=mp->param_stack[param_start+1];
13141 mp_show_token_list(mp, p,null,20,mp->tally);
13146 @ Now it is necessary to explain a little trick. We don't want to store a long
13147 string that corresponds to a token list, because that string might take up
13148 lots of memory; and we are printing during a time when an error message is
13149 being given, so we dare not do anything that might overflow one of \MP's
13150 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13151 that stores characters into a buffer of length |error_line|, where character
13152 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13153 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13154 |tally:=0| and |trick_count:=1000000|; then when we reach the
13155 point where transition from line 1 to line 2 should occur, we
13156 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13157 tally+1+error_line-half_error_line)|. At the end of the
13158 pseudoprinting, the values of |first_count|, |tally|, and
13159 |trick_count| give us all the information we need to print the two lines,
13160 and all of the necessary text is in |trick_buf|.
13162 Namely, let |l| be the length of the descriptive information that appears
13163 on the first line. The length of the context information gathered for that
13164 line is |k=first_count|, and the length of the context information
13165 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13166 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13167 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13168 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13169 and print `\.{...}' followed by
13170 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13171 where subscripts of |trick_buf| are circular modulo |error_line|. The
13172 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13173 unless |n+m>error_line|; in the latter case, further cropping is done.
13174 This is easier to program than to explain.
13176 @<Local variables for formatting...@>=
13177 int i; /* index into |buffer| */
13178 integer l; /* length of descriptive information on line 1 */
13179 integer m; /* context information gathered for line 2 */
13180 int n; /* length of line 1 */
13181 integer p; /* starting or ending place in |trick_buf| */
13182 integer q; /* temporary index */
13184 @ The following code tells the print routines to gather
13185 the desired information.
13187 @d begin_pseudoprint {
13188 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13189 mp->trick_count=1000000;
13191 @d set_trick_count {
13192 mp->first_count=mp->tally;
13193 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13194 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13197 @ And the following code uses the information after it has been gathered.
13199 @<Print two lines using the tricky pseudoprinted information@>=
13200 if ( mp->trick_count==1000000 ) set_trick_count;
13201 /* |set_trick_count| must be performed */
13202 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13203 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13204 if ( l+mp->first_count<=mp->half_error_line ) {
13205 p=0; n=l+mp->first_count;
13207 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13208 n=mp->half_error_line;
13210 for (q=p;q<=mp->first_count-1;q++) {
13211 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13214 for (q=1;q<=n;q++) {
13215 mp_print_char(mp, xord(' ')); /* print |n| spaces to begin line~2 */
13217 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13218 else p=mp->first_count+(mp->error_line-n-3);
13219 for (q=mp->first_count;q<=p-1;q++) {
13220 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13222 if ( m+n>mp->error_line ) mp_print(mp, "...")
13224 @ But the trick is distracting us from our current goal, which is to
13225 understand the input state. So let's concentrate on the data structures that
13226 are being pseudoprinted as we finish up the |show_context| procedure.
13228 @<Pseudoprint the line@>=
13231 for (i=start;i<=limit-1;i++) {
13232 if ( i==loc ) set_trick_count;
13233 mp_print_str(mp, mp->buffer[i]);
13237 @ @<Pseudoprint the token list@>=
13239 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13240 else mp_show_macro(mp, start,loc,100000)
13242 @ Here is the missing piece of |show_token_list| that is activated when the
13243 token beginning line~2 is about to be shown:
13245 @<Do magic computation@>=set_trick_count
13247 @* \[28] Maintaining the input stacks.
13248 The following subroutines change the input status in commonly needed ways.
13250 First comes |push_input|, which stores the current state and creates a
13251 new level (having, initially, the same properties as the old).
13253 @d push_input { /* enter a new input level, save the old */
13254 if ( mp->input_ptr>mp->max_in_stack ) {
13255 mp->max_in_stack=mp->input_ptr;
13256 if ( mp->input_ptr==mp->stack_size ) {
13257 int l = (mp->stack_size+(mp->stack_size/4));
13258 XREALLOC(mp->input_stack, l, in_state_record);
13259 mp->stack_size = l;
13262 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13263 incr(mp->input_ptr);
13266 @ And of course what goes up must come down.
13268 @d pop_input { /* leave an input level, re-enter the old */
13269 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13272 @ Here is a procedure that starts a new level of token-list input, given
13273 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13274 set |name|, reset~|loc|, and increase the macro's reference count.
13276 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13278 @c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13279 push_input; start=p; token_type=t;
13280 param_start=mp->param_ptr; loc=p;
13283 @ When a token list has been fully scanned, the following computations
13284 should be done as we leave that level of input.
13287 @c void mp_end_token_list (MP mp) { /* leave a token-list input level */
13288 pointer p; /* temporary register */
13289 if ( token_type>=backed_up ) { /* token list to be deleted */
13290 if ( token_type<=inserted ) {
13291 mp_flush_token_list(mp, start); goto DONE;
13293 mp_delete_mac_ref(mp, start); /* update reference count */
13296 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13297 decr(mp->param_ptr);
13298 p=mp->param_stack[mp->param_ptr];
13300 if ( mp_link(p)==mp_void ) { /* it's an \&{expr} parameter */
13301 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13303 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13308 pop_input; check_interrupt;
13311 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13312 token by the |cur_tok| routine.
13315 @c @<Declare the procedure called |make_exp_copy|@>
13316 pointer mp_cur_tok (MP mp) {
13317 pointer p; /* a new token node */
13318 quarterword save_type; /* |cur_type| to be restored */
13319 integer save_exp; /* |cur_exp| to be restored */
13320 if ( mp->cur_sym==0 ) {
13321 if ( mp->cur_cmd==capsule_token ) {
13322 save_type=mp->cur_type; save_exp=mp->cur_exp;
13323 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); mp_link(p)=null;
13324 mp->cur_type=save_type; mp->cur_exp=save_exp;
13326 p=mp_get_node(mp, token_node_size);
13327 value(p)=mp->cur_mod; name_type(p)=mp_token;
13328 if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
13329 else type(p)=mp_string_type;
13332 fast_get_avail(p); info(p)=mp->cur_sym;
13337 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13338 seen. The |back_input| procedure takes care of this by putting the token
13339 just scanned back into the input stream, ready to be read again.
13340 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13343 void mp_back_input (MP mp);
13345 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13346 pointer p; /* a token list of length one */
13348 while ( token_state &&(loc==null) )
13349 mp_end_token_list(mp); /* conserve stack space */
13353 @ The |back_error| routine is used when we want to restore or replace an
13354 offending token just before issuing an error message. We disable interrupts
13355 during the call of |back_input| so that the help message won't be lost.
13358 void mp_error (MP mp);
13359 void mp_back_error (MP mp);
13361 @ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
13362 mp->OK_to_interrupt=false;
13364 mp->OK_to_interrupt=true; mp_error(mp);
13366 void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13367 mp->OK_to_interrupt=false;
13368 mp_back_input(mp); token_type=inserted;
13369 mp->OK_to_interrupt=true; mp_error(mp);
13372 @ The |begin_file_reading| procedure starts a new level of input for lines
13373 of characters to be read from a file, or as an insertion from the
13374 terminal. It does not take care of opening the file, nor does it set |loc|
13375 or |limit| or |line|.
13376 @^system dependencies@>
13378 @c void mp_begin_file_reading (MP mp) {
13379 if ( mp->in_open==mp->max_in_open )
13380 mp_overflow(mp, "text input levels",mp->max_in_open);
13381 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13382 if ( mp->first==mp->buf_size )
13383 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4)));
13384 incr(mp->in_open); push_input; iindex=mp->in_open;
13385 mp->mpx_name[iindex]=absent;
13386 start=(halfword)mp->first;
13387 name=is_term; /* |terminal_input| is now |true| */
13390 @ Conversely, the variables must be downdated when such a level of input
13391 is finished. Any associated \.{MPX} file must also be closed and popped
13392 off the file stack.
13394 @c void mp_end_file_reading (MP mp) {
13395 if ( mp->in_open>iindex ) {
13396 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13397 mp_confusion(mp, "endinput");
13398 @:this can't happen endinput}{\quad endinput@>
13400 (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13401 delete_str_ref(mp->mpx_name[mp->in_open]);
13405 mp->first=(size_t)start;
13406 if ( iindex!=mp->in_open ) mp_confusion(mp, "endinput");
13407 if ( name>max_spec_src ) {
13408 (mp->close_file)(mp,cur_file);
13409 delete_str_ref(name);
13413 pop_input; decr(mp->in_open);
13416 @ Here is a function that tries to resume input from an \.{MPX} file already
13417 associated with the current input file. It returns |false| if this doesn't
13420 @c boolean mp_begin_mpx_reading (MP mp) {
13421 if ( mp->in_open!=iindex+1 ) {
13424 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13425 @:this can't happen mpx}{\quad mpx@>
13426 if ( mp->first==mp->buf_size )
13427 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4)));
13428 push_input; iindex=mp->in_open;
13429 start=(halfword)mp->first;
13430 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13431 @<Put an empty line in the input buffer@>;
13436 @ This procedure temporarily stops reading an \.{MPX} file.
13438 @c void mp_end_mpx_reading (MP mp) {
13439 if ( mp->in_open!=iindex ) mp_confusion(mp, "mpx");
13440 @:this can't happen mpx}{\quad mpx@>
13442 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13444 mp->first=(size_t)start;
13448 @ Here we enforce a restriction that simplifies the input stacks considerably.
13449 This should not inconvenience the user because \.{MPX} files are generated
13450 by an auxiliary program called \.{DVItoMP}.
13452 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13454 print_err("`mpxbreak' must be at the end of a line");
13455 help4("This file contains picture expressions for btex...etex",
13456 "blocks. Such files are normally generated automatically",
13457 "but this one seems to be messed up. I'm going to ignore",
13458 "the rest of this line.");
13462 @ In order to keep the stack from overflowing during a long sequence of
13463 inserted `\.{show}' commands, the following routine removes completed
13464 error-inserted lines from memory.
13466 @c void mp_clear_for_error_prompt (MP mp) {
13467 while ( file_state && terminal_input &&
13468 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13469 mp_print_ln(mp); clear_terminal;
13472 @ To get \MP's whole input mechanism going, we perform the following
13475 @<Initialize the input routines@>=
13476 { mp->input_ptr=0; mp->max_in_stack=0;
13477 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13478 mp->param_ptr=0; mp->max_param_stack=0;
13480 start=1; iindex=0; line=0; name=is_term;
13481 mp->mpx_name[0]=absent;
13482 mp->force_eof=false;
13483 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13484 limit=(halfword)mp->last; mp->first=mp->last+1;
13485 /* |init_terminal| has set |loc| and |last| */
13488 @* \[29] Getting the next token.
13489 The heart of \MP's input mechanism is the |get_next| procedure, which
13490 we shall develop in the next few sections of the program. Perhaps we
13491 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13492 eyes and mouth, reading the source files and gobbling them up. And it also
13493 helps \MP\ to regurgitate stored token lists that are to be processed again.
13495 The main duty of |get_next| is to input one token and to set |cur_cmd|
13496 and |cur_mod| to that token's command code and modifier. Furthermore, if
13497 the input token is a symbolic token, that token's |hash| address
13498 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13500 Underlying this simple description is a certain amount of complexity
13501 because of all the cases that need to be handled.
13502 However, the inner loop of |get_next| is reasonably short and fast.
13504 @ Before getting into |get_next|, we need to consider a mechanism by which
13505 \MP\ helps keep errors from propagating too far. Whenever the program goes
13506 into a mode where it keeps calling |get_next| repeatedly until a certain
13507 condition is met, it sets |scanner_status| to some value other than |normal|.
13508 Then if an input file ends, or if an `\&{outer}' symbol appears,
13509 an appropriate error recovery will be possible.
13511 The global variable |warning_info| helps in this error recovery by providing
13512 additional information. For example, |warning_info| might indicate the
13513 name of a macro whose replacement text is being scanned.
13515 @d normal 0 /* |scanner_status| at ``quiet times'' */
13516 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13517 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13518 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13519 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13520 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13521 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13522 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13525 integer scanner_status; /* are we scanning at high speed? */
13526 integer warning_info; /* if so, what else do we need to know,
13527 in case an error occurs? */
13529 @ @<Initialize the input routines@>=
13530 mp->scanner_status=normal;
13532 @ The following subroutine
13533 is called when an `\&{outer}' symbolic token has been scanned or
13534 when the end of a file has been reached. These two cases are distinguished
13535 by |cur_sym|, which is zero at the end of a file.
13537 @c boolean mp_check_outer_validity (MP mp) {
13538 pointer p; /* points to inserted token list */
13539 if ( mp->scanner_status==normal ) {
13541 } else if ( mp->scanner_status==tex_flushing ) {
13542 @<Check if the file has ended while flushing \TeX\ material and set the
13543 result value for |check_outer_validity|@>;
13545 mp->deletions_allowed=false;
13546 @<Back up an outer symbolic token so that it can be reread@>;
13547 if ( mp->scanner_status>skipping ) {
13548 @<Tell the user what has run away and try to recover@>;
13550 print_err("Incomplete if; all text was ignored after line ");
13551 @.Incomplete if...@>
13552 mp_print_int(mp, mp->warning_info);
13553 help3("A forbidden `outer' token occurred in skipped text.",
13554 "This kind of error happens when you say `if...' and forget",
13555 "the matching `fi'. I've inserted a `fi'; this might work.");
13556 if ( mp->cur_sym==0 )
13557 mp->help_line[2]="The file ended while I was skipping conditional text.";
13558 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13560 mp->deletions_allowed=true;
13565 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13566 if ( mp->cur_sym!=0 ) {
13569 mp->deletions_allowed=false;
13570 print_err("TeX mode didn't end; all text was ignored after line ");
13571 mp_print_int(mp, mp->warning_info);
13572 help2("The file ended while I was looking for the `etex' to",
13573 "finish this TeX material. I've inserted `etex' now.");
13574 mp->cur_sym = frozen_etex;
13576 mp->deletions_allowed=true;
13580 @ @<Back up an outer symbolic token so that it can be reread@>=
13581 if ( mp->cur_sym!=0 ) {
13582 p=mp_get_avail(mp); info(p)=mp->cur_sym;
13583 back_list(p); /* prepare to read the symbolic token again */
13586 @ @<Tell the user what has run away...@>=
13588 mp_runaway(mp); /* print the definition-so-far */
13589 if ( mp->cur_sym==0 ) {
13590 print_err("File ended");
13591 @.File ended while scanning...@>
13593 print_err("Forbidden token found");
13594 @.Forbidden token found...@>
13596 mp_print(mp, " while scanning ");
13597 help4("I suspect you have forgotten an `enddef',",
13598 "causing me to read past where you wanted me to stop.",
13599 "I'll try to recover; but if the error is serious,",
13600 "you'd better type `E' or `X' now and fix your file.");
13601 switch (mp->scanner_status) {
13602 @<Complete the error message,
13603 and set |cur_sym| to a token that might help recover from the error@>
13604 } /* there are no other cases */
13608 @ As we consider various kinds of errors, it is also appropriate to
13609 change the first line of the help message just given; |help_line[3]|
13610 points to the string that might be changed.
13612 @<Complete the error message,...@>=
13614 mp_print(mp, "to the end of the statement");
13615 mp->help_line[3]="A previous error seems to have propagated,";
13616 mp->cur_sym=frozen_semicolon;
13619 mp_print(mp, "a text argument");
13620 mp->help_line[3]="It seems that a right delimiter was left out,";
13621 if ( mp->warning_info==0 ) {
13622 mp->cur_sym=frozen_end_group;
13624 mp->cur_sym=frozen_right_delimiter;
13625 equiv(frozen_right_delimiter)=mp->warning_info;
13630 mp_print(mp, "the definition of ");
13631 if ( mp->scanner_status==op_defining )
13632 mp_print_text(mp->warning_info);
13634 mp_print_variable_name(mp, mp->warning_info);
13635 mp->cur_sym=frozen_end_def;
13637 case loop_defining:
13638 mp_print(mp, "the text of a ");
13639 mp_print_text(mp->warning_info);
13640 mp_print(mp, " loop");
13641 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13642 mp->cur_sym=frozen_end_for;
13645 @ The |runaway| procedure displays the first part of the text that occurred
13646 when \MP\ began its special |scanner_status|, if that text has been saved.
13648 @<Declare the procedure called |runaway|@>=
13649 void mp_runaway (MP mp) {
13650 if ( mp->scanner_status>flushing ) {
13651 mp_print_nl(mp, "Runaway ");
13652 switch (mp->scanner_status) {
13653 case absorbing: mp_print(mp, "text?"); break;
13655 case op_defining: mp_print(mp,"definition?"); break;
13656 case loop_defining: mp_print(mp, "loop?"); break;
13657 } /* there are no other cases */
13659 mp_show_token_list(mp, mp_link(hold_head),null,mp->error_line-10,0);
13663 @ We need to mention a procedure that may be called by |get_next|.
13666 void mp_firm_up_the_line (MP mp);
13668 @ And now we're ready to take the plunge into |get_next| itself.
13669 Note that the behavior depends on the |scanner_status| because percent signs
13670 and double quotes need to be passed over when skipping TeX material.
13673 void mp_get_next (MP mp) {
13674 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13676 /*restart*/ /* go here to get the next input token */
13677 /*exit*/ /* go here when the next input token has been got */
13678 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13679 /*found*/ /* go here when the end of a symbolic token has been found */
13680 /*switch*/ /* go here to branch on the class of an input character */
13681 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13682 /* go here at crucial stages when scanning a number */
13683 int k; /* an index into |buffer| */
13684 ASCII_code c; /* the current character in the buffer */
13685 int class; /* its class number */
13686 integer n,f; /* registers for decimal-to-binary conversion */
13689 if ( file_state ) {
13690 @<Input from external file; |goto restart| if no input found,
13691 or |return| if a non-symbolic token is found@>;
13693 @<Input from token list; |goto restart| if end of list or
13694 if a parameter needs to be expanded,
13695 or |return| if a non-symbolic token is found@>;
13698 @<Finish getting the symbolic token in |cur_sym|;
13699 |goto restart| if it is illegal@>;
13702 @ When a symbolic token is declared to be `\&{outer}', its command code
13703 is increased by |outer_tag|.
13706 @<Finish getting the symbolic token in |cur_sym|...@>=
13707 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13708 if ( mp->cur_cmd>=outer_tag ) {
13709 if ( mp_check_outer_validity(mp) )
13710 mp->cur_cmd=mp->cur_cmd-outer_tag;
13715 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13716 to have a special test for end-of-line.
13719 @<Input from external file;...@>=
13722 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13724 case digit_class: goto START_NUMERIC_TOKEN; break;
13726 class=mp->char_class[mp->buffer[loc]];
13727 if ( class>period_class ) {
13729 } else if ( class<period_class ) { /* |class=digit_class| */
13730 n=0; goto START_DECIMAL_TOKEN;
13734 case space_class: goto SWITCH; break;
13735 case percent_class:
13736 if ( mp->scanner_status==tex_flushing ) {
13737 if ( loc<limit ) goto SWITCH;
13739 @<Move to next line of file, or |goto restart| if there is no next line@>;
13744 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13745 else @<Get a string token and |return|@>;
13747 case isolated_classes:
13748 k=loc-1; goto FOUND; break;
13749 case invalid_class:
13750 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13751 else @<Decry the invalid character and |goto restart|@>;
13753 default: break; /* letters, etc. */
13756 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13758 START_NUMERIC_TOKEN:
13759 @<Get the integer part |n| of a numeric token;
13760 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13761 START_DECIMAL_TOKEN:
13762 @<Get the fraction part |f| of a numeric token@>;
13764 @<Pack the numeric and fraction parts of a numeric token
13767 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13770 @ We go to |restart| instead of to |SWITCH|, because we might enter
13771 |token_state| after the error has been dealt with
13772 (cf.\ |clear_for_error_prompt|).
13774 @<Decry the invalid...@>=
13776 print_err("Text line contains an invalid character");
13777 @.Text line contains...@>
13778 help2("A funny symbol that I can\'t read has just been input.",
13779 "Continue, and I'll forget that it ever happened.");
13780 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13784 @ @<Get a string token and |return|@>=
13786 if ( mp->buffer[loc]=='"' ) {
13787 mp->cur_mod=null_str;
13789 k=loc; mp->buffer[limit+1]=xord('"');
13792 } while (mp->buffer[loc]!='"');
13794 @<Decry the missing string delimiter and |goto restart|@>;
13797 mp->cur_mod=mp->buffer[k];
13801 append_char(mp->buffer[k]); incr(k);
13803 mp->cur_mod=mp_make_string(mp);
13806 incr(loc); mp->cur_cmd=string_token;
13810 @ We go to |restart| after this error message, not to |SWITCH|,
13811 because the |clear_for_error_prompt| routine might have reinstated
13812 |token_state| after |error| has finished.
13814 @<Decry the missing string delimiter and |goto restart|@>=
13816 loc=limit; /* the next character to be read on this line will be |"%"| */
13817 print_err("Incomplete string token has been flushed");
13818 @.Incomplete string token...@>
13819 help3("Strings should finish on the same line as they began.",
13820 "I've deleted the partial string; you might want to",
13821 "insert another by typing, e.g., `I\"new string\"'.");
13822 mp->deletions_allowed=false; mp_error(mp);
13823 mp->deletions_allowed=true;
13827 @ @<Get the integer part |n| of a numeric token...@>=
13829 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13830 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13833 if ( mp->buffer[loc]=='.' )
13834 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13837 goto FIN_NUMERIC_TOKEN;
13840 @ @<Get the fraction part |f| of a numeric token@>=
13843 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13844 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13847 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13848 f=mp_round_decimals(mp, k);
13853 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13855 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13856 } else if ( mp->scanner_status!=tex_flushing ) {
13857 print_err("Enormous number has been reduced");
13858 @.Enormous number...@>
13859 help2("I can\'t handle numbers bigger than 32767.99998;",
13860 "so I've changed your constant to that maximum amount.");
13861 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13862 mp->cur_mod=el_gordo;
13864 mp->cur_cmd=numeric_token; return
13866 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13868 mp->cur_mod=n*unity+f;
13869 if ( mp->cur_mod>=fraction_one ) {
13870 if ( (mp->internal[mp_warning_check]>0) &&
13871 (mp->scanner_status!=tex_flushing) ) {
13872 print_err("Number is too large (");
13873 mp_print_scaled(mp, mp->cur_mod);
13874 mp_print_char(mp, xord(')'));
13875 help3("It is at least 4096. Continue and I'll try to cope",
13876 "with that big value; but it might be dangerous.",
13877 "(Set warningcheck:=0 to suppress this message.)");
13883 @ Let's consider now what happens when |get_next| is looking at a token list.
13886 @<Input from token list;...@>=
13887 if ( loc>=mp->hi_mem_min ) { /* one-word token */
13888 mp->cur_sym=info(loc); loc=mp_link(loc); /* move to next */
13889 if ( mp->cur_sym>=expr_base ) {
13890 if ( mp->cur_sym>=suffix_base ) {
13891 @<Insert a suffix or text parameter and |goto restart|@>;
13893 mp->cur_cmd=capsule_token;
13894 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
13895 mp->cur_sym=0; return;
13898 } else if ( loc>null ) {
13899 @<Get a stored numeric or string or capsule token and |return|@>
13900 } else { /* we are done with this token list */
13901 mp_end_token_list(mp); goto RESTART; /* resume previous level */
13904 @ @<Insert a suffix or text parameter...@>=
13906 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
13907 /* |param_size=text_base-suffix_base| */
13908 mp_begin_token_list(mp,
13909 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
13914 @ @<Get a stored numeric or string or capsule token...@>=
13916 if ( name_type(loc)==mp_token ) {
13917 mp->cur_mod=value(loc);
13918 if ( type(loc)==mp_known ) {
13919 mp->cur_cmd=numeric_token;
13921 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
13924 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
13926 loc=mp_link(loc); return;
13929 @ All of the easy branches of |get_next| have now been taken care of.
13930 There is one more branch.
13932 @<Move to next line of file, or |goto restart|...@>=
13933 if ( name>max_spec_src) {
13934 @<Read next line of file into |buffer|, or
13935 |goto restart| if the file has ended@>;
13937 if ( mp->input_ptr>0 ) {
13938 /* text was inserted during error recovery or by \&{scantokens} */
13939 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
13941 if (mp->job_name == NULL && ( mp->selector<log_only || mp->selector>=write_file))
13942 mp_open_log_file(mp);
13943 if ( mp->interaction>mp_nonstop_mode ) {
13944 if ( limit==start ) /* previous line was empty */
13945 mp_print_nl(mp, "(Please type a command or say `end')");
13947 mp_print_ln(mp); mp->first=(size_t)start;
13948 prompt_input("*"); /* input on-line into |buffer| */
13950 limit=(halfword)mp->last; mp->buffer[limit]=xord('%');
13951 mp->first=(size_t)(limit+1); loc=start;
13953 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
13955 /* nonstop mode, which is intended for overnight batch processing,
13956 never waits for on-line input */
13960 @ The global variable |force_eof| is normally |false|; it is set |true|
13961 by an \&{endinput} command.
13964 boolean force_eof; /* should the next \&{input} be aborted early? */
13966 @ We must decrement |loc| in order to leave the buffer in a valid state
13967 when an error condition causes us to |goto restart| without calling
13968 |end_file_reading|.
13970 @<Read next line of file into |buffer|, or
13971 |goto restart| if the file has ended@>=
13973 incr(line); mp->first=(size_t)start;
13974 if ( ! mp->force_eof ) {
13975 if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
13976 mp_firm_up_the_line(mp); /* this sets |limit| */
13978 mp->force_eof=true;
13980 if ( mp->force_eof ) {
13981 mp->force_eof=false;
13983 if ( mpx_reading ) {
13984 @<Complain that the \.{MPX} file ended unexpectly; then set
13985 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
13987 mp_print_char(mp, xord(')')); decr(mp->open_parens);
13988 update_terminal; /* show user that file has been read */
13989 mp_end_file_reading(mp); /* resume previous level */
13990 if ( mp_check_outer_validity(mp) ) goto RESTART;
13994 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start; /* ready to read */
13997 @ We should never actually come to the end of an \.{MPX} file because such
13998 files should have an \&{mpxbreak} after the translation of the last
13999 \&{btex}$\,\ldots\,$\&{etex} block.
14001 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
14003 mp->mpx_name[iindex]=mpx_finished;
14004 print_err("mpx file ended unexpectedly");
14005 help4("The file had too few picture expressions for btex...etex",
14006 "blocks. Such files are normally generated automatically",
14007 "but this one got messed up. You might want to insert a",
14008 "picture expression now.");
14009 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
14010 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
14013 @ Sometimes we want to make it look as though we have just read a blank line
14014 without really doing so.
14016 @<Put an empty line in the input buffer@>=
14017 mp->last=mp->first; limit=(halfword)mp->last;
14018 /* simulate |input_ln| and |firm_up_the_line| */
14019 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start
14021 @ If the user has set the |mp_pausing| parameter to some positive value,
14022 and if nonstop mode has not been selected, each line of input is displayed
14023 on the terminal and the transcript file, followed by `\.{=>}'.
14024 \MP\ waits for a response. If the response is null (i.e., if nothing is
14025 typed except perhaps a few blank spaces), the original
14026 line is accepted as it stands; otherwise the line typed is
14027 used instead of the line in the file.
14029 @c void mp_firm_up_the_line (MP mp) {
14030 size_t k; /* an index into |buffer| */
14031 limit=(halfword)mp->last;
14032 if ((!mp->noninteractive)
14033 && (mp->internal[mp_pausing]>0 )
14034 && (mp->interaction>mp_nonstop_mode )) {
14035 wake_up_terminal; mp_print_ln(mp);
14036 if ( start<limit ) {
14037 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
14038 mp_print_str(mp, mp->buffer[k]);
14041 mp->first=(size_t)limit; prompt_input("=>"); /* wait for user response */
14043 if ( mp->last>mp->first ) {
14044 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
14045 mp->buffer[k+start-mp->first]=mp->buffer[k];
14047 limit=(halfword)(start+mp->last-mp->first);
14052 @* \[30] Dealing with \TeX\ material.
14053 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
14054 features need to be implemented at a low level in the scanning process
14055 so that \MP\ can stay in synch with the a preprocessor that treats
14056 blocks of \TeX\ material as they occur in the input file without trying
14057 to expand \MP\ macros. Thus we need a special version of |get_next|
14058 that does not expand macros and such but does handle \&{btex},
14059 \&{verbatimtex}, etc.
14061 The special version of |get_next| is called |get_t_next|. It works by flushing
14062 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
14063 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
14064 \&{btex}, and switching back when it sees \&{mpxbreak}.
14070 mp_primitive(mp, "btex",start_tex,btex_code);
14071 @:btex_}{\&{btex} primitive@>
14072 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
14073 @:verbatimtex_}{\&{verbatimtex} primitive@>
14074 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
14075 @:etex_}{\&{etex} primitive@>
14076 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
14077 @:mpx_break_}{\&{mpxbreak} primitive@>
14079 @ @<Cases of |print_cmd...@>=
14080 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
14081 else mp_print(mp, "verbatimtex"); break;
14082 case etex_marker: mp_print(mp, "etex"); break;
14083 case mpx_break: mp_print(mp, "mpxbreak"); break;
14085 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
14086 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
14089 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
14092 void mp_start_mpx_input (MP mp);
14095 void mp_t_next (MP mp) {
14096 int old_status; /* saves the |scanner_status| */
14097 integer old_info; /* saves the |warning_info| */
14098 while ( mp->cur_cmd<=max_pre_command ) {
14099 if ( mp->cur_cmd==mpx_break ) {
14100 if ( ! file_state || (mp->mpx_name[iindex]==absent) ) {
14101 @<Complain about a misplaced \&{mpxbreak}@>;
14103 mp_end_mpx_reading(mp);
14106 } else if ( mp->cur_cmd==start_tex ) {
14107 if ( token_state || (name<=max_spec_src) ) {
14108 @<Complain that we are not reading a file@>;
14109 } else if ( mpx_reading ) {
14110 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
14111 } else if ( (mp->cur_mod!=verbatim_code)&&
14112 (mp->mpx_name[iindex]!=mpx_finished) ) {
14113 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
14118 @<Complain about a misplaced \&{etex}@>;
14120 goto COMMON_ENDING;
14122 @<Flush the \TeX\ material@>;
14128 @ We could be in the middle of an operation such as skipping false conditional
14129 text when \TeX\ material is encountered, so we must be careful to save the
14132 @<Flush the \TeX\ material@>=
14133 old_status=mp->scanner_status;
14134 old_info=mp->warning_info;
14135 mp->scanner_status=tex_flushing;
14136 mp->warning_info=line;
14137 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14138 mp->scanner_status=old_status;
14139 mp->warning_info=old_info
14141 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14142 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14143 help4("This file contains picture expressions for btex...etex",
14144 "blocks. Such files are normally generated automatically",
14145 "but this one seems to be messed up. I'll just keep going",
14146 "and hope for the best.");
14150 @ @<Complain that we are not reading a file@>=
14151 { print_err("You can only use `btex' or `verbatimtex' in a file");
14152 help3("I'll have to ignore this preprocessor command because it",
14153 "only works when there is a file to preprocess. You might",
14154 "want to delete everything up to the next `etex`.");
14158 @ @<Complain about a misplaced \&{mpxbreak}@>=
14159 { print_err("Misplaced mpxbreak");
14160 help2("I'll ignore this preprocessor command because it",
14161 "doesn't belong here");
14165 @ @<Complain about a misplaced \&{etex}@>=
14166 { print_err("Extra etex will be ignored");
14167 help1("There is no btex or verbatimtex for this to match");
14171 @* \[31] Scanning macro definitions.
14172 \MP\ has a variety of ways to tuck tokens away into token lists for later
14173 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14174 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14175 All such operations are handled by the routines in this part of the program.
14177 The modifier part of each command code is zero for the ``ending delimiters''
14178 like \&{enddef} and \&{endfor}.
14180 @d start_def 1 /* command modifier for \&{def} */
14181 @d var_def 2 /* command modifier for \&{vardef} */
14182 @d end_def 0 /* command modifier for \&{enddef} */
14183 @d start_forever 1 /* command modifier for \&{forever} */
14184 @d end_for 0 /* command modifier for \&{endfor} */
14187 mp_primitive(mp, "def",macro_def,start_def);
14188 @:def_}{\&{def} primitive@>
14189 mp_primitive(mp, "vardef",macro_def,var_def);
14190 @:var_def_}{\&{vardef} primitive@>
14191 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14192 @:primary_def_}{\&{primarydef} primitive@>
14193 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14194 @:secondary_def_}{\&{secondarydef} primitive@>
14195 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14196 @:tertiary_def_}{\&{tertiarydef} primitive@>
14197 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14198 @:end_def_}{\&{enddef} primitive@>
14200 mp_primitive(mp, "for",iteration,expr_base);
14201 @:for_}{\&{for} primitive@>
14202 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14203 @:for_suffixes_}{\&{forsuffixes} primitive@>
14204 mp_primitive(mp, "forever",iteration,start_forever);
14205 @:forever_}{\&{forever} primitive@>
14206 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14207 @:end_for_}{\&{endfor} primitive@>
14209 @ @<Cases of |print_cmd...@>=
14211 if ( m<=var_def ) {
14212 if ( m==start_def ) mp_print(mp, "def");
14213 else if ( m<start_def ) mp_print(mp, "enddef");
14214 else mp_print(mp, "vardef");
14215 } else if ( m==secondary_primary_macro ) {
14216 mp_print(mp, "primarydef");
14217 } else if ( m==tertiary_secondary_macro ) {
14218 mp_print(mp, "secondarydef");
14220 mp_print(mp, "tertiarydef");
14224 if ( m<=start_forever ) {
14225 if ( m==start_forever ) mp_print(mp, "forever");
14226 else mp_print(mp, "endfor");
14227 } else if ( m==expr_base ) {
14228 mp_print(mp, "for");
14230 mp_print(mp, "forsuffixes");
14234 @ Different macro-absorbing operations have different syntaxes, but they
14235 also have a lot in common. There is a list of special symbols that are to
14236 be replaced by parameter tokens; there is a special command code that
14237 ends the definition; the quotation conventions are identical. Therefore
14238 it makes sense to have most of the work done by a single subroutine. That
14239 subroutine is called |scan_toks|.
14241 The first parameter to |scan_toks| is the command code that will
14242 terminate scanning (either |macro_def| or |iteration|).
14244 The second parameter, |subst_list|, points to a (possibly empty) list
14245 of two-word nodes whose |info| and |value| fields specify symbol tokens
14246 before and after replacement. The list will be returned to free storage
14249 The third parameter is simply appended to the token list that is built.
14250 And the final parameter tells how many of the special operations
14251 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14252 When such parameters are present, they are called \.{(SUFFIX0)},
14253 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14255 @c pointer mp_scan_toks (MP mp,command_code terminator, pointer
14256 subst_list, pointer tail_end, quarterword suffix_count) {
14257 pointer p; /* tail of the token list being built */
14258 pointer q; /* temporary for link management */
14259 integer balance; /* left delimiters minus right delimiters */
14260 p=hold_head; balance=1; mp_link(hold_head)=null;
14263 if ( mp->cur_sym>0 ) {
14264 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14265 if ( mp->cur_cmd==terminator ) {
14266 @<Adjust the balance; |break| if it's zero@>;
14267 } else if ( mp->cur_cmd==macro_special ) {
14268 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14271 mp_link(p)=mp_cur_tok(mp); p=mp_link(p);
14273 mp_link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14274 return mp_link(hold_head);
14277 @ @<Substitute for |cur_sym|...@>=
14280 while ( q!=null ) {
14281 if ( info(q)==mp->cur_sym ) {
14282 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14288 @ @<Adjust the balance; |break| if it's zero@>=
14289 if ( mp->cur_mod>0 ) {
14297 @ Four commands are intended to be used only within macro texts: \&{quote},
14298 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14299 code called |macro_special|.
14301 @d quote 0 /* |macro_special| modifier for \&{quote} */
14302 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14303 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14304 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14307 mp_primitive(mp, "quote",macro_special,quote);
14308 @:quote_}{\&{quote} primitive@>
14309 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14310 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14311 mp_primitive(mp, "@@",macro_special,macro_at);
14312 @:]]]\AT!_}{\.{\AT!} primitive@>
14313 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14314 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14316 @ @<Cases of |print_cmd...@>=
14317 case macro_special:
14319 case macro_prefix: mp_print(mp, "#@@"); break;
14320 case macro_at: mp_print_char(mp, xord('@@')); break;
14321 case macro_suffix: mp_print(mp, "@@#"); break;
14322 default: mp_print(mp, "quote"); break;
14326 @ @<Handle quoted...@>=
14328 if ( mp->cur_mod==quote ) { get_t_next; }
14329 else if ( mp->cur_mod<=suffix_count )
14330 mp->cur_sym=suffix_base-1+mp->cur_mod;
14333 @ Here is a routine that's used whenever a token will be redefined. If
14334 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14335 substituted; the latter is redefinable but essentially impossible to use,
14336 hence \MP's tables won't get fouled up.
14338 @c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14341 if ( (mp->cur_sym==0)||(mp->cur_sym>(integer)frozen_inaccessible) ) {
14342 print_err("Missing symbolic token inserted");
14343 @.Missing symbolic token...@>
14344 help3("Sorry: You can\'t redefine a number, string, or expr.",
14345 "I've inserted an inaccessible symbol so that your",
14346 "definition will be completed without mixing me up too badly.");
14347 if ( mp->cur_sym>0 )
14348 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14349 else if ( mp->cur_cmd==string_token )
14350 delete_str_ref(mp->cur_mod);
14351 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14355 @ Before we actually redefine a symbolic token, we need to clear away its
14356 former value, if it was a variable. The following stronger version of
14357 |get_symbol| does that.
14359 @c void mp_get_clear_symbol (MP mp) {
14360 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14363 @ Here's another little subroutine; it checks that an equals sign
14364 or assignment sign comes along at the proper place in a macro definition.
14366 @c void mp_check_equals (MP mp) {
14367 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14368 mp_missing_err(mp, "=");
14370 help5("The next thing in this `def' should have been `=',",
14371 "because I've already looked at the definition heading.",
14372 "But don't worry; I'll pretend that an equals sign",
14373 "was present. Everything from here to `enddef'",
14374 "will be the replacement text of this macro.");
14379 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14380 handled now that we have |scan_toks|. In this case there are
14381 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14382 |expr_base| and |expr_base+1|).
14384 @c void mp_make_op_def (MP mp) {
14385 command_code m; /* the type of definition */
14386 pointer p,q,r; /* for list manipulation */
14388 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14389 info(q)=mp->cur_sym; value(q)=expr_base;
14390 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14391 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14392 info(p)=mp->cur_sym; value(p)=expr_base+1; mp_link(p)=q;
14393 get_t_next; mp_check_equals(mp);
14394 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14395 r=mp_get_avail(mp); mp_link(q)=r; info(r)=general_macro;
14396 mp_link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14397 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14398 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14401 @ Parameters to macros are introduced by the keywords \&{expr},
14402 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14405 mp_primitive(mp, "expr",param_type,expr_base);
14406 @:expr_}{\&{expr} primitive@>
14407 mp_primitive(mp, "suffix",param_type,suffix_base);
14408 @:suffix_}{\&{suffix} primitive@>
14409 mp_primitive(mp, "text",param_type,text_base);
14410 @:text_}{\&{text} primitive@>
14411 mp_primitive(mp, "primary",param_type,primary_macro);
14412 @:primary_}{\&{primary} primitive@>
14413 mp_primitive(mp, "secondary",param_type,secondary_macro);
14414 @:secondary_}{\&{secondary} primitive@>
14415 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14416 @:tertiary_}{\&{tertiary} primitive@>
14418 @ @<Cases of |print_cmd...@>=
14420 if ( m>=expr_base ) {
14421 if ( m==expr_base ) mp_print(mp, "expr");
14422 else if ( m==suffix_base ) mp_print(mp, "suffix");
14423 else mp_print(mp, "text");
14424 } else if ( m<secondary_macro ) {
14425 mp_print(mp, "primary");
14426 } else if ( m==secondary_macro ) {
14427 mp_print(mp, "secondary");
14429 mp_print(mp, "tertiary");
14433 @ Let's turn next to the more complex processing associated with \&{def}
14434 and \&{vardef}. When the following procedure is called, |cur_mod|
14435 should be either |start_def| or |var_def|.
14437 @c @<Declare the procedure called |check_delimiter|@>
14438 @<Declare the function called |scan_declared_variable|@>
14439 void mp_scan_def (MP mp) {
14440 int m; /* the type of definition */
14441 int n; /* the number of special suffix parameters */
14442 int k; /* the total number of parameters */
14443 int c; /* the kind of macro we're defining */
14444 pointer r; /* parameter-substitution list */
14445 pointer q; /* tail of the macro token list */
14446 pointer p; /* temporary storage */
14447 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14448 pointer l_delim,r_delim; /* matching delimiters */
14449 m=mp->cur_mod; c=general_macro; mp_link(hold_head)=null;
14450 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14451 @<Scan the token or variable to be defined;
14452 set |n|, |scanner_status|, and |warning_info|@>;
14454 if ( mp->cur_cmd==left_delimiter ) {
14455 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14457 if ( mp->cur_cmd==param_type ) {
14458 @<Absorb undelimited parameters, putting them into list |r|@>;
14460 mp_check_equals(mp);
14461 p=mp_get_avail(mp); info(p)=c; mp_link(q)=p;
14462 @<Attach the replacement text to the tail of node |p|@>;
14463 mp->scanner_status=normal; mp_get_x_next(mp);
14466 @ We don't put `|frozen_end_group|' into the replacement text of
14467 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14469 @<Attach the replacement text to the tail of node |p|@>=
14470 if ( m==start_def ) {
14471 mp_link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14473 q=mp_get_avail(mp); info(q)=mp->bg_loc; mp_link(p)=q;
14474 p=mp_get_avail(mp); info(p)=mp->eg_loc;
14475 mp_link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14477 if ( mp->warning_info==bad_vardef )
14478 mp_flush_token_list(mp, value(bad_vardef))
14482 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14484 @ @<Scan the token or variable to be defined;...@>=
14485 if ( m==start_def ) {
14486 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14487 mp->scanner_status=op_defining; n=0;
14488 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14490 p=mp_scan_declared_variable(mp);
14491 mp_flush_variable(mp, equiv(info(p)),mp_link(p),true);
14492 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14493 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14494 mp->scanner_status=var_defining; n=2;
14495 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14498 type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14499 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14501 @ @<Change to `\.{a bad variable}'@>=
14503 print_err("This variable already starts with a macro");
14504 @.This variable already...@>
14505 help2("After `vardef a' you can\'t say `vardef a.b'.",
14506 "So I'll have to discard this definition.");
14507 mp_error(mp); mp->warning_info=bad_vardef;
14510 @ @<Initialize table entries...@>=
14511 name_type(bad_vardef)=mp_root; mp_link(bad_vardef)=frozen_bad_vardef;
14512 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14514 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14516 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14517 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14520 print_err("Missing parameter type; `expr' will be assumed");
14521 @.Missing parameter type@>
14522 help1("You should've had `expr' or `suffix' or `text' here.");
14523 mp_back_error(mp); base=expr_base;
14525 @<Absorb parameter tokens for type |base|@>;
14526 mp_check_delimiter(mp, l_delim,r_delim);
14528 } while (mp->cur_cmd==left_delimiter)
14530 @ @<Absorb parameter tokens for type |base|@>=
14532 mp_link(q)=mp_get_avail(mp); q=mp_link(q); info(q)=base+k;
14533 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14534 value(p)=base+k; info(p)=mp->cur_sym;
14535 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14536 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14537 incr(k); mp_link(p)=r; r=p; get_t_next;
14538 } while (mp->cur_cmd==comma)
14540 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14542 p=mp_get_node(mp, token_node_size);
14543 if ( mp->cur_mod<expr_base ) {
14544 c=mp->cur_mod; value(p)=expr_base+k;
14546 value(p)=mp->cur_mod+k;
14547 if ( mp->cur_mod==expr_base ) c=expr_macro;
14548 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14551 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14552 incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; mp_link(p)=r; r=p; get_t_next;
14553 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14554 c=of_macro; p=mp_get_node(mp, token_node_size);
14555 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14556 value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
14557 mp_link(p)=r; r=p; get_t_next;
14561 @* \[32] Expanding the next token.
14562 Only a few command codes |<min_command| can possibly be returned by
14563 |get_t_next|; in increasing order, they are
14564 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14565 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14567 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14568 like |get_t_next| except that it keeps getting more tokens until
14569 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14570 macros and removes conditionals or iterations or input instructions that
14573 It follows that |get_x_next| might invoke itself recursively. In fact,
14574 there is massive recursion, since macro expansion can involve the
14575 scanning of arbitrarily complex expressions, which in turn involve
14576 macro expansion and conditionals, etc.
14579 Therefore it's necessary to declare a whole bunch of |forward|
14580 procedures at this point, and to insert some other procedures
14581 that will be invoked by |get_x_next|.
14584 void mp_scan_primary (MP mp);
14585 void mp_scan_secondary (MP mp);
14586 void mp_scan_tertiary (MP mp);
14587 void mp_scan_expression (MP mp);
14588 void mp_scan_suffix (MP mp);
14589 @<Declare the procedure called |macro_call|@>
14590 void mp_get_boolean (MP mp);
14591 void mp_pass_text (MP mp);
14592 void mp_conditional (MP mp);
14593 void mp_start_input (MP mp);
14594 void mp_begin_iteration (MP mp);
14595 void mp_resume_iteration (MP mp);
14596 void mp_stop_iteration (MP mp);
14598 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14599 when it has to do exotic expansion commands.
14601 @c void mp_expand (MP mp) {
14602 pointer p; /* for list manipulation */
14603 size_t k; /* something that we hope is |<=buf_size| */
14604 pool_pointer j; /* index into |str_pool| */
14605 if ( mp->internal[mp_tracing_commands]>unity )
14606 if ( mp->cur_cmd!=defined_macro )
14608 switch (mp->cur_cmd) {
14610 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14613 @<Terminate the current conditional and skip to \&{fi}@>;
14616 @<Initiate or terminate input from a file@>;
14619 if ( mp->cur_mod==end_for ) {
14620 @<Scold the user for having an extra \&{endfor}@>;
14622 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14629 @<Exit a loop if the proper time has come@>;
14634 @<Expand the token after the next token@>;
14637 @<Put a string into the input buffer@>;
14639 case defined_macro:
14640 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14642 }; /* there are no other cases */
14645 @ @<Scold the user...@>=
14647 print_err("Extra `endfor'");
14649 help2("I'm not currently working on a for loop,",
14650 "so I had better not try to end anything.");
14654 @ The processing of \&{input} involves the |start_input| subroutine,
14655 which will be declared later; the processing of \&{endinput} is trivial.
14658 mp_primitive(mp, "input",input,0);
14659 @:input_}{\&{input} primitive@>
14660 mp_primitive(mp, "endinput",input,1);
14661 @:end_input_}{\&{endinput} primitive@>
14663 @ @<Cases of |print_cmd_mod|...@>=
14665 if ( m==0 ) mp_print(mp, "input");
14666 else mp_print(mp, "endinput");
14669 @ @<Initiate or terminate input...@>=
14670 if ( mp->cur_mod>0 ) mp->force_eof=true;
14671 else mp_start_input(mp)
14673 @ We'll discuss the complicated parts of loop operations later. For now
14674 it suffices to know that there's a global variable called |loop_ptr|
14675 that will be |null| if no loop is in progress.
14678 { while ( token_state &&(loc==null) )
14679 mp_end_token_list(mp); /* conserve stack space */
14680 if ( mp->loop_ptr==null ) {
14681 print_err("Lost loop");
14683 help2("I'm confused; after exiting from a loop, I still seem",
14684 "to want to repeat it. I'll try to forget the problem.");
14687 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14691 @ @<Exit a loop if the proper time has come@>=
14692 { mp_get_boolean(mp);
14693 if ( mp->internal[mp_tracing_commands]>unity )
14694 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14695 if ( mp->cur_exp==true_code ) {
14696 if ( mp->loop_ptr==null ) {
14697 print_err("No loop is in progress");
14698 @.No loop is in progress@>
14699 help1("Why say `exitif' when there's nothing to exit from?");
14700 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14702 @<Exit prematurely from an iteration@>;
14704 } else if ( mp->cur_cmd!=semicolon ) {
14705 mp_missing_err(mp, ";");
14707 help2("After `exitif <boolean exp>' I expect to see a semicolon.",
14708 "I shall pretend that one was there."); mp_back_error(mp);
14712 @ Here we use the fact that |forever_text| is the only |token_type| that
14713 is less than |loop_text|.
14715 @<Exit prematurely...@>=
14718 if ( file_state ) {
14719 mp_end_file_reading(mp);
14721 if ( token_type<=loop_text ) p=start;
14722 mp_end_token_list(mp);
14725 if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14727 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14730 @ @<Expand the token after the next token@>=
14732 p=mp_cur_tok(mp); get_t_next;
14733 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14734 else mp_back_input(mp);
14738 @ @<Put a string into the input buffer@>=
14739 { mp_get_x_next(mp); mp_scan_primary(mp);
14740 if ( mp->cur_type!=mp_string_type ) {
14741 mp_disp_err(mp, null,"Not a string");
14743 help2("I'm going to flush this expression, since",
14744 "scantokens should be followed by a known string.");
14745 mp_put_get_flush_error(mp, 0);
14748 if ( length(mp->cur_exp)>0 )
14749 @<Pretend we're reading a new one-line file@>;
14753 @ @<Pretend we're reading a new one-line file@>=
14754 { mp_begin_file_reading(mp); name=is_scantok;
14755 k=mp->first+length(mp->cur_exp);
14756 if ( k>=mp->max_buf_stack ) {
14757 while ( k>=mp->buf_size ) {
14758 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4)));
14760 mp->max_buf_stack=k+1;
14762 j=mp->str_start[mp->cur_exp]; limit=(halfword)k;
14763 while ( mp->first<(size_t)limit ) {
14764 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14766 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start;
14767 mp_flush_cur_exp(mp, 0);
14770 @ Here finally is |get_x_next|.
14772 The expression scanning routines to be considered later
14773 communicate via the global quantities |cur_type| and |cur_exp|;
14774 we must be very careful to save and restore these quantities while
14775 macros are being expanded.
14779 void mp_get_x_next (MP mp);
14781 @ @c void mp_get_x_next (MP mp) {
14782 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14784 if ( mp->cur_cmd<min_command ) {
14785 save_exp=mp_stash_cur_exp(mp);
14787 if ( mp->cur_cmd==defined_macro )
14788 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14792 } while (mp->cur_cmd<min_command);
14793 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14797 @ Now let's consider the |macro_call| procedure, which is used to start up
14798 all user-defined macros. Since the arguments to a macro might be expressions,
14799 |macro_call| is recursive.
14802 The first parameter to |macro_call| points to the reference count of the
14803 token list that defines the macro. The second parameter contains any
14804 arguments that have already been parsed (see below). The third parameter
14805 points to the symbolic token that names the macro. If the third parameter
14806 is |null|, the macro was defined by \&{vardef}, so its name can be
14807 reconstructed from the prefix and ``at'' arguments found within the
14810 What is this second parameter? It's simply a linked list of one-word items,
14811 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14812 no arguments have been scanned yet; otherwise |info(arg_list)| points to
14813 the first scanned argument, and |mp_link(arg_list)| points to the list of
14814 further arguments (if any).
14816 Arguments of type \&{expr} are so-called capsules, which we will
14817 discuss later when we concentrate on expressions; they can be
14818 recognized easily because their |link| field is |void|. Arguments of type
14819 \&{suffix} and \&{text} are token lists without reference counts.
14821 @ After argument scanning is complete, the arguments are moved to the
14822 |param_stack|. (They can't be put on that stack any sooner, because
14823 the stack is growing and shrinking in unpredictable ways as more arguments
14824 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14825 the replacement text of the macro is placed at the top of the \MP's
14826 input stack, so that |get_t_next| will proceed to read it next.
14828 @<Declare the procedure called |macro_call|@>=
14829 @<Declare the procedure called |print_macro_name|@>
14830 @<Declare the procedure called |print_arg|@>
14831 @<Declare the procedure called |scan_text_arg|@>
14832 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14833 pointer macro_name) ;
14836 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14837 pointer macro_name) {
14838 /* invokes a user-defined control sequence */
14839 pointer r; /* current node in the macro's token list */
14840 pointer p,q; /* for list manipulation */
14841 integer n; /* the number of arguments */
14842 pointer tail = 0; /* tail of the argument list */
14843 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14844 r=mp_link(def_ref); add_mac_ref(def_ref);
14845 if ( arg_list==null ) {
14848 @<Determine the number |n| of arguments already supplied,
14849 and set |tail| to the tail of |arg_list|@>;
14851 if ( mp->internal[mp_tracing_macros]>0 ) {
14852 @<Show the text of the macro being expanded, and the existing arguments@>;
14854 @<Scan the remaining arguments, if any; set |r| to the first token
14855 of the replacement text@>;
14856 @<Feed the arguments and replacement text to the scanner@>;
14859 @ @<Show the text of the macro...@>=
14860 mp_begin_diagnostic(mp); mp_print_ln(mp);
14861 mp_print_macro_name(mp, arg_list,macro_name);
14862 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14863 mp_show_macro(mp, def_ref,null,100000);
14864 if ( arg_list!=null ) {
14868 mp_print_arg(mp, q,n,0);
14869 incr(n); p=mp_link(p);
14872 mp_end_diagnostic(mp, false)
14875 @ @<Declare the procedure called |print_macro_name|@>=
14876 void mp_print_macro_name (MP mp,pointer a, pointer n);
14879 void mp_print_macro_name (MP mp,pointer a, pointer n) {
14880 pointer p,q; /* they traverse the first part of |a| */
14886 mp_print_text(info(info(mp_link(a))));
14889 while ( mp_link(q)!=null ) q=mp_link(q);
14890 mp_link(q)=info(mp_link(a));
14891 mp_show_token_list(mp, p,null,1000,0);
14897 @ @<Declare the procedure called |print_arg|@>=
14898 void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
14901 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
14902 if ( mp_link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
14903 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
14904 else mp_print_nl(mp, "(TEXT");
14905 mp_print_int(mp, n); mp_print(mp, ")<-");
14906 if ( mp_link(q)==mp_void ) mp_print_exp(mp, q,1);
14907 else mp_show_token_list(mp, q,null,1000,0);
14910 @ @<Determine the number |n| of arguments already supplied...@>=
14912 n=1; tail=arg_list;
14913 while ( mp_link(tail)!=null ) {
14914 incr(n); tail=mp_link(tail);
14918 @ @<Scan the remaining arguments, if any; set |r|...@>=
14919 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
14920 while ( info(r)>=expr_base ) {
14921 @<Scan the delimited argument represented by |info(r)|@>;
14924 if ( mp->cur_cmd==comma ) {
14925 print_err("Too many arguments to ");
14926 @.Too many arguments...@>
14927 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, xord(';'));
14928 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
14930 mp_print(mp, "' has been inserted");
14931 help3("I'm going to assume that the comma I just read was a",
14932 "right delimiter, and then I'll begin expanding the macro.",
14933 "You might want to delete some tokens before continuing.");
14936 if ( info(r)!=general_macro ) {
14937 @<Scan undelimited argument(s)@>;
14941 @ At this point, the reader will find it advisable to review the explanation
14942 of token list format that was presented earlier, paying special attention to
14943 the conventions that apply only at the beginning of a macro's token list.
14945 On the other hand, the reader will have to take the expression-parsing
14946 aspects of the following program on faith; we will explain |cur_type|
14947 and |cur_exp| later. (Several things in this program depend on each other,
14948 and it's necessary to jump into the circle somewhere.)
14950 @<Scan the delimited argument represented by |info(r)|@>=
14951 if ( mp->cur_cmd!=comma ) {
14953 if ( mp->cur_cmd!=left_delimiter ) {
14954 print_err("Missing argument to ");
14955 @.Missing argument...@>
14956 mp_print_macro_name(mp, arg_list,macro_name);
14957 help3("That macro has more parameters than you thought.",
14958 "I'll continue by pretending that each missing argument",
14959 "is either zero or null.");
14960 if ( info(r)>=suffix_base ) {
14961 mp->cur_exp=null; mp->cur_type=mp_token_list;
14963 mp->cur_exp=0; mp->cur_type=mp_known;
14965 mp_back_error(mp); mp->cur_cmd=right_delimiter;
14968 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
14970 @<Scan the argument represented by |info(r)|@>;
14971 if ( mp->cur_cmd!=comma )
14972 @<Check that the proper right delimiter was present@>;
14974 @<Append the current expression to |arg_list|@>
14976 @ @<Check that the proper right delim...@>=
14977 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
14978 if ( info(mp_link(r))>=expr_base ) {
14979 mp_missing_err(mp, ",");
14981 help3("I've finished reading a macro argument and am about to",
14982 "read another; the arguments weren't delimited correctly.",
14983 "You might want to delete some tokens before continuing.");
14984 mp_back_error(mp); mp->cur_cmd=comma;
14986 mp_missing_err(mp, str(text(r_delim)));
14988 help2("I've gotten to the end of the macro parameter list.",
14989 "You might want to delete some tokens before continuing.");
14994 @ A \&{suffix} or \&{text} parameter will have been scanned as
14995 a token list pointed to by |cur_exp|, in which case we will have
14996 |cur_type=token_list|.
14998 @<Append the current expression to |arg_list|@>=
15000 p=mp_get_avail(mp);
15001 if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
15002 else info(p)=mp_stash_cur_exp(mp);
15003 if ( mp->internal[mp_tracing_macros]>0 ) {
15004 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
15005 mp_end_diagnostic(mp, false);
15007 if ( arg_list==null ) arg_list=p;
15008 else mp_link(tail)=p;
15012 @ @<Scan the argument represented by |info(r)|@>=
15013 if ( info(r)>=text_base ) {
15014 mp_scan_text_arg(mp, l_delim,r_delim);
15017 if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
15018 else mp_scan_expression(mp);
15021 @ The parameters to |scan_text_arg| are either a pair of delimiters
15022 or zero; the latter case is for undelimited text arguments, which
15023 end with the first semicolon or \&{endgroup} or \&{end} that is not
15024 contained in a group.
15026 @<Declare the procedure called |scan_text_arg|@>=
15027 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
15030 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
15031 integer balance; /* excess of |l_delim| over |r_delim| */
15032 pointer p; /* list tail */
15033 mp->warning_info=l_delim; mp->scanner_status=absorbing;
15034 p=hold_head; balance=1; mp_link(hold_head)=null;
15037 if ( l_delim==0 ) {
15038 @<Adjust the balance for an undelimited argument; |break| if done@>;
15040 @<Adjust the balance for a delimited argument; |break| if done@>;
15042 mp_link(p)=mp_cur_tok(mp); p=mp_link(p);
15044 mp->cur_exp=mp_link(hold_head); mp->cur_type=mp_token_list;
15045 mp->scanner_status=normal;
15048 @ @<Adjust the balance for a delimited argument...@>=
15049 if ( mp->cur_cmd==right_delimiter ) {
15050 if ( mp->cur_mod==l_delim ) {
15052 if ( balance==0 ) break;
15054 } else if ( mp->cur_cmd==left_delimiter ) {
15055 if ( mp->cur_mod==r_delim ) incr(balance);
15058 @ @<Adjust the balance for an undelimited...@>=
15059 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
15060 if ( balance==1 ) { break; }
15061 else { if ( mp->cur_cmd==end_group ) decr(balance); }
15062 } else if ( mp->cur_cmd==begin_group ) {
15066 @ @<Scan undelimited argument(s)@>=
15068 if ( info(r)<text_macro ) {
15070 if ( info(r)!=suffix_macro ) {
15071 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
15075 case primary_macro:mp_scan_primary(mp); break;
15076 case secondary_macro:mp_scan_secondary(mp); break;
15077 case tertiary_macro:mp_scan_tertiary(mp); break;
15078 case expr_macro:mp_scan_expression(mp); break;
15080 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
15083 @<Scan a suffix with optional delimiters@>;
15085 case text_macro:mp_scan_text_arg(mp, 0,0); break;
15086 } /* there are no other cases */
15088 @<Append the current expression to |arg_list|@>;
15091 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
15093 mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
15094 if ( mp->internal[mp_tracing_macros]>0 ) {
15095 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
15096 mp_end_diagnostic(mp, false);
15098 if ( arg_list==null ) arg_list=p; else mp_link(tail)=p;
15100 if ( mp->cur_cmd!=of_token ) {
15101 mp_missing_err(mp, "of"); mp_print(mp, " for ");
15103 mp_print_macro_name(mp, arg_list,macro_name);
15104 help1("I've got the first argument; will look now for the other.");
15107 mp_get_x_next(mp); mp_scan_primary(mp);
15110 @ @<Scan a suffix with optional delimiters@>=
15112 if ( mp->cur_cmd!=left_delimiter ) {
15115 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
15117 mp_scan_suffix(mp);
15118 if ( l_delim!=null ) {
15119 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15120 mp_missing_err(mp, str(text(r_delim)));
15122 help2("I've gotten to the end of the macro parameter list.",
15123 "You might want to delete some tokens before continuing.");
15130 @ Before we put a new token list on the input stack, it is wise to clean off
15131 all token lists that have recently been depleted. Then a user macro that ends
15132 with a call to itself will not require unbounded stack space.
15134 @<Feed the arguments and replacement text to the scanner@>=
15135 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15136 if ( mp->param_ptr+n>mp->max_param_stack ) {
15137 mp->max_param_stack=mp->param_ptr+n;
15138 if ( mp->max_param_stack>mp->param_size )
15139 mp_overflow(mp, "parameter stack size",mp->param_size);
15140 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15142 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15146 mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=mp_link(p);
15148 mp_flush_list(mp, arg_list);
15151 @ It's sometimes necessary to put a single argument onto |param_stack|.
15152 The |stack_argument| subroutine does this.
15154 @c void mp_stack_argument (MP mp,pointer p) {
15155 if ( mp->param_ptr==mp->max_param_stack ) {
15156 incr(mp->max_param_stack);
15157 if ( mp->max_param_stack>mp->param_size )
15158 mp_overflow(mp, "parameter stack size",mp->param_size);
15159 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15161 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15164 @* \[33] Conditional processing.
15165 Let's consider now the way \&{if} commands are handled.
15167 Conditions can be inside conditions, and this nesting has a stack
15168 that is independent of other stacks.
15169 Four global variables represent the top of the condition stack:
15170 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15171 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15172 the largest code of a |fi_or_else| command that is syntactically legal;
15173 and |if_line| is the line number at which the current conditional began.
15175 If no conditions are currently in progress, the condition stack has the
15176 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15177 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15178 |link| fields of the first word contain |if_limit|, |cur_if|, and
15179 |cond_ptr| at the next level, and the second word contains the
15180 corresponding |if_line|.
15182 @d if_node_size 2 /* number of words in stack entry for conditionals */
15183 @d if_line_field(A) mp->mem[(A)+1].cint
15184 @d if_code 1 /* code for \&{if} being evaluated */
15185 @d fi_code 2 /* code for \&{fi} */
15186 @d else_code 3 /* code for \&{else} */
15187 @d else_if_code 4 /* code for \&{elseif} */
15190 pointer cond_ptr; /* top of the condition stack */
15191 integer if_limit; /* upper bound on |fi_or_else| codes */
15192 quarterword cur_if; /* type of conditional being worked on */
15193 integer if_line; /* line where that conditional began */
15196 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15199 mp_primitive(mp, "if",if_test,if_code);
15200 @:if_}{\&{if} primitive@>
15201 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15202 @:fi_}{\&{fi} primitive@>
15203 mp_primitive(mp, "else",fi_or_else,else_code);
15204 @:else_}{\&{else} primitive@>
15205 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15206 @:else_if_}{\&{elseif} primitive@>
15208 @ @<Cases of |print_cmd_mod|...@>=
15212 case if_code:mp_print(mp, "if"); break;
15213 case fi_code:mp_print(mp, "fi"); break;
15214 case else_code:mp_print(mp, "else"); break;
15215 default: mp_print(mp, "elseif"); break;
15219 @ Here is a procedure that ignores text until coming to an \&{elseif},
15220 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15221 nesting. After it has acted, |cur_mod| will indicate the token that
15224 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15225 makes the skipping process a bit simpler.
15228 void mp_pass_text (MP mp) {
15230 mp->scanner_status=skipping;
15231 mp->warning_info=mp_true_line(mp);
15234 if ( mp->cur_cmd<=fi_or_else ) {
15235 if ( mp->cur_cmd<fi_or_else ) {
15239 if ( mp->cur_mod==fi_code ) decr(l);
15242 @<Decrease the string reference count,
15243 if the current token is a string@>;
15246 mp->scanner_status=normal;
15249 @ @<Decrease the string reference count...@>=
15250 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15252 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15253 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15254 condition has been evaluated, a colon will be inserted.
15255 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15257 @<Push the condition stack@>=
15258 { p=mp_get_node(mp, if_node_size); mp_link(p)=mp->cond_ptr; type(p)=mp->if_limit;
15259 name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15260 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15261 mp->cur_if=if_code;
15264 @ @<Pop the condition stack@>=
15265 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15266 mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=mp_link(p);
15267 mp_free_node(mp, p,if_node_size);
15270 @ Here's a procedure that changes the |if_limit| code corresponding to
15271 a given value of |cond_ptr|.
15273 @c void mp_change_if_limit (MP mp,quarterword l, pointer p) {
15275 if ( p==mp->cond_ptr ) {
15276 mp->if_limit=l; /* that's the easy case */
15280 if ( q==null ) mp_confusion(mp, "if");
15281 @:this can't happen if}{\quad if@>
15282 if ( mp_link(q)==p ) {
15290 @ The user is supposed to put colons into the proper parts of conditional
15291 statements. Therefore, \MP\ has to check for their presence.
15294 void mp_check_colon (MP mp) {
15295 if ( mp->cur_cmd!=colon ) {
15296 mp_missing_err(mp, ":");
15298 help2("There should've been a colon after the condition.",
15299 "I shall pretend that one was there.");
15304 @ A condition is started when the |get_x_next| procedure encounters
15305 an |if_test| command; in that case |get_x_next| calls |conditional|,
15306 which is a recursive procedure.
15309 @c void mp_conditional (MP mp) {
15310 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15311 int new_if_limit; /* future value of |if_limit| */
15312 pointer p; /* temporary register */
15313 @<Push the condition stack@>;
15314 save_cond_ptr=mp->cond_ptr;
15316 mp_get_boolean(mp); new_if_limit=else_if_code;
15317 if ( mp->internal[mp_tracing_commands]>unity ) {
15318 @<Display the boolean value of |cur_exp|@>;
15321 mp_check_colon(mp);
15322 if ( mp->cur_exp==true_code ) {
15323 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15324 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15326 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15328 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15329 if ( mp->cur_mod==fi_code ) {
15330 @<Pop the condition stack@>
15331 } else if ( mp->cur_mod==else_if_code ) {
15334 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15339 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15340 \&{else}: \\{bar} \&{fi}', the first \&{else}
15341 that we come to after learning that the \&{if} is false is not the
15342 \&{else} we're looking for. Hence the following curious logic is needed.
15344 @<Skip to \&{elseif}...@>=
15347 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15348 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15352 @ @<Display the boolean value...@>=
15353 { mp_begin_diagnostic(mp);
15354 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15355 else mp_print(mp, "{false}");
15356 mp_end_diagnostic(mp, false);
15359 @ The processing of conditionals is complete except for the following
15360 code, which is actually part of |get_x_next|. It comes into play when
15361 \&{elseif}, \&{else}, or \&{fi} is scanned.
15363 @<Terminate the current conditional and skip to \&{fi}@>=
15364 if ( mp->cur_mod>mp->if_limit ) {
15365 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15366 mp_missing_err(mp, ":");
15368 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15370 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15374 help1("I'm ignoring this; it doesn't match any if.");
15378 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15379 @<Pop the condition stack@>;
15382 @* \[34] Iterations.
15383 To bring our treatment of |get_x_next| to a close, we need to consider what
15384 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15386 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15387 that are currently active. If |loop_ptr=null|, no loops are in progress;
15388 otherwise |info(loop_ptr)| points to the iterative text of the current
15389 (innermost) loop, and |mp_link(loop_ptr)| points to the data for any other
15390 loops that enclose the current one.
15392 A loop-control node also has two other fields, called |loop_type| and
15393 |loop_list|, whose contents depend on the type of loop:
15395 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15396 points to a list of one-word nodes whose |info| fields point to the
15397 remaining argument values of a suffix list and expression list.
15399 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15402 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15403 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15404 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15407 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15408 header and |loop_list(loop_ptr)| points into the graphical object list for
15411 \yskip\noindent In the case of a progression node, the first word is not used
15412 because the link field of words in the dynamic memory area cannot be arbitrary.
15414 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15415 @d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
15416 @d loop_list(A) mp_link(loop_list_loc((A))) /* the remaining list elements */
15417 @d loop_node_size 2 /* the number of words in a loop control node */
15418 @d progression_node_size 4 /* the number of words in a progression node */
15419 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15420 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15421 @d progression_flag (null+2)
15422 /* |loop_type| value when |loop_list| points to a progression node */
15425 pointer loop_ptr; /* top of the loop-control-node stack */
15430 @ If the expressions that define an arithmetic progression in
15431 a \&{for} loop don't have known numeric values, the |bad_for|
15432 subroutine screams at the user.
15434 @c void mp_bad_for (MP mp, const char * s) {
15435 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15436 @.Improper...replaced by 0@>
15437 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15438 help4("When you say `for x=a step b until c',",
15439 "the initial value `a' and the step size `b'",
15440 "and the final value `c' must have known numeric values.",
15441 "I'm zeroing this one. Proceed, with fingers crossed.");
15442 mp_put_get_flush_error(mp, 0);
15445 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15446 has just been scanned. (This code requires slight familiarity with
15447 expression-parsing routines that we have not yet discussed; but it seems
15448 to belong in the present part of the program, even though the original author
15449 didn't write it until later. The reader may wish to come back to it.)
15451 @c void mp_begin_iteration (MP mp) {
15452 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15453 halfword n; /* hash address of the current symbol */
15454 pointer s; /* the new loop-control node */
15455 pointer p; /* substitution list for |scan_toks| */
15456 pointer q; /* link manipulation register */
15457 pointer pp; /* a new progression node */
15458 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15459 if ( m==start_forever ){
15460 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15462 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15463 info(p)=mp->cur_sym; value(p)=m;
15465 if ( mp->cur_cmd==within_token ) {
15466 @<Set up a picture iteration@>;
15468 @<Check for the |"="| or |":="| in a loop header@>;
15469 @<Scan the values to be used in the loop@>;
15472 @<Check for the presence of a colon@>;
15473 @<Scan the loop text and put it on the loop control stack@>;
15474 mp_resume_iteration(mp);
15477 @ @<Check for the |"="| or |":="| in a loop header@>=
15478 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15479 mp_missing_err(mp, "=");
15481 help3("The next thing in this loop should have been `=' or `:='.",
15482 "But don't worry; I'll pretend that an equals sign",
15483 "was present, and I'll look for the values next.");
15487 @ @<Check for the presence of a colon@>=
15488 if ( mp->cur_cmd!=colon ) {
15489 mp_missing_err(mp, ":");
15491 help3("The next thing in this loop should have been a `:'.",
15492 "So I'll pretend that a colon was present;",
15493 "everything from here to `endfor' will be iterated.");
15497 @ We append a special |frozen_repeat_loop| token in place of the
15498 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15499 at the proper time to cause the loop to be repeated.
15501 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15502 he will be foiled by the |get_symbol| routine, which keeps frozen
15503 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15504 token, so it won't be lost accidentally.)
15506 @ @<Scan the loop text...@>=
15507 q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
15508 mp->scanner_status=loop_defining; mp->warning_info=n;
15509 info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15510 mp_link(s)=mp->loop_ptr; mp->loop_ptr=s
15512 @ @<Initialize table...@>=
15513 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15514 text(frozen_repeat_loop)=intern(" ENDFOR");
15516 @ The loop text is inserted into \MP's scanning apparatus by the
15517 |resume_iteration| routine.
15519 @c void mp_resume_iteration (MP mp) {
15520 pointer p,q; /* link registers */
15521 p=loop_type(mp->loop_ptr);
15522 if ( p==progression_flag ) {
15523 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15524 mp->cur_exp=value(p);
15525 if ( @<The arithmetic progression has ended@> ) {
15526 mp_stop_iteration(mp);
15529 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15530 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15531 } else if ( p==null ) {
15532 p=loop_list(mp->loop_ptr);
15534 mp_stop_iteration(mp);
15537 loop_list(mp->loop_ptr)=mp_link(p); q=info(p); free_avail(p);
15538 } else if ( p==mp_void ) {
15539 mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
15541 @<Make |q| a capsule containing the next picture component from
15542 |loop_list(loop_ptr)| or |goto not_found|@>;
15544 mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
15545 mp_stack_argument(mp, q);
15546 if ( mp->internal[mp_tracing_commands]>unity ) {
15547 @<Trace the start of a loop@>;
15551 mp_stop_iteration(mp);
15554 @ @<The arithmetic progression has ended@>=
15555 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15556 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15558 @ @<Trace the start of a loop@>=
15560 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15562 if ( (q!=null)&&(mp_link(q)==mp_void) ) mp_print_exp(mp, q,1);
15563 else mp_show_token_list(mp, q,null,50,0);
15564 mp_print_char(mp, xord('}')); mp_end_diagnostic(mp, false);
15567 @ @<Make |q| a capsule containing the next picture component from...@>=
15568 { q=loop_list(mp->loop_ptr);
15569 if ( q==null ) goto NOT_FOUND;
15570 skip_component(q) goto NOT_FOUND;
15571 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15572 mp_init_bbox(mp, mp->cur_exp);
15573 mp->cur_type=mp_picture_type;
15574 loop_list(mp->loop_ptr)=q;
15575 q=mp_stash_cur_exp(mp);
15578 @ A level of loop control disappears when |resume_iteration| has decided
15579 not to resume, or when an \&{exitif} construction has removed the loop text
15580 from the input stack.
15582 @c void mp_stop_iteration (MP mp) {
15583 pointer p,q; /* the usual */
15584 p=loop_type(mp->loop_ptr);
15585 if ( p==progression_flag ) {
15586 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15587 } else if ( p==null ){
15588 q=loop_list(mp->loop_ptr);
15589 while ( q!=null ) {
15592 if ( mp_link(p)==mp_void ) { /* it's an \&{expr} parameter */
15593 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15595 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15598 p=q; q=mp_link(q); free_avail(p);
15600 } else if ( p>progression_flag ) {
15601 delete_edge_ref(p);
15603 p=mp->loop_ptr; mp->loop_ptr=mp_link(p); mp_flush_token_list(mp, info(p));
15604 mp_free_node(mp, p,loop_node_size);
15607 @ Now that we know all about loop control, we can finish up
15608 the missing portion of |begin_iteration| and we'll be done.
15610 The following code is performed after the `\.=' has been scanned in
15611 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15612 (if |m=suffix_base|).
15614 @<Scan the values to be used in the loop@>=
15615 loop_type(s)=null; q=loop_list_loc(s); mp_link(q)=null; /* |mp_link(q)=loop_list(s)| */
15618 if ( m!=expr_base ) {
15619 mp_scan_suffix(mp);
15621 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15623 mp_scan_expression(mp);
15624 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15625 @<Prepare for step-until construction and |break|@>;
15627 mp->cur_exp=mp_stash_cur_exp(mp);
15629 mp_link(q)=mp_get_avail(mp); q=mp_link(q);
15630 info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15633 } while (mp->cur_cmd==comma)
15635 @ @<Prepare for step-until construction and |break|@>=
15637 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15638 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15639 mp_get_x_next(mp); mp_scan_expression(mp);
15640 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15641 step_size(pp)=mp->cur_exp;
15642 if ( mp->cur_cmd!=until_token ) {
15643 mp_missing_err(mp, "until");
15644 @.Missing `until'@>
15645 help2("I assume you meant to say `until' after `step'.",
15646 "So I'll look for the final value and colon next.");
15649 mp_get_x_next(mp); mp_scan_expression(mp);
15650 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15651 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15652 loop_type(s)=progression_flag;
15656 @ The last case is when we have just seen ``\&{within}'', and we need to
15657 parse a picture expression and prepare to iterate over it.
15659 @<Set up a picture iteration@>=
15660 { mp_get_x_next(mp);
15661 mp_scan_expression(mp);
15662 @<Make sure the current expression is a known picture@>;
15663 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15664 q=mp_link(dummy_loc(mp->cur_exp));
15666 if ( is_start_or_stop(q) )
15667 if ( mp_skip_1component(mp, q)==null ) q=mp_link(q);
15671 @ @<Make sure the current expression is a known picture@>=
15672 if ( mp->cur_type!=mp_picture_type ) {
15673 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15674 help1("When you say `for x in p', p must be a known picture.");
15675 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15676 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15679 @* \[35] File names.
15680 It's time now to fret about file names. Besides the fact that different
15681 operating systems treat files in different ways, we must cope with the
15682 fact that completely different naming conventions are used by different
15683 groups of people. The following programs show what is required for one
15684 particular operating system; similar routines for other systems are not
15685 difficult to devise.
15686 @^system dependencies@>
15688 \MP\ assumes that a file name has three parts: the name proper; its
15689 ``extension''; and a ``file area'' where it is found in an external file
15690 system. The extension of an input file is assumed to be
15691 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15692 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15693 metric files that describe characters in any fonts created by \MP; it is
15694 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15695 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15696 The file area can be arbitrary on input files, but files are usually
15697 output to the user's current area. If an input file cannot be
15698 found on the specified area, \MP\ will look for it on a special system
15699 area; this special area is intended for commonly used input files.
15701 Simple uses of \MP\ refer only to file names that have no explicit
15702 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15703 instead of `\.{input} \.{cmr10.new}'. Simple file
15704 names are best, because they make the \MP\ source files portable;
15705 whenever a file name consists entirely of letters and digits, it should be
15706 treated in the same way by all implementations of \MP. However, users
15707 need the ability to refer to other files in their environment, especially
15708 when responding to error messages concerning unopenable files; therefore
15709 we want to let them use the syntax that appears in their favorite
15712 @ \MP\ uses the same conventions that have proved to be satisfactory for
15713 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15714 @^system dependencies@>
15715 the system-independent parts of \MP\ are expressed in terms
15716 of three system-dependent
15717 procedures called |begin_name|, |more_name|, and |end_name|. In
15718 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15719 the system-independent driver program does the operations
15720 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
15722 These three procedures communicate with each other via global variables.
15723 Afterwards the file name will appear in the string pool as three strings
15724 called |cur_name|\penalty10000\hskip-.05em,
15725 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15726 |""|), unless they were explicitly specified by the user.
15728 Actually the situation is slightly more complicated, because \MP\ needs
15729 to know when the file name ends. The |more_name| routine is a function
15730 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15731 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15732 returns |false|; or, it returns |true| and $c_n$ is the last character
15733 on the current input line. In other words,
15734 |more_name| is supposed to return |true| unless it is sure that the
15735 file name has been completely scanned; and |end_name| is supposed to be able
15736 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15737 whether $|more_name|(c_n)$ returned |true| or |false|.
15740 char * cur_name; /* name of file just scanned */
15741 char * cur_area; /* file area just scanned, or \.{""} */
15742 char * cur_ext; /* file extension just scanned, or \.{""} */
15744 @ It is easier to maintain reference counts if we assign initial values.
15747 mp->cur_name=xstrdup("");
15748 mp->cur_area=xstrdup("");
15749 mp->cur_ext=xstrdup("");
15751 @ @<Dealloc variables@>=
15752 xfree(mp->cur_area);
15753 xfree(mp->cur_name);
15754 xfree(mp->cur_ext);
15756 @ The file names we shall deal with for illustrative purposes have the
15757 following structure: If the name contains `\.>' or `\.:', the file area
15758 consists of all characters up to and including the final such character;
15759 otherwise the file area is null. If the remaining file name contains
15760 `\..', the file extension consists of all such characters from the first
15761 remaining `\..' to the end, otherwise the file extension is null.
15762 @^system dependencies@>
15764 We can scan such file names easily by using two global variables that keep track
15765 of the occurrences of area and extension delimiters. Note that these variables
15766 cannot be of type |pool_pointer| because a string pool compaction could occur
15767 while scanning a file name.
15770 integer area_delimiter;
15771 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15772 integer ext_delimiter; /* the relevant `\..', if any */
15774 @ Here now is the first of the system-dependent routines for file name scanning.
15775 @^system dependencies@>
15777 The file name length is limited to |file_name_size|. That is good, because
15778 in the current configuration we cannot call |mp_do_compaction| while a name
15779 is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct
15780 offsets into |mp->str_pool|. I am not in a great hurry to fix this, because
15781 calling |str_room()| just once is more efficient anyway. TODO.
15783 @<Declare subroutines for parsing file names@>=
15784 void mp_begin_name (MP mp) {
15785 xfree(mp->cur_name);
15786 xfree(mp->cur_area);
15787 xfree(mp->cur_ext);
15788 mp->area_delimiter=-1;
15789 mp->ext_delimiter=-1;
15790 str_room(file_name_size);
15793 @ And here's the second.
15794 @^system dependencies@>
15796 @<Declare subroutines for parsing file names@>=
15797 boolean mp_more_name (MP mp, ASCII_code c) {
15801 if ( (c=='>')||(c==':') ) {
15802 mp->area_delimiter=mp->pool_ptr;
15803 mp->ext_delimiter=-1;
15804 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15805 mp->ext_delimiter=mp->pool_ptr;
15807 append_char(c); /* contribute |c| to the current string */
15813 @^system dependencies@>
15815 @d copy_pool_segment(A,B,C) {
15816 A = xmalloc(C+1,sizeof(char));
15817 strncpy(A,(char *)(mp->str_pool+B),C);
15820 @<Declare subroutines for parsing file names@>=
15821 void mp_end_name (MP mp) {
15822 pool_pointer s; /* length of area, name, and extension */
15825 s = mp->str_start[mp->str_ptr];
15826 if ( mp->area_delimiter<0 ) {
15827 mp->cur_area=xstrdup("");
15829 len = (unsigned)(mp->area_delimiter-s);
15830 copy_pool_segment(mp->cur_area,s,len);
15833 if ( mp->ext_delimiter<0 ) {
15834 mp->cur_ext=xstrdup("");
15835 len = (unsigned)(mp->pool_ptr-s);
15837 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(size_t)(mp->pool_ptr-mp->ext_delimiter));
15838 len = (unsigned)(mp->ext_delimiter-s);
15840 copy_pool_segment(mp->cur_name,s,len);
15841 mp->pool_ptr=s; /* don't need this partial string */
15844 @ Conversely, here is a routine that takes three strings and prints a file
15845 name that might have produced them. (The routine is system dependent, because
15846 some operating systems put the file area last instead of first.)
15847 @^system dependencies@>
15849 @<Basic printing...@>=
15850 void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15851 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15854 @ Another system-dependent routine is needed to convert three internal
15856 to the |name_of_file| value that is used to open files. The present code
15857 allows both lowercase and uppercase letters in the file name.
15858 @^system dependencies@>
15860 @d append_to_name(A) { c=xord((int)(A));
15861 if ( k<file_name_size ) {
15862 mp->name_of_file[k]=(char)xchr(c);
15867 @<Declare subroutines for parsing file names@>=
15868 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
15869 integer k; /* number of positions filled in |name_of_file| */
15870 ASCII_code c; /* character being packed */
15871 const char *j; /* a character index */
15875 for (j=a;*j!='\0';j++) { append_to_name(*j); }
15877 for (j=n;*j!='\0';j++) { append_to_name(*j); }
15879 for (j=e;*j!='\0';j++) { append_to_name(*j); }
15881 mp->name_of_file[k]=0;
15885 @ @<Internal library declarations@>=
15886 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
15888 @ @<Option variables@>=
15889 char *mem_name; /* for commandline */
15891 @ @<Find constant sizes@>=
15892 mp->mem_name = xstrdup(opt->mem_name);
15893 if (mp->mem_name) {
15894 size_t l = strlen(mp->mem_name);
15896 char *test = strstr(mp->mem_name,".mem");
15897 if (test == mp->mem_name+l-4) {
15904 @ @<Dealloc variables@>=
15905 xfree(mp->mem_name);
15907 @ This part of the program becomes active when a ``virgin'' \MP\ is
15908 trying to get going, just after the preliminary initialization, or
15909 when the user is substituting another mem file by typing `\.\&' after
15910 the initial `\.{**}' prompt. The buffer contains the first line of
15911 input in |buffer[loc..(last-1)]|, where |loc<last| and |buffer[loc]<>""|.
15914 boolean mp_open_mem_name (MP mp) ;
15915 boolean mp_open_mem_file (MP mp) ;
15918 boolean mp_open_mem_name (MP mp) {
15919 if (mp->mem_name!=NULL) {
15920 size_t l = strlen(mp->mem_name);
15921 char *s = xstrdup (mp->mem_name);
15923 char *test = strstr(s,".mem");
15924 if (test == NULL || test != s+l-4) {
15925 s = xrealloc (s, l+5, 1);
15926 strcat (s, ".mem");
15929 s = xrealloc (s, l+5, 1);
15930 strcat (s, ".mem");
15932 mp->mem_file = (mp->open_file)(mp,s, "r", mp_filetype_memfile);
15934 if ( mp->mem_file ) return true;
15938 boolean mp_open_mem_file (MP mp) {
15939 if (mp->mem_file != NULL)
15941 if (mp_open_mem_name(mp))
15943 if (mp_xstrcmp(mp->mem_name, "plain")) {
15945 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
15946 @.Sorry, I can't find...@>
15948 /* now pull out all the stops: try for the system \.{plain} file */
15949 xfree(mp->mem_name);
15950 mp->mem_name = xstrdup("plain");
15951 if (mp_open_mem_name(mp))
15955 wterm_ln("I can\'t find the PLAIN mem file!");
15956 @.I can't find PLAIN...@>
15961 @ Operating systems often make it possible to determine the exact name (and
15962 possible version number) of a file that has been opened. The following routine,
15963 which simply makes a \MP\ string from the value of |name_of_file|, should
15964 ideally be changed to deduce the full name of file~|f|, which is the file
15965 most recently opened, if it is possible to do this.
15966 @^system dependencies@>
15969 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
15970 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
15971 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
15974 str_number mp_make_name_string (MP mp) {
15975 int k; /* index into |name_of_file| */
15976 str_room(mp->name_length);
15977 for (k=0;k<mp->name_length;k++) {
15978 append_char(xord((int)mp->name_of_file[k]));
15980 return mp_make_string(mp);
15983 @ Now let's consider the ``driver''
15984 routines by which \MP\ deals with file names
15985 in a system-independent manner. First comes a procedure that looks for a
15986 file name in the input by taking the information from the input buffer.
15987 (We can't use |get_next|, because the conversion to tokens would
15988 destroy necessary information.)
15990 This procedure doesn't allow semicolons or percent signs to be part of
15991 file names, because of other conventions of \MP.
15992 {\sl The {\logos METAFONT\/}book} doesn't
15993 use semicolons or percents immediately after file names, but some users
15994 no doubt will find it natural to do so; therefore system-dependent
15995 changes to allow such characters in file names should probably
15996 be made with reluctance, and only when an entire file name that
15997 includes special characters is ``quoted'' somehow.
15998 @^system dependencies@>
16000 @c void mp_scan_file_name (MP mp) {
16002 while ( mp->buffer[loc]==' ' ) incr(loc);
16004 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
16005 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
16011 @ Here is another version that takes its input from a string.
16013 @<Declare subroutines for parsing file names@>=
16014 void mp_str_scan_file (MP mp, str_number s) {
16015 pool_pointer p,q; /* current position and stopping point */
16017 p=mp->str_start[s]; q=str_stop(s);
16019 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
16025 @ And one that reads from a |char*|.
16027 @<Declare subroutines for parsing file names@>=
16028 void mp_ptr_scan_file (MP mp, char *s) {
16029 char *p, *q; /* current position and stopping point */
16031 p=s; q=p+strlen(s);
16033 if ( ! mp_more_name(mp, xord((int)(*p)))) break;
16040 @ The global variable |job_name| contains the file name that was first
16041 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
16042 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
16045 boolean log_opened; /* has the transcript file been opened? */
16046 char *log_name; /* full name of the log file */
16048 @ @<Option variables@>=
16049 char *job_name; /* principal file name */
16051 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
16052 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
16053 except of course for a short time just after |job_name| has become nonzero.
16055 @<Allocate or ...@>=
16056 mp->job_name=mp_xstrdup(mp, opt->job_name);
16057 if (opt->noninteractive && opt->ini_version) {
16058 if (mp->job_name == NULL)
16059 mp->job_name=mp_xstrdup(mp,mp->mem_name);
16060 if (mp->job_name != NULL) {
16061 size_t l = strlen(mp->job_name);
16063 char *test = strstr(mp->job_name,".mem");
16064 if (test == mp->job_name+l-4)
16069 mp->log_opened=false;
16071 @ @<Dealloc variables@>=
16072 xfree(mp->job_name);
16074 @ Here is a routine that manufactures the output file names, assuming that
16075 |job_name<>0|. It ignores and changes the current settings of |cur_area|
16078 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
16081 void mp_pack_job_name (MP mp, const char *s) ;
16084 void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
16085 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
16086 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16087 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
16091 @ If some trouble arises when \MP\ tries to open a file, the following
16092 routine calls upon the user to supply another file name. Parameter~|s|
16093 is used in the error message to identify the type of file; parameter~|e|
16094 is the default extension if none is given. Upon exit from the routine,
16095 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16096 ready for another attempt at file opening.
16099 void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
16101 @ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
16102 size_t k; /* index into |buffer| */
16103 char * saved_cur_name;
16104 if ( mp->interaction==mp_scroll_mode )
16106 if (strcmp(s,"input file name")==0) {
16107 print_err("I can\'t find file `");
16108 @.I can't find file x@>
16110 print_err("I can\'t write on file `");
16111 @.I can't write on file x@>
16113 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16114 mp_print(mp, "'.");
16115 if (strcmp(e,"")==0)
16116 mp_show_context(mp);
16117 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16119 if (mp->noninteractive || mp->interaction<mp_scroll_mode )
16120 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16121 @.job aborted, file error...@>
16122 saved_cur_name = xstrdup(mp->cur_name);
16123 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16124 if (strcmp(mp->cur_ext,"")==0)
16125 mp->cur_ext=xstrdup(e);
16126 if (strlen(mp->cur_name)==0) {
16127 mp->cur_name=saved_cur_name;
16129 xfree(saved_cur_name);
16134 @ @<Scan file name in the buffer@>=
16136 mp_begin_name(mp); k=mp->first;
16137 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16139 if ( k==mp->last ) break;
16140 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16146 @ The |open_log_file| routine is used to open the transcript file and to help
16147 it catch up to what has previously been printed on the terminal.
16149 @c void mp_open_log_file (MP mp) {
16150 unsigned old_setting; /* previous |selector| setting */
16151 int k; /* index into |months| and |buffer| */
16152 int l; /* end of first input line */
16153 integer m; /* the current month */
16154 const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16155 /* abbreviations of month names */
16156 old_setting=mp->selector;
16157 if ( mp->job_name==NULL ) {
16158 mp->job_name=xstrdup("mpout");
16160 mp_pack_job_name(mp,".log");
16161 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16162 @<Try to get a different log file name@>;
16164 mp->log_name=xstrdup(mp->name_of_file);
16165 mp->selector=log_only; mp->log_opened=true;
16166 @<Print the banner line, including the date and time@>;
16167 mp->input_stack[mp->input_ptr]=mp->cur_input;
16168 /* make sure bottom level is in memory */
16169 if (!mp->noninteractive) {
16170 mp_print_nl(mp, "**");
16172 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16173 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16174 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16176 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16179 @ @<Dealloc variables@>=
16180 xfree(mp->log_name);
16182 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16183 unable to print error messages or even to |show_context|.
16184 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16185 routine will not be invoked because |log_opened| will be false.
16187 The normal idea of |mp_batch_mode| is that nothing at all should be written
16188 on the terminal. However, in the unusual case that
16189 no log file could be opened, we make an exception and allow
16190 an explanatory message to be seen.
16192 Incidentally, the program always refers to the log file as a `\.{transcript
16193 file}', because some systems cannot use the extension `\.{.log}' for
16196 @<Try to get a different log file name@>=
16198 mp->selector=term_only;
16199 mp_prompt_file_name(mp, "transcript file name",".log");
16202 @ @<Print the banner...@>=
16205 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16206 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16207 mp_print_char(mp, xord(' '));
16208 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16209 for (k=3*m-3;k<3*m;k++) { wlog_chr((unsigned char)months[k]); }
16210 mp_print_char(mp, xord(' '));
16211 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16212 mp_print_char(mp, xord(' '));
16213 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16214 mp_print_dd(mp, m / 60); mp_print_char(mp, xord(':')); mp_print_dd(mp, m % 60);
16217 @ The |try_extension| function tries to open an input file determined by
16218 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16219 can't find the file in |cur_area| or the appropriate system area.
16221 @c boolean mp_try_extension (MP mp, const char *ext) {
16222 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16223 in_name=xstrdup(mp->cur_name);
16224 in_area=xstrdup(mp->cur_area);
16225 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16228 mp_pack_file_name(mp, mp->cur_name,NULL,ext);
16229 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16233 @ Let's turn now to the procedure that is used to initiate file reading
16234 when an `\.{input}' command is being processed.
16236 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16237 char *fname = NULL;
16238 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16240 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16241 if ( strlen(mp->cur_ext)==0 ) {
16242 if ( mp_try_extension(mp, ".mp") ) break;
16243 else if ( mp_try_extension(mp, "") ) break;
16244 else if ( mp_try_extension(mp, ".mf") ) break;
16245 /* |else do_nothing; | */
16246 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16249 mp_end_file_reading(mp); /* remove the level that didn't work */
16250 mp_prompt_file_name(mp, "input file name","");
16252 name=mp_a_make_name_string(mp, cur_file);
16253 fname = xstrdup(mp->name_of_file);
16254 if ( mp->job_name==NULL ) {
16255 mp->job_name=xstrdup(mp->cur_name);
16256 mp_open_log_file(mp);
16257 } /* |open_log_file| doesn't |show_context|, so |limit|
16258 and |loc| needn't be set to meaningful values yet */
16259 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16260 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, xord(' '));
16261 mp_print_char(mp, xord('(')); incr(mp->open_parens); mp_print(mp, fname);
16264 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16265 @<Read the first line of the new file@>;
16268 @ This code should be omitted if |a_make_name_string| returns something other
16269 than just a copy of its argument and the full file name is needed for opening
16270 \.{MPX} files or implementing the switch-to-editor option.
16271 @^system dependencies@>
16273 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16274 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16276 @ If the file is empty, it is considered to contain a single blank line,
16277 so there is no need to test the return value.
16279 @<Read the first line...@>=
16282 (void)mp_input_ln(mp, cur_file );
16283 mp_firm_up_the_line(mp);
16284 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start;
16287 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16288 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16289 if ( token_state ) {
16290 print_err("File names can't appear within macros");
16291 @.File names can't...@>
16292 help3("Sorry...I've converted what follows to tokens,",
16293 "possibly garbaging the name you gave.",
16294 "Please delete the tokens and insert the name again.");
16297 if ( file_state ) {
16298 mp_scan_file_name(mp);
16300 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16301 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16302 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16305 @ The following simple routine starts reading the \.{MPX} file associated
16306 with the current input file.
16308 @c void mp_start_mpx_input (MP mp) {
16309 char *origname = NULL; /* a copy of nameoffile */
16310 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16311 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16312 |goto not_found| if there is a problem@>;
16313 mp_begin_file_reading(mp);
16314 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16315 mp_end_file_reading(mp);
16318 name=mp_a_make_name_string(mp, cur_file);
16319 mp->mpx_name[iindex]=name; add_str_ref(name);
16320 @<Read the first line of the new file@>;
16324 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16328 @ This should ideally be changed to do whatever is necessary to create the
16329 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16330 of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
16331 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16332 completely different typesetting program if suitable postprocessor is
16333 available to perform the function of \.{DVItoMP}.)
16334 @^system dependencies@>
16336 @ @<Exported types@>=
16337 typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
16339 @ @<Option variables@>=
16340 mp_run_make_mpx_command run_make_mpx;
16342 @ @<Allocate or initialize ...@>=
16343 set_callback_option(run_make_mpx);
16345 @ @<Internal library declarations@>=
16346 int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16348 @ The default does nothing.
16350 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16357 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16358 |goto not_found| if there is a problem@>=
16359 origname = mp_xstrdup(mp,mp->name_of_file);
16360 *(origname+strlen(origname)-1)=0; /* drop the x */
16361 if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
16364 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16365 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16366 mp_print_nl(mp, ">> ");
16367 mp_print(mp, origname);
16368 mp_print_nl(mp, ">> ");
16369 mp_print(mp, mp->name_of_file);
16370 mp_print_nl(mp, "! Unable to make mpx file");
16371 help4("The two files given above are one of your source files",
16372 "and an auxiliary file I need to read to find out what your",
16373 "btex..etex blocks mean. If you don't know why I had trouble,",
16374 "try running it manually through MPtoTeX, TeX, and DVItoMP");
16377 @ The last file-opening commands are for files accessed via the \&{readfrom}
16378 @:read_from_}{\&{readfrom} primitive@>
16379 operator and the \&{write} command. Such files are stored in separate arrays.
16380 @:write_}{\&{write} primitive@>
16382 @<Types in the outer block@>=
16383 typedef unsigned int readf_index; /* |0..max_read_files| */
16384 typedef unsigned int write_index; /* |0..max_write_files| */
16387 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16388 void ** rd_file; /* \&{readfrom} files */
16389 char ** rd_fname; /* corresponding file name or 0 if file not open */
16390 readf_index read_files; /* number of valid entries in the above arrays */
16391 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16392 void ** wr_file; /* \&{write} files */
16393 char ** wr_fname; /* corresponding file name or 0 if file not open */
16394 write_index write_files; /* number of valid entries in the above arrays */
16396 @ @<Allocate or initialize ...@>=
16397 mp->max_read_files=8;
16398 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
16399 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16400 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16401 mp->max_write_files=8;
16402 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
16403 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16404 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16407 @ This routine starts reading the file named by string~|s| without setting
16408 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16409 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16411 @c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16412 mp_ptr_scan_file(mp, s);
16414 mp_begin_file_reading(mp);
16415 if ( ! mp_a_open_in(mp, &mp->rd_file[n], (int)(mp_filetype_text+n)) )
16417 if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
16418 (mp->close_file)(mp,mp->rd_file[n]);
16421 mp->rd_fname[n]=xstrdup(s);
16424 mp_end_file_reading(mp);
16428 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16431 void mp_open_write_file (MP mp, char *s, readf_index n) ;
16433 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16434 mp_ptr_scan_file(mp, s);
16436 while ( ! mp_a_open_out(mp, &mp->wr_file[n], (int)(mp_filetype_text+n)) )
16437 mp_prompt_file_name(mp, "file name for write output","");
16438 mp->wr_fname[n]=xstrdup(s);
16442 @* \[36] Introduction to the parsing routines.
16443 We come now to the central nervous system that sparks many of \MP's activities.
16444 By evaluating expressions, from their primary constituents to ever larger
16445 subexpressions, \MP\ builds the structures that ultimately define complete
16446 pictures or fonts of type.
16448 Four mutually recursive subroutines are involved in this process: We call them
16449 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16450 and |scan_expression|.}$$
16452 Each of them is parameterless and begins with the first token to be scanned
16453 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16454 the value of the primary or secondary or tertiary or expression that was
16455 found will appear in the global variables |cur_type| and |cur_exp|. The
16456 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16459 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16460 backup mechanisms have been added in order to provide reasonable error
16464 quarterword cur_type; /* the type of the expression just found */
16465 integer cur_exp; /* the value of the expression just found */
16470 @ Many different kinds of expressions are possible, so it is wise to have
16471 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16474 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16475 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16476 construction in which there was no expression before the \&{endgroup}.
16477 In this case |cur_exp| has some irrelevant value.
16480 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16484 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16486 a ring of equivalent booleans whose value has not yet been defined.
16489 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16490 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16491 includes this particular reference.
16494 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16496 a ring of equivalent strings whose value has not yet been defined.
16499 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16500 else points to any of the nodes in this pen. The pen may be polygonal or
16504 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16506 a ring of equivalent pens whose value has not yet been defined.
16509 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16510 a path; nobody else points to this particular path. The control points of
16511 the path will have been chosen.
16514 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16516 a ring of equivalent paths whose value has not yet been defined.
16519 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16520 There may be other pointers to this particular set of edges. The header node
16521 contains a reference count that includes this particular reference.
16524 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16526 a ring of equivalent pictures whose value has not yet been defined.
16529 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16530 capsule node. The |value| part of this capsule
16531 points to a transform node that contains six numeric values,
16532 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16535 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16536 capsule node. The |value| part of this capsule
16537 points to a color node that contains three numeric values,
16538 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16541 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16542 capsule node. The |value| part of this capsule
16543 points to a color node that contains four numeric values,
16544 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16547 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16548 node whose type is |mp_pair_type|. The |value| part of this capsule
16549 points to a pair node that contains two numeric values,
16550 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16553 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16556 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16557 is |dependent|. The |dep_list| field in this capsule points to the associated
16561 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16562 capsule node. The |dep_list| field in this capsule
16563 points to the associated dependency list.
16566 |cur_type=independent| means that |cur_exp| points to a capsule node
16567 whose type is |independent|. This somewhat unusual case can arise, for
16568 example, in the expression
16569 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16572 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16575 \smallskip\noindent
16576 The possible settings of |cur_type| have been listed here in increasing
16577 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16578 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16579 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16582 @ Capsules are two-word nodes that have a similar meaning
16583 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
16584 and their |type| field is one of the possibilities for |cur_type| listed above.
16585 Also |link<=void| in capsules that aren't part of a token list.
16587 The |value| field of a capsule is, in most cases, the value that
16588 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16589 However, when |cur_exp| would point to a capsule,
16590 no extra layer of indirection is present; the |value|
16591 field is what would have been called |value(cur_exp)| if it had not been
16592 encapsulated. Furthermore, if the type is |dependent| or
16593 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16594 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16595 always part of the general |dep_list| structure.
16597 The |get_x_next| routine is careful not to change the values of |cur_type|
16598 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16599 call a macro, which might parse an expression, which might execute lots of
16600 commands in a group; hence it's possible that |cur_type| might change
16601 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16602 |known| or |independent|, during the time |get_x_next| is called. The
16603 programs below are careful to stash sensitive intermediate results in
16604 capsules, so that \MP's generality doesn't cause trouble.
16606 Here's a procedure that illustrates these conventions. It takes
16607 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16608 and stashes them away in a
16609 capsule. It is not used when |cur_type=mp_token_list|.
16610 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16611 copy path lists or to update reference counts, etc.
16613 The special link |mp_void| is put on the capsule returned by
16614 |stash_cur_exp|, because this procedure is used to store macro parameters
16615 that must be easily distinguishable from token lists.
16617 @<Declare the stashing/unstashing routines@>=
16618 pointer mp_stash_cur_exp (MP mp) {
16619 pointer p; /* the capsule that will be returned */
16620 switch (mp->cur_type) {
16621 case unknown_types:
16622 case mp_transform_type:
16623 case mp_color_type:
16626 case mp_proto_dependent:
16627 case mp_independent:
16628 case mp_cmykcolor_type:
16632 p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
16633 type(p)=mp->cur_type; value(p)=mp->cur_exp;
16636 mp->cur_type=mp_vacuous; mp_link(p)=mp_void;
16640 @ The inverse of |stash_cur_exp| is the following procedure, which
16641 deletes an unnecessary capsule and puts its contents into |cur_type|
16644 The program steps of \MP\ can be divided into two categories: those in
16645 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16646 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16647 information or not. It's important not to ignore them when they're alive,
16648 and it's important not to pay attention to them when they're dead.
16650 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16651 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16652 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16653 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16654 only when they are alive or dormant.
16656 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16657 are alive or dormant. The \\{unstash} procedure assumes that they are
16658 dead or dormant; it resuscitates them.
16660 @<Declare the stashing/unstashing...@>=
16661 void mp_unstash_cur_exp (MP mp,pointer p) ;
16664 void mp_unstash_cur_exp (MP mp,pointer p) {
16665 mp->cur_type=type(p);
16666 switch (mp->cur_type) {
16667 case unknown_types:
16668 case mp_transform_type:
16669 case mp_color_type:
16672 case mp_proto_dependent:
16673 case mp_independent:
16674 case mp_cmykcolor_type:
16678 mp->cur_exp=value(p);
16679 mp_free_node(mp, p,value_node_size);
16684 @ The following procedure prints the values of expressions in an
16685 abbreviated format. If its first parameter |p| is null, the value of
16686 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16687 containing the desired value. The second parameter controls the amount of
16688 output. If it is~0, dependency lists will be abbreviated to
16689 `\.{linearform}' unless they consist of a single term. If it is greater
16690 than~1, complicated structures (pens, pictures, and paths) will be displayed
16694 @<Declare subroutines for printing expressions@>=
16695 @<Declare the procedure called |print_dp|@>
16696 @<Declare the stashing/unstashing routines@>
16697 void mp_print_exp (MP mp,pointer p, quarterword verbosity) {
16698 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16699 quarterword t; /* the type of the expression */
16700 pointer q; /* a big node being displayed */
16701 integer v=0; /* the value of the expression */
16703 restore_cur_exp=false;
16705 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16708 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16709 @<Print an abbreviated value of |v| with format depending on |t|@>;
16710 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16713 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16715 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16716 case mp_boolean_type:
16717 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16719 case unknown_types: case mp_numeric_type:
16720 @<Display a variable that's been declared but not defined@>;
16722 case mp_string_type:
16723 mp_print_char(mp, xord('"')); mp_print_str(mp, v); mp_print_char(mp, xord('"'));
16725 case mp_pen_type: case mp_path_type: case mp_picture_type:
16726 @<Display a complex type@>;
16728 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16729 if ( v==null ) mp_print_type(mp, t);
16730 else @<Display a big node@>;
16732 case mp_known:mp_print_scaled(mp, v); break;
16733 case mp_dependent: case mp_proto_dependent:
16734 mp_print_dp(mp, t,v,verbosity);
16736 case mp_independent:mp_print_variable_name(mp, p); break;
16737 default: mp_confusion(mp, "exp"); break;
16738 @:this can't happen exp}{\quad exp@>
16741 @ @<Display a big node@>=
16743 mp_print_char(mp, xord('(')); q=v+mp->big_node_size[t];
16745 if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
16746 else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
16747 else mp_print_dp(mp, type(v),dep_list(v),verbosity);
16749 if ( v!=q ) mp_print_char(mp, xord(','));
16751 mp_print_char(mp, xord(')'));
16754 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16755 in the log file only, unless the user has given a positive value to
16758 @<Display a complex type@>=
16759 if ( verbosity<=1 ) {
16760 mp_print_type(mp, t);
16762 if ( mp->selector==term_and_log )
16763 if ( mp->internal[mp_tracing_online]<=0 ) {
16764 mp->selector=term_only;
16765 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16766 mp->selector=term_and_log;
16769 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16770 case mp_path_type:mp_print_path(mp, v,"",false); break;
16771 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16772 } /* there are no other cases */
16775 @ @<Declare the procedure called |print_dp|@>=
16776 void mp_print_dp (MP mp, quarterword t, pointer p,
16777 quarterword verbosity) {
16778 pointer q; /* the node following |p| */
16780 if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16781 else mp_print(mp, "linearform");
16784 @ The displayed name of a variable in a ring will not be a capsule unless
16785 the ring consists entirely of capsules.
16787 @<Display a variable that's been declared but not defined@>=
16788 { mp_print_type(mp, t);
16790 { mp_print_char(mp, xord(' '));
16791 while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16792 mp_print_variable_name(mp, v);
16796 @ When errors are detected during parsing, it is often helpful to
16797 display an expression just above the error message, using |exp_err|
16798 or |disp_err| instead of |print_err|.
16800 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16802 @<Declare subroutines for printing expressions@>=
16803 void mp_disp_err (MP mp,pointer p, const char *s) {
16804 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16805 mp_print_nl(mp, ">> ");
16807 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16809 mp_print_nl(mp, "! "); mp_print(mp, s);
16814 @ If |cur_type| and |cur_exp| contain relevant information that should
16815 be recycled, we will use the following procedure, which changes |cur_type|
16816 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16817 and |cur_exp| as either alive or dormant after this has been done,
16818 because |cur_exp| will not contain a pointer value.
16820 @ @c void mp_flush_cur_exp (MP mp,scaled v) {
16821 switch (mp->cur_type) {
16822 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16823 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16824 mp_recycle_value(mp, mp->cur_exp);
16825 mp_free_node(mp, mp->cur_exp,value_node_size);
16827 case mp_string_type:
16828 delete_str_ref(mp->cur_exp); break;
16829 case mp_pen_type: case mp_path_type:
16830 mp_toss_knot_list(mp, mp->cur_exp); break;
16831 case mp_picture_type:
16832 delete_edge_ref(mp->cur_exp); break;
16836 mp->cur_type=mp_known; mp->cur_exp=v;
16839 @ There's a much more general procedure that is capable of releasing
16840 the storage associated with any two-word value packet.
16842 @<Declare the recycling subroutines@>=
16843 void mp_recycle_value (MP mp,pointer p) ;
16845 @ @c void mp_recycle_value (MP mp,pointer p) {
16846 quarterword t; /* a type code */
16847 integer vv; /* another value */
16848 pointer q,r,s,pp; /* link manipulation registers */
16849 integer v=0; /* a value */
16851 if ( t<mp_dependent ) v=value(p);
16853 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
16854 case mp_numeric_type:
16856 case unknown_types:
16857 mp_ring_delete(mp, p); break;
16858 case mp_string_type:
16859 delete_str_ref(v); break;
16860 case mp_path_type: case mp_pen_type:
16861 mp_toss_knot_list(mp, v); break;
16862 case mp_picture_type:
16863 delete_edge_ref(v); break;
16864 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
16865 case mp_transform_type:
16866 @<Recycle a big node@>; break;
16867 case mp_dependent: case mp_proto_dependent:
16868 @<Recycle a dependency list@>; break;
16869 case mp_independent:
16870 @<Recycle an independent variable@>; break;
16871 case mp_token_list: case mp_structured:
16872 mp_confusion(mp, "recycle"); break;
16873 @:this can't happen recycle}{\quad recycle@>
16874 case mp_unsuffixed_macro: case mp_suffixed_macro:
16875 mp_delete_mac_ref(mp, value(p)); break;
16876 } /* there are no other cases */
16880 @ @<Recycle a big node@>=
16882 q=v+mp->big_node_size[t];
16884 q=q-2; mp_recycle_value(mp, q);
16886 mp_free_node(mp, v,mp->big_node_size[t]);
16889 @ @<Recycle a dependency list@>=
16892 while ( info(q)!=null ) q=mp_link(q);
16893 mp_link(prev_dep(p))=mp_link(q);
16894 prev_dep(mp_link(q))=prev_dep(p);
16895 mp_link(q)=null; mp_flush_node_list(mp, dep_list(p));
16898 @ When an independent variable disappears, it simply fades away, unless
16899 something depends on it. In the latter case, a dependent variable whose
16900 coefficient of dependence is maximal will take its place.
16901 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
16902 as part of his Ph.D. thesis (Stanford University, December 1982).
16903 @^Zabala Salelles, Ignacio Andr\'es@>
16905 For example, suppose that variable $x$ is being recycled, and that the
16906 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
16907 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
16908 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
16909 we will print `\.{\#\#\# -2x=-y+a}'.
16911 There's a slight complication, however: An independent variable $x$
16912 can occur both in dependency lists and in proto-dependency lists.
16913 This makes it necessary to be careful when deciding which coefficient
16916 Furthermore, this complication is not so slight when
16917 a proto-dependent variable is chosen to become independent. For example,
16918 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
16919 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
16920 large coefficient `50'.
16922 In order to deal with these complications without wasting too much time,
16923 we shall link together the occurrences of~$x$ among all the linear
16924 dependencies, maintaining separate lists for the dependent and
16925 proto-dependent cases.
16927 @<Recycle an independent variable@>=
16929 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
16930 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
16931 q=mp_link(dep_head);
16932 while ( q!=dep_head ) {
16933 s=value_loc(q); /* now |mp_link(s)=dep_list(q)| */
16936 if ( info(r)==null ) break;
16937 if ( info(r)!=p ) {
16940 t=type(q); mp_link(s)=mp_link(r); info(r)=q;
16941 if ( abs(value(r))>mp->max_c[t] ) {
16942 @<Record a new maximum coefficient of type |t|@>;
16944 mp_link(r)=mp->max_link[t]; mp->max_link[t]=r;
16950 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
16951 @<Choose a dependent variable to take the place of the disappearing
16952 independent variable, and change all remaining dependencies
16957 @ The code for independency removal makes use of three two-word arrays.
16960 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
16961 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
16962 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
16964 @ @<Record a new maximum coefficient...@>=
16966 if ( mp->max_c[t]>0 ) {
16967 mp_link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
16969 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
16972 @ @<Choose a dependent...@>=
16974 if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
16977 t=mp_proto_dependent;
16978 @<Determine the dependency list |s| to substitute for the independent
16980 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
16981 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
16982 mp_link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
16984 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
16985 else { @<Substitute new proto-dependencies in place of |p|@>;}
16986 mp_flush_node_list(mp, s);
16987 if ( mp->fix_needed ) mp_fix_dependencies(mp);
16991 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
16992 and |info(s)| points to the dependent variable~|pp| of type~|t| from
16993 whose dependency list we have removed node~|s|. We must reinsert
16994 node~|s| into the dependency list, with coefficient $-1.0$, and with
16995 |pp| as the new independent variable. Since |pp| will have a larger serial
16996 number than any other variable, we can put node |s| at the head of the
16999 @<Determine the dep...@>=
17000 s=mp->max_ptr[t]; pp=info(s); v=value(s);
17001 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
17002 r=dep_list(pp); mp_link(s)=r;
17003 while ( info(r)!=null ) r=mp_link(r);
17004 q=mp_link(r); mp_link(r)=null;
17005 prev_dep(q)=prev_dep(pp); mp_link(prev_dep(pp))=q;
17007 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
17008 if ( mp->internal[mp_tracing_equations]>0 ) {
17009 @<Show the transformed dependency@>;
17012 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
17013 by the dependency list~|s|.
17015 @<Show the transformed...@>=
17016 if ( mp_interesting(mp, p) ) {
17017 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
17018 @:]]]\#\#\#_}{\.{\#\#\#}@>
17019 if ( v>0 ) mp_print_char(mp, xord('-'));
17020 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
17021 else vv=mp->max_c[mp_proto_dependent];
17022 if ( vv!=unity ) mp_print_scaled(mp, vv);
17023 mp_print_variable_name(mp, p);
17024 while ( value(p) % s_scale>0 ) {
17025 mp_print(mp, "*4"); value(p)=value(p)-2;
17027 if ( t==mp_dependent ) mp_print_char(mp, xord('=')); else mp_print(mp, " = ");
17028 mp_print_dependency(mp, s,t);
17029 mp_end_diagnostic(mp, false);
17032 @ Finally, there are dependent and proto-dependent variables whose
17033 dependency lists must be brought up to date.
17035 @<Substitute new dependencies...@>=
17036 for (t=mp_dependent;t<=mp_proto_dependent;t++){
17038 while ( r!=null ) {
17040 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17041 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
17042 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
17043 q=r; r=mp_link(r); mp_free_node(mp, q,dep_node_size);
17047 @ @<Substitute new proto...@>=
17048 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
17050 while ( r!=null ) {
17052 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
17053 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
17054 mp->cur_type=mp_proto_dependent;
17055 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
17056 mp_dependent,mp_proto_dependent);
17057 type(q)=mp_proto_dependent;
17058 value(r)=mp_round_fraction(mp, value(r));
17060 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17061 mp_make_scaled(mp, value(r),-v),s,
17062 mp_proto_dependent,mp_proto_dependent);
17063 if ( dep_list(q)==mp->dep_final )
17064 mp_make_known(mp, q,mp->dep_final);
17065 q=r; r=mp_link(r); mp_free_node(mp, q,dep_node_size);
17069 @ Here are some routines that provide handy combinations of actions
17070 that are often needed during error recovery. For example,
17071 `|flush_error|' flushes the current expression, replaces it by
17072 a given value, and calls |error|.
17074 Errors often are detected after an extra token has already been scanned.
17075 The `\\{put\_get}' routines put that token back before calling |error|;
17076 then they get it back again. (Or perhaps they get another token, if
17077 the user has changed things.)
17080 void mp_flush_error (MP mp,scaled v);
17081 void mp_put_get_error (MP mp);
17082 void mp_put_get_flush_error (MP mp,scaled v) ;
17085 void mp_flush_error (MP mp,scaled v) {
17086 mp_error(mp); mp_flush_cur_exp(mp, v);
17088 void mp_put_get_error (MP mp) {
17089 mp_back_error(mp); mp_get_x_next(mp);
17091 void mp_put_get_flush_error (MP mp,scaled v) {
17092 mp_put_get_error(mp);
17093 mp_flush_cur_exp(mp, v);
17096 @ A global variable |var_flag| is set to a special command code
17097 just before \MP\ calls |scan_expression|, if the expression should be
17098 treated as a variable when this command code immediately follows. For
17099 example, |var_flag| is set to |assignment| at the beginning of a
17100 statement, because we want to know the {\sl location\/} of a variable at
17101 the left of `\.{:=}', not the {\sl value\/} of that variable.
17103 The |scan_expression| subroutine calls |scan_tertiary|,
17104 which calls |scan_secondary|, which calls |scan_primary|, which sets
17105 |var_flag:=0|. In this way each of the scanning routines ``knows''
17106 when it has been called with a special |var_flag|, but |var_flag| is
17109 A variable preceding a command that equals |var_flag| is converted to a
17110 token list rather than a value. Furthermore, an `\.{=}' sign following an
17111 expression with |var_flag=assignment| is not considered to be a relation
17112 that produces boolean expressions.
17116 int var_flag; /* command that wants a variable */
17121 @* \[37] Parsing primary expressions.
17122 The first parsing routine, |scan_primary|, is also the most complicated one,
17123 since it involves so many different cases. But each case---with one
17124 exception---is fairly simple by itself.
17126 When |scan_primary| begins, the first token of the primary to be scanned
17127 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17128 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17129 earlier. If |cur_cmd| is not between |min_primary_command| and
17130 |max_primary_command|, inclusive, a syntax error will be signaled.
17132 @<Declare the basic parsing subroutines@>=
17133 void mp_scan_primary (MP mp) {
17134 pointer p,q,r; /* for list manipulation */
17135 quarterword c; /* a primitive operation code */
17136 int my_var_flag; /* initial value of |my_var_flag| */
17137 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17138 @<Other local variables for |scan_primary|@>;
17139 my_var_flag=mp->var_flag; mp->var_flag=0;
17142 @<Supply diagnostic information, if requested@>;
17143 switch (mp->cur_cmd) {
17144 case left_delimiter:
17145 @<Scan a delimited primary@>; break;
17147 @<Scan a grouped primary@>; break;
17149 @<Scan a string constant@>; break;
17150 case numeric_token:
17151 @<Scan a primary that starts with a numeric token@>; break;
17153 @<Scan a nullary operation@>; break;
17154 case unary: case type_name: case cycle: case plus_or_minus:
17155 @<Scan a unary operation@>; break;
17156 case primary_binary:
17157 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17159 @<Convert a suffix to a string@>; break;
17160 case internal_quantity:
17161 @<Scan an internal numeric quantity@>; break;
17162 case capsule_token:
17163 mp_make_exp_copy(mp, mp->cur_mod); break;
17165 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17167 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17168 @.A primary expression...@>
17170 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17172 if ( mp->cur_cmd==left_bracket ) {
17173 if ( mp->cur_type>=mp_known ) {
17174 @<Scan a mediation construction@>;
17181 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17183 @c void mp_bad_exp (MP mp, const char * s) {
17185 print_err(s); mp_print(mp, " expression can't begin with `");
17186 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17187 mp_print_char(mp, xord('\''));
17188 help4("I'm afraid I need some sort of value in order to continue,",
17189 "so I've tentatively inserted `0'. You may want to",
17190 "delete this zero and insert something else;",
17191 "see Chapter 27 of The METAFONTbook for an example.");
17192 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17193 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17194 mp->cur_mod=0; mp_ins_error(mp);
17195 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17196 mp->var_flag=save_flag;
17199 @ @<Supply diagnostic information, if requested@>=
17201 if ( mp->panicking ) mp_check_mem(mp, false);
17203 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17204 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17207 @ @<Scan a delimited primary@>=
17209 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17210 mp_get_x_next(mp); mp_scan_expression(mp);
17211 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17212 @<Scan the rest of a delimited set of numerics@>;
17214 mp_check_delimiter(mp, l_delim,r_delim);
17218 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17219 within a ``big node.''
17221 @c void mp_stash_in (MP mp,pointer p) {
17222 pointer q; /* temporary register */
17223 type(p)=mp->cur_type;
17224 if ( mp->cur_type==mp_known ) {
17225 value(p)=mp->cur_exp;
17227 if ( mp->cur_type==mp_independent ) {
17228 @<Stash an independent |cur_exp| into a big node@>;
17230 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17231 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17232 mp_link(prev_dep(p))=p;
17234 mp_free_node(mp, mp->cur_exp,value_node_size);
17236 mp->cur_type=mp_vacuous;
17239 @ In rare cases the current expression can become |independent|. There
17240 may be many dependency lists pointing to such an independent capsule,
17241 so we can't simply move it into place within a big node. Instead,
17242 we copy it, then recycle it.
17244 @ @<Stash an independent |cur_exp|...@>=
17246 q=mp_single_dependency(mp, mp->cur_exp);
17247 if ( q==mp->dep_final ){
17248 type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17250 type(p)=mp_dependent; mp_new_dep(mp, p,q);
17252 mp_recycle_value(mp, mp->cur_exp);
17255 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17256 are synonymous with |x_part_loc| and |y_part_loc|.
17258 @<Scan the rest of a delimited set of numerics@>=
17260 p=mp_stash_cur_exp(mp);
17261 mp_get_x_next(mp); mp_scan_expression(mp);
17262 @<Make sure the second part of a pair or color has a numeric type@>;
17263 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
17264 if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
17265 else type(q)=mp_pair_type;
17266 mp_init_big_node(mp, q); r=value(q);
17267 mp_stash_in(mp, y_part_loc(r));
17268 mp_unstash_cur_exp(mp, p);
17269 mp_stash_in(mp, x_part_loc(r));
17270 if ( mp->cur_cmd==comma ) {
17271 @<Scan the last of a triplet of numerics@>;
17273 if ( mp->cur_cmd==comma ) {
17274 type(q)=mp_cmykcolor_type;
17275 mp_init_big_node(mp, q); t=value(q);
17276 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17277 value(cyan_part_loc(t))=value(red_part_loc(r));
17278 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17279 value(magenta_part_loc(t))=value(green_part_loc(r));
17280 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17281 value(yellow_part_loc(t))=value(blue_part_loc(r));
17282 mp_recycle_value(mp, r);
17284 @<Scan the last of a quartet of numerics@>;
17286 mp_check_delimiter(mp, l_delim,r_delim);
17287 mp->cur_type=type(q);
17291 @ @<Make sure the second part of a pair or color has a numeric type@>=
17292 if ( mp->cur_type<mp_known ) {
17293 exp_err("Nonnumeric ypart has been replaced by 0");
17294 @.Nonnumeric...replaced by 0@>
17295 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';",
17296 "but after finding a nice `a' I found a `b' that isn't",
17297 "of numeric type. So I've changed that part to zero.",
17298 "(The b that I didn't like appears above the error message.)");
17299 mp_put_get_flush_error(mp, 0);
17302 @ @<Scan the last of a triplet of numerics@>=
17304 mp_get_x_next(mp); mp_scan_expression(mp);
17305 if ( mp->cur_type<mp_known ) {
17306 exp_err("Nonnumeric third part has been replaced by 0");
17307 @.Nonnumeric...replaced by 0@>
17308 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'",
17309 "isn't of numeric type. So I've changed that part to zero.",
17310 "(The c that I didn't like appears above the error message.)");
17311 mp_put_get_flush_error(mp, 0);
17313 mp_stash_in(mp, blue_part_loc(r));
17316 @ @<Scan the last of a quartet of numerics@>=
17318 mp_get_x_next(mp); mp_scan_expression(mp);
17319 if ( mp->cur_type<mp_known ) {
17320 exp_err("Nonnumeric blackpart has been replaced by 0");
17321 @.Nonnumeric...replaced by 0@>
17322 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't",
17323 "of numeric type. So I've changed that part to zero.",
17324 "(The k that I didn't like appears above the error message.)");
17325 mp_put_get_flush_error(mp, 0);
17327 mp_stash_in(mp, black_part_loc(r));
17330 @ The local variable |group_line| keeps track of the line
17331 where a \&{begingroup} command occurred; this will be useful
17332 in an error message if the group doesn't actually end.
17334 @<Other local variables for |scan_primary|@>=
17335 integer group_line; /* where a group began */
17337 @ @<Scan a grouped primary@>=
17339 group_line=mp_true_line(mp);
17340 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17341 save_boundary_item(p);
17343 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17344 } while (mp->cur_cmd==semicolon);
17345 if ( mp->cur_cmd!=end_group ) {
17346 print_err("A group begun on line ");
17347 @.A group...never ended@>
17348 mp_print_int(mp, group_line);
17349 mp_print(mp, " never ended");
17350 help2("I saw a `begingroup' back there that hasn't been matched",
17351 "by `endgroup'. So I've inserted `endgroup' now.");
17352 mp_back_error(mp); mp->cur_cmd=end_group;
17355 /* this might change |cur_type|, if independent variables are recycled */
17356 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17359 @ @<Scan a string constant@>=
17361 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17364 @ Later we'll come to procedures that perform actual operations like
17365 addition, square root, and so on; our purpose now is to do the parsing.
17366 But we might as well mention those future procedures now, so that the
17367 suspense won't be too bad:
17370 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17371 `\&{true}' or `\&{pencircle}');
17374 |do_unary(c)| applies a primitive operation to the current expression;
17377 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17378 and the current expression.
17380 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17382 @ @<Scan a unary operation@>=
17384 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17385 mp_do_unary(mp, c); goto DONE;
17388 @ A numeric token might be a primary by itself, or it might be the
17389 numerator of a fraction composed solely of numeric tokens, or it might
17390 multiply the primary that follows (provided that the primary doesn't begin
17391 with a plus sign or a minus sign). The code here uses the facts that
17392 |max_primary_command=plus_or_minus| and
17393 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17394 than unity, we try to retain higher precision when we use it in scalar
17397 @<Other local variables for |scan_primary|@>=
17398 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17400 @ @<Scan a primary that starts with a numeric token@>=
17402 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17403 if ( mp->cur_cmd!=slash ) {
17407 if ( mp->cur_cmd!=numeric_token ) {
17409 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17412 num=mp->cur_exp; denom=mp->cur_mod;
17413 if ( denom==0 ) { @<Protest division by zero@>; }
17414 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17415 check_arith; mp_get_x_next(mp);
17417 if ( mp->cur_cmd>=min_primary_command ) {
17418 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17419 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17420 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17421 mp_do_binary(mp, p,times);
17423 mp_frac_mult(mp, num,denom);
17424 mp_free_node(mp, p,value_node_size);
17431 @ @<Protest division...@>=
17433 print_err("Division by zero");
17434 @.Division by zero@>
17435 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17438 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17440 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17441 if ( mp->cur_cmd!=of_token ) {
17442 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17443 mp_print_cmd_mod(mp, primary_binary,c);
17445 help1("I've got the first argument; will look now for the other.");
17448 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17449 mp_do_binary(mp, p,c); goto DONE;
17452 @ @<Convert a suffix to a string@>=
17454 mp_get_x_next(mp); mp_scan_suffix(mp);
17455 mp->old_setting=mp->selector; mp->selector=new_string;
17456 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17457 mp_flush_token_list(mp, mp->cur_exp);
17458 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17459 mp->cur_type=mp_string_type;
17463 @ If an internal quantity appears all by itself on the left of an
17464 assignment, we return a token list of length one, containing the address
17465 of the internal quantity plus |hash_end|. (This accords with the conventions
17466 of the save stack, as described earlier.)
17468 @<Scan an internal...@>=
17471 if ( my_var_flag==assignment ) {
17473 if ( mp->cur_cmd==assignment ) {
17474 mp->cur_exp=mp_get_avail(mp);
17475 info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17480 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17483 @ The most difficult part of |scan_primary| has been saved for last, since
17484 it was necessary to build up some confidence first. We can now face the task
17485 of scanning a variable.
17487 As we scan a variable, we build a token list containing the relevant
17488 names and subscript values, simultaneously following along in the
17489 ``collective'' structure to see if we are actually dealing with a macro
17490 instead of a value.
17492 The local variables |pre_head| and |post_head| will point to the beginning
17493 of the prefix and suffix lists; |tail| will point to the end of the list
17494 that is currently growing.
17496 Another local variable, |tt|, contains partial information about the
17497 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17498 relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
17499 doesn't bother to update its information about type. And if
17500 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17502 @ @<Other local variables for |scan_primary|@>=
17503 pointer pre_head,post_head,tail;
17504 /* prefix and suffix list variables */
17505 quarterword tt; /* approximation to the type of the variable-so-far */
17506 pointer t; /* a token */
17507 pointer macro_ref = 0; /* reference count for a suffixed macro */
17509 @ @<Scan a variable primary...@>=
17511 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17513 t=mp_cur_tok(mp); mp_link(tail)=t;
17514 if ( tt!=undefined ) {
17515 @<Find the approximate type |tt| and corresponding~|q|@>;
17516 if ( tt>=mp_unsuffixed_macro ) {
17517 @<Either begin an unsuffixed macro call or
17518 prepare for a suffixed one@>;
17521 mp_get_x_next(mp); tail=t;
17522 if ( mp->cur_cmd==left_bracket ) {
17523 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17525 if ( mp->cur_cmd>max_suffix_token ) break;
17526 if ( mp->cur_cmd<min_suffix_token ) break;
17527 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17528 @<Handle unusual cases that masquerade as variables, and |goto restart|
17529 or |goto done| if appropriate;
17530 otherwise make a copy of the variable and |goto done|@>;
17533 @ @<Either begin an unsuffixed macro call or...@>=
17535 mp_link(tail)=null;
17536 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17537 post_head=mp_get_avail(mp); tail=post_head; mp_link(tail)=t;
17538 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17540 @<Set up unsuffixed macro call and |goto restart|@>;
17544 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17546 mp_get_x_next(mp); mp_scan_expression(mp);
17547 if ( mp->cur_cmd!=right_bracket ) {
17548 @<Put the left bracket and the expression back to be rescanned@>;
17550 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17551 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17555 @ The left bracket that we thought was introducing a subscript might have
17556 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17557 So we don't issue an error message at this point; but we do want to back up
17558 so as to avoid any embarrassment about our incorrect assumption.
17560 @<Put the left bracket and the expression back to be rescanned@>=
17562 mp_back_input(mp); /* that was the token following the current expression */
17563 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17564 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17567 @ Here's a routine that puts the current expression back to be read again.
17569 @c void mp_back_expr (MP mp) {
17570 pointer p; /* capsule token */
17571 p=mp_stash_cur_exp(mp); mp_link(p)=null; back_list(p);
17574 @ Unknown subscripts lead to the following error message.
17576 @c void mp_bad_subscript (MP mp) {
17577 exp_err("Improper subscript has been replaced by zero");
17578 @.Improper subscript...@>
17579 help3("A bracketed subscript must have a known numeric value;",
17580 "unfortunately, what I found was the value that appears just",
17581 "above this error message. So I'll try a zero subscript.");
17582 mp_flush_error(mp, 0);
17585 @ Every time we call |get_x_next|, there's a chance that the variable we've
17586 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17587 into the variable structure; we need to start searching from the root each time.
17589 @<Find the approximate type |tt| and corresponding~|q|@>=
17592 p=mp_link(pre_head); q=info(p); tt=undefined;
17593 if ( eq_type(q) % outer_tag==tag_token ) {
17595 if ( q==null ) goto DONE2;
17599 tt=type(q); goto DONE2;
17601 if ( type(q)!=mp_structured ) goto DONE2;
17602 q=mp_link(attr_head(q)); /* the |collective_subscript| attribute */
17603 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17604 do { q=mp_link(q); } while (! (attr_loc(q)>=info(p)));
17605 if ( attr_loc(q)>info(p) ) goto DONE2;
17613 @ How do things stand now? Well, we have scanned an entire variable name,
17614 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17615 |cur_sym| represent the token that follows. If |post_head=null|, a
17616 token list for this variable name starts at |mp_link(pre_head)|, with all
17617 subscripts evaluated. But if |post_head<>null|, the variable turned out
17618 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17619 |post_head| is the head of a token list containing both `\.{\AT!}' and
17622 Our immediate problem is to see if this variable still exists. (Variable
17623 structures can change drastically whenever we call |get_x_next|; users
17624 aren't supposed to do this, but the fact that it is possible means that
17625 we must be cautious.)
17627 The following procedure prints an error message when a variable
17628 unexpectedly disappears. Its help message isn't quite right for
17629 our present purposes, but we'll be able to fix that up.
17632 void mp_obliterated (MP mp,pointer q) {
17633 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17634 mp_print(mp, " has been obliterated");
17635 @.Variable...obliterated@>
17636 help5("It seems you did a nasty thing---probably by accident,",
17637 "but nevertheless you nearly hornswoggled me...",
17638 "While I was evaluating the right-hand side of this",
17639 "command, something happened, and the left-hand side",
17640 "is no longer a variable! So I won't change anything.");
17643 @ If the variable does exist, we also need to check
17644 for a few other special cases before deciding that a plain old ordinary
17645 variable has, indeed, been scanned.
17647 @<Handle unusual cases that masquerade as variables...@>=
17648 if ( post_head!=null ) {
17649 @<Set up suffixed macro call and |goto restart|@>;
17651 q=mp_link(pre_head); free_avail(pre_head);
17652 if ( mp->cur_cmd==my_var_flag ) {
17653 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17655 p=mp_find_variable(mp, q);
17657 mp_make_exp_copy(mp, p);
17659 mp_obliterated(mp, q);
17660 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17661 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17662 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17663 mp_put_get_flush_error(mp, 0);
17665 mp_flush_node_list(mp, q);
17668 @ The only complication associated with macro calling is that the prefix
17669 and ``at'' parameters must be packaged in an appropriate list of lists.
17671 @<Set up unsuffixed macro call and |goto restart|@>=
17673 p=mp_get_avail(mp); info(pre_head)=mp_link(pre_head); mp_link(pre_head)=p;
17674 info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17679 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17680 we don't care, because we have reserved a pointer (|macro_ref|) to its
17683 @<Set up suffixed macro call and |goto restart|@>=
17685 mp_back_input(mp); p=mp_get_avail(mp); q=mp_link(post_head);
17686 info(pre_head)=mp_link(pre_head); mp_link(pre_head)=post_head;
17687 info(post_head)=q; mp_link(post_head)=p; info(p)=mp_link(q); mp_link(q)=null;
17688 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17689 mp_get_x_next(mp); goto RESTART;
17692 @ Our remaining job is simply to make a copy of the value that has been
17693 found. Some cases are harder than others, but complexity arises solely
17694 because of the multiplicity of possible cases.
17696 @<Declare the procedure called |make_exp_copy|@>=
17697 @<Declare subroutines needed by |make_exp_copy|@>
17698 void mp_make_exp_copy (MP mp,pointer p) {
17699 pointer q,r,t; /* registers for list manipulation */
17701 mp->cur_type=type(p);
17702 switch (mp->cur_type) {
17703 case mp_vacuous: case mp_boolean_type: case mp_known:
17704 mp->cur_exp=value(p); break;
17705 case unknown_types:
17706 mp->cur_exp=mp_new_ring_entry(mp, p);
17708 case mp_string_type:
17709 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17711 case mp_picture_type:
17712 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17715 mp->cur_exp=copy_pen(value(p));
17718 mp->cur_exp=mp_copy_path(mp, value(p));
17720 case mp_transform_type: case mp_color_type:
17721 case mp_cmykcolor_type: case mp_pair_type:
17722 @<Copy the big node |p|@>;
17724 case mp_dependent: case mp_proto_dependent:
17725 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17727 case mp_numeric_type:
17728 new_indep(p); goto RESTART;
17730 case mp_independent:
17731 q=mp_single_dependency(mp, p);
17732 if ( q==mp->dep_final ){
17733 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
17735 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17739 mp_confusion(mp, "copy");
17740 @:this can't happen copy}{\quad copy@>
17745 @ The |encapsulate| subroutine assumes that |dep_final| is the
17746 tail of dependency list~|p|.
17748 @<Declare subroutines needed by |make_exp_copy|@>=
17749 void mp_encapsulate (MP mp,pointer p) {
17750 mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
17751 name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17754 @ The most tedious case arises when the user refers to a
17755 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17756 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17759 @<Copy the big node |p|@>=
17761 if ( value(p)==null )
17762 mp_init_big_node(mp, p);
17763 t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
17764 mp_init_big_node(mp, t);
17765 q=value(p)+mp->big_node_size[mp->cur_type];
17766 r=value(t)+mp->big_node_size[mp->cur_type];
17768 q=q-2; r=r-2; mp_install(mp, r,q);
17769 } while (q!=value(p));
17773 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17774 a big node that will be part of a capsule.
17776 @<Declare subroutines needed by |make_exp_copy|@>=
17777 void mp_install (MP mp,pointer r, pointer q) {
17778 pointer p; /* temporary register */
17779 if ( type(q)==mp_known ){
17780 value(r)=value(q); type(r)=mp_known;
17781 } else if ( type(q)==mp_independent ) {
17782 p=mp_single_dependency(mp, q);
17783 if ( p==mp->dep_final ) {
17784 type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
17786 type(r)=mp_dependent; mp_new_dep(mp, r,p);
17789 type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17793 @ Expressions of the form `\.{a[b,c]}' are converted into
17794 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17795 provided that \.a is numeric.
17797 @<Scan a mediation...@>=
17799 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17800 if ( mp->cur_cmd!=comma ) {
17801 @<Put the left bracket and the expression back...@>;
17802 mp_unstash_cur_exp(mp, p);
17804 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17805 if ( mp->cur_cmd!=right_bracket ) {
17806 mp_missing_err(mp, "]");
17808 help3("I've scanned an expression of the form `a[b,c',",
17809 "so a right bracket should have come next.",
17810 "I shall pretend that one was there.");
17813 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17814 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17815 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17819 @ Here is a comparatively simple routine that is used to scan the
17820 \&{suffix} parameters of a macro.
17822 @<Declare the basic parsing subroutines@>=
17823 void mp_scan_suffix (MP mp) {
17824 pointer h,t; /* head and tail of the list being built */
17825 pointer p; /* temporary register */
17826 h=mp_get_avail(mp); t=h;
17828 if ( mp->cur_cmd==left_bracket ) {
17829 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17831 if ( mp->cur_cmd==numeric_token ) {
17832 p=mp_new_num_tok(mp, mp->cur_mod);
17833 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17834 p=mp_get_avail(mp); info(p)=mp->cur_sym;
17838 mp_link(t)=p; t=p; mp_get_x_next(mp);
17840 mp->cur_exp=mp_link(h); free_avail(h); mp->cur_type=mp_token_list;
17843 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17845 mp_get_x_next(mp); mp_scan_expression(mp);
17846 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17847 if ( mp->cur_cmd!=right_bracket ) {
17848 mp_missing_err(mp, "]");
17850 help3("I've seen a `[' and a subscript value, in a suffix,",
17851 "so a right bracket should have come next.",
17852 "I shall pretend that one was there.");
17855 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
17858 @* \[38] Parsing secondary and higher expressions.
17860 After the intricacies of |scan_primary|\kern-1pt,
17861 the |scan_secondary| routine is
17862 refreshingly simple. It's not trivial, but the operations are relatively
17863 straightforward; the main difficulty is, again, that expressions and data
17864 structures might change drastically every time we call |get_x_next|, so a
17865 cautious approach is mandatory. For example, a macro defined by
17866 \&{primarydef} might have disappeared by the time its second argument has
17867 been scanned; we solve this by increasing the reference count of its token
17868 list, so that the macro can be called even after it has been clobbered.
17870 @<Declare the basic parsing subroutines@>=
17871 void mp_scan_secondary (MP mp) {
17872 pointer p; /* for list manipulation */
17873 halfword c,d; /* operation codes or modifiers */
17874 pointer mac_name; /* token defined with \&{primarydef} */
17876 if ((mp->cur_cmd<min_primary_command)||
17877 (mp->cur_cmd>max_primary_command) )
17878 mp_bad_exp(mp, "A secondary");
17879 @.A secondary expression...@>
17880 mp_scan_primary(mp);
17882 if ( mp->cur_cmd<=max_secondary_command &&
17883 mp->cur_cmd>=min_secondary_command ) {
17884 p=mp_stash_cur_exp(mp);
17885 c=mp->cur_mod; d=mp->cur_cmd;
17886 if ( d==secondary_primary_macro ) {
17887 mac_name=mp->cur_sym;
17891 mp_scan_primary(mp);
17892 if ( d!=secondary_primary_macro ) {
17893 mp_do_binary(mp, p,c);
17896 mp_binary_mac(mp, p,c,mac_name);
17897 decr(ref_count(c));
17905 @ The following procedure calls a macro that has two parameters,
17908 @c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
17909 pointer q,r; /* nodes in the parameter list */
17910 q=mp_get_avail(mp); r=mp_get_avail(mp); mp_link(q)=r;
17911 info(q)=p; info(r)=mp_stash_cur_exp(mp);
17912 mp_macro_call(mp, c,q,n);
17915 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
17917 @<Declare the basic parsing subroutines@>=
17918 void mp_scan_tertiary (MP mp) {
17919 pointer p; /* for list manipulation */
17920 halfword c,d; /* operation codes or modifiers */
17921 pointer mac_name; /* token defined with \&{secondarydef} */
17923 if ((mp->cur_cmd<min_primary_command)||
17924 (mp->cur_cmd>max_primary_command) )
17925 mp_bad_exp(mp, "A tertiary");
17926 @.A tertiary expression...@>
17927 mp_scan_secondary(mp);
17929 if ( mp->cur_cmd<=max_tertiary_command ) {
17930 if ( mp->cur_cmd>=min_tertiary_command ) {
17931 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
17932 if ( d==tertiary_secondary_macro ) {
17933 mac_name=mp->cur_sym; add_mac_ref(c);
17935 mp_get_x_next(mp); mp_scan_secondary(mp);
17936 if ( d!=tertiary_secondary_macro ) {
17937 mp_do_binary(mp, p,c);
17939 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
17940 decr(ref_count(c)); mp_get_x_next(mp);
17948 @ Finally we reach the deepest level in our quartet of parsing routines.
17949 This one is much like the others; but it has an extra complication from
17950 paths, which materialize here.
17952 @d continue_path 25 /* a label inside of |scan_expression| */
17953 @d finish_path 26 /* another */
17955 @<Declare the basic parsing subroutines@>=
17956 void mp_scan_expression (MP mp) {
17957 pointer p,q,r,pp,qq; /* for list manipulation */
17958 halfword c,d; /* operation codes or modifiers */
17959 int my_var_flag; /* initial value of |var_flag| */
17960 pointer mac_name; /* token defined with \&{tertiarydef} */
17961 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
17962 scaled x,y; /* explicit coordinates or tension at a path join */
17963 int t; /* knot type following a path join */
17965 my_var_flag=mp->var_flag; mac_name=null;
17967 if ((mp->cur_cmd<min_primary_command)||
17968 (mp->cur_cmd>max_primary_command) )
17969 mp_bad_exp(mp, "An");
17970 @.An expression...@>
17971 mp_scan_tertiary(mp);
17973 if ( mp->cur_cmd<=max_expression_command )
17974 if ( mp->cur_cmd>=min_expression_command ) {
17975 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
17976 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
17977 if ( d==expression_tertiary_macro ) {
17978 mac_name=mp->cur_sym; add_mac_ref(c);
17980 if ( (d<ampersand)||((d==ampersand)&&
17981 ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
17982 @<Scan a path construction operation;
17983 but |return| if |p| has the wrong type@>;
17985 mp_get_x_next(mp); mp_scan_tertiary(mp);
17986 if ( d!=expression_tertiary_macro ) {
17987 mp_do_binary(mp, p,c);
17989 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
17990 decr(ref_count(c)); mp_get_x_next(mp);
17999 @ The reader should review the data structure conventions for paths before
18000 hoping to understand the next part of this code.
18002 @<Scan a path construction operation...@>=
18005 @<Convert the left operand, |p|, into a partial path ending at~|q|;
18006 but |return| if |p| doesn't have a suitable type@>;
18008 @<Determine the path join parameters;
18009 but |goto finish_path| if there's only a direction specifier@>;
18010 if ( mp->cur_cmd==cycle ) {
18011 @<Get ready to close a cycle@>;
18013 mp_scan_tertiary(mp);
18014 @<Convert the right operand, |cur_exp|,
18015 into a partial path from |pp| to~|qq|@>;
18017 @<Join the partial paths and reset |p| and |q| to the head and tail
18019 if ( mp->cur_cmd>=min_expression_command )
18020 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
18022 @<Choose control points for the path and put the result into |cur_exp|@>;
18025 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
18027 mp_unstash_cur_exp(mp, p);
18028 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
18029 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
18032 while ( mp_link(q)!=p ) q=mp_link(q);
18033 if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
18034 r=mp_copy_knot(mp, p); mp_link(q)=r; q=r;
18036 left_type(p)=mp_open; right_type(q)=mp_open;
18039 @ A pair of numeric values is changed into a knot node for a one-point path
18040 when \MP\ discovers that the pair is part of a path.
18042 @c @<Declare the procedure called |known_pair|@>
18043 pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
18044 pointer q; /* the new node */
18045 q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
18046 right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; mp_link(q)=q;
18047 mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
18051 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
18052 of the current expression, assuming that the current expression is a
18053 pair of known numerics. Unknown components are zeroed, and the
18054 current expression is flushed.
18056 @<Declare the procedure called |known_pair|@>=
18057 void mp_known_pair (MP mp) {
18058 pointer p; /* the pair node */
18059 if ( mp->cur_type!=mp_pair_type ) {
18060 exp_err("Undefined coordinates have been replaced by (0,0)");
18061 @.Undefined coordinates...@>
18062 help5("I need x and y numbers for this part of the path.",
18063 "The value I found (see above) was no good;",
18064 "so I'll try to keep going by using zero instead.",
18065 "(Chapter 27 of The METAFONTbook explains that",
18066 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18067 "you might want to type `I ??" "?' now.)");
18068 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
18070 p=value(mp->cur_exp);
18071 @<Make sure that both |x| and |y| parts of |p| are known;
18072 copy them into |cur_x| and |cur_y|@>;
18073 mp_flush_cur_exp(mp, 0);
18077 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
18078 if ( type(x_part_loc(p))==mp_known ) {
18079 mp->cur_x=value(x_part_loc(p));
18081 mp_disp_err(mp, x_part_loc(p),
18082 "Undefined x coordinate has been replaced by 0");
18083 @.Undefined coordinates...@>
18084 help5("I need a `known' x value for this part of the path.",
18085 "The value I found (see above) was no good;",
18086 "so I'll try to keep going by using zero instead.",
18087 "(Chapter 27 of The METAFONTbook explains that",
18088 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18089 "you might want to type `I ??" "?' now.)");
18090 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18092 if ( type(y_part_loc(p))==mp_known ) {
18093 mp->cur_y=value(y_part_loc(p));
18095 mp_disp_err(mp, y_part_loc(p),
18096 "Undefined y coordinate has been replaced by 0");
18097 help5("I need a `known' y value for this part of the path.",
18098 "The value I found (see above) was no good;",
18099 "so I'll try to keep going by using zero instead.",
18100 "(Chapter 27 of The METAFONTbook explains that",
18101 "you might want to type `I ??" "?' now.)");
18102 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18105 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18107 @<Determine the path join parameters...@>=
18108 if ( mp->cur_cmd==left_brace ) {
18109 @<Put the pre-join direction information into node |q|@>;
18112 if ( d==path_join ) {
18113 @<Determine the tension and/or control points@>;
18114 } else if ( d!=ampersand ) {
18118 if ( mp->cur_cmd==left_brace ) {
18119 @<Put the post-join direction information into |x| and |t|@>;
18120 } else if ( right_type(q)!=mp_explicit ) {
18124 @ The |scan_direction| subroutine looks at the directional information
18125 that is enclosed in braces, and also scans ahead to the following character.
18126 A type code is returned, either |open| (if the direction was $(0,0)$),
18127 or |curl| (if the direction was a curl of known value |cur_exp|), or
18128 |given| (if the direction is given by the |angle| value that now
18129 appears in |cur_exp|).
18131 There's nothing difficult about this subroutine, but the program is rather
18132 lengthy because a variety of potential errors need to be nipped in the bud.
18134 @c quarterword mp_scan_direction (MP mp) {
18135 int t; /* the type of information found */
18136 scaled x; /* an |x| coordinate */
18138 if ( mp->cur_cmd==curl_command ) {
18139 @<Scan a curl specification@>;
18141 @<Scan a given direction@>;
18143 if ( mp->cur_cmd!=right_brace ) {
18144 mp_missing_err(mp, "}");
18145 @.Missing `\char`\}'@>
18146 help3("I've scanned a direction spec for part of a path,",
18147 "so a right brace should have come next.",
18148 "I shall pretend that one was there.");
18155 @ @<Scan a curl specification@>=
18156 { mp_get_x_next(mp); mp_scan_expression(mp);
18157 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18158 exp_err("Improper curl has been replaced by 1");
18160 help1("A curl must be a known, nonnegative number.");
18161 mp_put_get_flush_error(mp, unity);
18166 @ @<Scan a given direction@>=
18167 { mp_scan_expression(mp);
18168 if ( mp->cur_type>mp_pair_type ) {
18169 @<Get given directions separated by commas@>;
18173 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18174 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18177 @ @<Get given directions separated by commas@>=
18179 if ( mp->cur_type!=mp_known ) {
18180 exp_err("Undefined x coordinate has been replaced by 0");
18181 @.Undefined coordinates...@>
18182 help5("I need a `known' x value for this part of the path.",
18183 "The value I found (see above) was no good;",
18184 "so I'll try to keep going by using zero instead.",
18185 "(Chapter 27 of The METAFONTbook explains that",
18186 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18187 "you might want to type `I ??" "?' now.)");
18188 mp_put_get_flush_error(mp, 0);
18191 if ( mp->cur_cmd!=comma ) {
18192 mp_missing_err(mp, ",");
18194 help2("I've got the x coordinate of a path direction;",
18195 "will look for the y coordinate next.");
18198 mp_get_x_next(mp); mp_scan_expression(mp);
18199 if ( mp->cur_type!=mp_known ) {
18200 exp_err("Undefined y coordinate has been replaced by 0");
18201 help5("I need a `known' y value for this part of the path.",
18202 "The value I found (see above) was no good;",
18203 "so I'll try to keep going by using zero instead.",
18204 "(Chapter 27 of The METAFONTbook explains that",
18205 "you might want to type `I ??" "?' now.)");
18206 mp_put_get_flush_error(mp, 0);
18208 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18211 @ At this point |right_type(q)| is usually |open|, but it may have been
18212 set to some other value by a previous operation. We must maintain
18213 the value of |right_type(q)| in cases such as
18214 `\.{..\{curl2\}z\{0,0\}..}'.
18216 @<Put the pre-join...@>=
18218 t=mp_scan_direction(mp);
18219 if ( t!=mp_open ) {
18220 right_type(q)=t; right_given(q)=mp->cur_exp;
18221 if ( left_type(q)==mp_open ) {
18222 left_type(q)=t; left_given(q)=mp->cur_exp;
18223 } /* note that |left_given(q)=left_curl(q)| */
18227 @ Since |left_tension| and |left_y| share the same position in knot nodes,
18228 and since |left_given| is similarly equivalent to |left_x|, we use
18229 |x| and |y| to hold the given direction and tension information when
18230 there are no explicit control points.
18232 @<Put the post-join...@>=
18234 t=mp_scan_direction(mp);
18235 if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
18236 else t=mp_explicit; /* the direction information is superfluous */
18239 @ @<Determine the tension and/or...@>=
18242 if ( mp->cur_cmd==tension ) {
18243 @<Set explicit tensions@>;
18244 } else if ( mp->cur_cmd==controls ) {
18245 @<Set explicit control points@>;
18247 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18250 if ( mp->cur_cmd!=path_join ) {
18251 mp_missing_err(mp, "..");
18253 help1("A path join command should end with two dots.");
18260 @ @<Set explicit tensions@>=
18262 mp_get_x_next(mp); y=mp->cur_cmd;
18263 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18264 mp_scan_primary(mp);
18265 @<Make sure that the current expression is a valid tension setting@>;
18266 if ( y==at_least ) negate(mp->cur_exp);
18267 right_tension(q)=mp->cur_exp;
18268 if ( mp->cur_cmd==and_command ) {
18269 mp_get_x_next(mp); y=mp->cur_cmd;
18270 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18271 mp_scan_primary(mp);
18272 @<Make sure that the current expression is a valid tension setting@>;
18273 if ( y==at_least ) negate(mp->cur_exp);
18278 @ @d min_tension three_quarter_unit
18280 @<Make sure that the current expression is a valid tension setting@>=
18281 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18282 exp_err("Improper tension has been set to 1");
18283 @.Improper tension@>
18284 help1("The expression above should have been a number >=3/4.");
18285 mp_put_get_flush_error(mp, unity);
18288 @ @<Set explicit control points@>=
18290 right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18291 mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
18292 if ( mp->cur_cmd!=and_command ) {
18293 x=right_x(q); y=right_y(q);
18295 mp_get_x_next(mp); mp_scan_primary(mp);
18296 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18300 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18302 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18303 else pp=mp->cur_exp;
18305 while ( mp_link(qq)!=pp ) qq=mp_link(qq);
18306 if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18307 r=mp_copy_knot(mp, pp); mp_link(qq)=r; qq=r;
18309 left_type(pp)=mp_open; right_type(qq)=mp_open;
18312 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18313 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18314 shouldn't have length zero.
18316 @<Get ready to close a cycle@>=
18318 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18319 if ( d==ampersand ) if ( p==q ) {
18320 d=path_join; right_tension(q)=unity; y=unity;
18324 @ @<Join the partial paths and reset |p| and |q|...@>=
18326 if ( d==ampersand ) {
18327 if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
18328 print_err("Paths don't touch; `&' will be changed to `..'");
18329 @.Paths don't touch@>
18330 help3("When you join paths `p&q', the ending point of p",
18331 "must be exactly equal to the starting point of q.",
18332 "So I'm going to pretend that you said `p..q' instead.");
18333 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18336 @<Plug an opening in |right_type(pp)|, if possible@>;
18337 if ( d==ampersand ) {
18338 @<Splice independent paths together@>;
18340 @<Plug an opening in |right_type(q)|, if possible@>;
18341 mp_link(q)=pp; left_y(pp)=y;
18342 if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
18347 @ @<Plug an opening in |right_type(q)|...@>=
18348 if ( right_type(q)==mp_open ) {
18349 if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
18350 right_type(q)=left_type(q); right_given(q)=left_given(q);
18354 @ @<Plug an opening in |right_type(pp)|...@>=
18355 if ( right_type(pp)==mp_open ) {
18356 if ( (t==mp_curl)||(t==mp_given) ) {
18357 right_type(pp)=t; right_given(pp)=x;
18361 @ @<Splice independent paths together@>=
18363 if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
18364 left_type(q)=mp_curl; left_curl(q)=unity;
18366 if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
18367 right_type(pp)=mp_curl; right_curl(pp)=unity;
18369 right_type(q)=right_type(pp); mp_link(q)=mp_link(pp);
18370 right_x(q)=right_x(pp); right_y(q)=right_y(pp);
18371 mp_free_node(mp, pp,knot_node_size);
18372 if ( qq==pp ) qq=q;
18375 @ @<Choose control points for the path...@>=
18377 if ( d==ampersand ) p=q;
18379 left_type(p)=mp_endpoint;
18380 if ( right_type(p)==mp_open ) {
18381 right_type(p)=mp_curl; right_curl(p)=unity;
18383 right_type(q)=mp_endpoint;
18384 if ( left_type(q)==mp_open ) {
18385 left_type(q)=mp_curl; left_curl(q)=unity;
18389 mp_make_choices(mp, p);
18390 mp->cur_type=mp_path_type; mp->cur_exp=p
18392 @ Finally, we sometimes need to scan an expression whose value is
18393 supposed to be either |true_code| or |false_code|.
18395 @<Declare the basic parsing subroutines@>=
18396 void mp_get_boolean (MP mp) {
18397 mp_get_x_next(mp); mp_scan_expression(mp);
18398 if ( mp->cur_type!=mp_boolean_type ) {
18399 exp_err("Undefined condition will be treated as `false'");
18400 @.Undefined condition...@>
18401 help2("The expression shown above should have had a definite",
18402 "true-or-false value. I'm changing it to `false'.");
18403 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18407 @* \[39] Doing the operations.
18408 The purpose of parsing is primarily to permit people to avoid piles of
18409 parentheses. But the real work is done after the structure of an expression
18410 has been recognized; that's when new expressions are generated. We
18411 turn now to the guts of \MP, which handles individual operators that
18412 have come through the parsing mechanism.
18414 We'll start with the easy ones that take no operands, then work our way
18415 up to operators with one and ultimately two arguments. In other words,
18416 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18417 that are invoked periodically by the expression scanners.
18419 First let's make sure that all of the primitive operators are in the
18420 hash table. Although |scan_primary| and its relatives made use of the
18421 \\{cmd} code for these operators, the \\{do} routines base everything
18422 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18423 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18426 mp_primitive(mp, "true",nullary,true_code);
18427 @:true_}{\&{true} primitive@>
18428 mp_primitive(mp, "false",nullary,false_code);
18429 @:false_}{\&{false} primitive@>
18430 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18431 @:null_picture_}{\&{nullpicture} primitive@>
18432 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18433 @:null_pen_}{\&{nullpen} primitive@>
18434 mp_primitive(mp, "jobname",nullary,job_name_op);
18435 @:job_name_}{\&{jobname} primitive@>
18436 mp_primitive(mp, "readstring",nullary,read_string_op);
18437 @:read_string_}{\&{readstring} primitive@>
18438 mp_primitive(mp, "pencircle",nullary,pen_circle);
18439 @:pen_circle_}{\&{pencircle} primitive@>
18440 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18441 @:normal_deviate_}{\&{normaldeviate} primitive@>
18442 mp_primitive(mp, "readfrom",unary,read_from_op);
18443 @:read_from_}{\&{readfrom} primitive@>
18444 mp_primitive(mp, "closefrom",unary,close_from_op);
18445 @:close_from_}{\&{closefrom} primitive@>
18446 mp_primitive(mp, "odd",unary,odd_op);
18447 @:odd_}{\&{odd} primitive@>
18448 mp_primitive(mp, "known",unary,known_op);
18449 @:known_}{\&{known} primitive@>
18450 mp_primitive(mp, "unknown",unary,unknown_op);
18451 @:unknown_}{\&{unknown} primitive@>
18452 mp_primitive(mp, "not",unary,not_op);
18453 @:not_}{\&{not} primitive@>
18454 mp_primitive(mp, "decimal",unary,decimal);
18455 @:decimal_}{\&{decimal} primitive@>
18456 mp_primitive(mp, "reverse",unary,reverse);
18457 @:reverse_}{\&{reverse} primitive@>
18458 mp_primitive(mp, "makepath",unary,make_path_op);
18459 @:make_path_}{\&{makepath} primitive@>
18460 mp_primitive(mp, "makepen",unary,make_pen_op);
18461 @:make_pen_}{\&{makepen} primitive@>
18462 mp_primitive(mp, "oct",unary,oct_op);
18463 @:oct_}{\&{oct} primitive@>
18464 mp_primitive(mp, "hex",unary,hex_op);
18465 @:hex_}{\&{hex} primitive@>
18466 mp_primitive(mp, "ASCII",unary,ASCII_op);
18467 @:ASCII_}{\&{ASCII} primitive@>
18468 mp_primitive(mp, "char",unary,char_op);
18469 @:char_}{\&{char} primitive@>
18470 mp_primitive(mp, "length",unary,length_op);
18471 @:length_}{\&{length} primitive@>
18472 mp_primitive(mp, "turningnumber",unary,turning_op);
18473 @:turning_number_}{\&{turningnumber} primitive@>
18474 mp_primitive(mp, "xpart",unary,x_part);
18475 @:x_part_}{\&{xpart} primitive@>
18476 mp_primitive(mp, "ypart",unary,y_part);
18477 @:y_part_}{\&{ypart} primitive@>
18478 mp_primitive(mp, "xxpart",unary,xx_part);
18479 @:xx_part_}{\&{xxpart} primitive@>
18480 mp_primitive(mp, "xypart",unary,xy_part);
18481 @:xy_part_}{\&{xypart} primitive@>
18482 mp_primitive(mp, "yxpart",unary,yx_part);
18483 @:yx_part_}{\&{yxpart} primitive@>
18484 mp_primitive(mp, "yypart",unary,yy_part);
18485 @:yy_part_}{\&{yypart} primitive@>
18486 mp_primitive(mp, "redpart",unary,red_part);
18487 @:red_part_}{\&{redpart} primitive@>
18488 mp_primitive(mp, "greenpart",unary,green_part);
18489 @:green_part_}{\&{greenpart} primitive@>
18490 mp_primitive(mp, "bluepart",unary,blue_part);
18491 @:blue_part_}{\&{bluepart} primitive@>
18492 mp_primitive(mp, "cyanpart",unary,cyan_part);
18493 @:cyan_part_}{\&{cyanpart} primitive@>
18494 mp_primitive(mp, "magentapart",unary,magenta_part);
18495 @:magenta_part_}{\&{magentapart} primitive@>
18496 mp_primitive(mp, "yellowpart",unary,yellow_part);
18497 @:yellow_part_}{\&{yellowpart} primitive@>
18498 mp_primitive(mp, "blackpart",unary,black_part);
18499 @:black_part_}{\&{blackpart} primitive@>
18500 mp_primitive(mp, "greypart",unary,grey_part);
18501 @:grey_part_}{\&{greypart} primitive@>
18502 mp_primitive(mp, "colormodel",unary,color_model_part);
18503 @:color_model_part_}{\&{colormodel} primitive@>
18504 mp_primitive(mp, "fontpart",unary,font_part);
18505 @:font_part_}{\&{fontpart} primitive@>
18506 mp_primitive(mp, "textpart",unary,text_part);
18507 @:text_part_}{\&{textpart} primitive@>
18508 mp_primitive(mp, "pathpart",unary,path_part);
18509 @:path_part_}{\&{pathpart} primitive@>
18510 mp_primitive(mp, "penpart",unary,pen_part);
18511 @:pen_part_}{\&{penpart} primitive@>
18512 mp_primitive(mp, "dashpart",unary,dash_part);
18513 @:dash_part_}{\&{dashpart} primitive@>
18514 mp_primitive(mp, "sqrt",unary,sqrt_op);
18515 @:sqrt_}{\&{sqrt} primitive@>
18516 mp_primitive(mp, "mexp",unary,mp_m_exp_op);
18517 @:m_exp_}{\&{mexp} primitive@>
18518 mp_primitive(mp, "mlog",unary,mp_m_log_op);
18519 @:m_log_}{\&{mlog} primitive@>
18520 mp_primitive(mp, "sind",unary,sin_d_op);
18521 @:sin_d_}{\&{sind} primitive@>
18522 mp_primitive(mp, "cosd",unary,cos_d_op);
18523 @:cos_d_}{\&{cosd} primitive@>
18524 mp_primitive(mp, "floor",unary,floor_op);
18525 @:floor_}{\&{floor} primitive@>
18526 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18527 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18528 mp_primitive(mp, "charexists",unary,char_exists_op);
18529 @:char_exists_}{\&{charexists} primitive@>
18530 mp_primitive(mp, "fontsize",unary,font_size);
18531 @:font_size_}{\&{fontsize} primitive@>
18532 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18533 @:ll_corner_}{\&{llcorner} primitive@>
18534 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18535 @:lr_corner_}{\&{lrcorner} primitive@>
18536 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18537 @:ul_corner_}{\&{ulcorner} primitive@>
18538 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18539 @:ur_corner_}{\&{urcorner} primitive@>
18540 mp_primitive(mp, "arclength",unary,arc_length);
18541 @:arc_length_}{\&{arclength} primitive@>
18542 mp_primitive(mp, "angle",unary,angle_op);
18543 @:angle_}{\&{angle} primitive@>
18544 mp_primitive(mp, "cycle",cycle,cycle_op);
18545 @:cycle_}{\&{cycle} primitive@>
18546 mp_primitive(mp, "stroked",unary,stroked_op);
18547 @:stroked_}{\&{stroked} primitive@>
18548 mp_primitive(mp, "filled",unary,filled_op);
18549 @:filled_}{\&{filled} primitive@>
18550 mp_primitive(mp, "textual",unary,textual_op);
18551 @:textual_}{\&{textual} primitive@>
18552 mp_primitive(mp, "clipped",unary,clipped_op);
18553 @:clipped_}{\&{clipped} primitive@>
18554 mp_primitive(mp, "bounded",unary,bounded_op);
18555 @:bounded_}{\&{bounded} primitive@>
18556 mp_primitive(mp, "+",plus_or_minus,plus);
18557 @:+ }{\.{+} primitive@>
18558 mp_primitive(mp, "-",plus_or_minus,minus);
18559 @:- }{\.{-} primitive@>
18560 mp_primitive(mp, "*",secondary_binary,times);
18561 @:* }{\.{*} primitive@>
18562 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18563 @:/ }{\.{/} primitive@>
18564 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18565 @:++_}{\.{++} primitive@>
18566 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18567 @:+-+_}{\.{+-+} primitive@>
18568 mp_primitive(mp, "or",tertiary_binary,or_op);
18569 @:or_}{\&{or} primitive@>
18570 mp_primitive(mp, "and",and_command,and_op);
18571 @:and_}{\&{and} primitive@>
18572 mp_primitive(mp, "<",expression_binary,less_than);
18573 @:< }{\.{<} primitive@>
18574 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18575 @:<=_}{\.{<=} primitive@>
18576 mp_primitive(mp, ">",expression_binary,greater_than);
18577 @:> }{\.{>} primitive@>
18578 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18579 @:>=_}{\.{>=} primitive@>
18580 mp_primitive(mp, "=",equals,equal_to);
18581 @:= }{\.{=} primitive@>
18582 mp_primitive(mp, "<>",expression_binary,unequal_to);
18583 @:<>_}{\.{<>} primitive@>
18584 mp_primitive(mp, "substring",primary_binary,substring_of);
18585 @:substring_}{\&{substring} primitive@>
18586 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18587 @:subpath_}{\&{subpath} primitive@>
18588 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18589 @:direction_time_}{\&{directiontime} primitive@>
18590 mp_primitive(mp, "point",primary_binary,point_of);
18591 @:point_}{\&{point} primitive@>
18592 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18593 @:precontrol_}{\&{precontrol} primitive@>
18594 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18595 @:postcontrol_}{\&{postcontrol} primitive@>
18596 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18597 @:pen_offset_}{\&{penoffset} primitive@>
18598 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18599 @:arc_time_of_}{\&{arctime} primitive@>
18600 mp_primitive(mp, "mpversion",nullary,mp_version);
18601 @:mp_verison_}{\&{mpversion} primitive@>
18602 mp_primitive(mp, "&",ampersand,concatenate);
18603 @:!!!}{\.{\&} primitive@>
18604 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18605 @:rotated_}{\&{rotated} primitive@>
18606 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18607 @:slanted_}{\&{slanted} primitive@>
18608 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18609 @:scaled_}{\&{scaled} primitive@>
18610 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18611 @:shifted_}{\&{shifted} primitive@>
18612 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18613 @:transformed_}{\&{transformed} primitive@>
18614 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18615 @:x_scaled_}{\&{xscaled} primitive@>
18616 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18617 @:y_scaled_}{\&{yscaled} primitive@>
18618 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18619 @:z_scaled_}{\&{zscaled} primitive@>
18620 mp_primitive(mp, "infont",secondary_binary,in_font);
18621 @:in_font_}{\&{infont} primitive@>
18622 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18623 @:intersection_times_}{\&{intersectiontimes} primitive@>
18624 mp_primitive(mp, "envelope",primary_binary,envelope_of);
18625 @:envelope_}{\&{envelope} primitive@>
18627 @ @<Cases of |print_cmd...@>=
18630 case primary_binary:
18631 case secondary_binary:
18632 case tertiary_binary:
18633 case expression_binary:
18635 case plus_or_minus:
18640 mp_print_op(mp, m);
18643 @ OK, let's look at the simplest \\{do} procedure first.
18645 @c @<Declare nullary action procedure@>
18646 void mp_do_nullary (MP mp,quarterword c) {
18648 if ( mp->internal[mp_tracing_commands]>two )
18649 mp_show_cmd_mod(mp, nullary,c);
18651 case true_code: case false_code:
18652 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18654 case null_picture_code:
18655 mp->cur_type=mp_picture_type;
18656 mp->cur_exp=mp_get_node(mp, edge_header_size);
18657 mp_init_edges(mp, mp->cur_exp);
18659 case null_pen_code:
18660 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18662 case normal_deviate:
18663 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18666 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18669 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18670 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18673 mp->cur_type=mp_string_type;
18674 mp->cur_exp=intern(metapost_version) ;
18676 case read_string_op:
18677 @<Read a string from the terminal@>;
18679 } /* there are no other cases */
18683 @ @<Read a string...@>=
18685 if (mp->noninteractive || mp->interaction<=mp_nonstop_mode )
18686 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18687 mp_begin_file_reading(mp); name=is_read;
18688 limit=start; prompt_input("");
18689 mp_finish_read(mp);
18692 @ @<Declare nullary action procedure@>=
18693 void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18695 str_room((int)mp->last-start);
18696 for (k=(size_t)start;k<=mp->last-1;k++) {
18697 append_char(mp->buffer[k]);
18699 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18700 mp->cur_exp=mp_make_string(mp);
18703 @ Things get a bit more interesting when there's an operand. The
18704 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18706 @c @<Declare unary action procedures@>
18707 void mp_do_unary (MP mp,quarterword c) {
18708 pointer p,q,r; /* for list manipulation */
18709 integer x; /* a temporary register */
18711 if ( mp->internal[mp_tracing_commands]>two )
18712 @<Trace the current unary operation@>;
18715 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18718 @<Negate the current expression@>;
18720 @<Additional cases of unary operators@>;
18721 } /* there are no other cases */
18725 @ The |nice_pair| function returns |true| if both components of a pair
18728 @<Declare unary action procedures@>=
18729 boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18730 if ( t==mp_pair_type ) {
18732 if ( type(x_part_loc(p))==mp_known )
18733 if ( type(y_part_loc(p))==mp_known )
18739 @ The |nice_color_or_pair| function is analogous except that it also accepts
18740 fully known colors.
18742 @<Declare unary action procedures@>=
18743 boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18744 pointer q,r; /* for scanning the big node */
18745 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18749 r=q+mp->big_node_size[type(p)];
18752 if ( type(r)!=mp_known )
18759 @ @<Declare unary action...@>=
18760 void mp_print_known_or_unknown_type (MP mp,quarterword t, integer v) {
18761 mp_print_char(mp, xord('('));
18762 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18763 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18764 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18765 mp_print_type(mp, t);
18767 mp_print_char(mp, xord(')'));
18770 @ @<Declare unary action...@>=
18771 void mp_bad_unary (MP mp,quarterword c) {
18772 exp_err("Not implemented: "); mp_print_op(mp, c);
18773 @.Not implemented...@>
18774 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18775 help3("I'm afraid I don't know how to apply that operation to that",
18776 "particular type. Continue, and I'll simply return the",
18777 "argument (shown above) as the result of the operation.");
18778 mp_put_get_error(mp);
18781 @ @<Trace the current unary operation@>=
18783 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18784 mp_print_op(mp, c); mp_print_char(mp, xord('('));
18785 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18786 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18789 @ Negation is easy except when the current expression
18790 is of type |independent|, or when it is a pair with one or more
18791 |independent| components.
18793 It is tempting to argue that the negative of an independent variable
18794 is an independent variable, hence we don't have to do anything when
18795 negating it. The fallacy is that other dependent variables pointing
18796 to the current expression must change the sign of their
18797 coefficients if we make no change to the current expression.
18799 Instead, we work around the problem by copying the current expression
18800 and recycling it afterwards (cf.~the |stash_in| routine).
18802 @<Negate the current expression@>=
18803 switch (mp->cur_type) {
18804 case mp_color_type:
18805 case mp_cmykcolor_type:
18807 case mp_independent:
18808 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18809 if ( mp->cur_type==mp_dependent ) {
18810 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18811 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18812 p=value(mp->cur_exp);
18813 r=p+mp->big_node_size[mp->cur_type];
18816 if ( type(r)==mp_known ) negate(value(r));
18817 else mp_negate_dep_list(mp, dep_list(r));
18819 } /* if |cur_type=mp_known| then |cur_exp=0| */
18820 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18823 case mp_proto_dependent:
18824 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18827 negate(mp->cur_exp);
18830 mp_bad_unary(mp, minus);
18834 @ @<Declare unary action...@>=
18835 void mp_negate_dep_list (MP mp,pointer p) {
18838 if ( info(p)==null ) return;
18843 @ @<Additional cases of unary operators@>=
18845 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
18846 else mp->cur_exp=true_code+false_code-mp->cur_exp;
18849 @ @d three_sixty_units 23592960 /* that's |360*unity| */
18850 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
18852 @<Additional cases of unary operators@>=
18859 case uniform_deviate:
18861 case char_exists_op:
18862 if ( mp->cur_type!=mp_known ) {
18863 mp_bad_unary(mp, c);
18866 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
18867 case mp_m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
18868 case mp_m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
18871 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
18872 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
18873 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
18875 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
18876 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
18878 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
18879 mp->cur_type=mp_boolean_type;
18881 case char_exists_op:
18882 @<Determine if a character has been shipped out@>;
18884 } /* there are no other cases */
18888 @ @<Additional cases of unary operators@>=
18890 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
18891 p=value(mp->cur_exp);
18892 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
18893 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
18894 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
18896 mp_bad_unary(mp, angle_op);
18900 @ If the current expression is a pair, but the context wants it to
18901 be a path, we call |pair_to_path|.
18903 @<Declare unary action...@>=
18904 void mp_pair_to_path (MP mp) {
18905 mp->cur_exp=mp_new_knot(mp);
18906 mp->cur_type=mp_path_type;
18910 @d pict_color_type(A) ((mp_link(dummy_loc(mp->cur_exp))!=null) &&
18911 (has_color(mp_link(dummy_loc(mp->cur_exp)))) &&
18912 ((color_model(mp_link(dummy_loc(mp->cur_exp)))==A)
18914 ((color_model(mp_link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) &&
18915 (mp->internal[mp_default_color_model]/unity)==(A))))
18917 @<Additional cases of unary operators@>=
18920 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
18921 mp_take_part(mp, c);
18922 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18923 else mp_bad_unary(mp, c);
18929 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
18930 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18931 else mp_bad_unary(mp, c);
18936 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
18937 else if ( mp->cur_type==mp_picture_type ) {
18938 if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
18939 else mp_bad_color_part(mp, c);
18941 else mp_bad_unary(mp, c);
18947 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
18948 else if ( mp->cur_type==mp_picture_type ) {
18949 if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
18950 else mp_bad_color_part(mp, c);
18952 else mp_bad_unary(mp, c);
18955 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
18956 else if ( mp->cur_type==mp_picture_type ) {
18957 if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
18958 else mp_bad_color_part(mp, c);
18960 else mp_bad_unary(mp, c);
18962 case color_model_part:
18963 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18964 else mp_bad_unary(mp, c);
18967 @ @<Declarations@>=
18968 void mp_bad_color_part(MP mp, quarterword c);
18971 void mp_bad_color_part(MP mp, quarterword c) {
18972 pointer p; /* the big node */
18973 p=mp_link(dummy_loc(mp->cur_exp));
18974 exp_err("Wrong picture color model: "); mp_print_op(mp, c);
18975 @.Wrong picture color model...@>
18976 if (color_model(p)==mp_grey_model)
18977 mp_print(mp, " of grey object");
18978 else if (color_model(p)==mp_cmyk_model)
18979 mp_print(mp, " of cmyk object");
18980 else if (color_model(p)==mp_rgb_model)
18981 mp_print(mp, " of rgb object");
18982 else if (color_model(p)==mp_no_model)
18983 mp_print(mp, " of marking object");
18985 mp_print(mp," of defaulted object");
18986 help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,",
18987 "the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ",
18988 "or the greypart of a grey object. No mixing and matching, please.");
18991 mp_flush_cur_exp(mp,unity);
18993 mp_flush_cur_exp(mp,0);
18996 @ In the following procedure, |cur_exp| points to a capsule, which points to
18997 a big node. We want to delete all but one part of the big node.
18999 @<Declare unary action...@>=
19000 void mp_take_part (MP mp,quarterword c) {
19001 pointer p; /* the big node */
19002 p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
19003 mp_link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
19004 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
19005 mp_recycle_value(mp, temp_val);
19008 @ @<Initialize table entries...@>=
19009 name_type(temp_val)=mp_capsule;
19011 @ @<Additional cases of unary operators@>=
19017 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19018 else mp_bad_unary(mp, c);
19021 @ @<Declarations@>=
19022 void mp_scale_edges (MP mp);
19024 @ @<Declare unary action...@>=
19025 void mp_take_pict_part (MP mp,quarterword c) {
19026 pointer p; /* first graphical object in |cur_exp| */
19027 p=mp_link(dummy_loc(mp->cur_exp));
19030 case x_part: case y_part: case xx_part:
19031 case xy_part: case yx_part: case yy_part:
19032 if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
19033 else goto NOT_FOUND;
19035 case red_part: case green_part: case blue_part:
19036 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
19037 else goto NOT_FOUND;
19039 case cyan_part: case magenta_part: case yellow_part:
19041 if ( has_color(p) ) {
19042 if ( color_model(p)==mp_uninitialized_model && c==black_part)
19043 mp_flush_cur_exp(mp, unity);
19045 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
19046 } else goto NOT_FOUND;
19049 if ( has_color(p) )
19050 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
19051 else goto NOT_FOUND;
19053 case color_model_part:
19054 if ( has_color(p) ) {
19055 if ( color_model(p)==mp_uninitialized_model )
19056 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
19058 mp_flush_cur_exp(mp, color_model(p)*unity);
19059 } else goto NOT_FOUND;
19061 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
19062 } /* all cases have been enumerated */
19066 @<Convert the current expression to a null value appropriate
19070 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
19072 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19074 mp_flush_cur_exp(mp, text_p(p));
19075 add_str_ref(mp->cur_exp);
19076 mp->cur_type=mp_string_type;
19080 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19082 mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
19083 add_str_ref(mp->cur_exp);
19084 mp->cur_type=mp_string_type;
19088 if ( type(p)==mp_text_code ) goto NOT_FOUND;
19089 else if ( is_stop(p) ) mp_confusion(mp, "pict");
19090 @:this can't happen pict}{\quad pict@>
19092 mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
19093 mp->cur_type=mp_path_type;
19097 if ( ! has_pen(p) ) goto NOT_FOUND;
19099 if ( pen_p(p)==null ) goto NOT_FOUND;
19100 else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
19101 mp->cur_type=mp_pen_type;
19106 if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
19107 else { if ( dash_p(p)==null ) goto NOT_FOUND;
19108 else { add_edge_ref(dash_p(p));
19109 mp->se_sf=dash_scale(p);
19110 mp->se_pic=dash_p(p);
19111 mp_scale_edges(mp);
19112 mp_flush_cur_exp(mp, mp->se_pic);
19113 mp->cur_type=mp_picture_type;
19118 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
19119 parameterless procedure even though it really takes two arguments and updates
19120 one of them. Hence the following globals are needed.
19123 pointer se_pic; /* edge header used and updated by |scale_edges| */
19124 scaled se_sf; /* the scale factor argument to |scale_edges| */
19126 @ @<Convert the current expression to a null value appropriate...@>=
19128 case text_part: case font_part:
19129 mp_flush_cur_exp(mp, null_str);
19130 mp->cur_type=mp_string_type;
19133 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19134 left_type(mp->cur_exp)=mp_endpoint;
19135 right_type(mp->cur_exp)=mp_endpoint;
19136 mp_link(mp->cur_exp)=mp->cur_exp;
19137 x_coord(mp->cur_exp)=0;
19138 y_coord(mp->cur_exp)=0;
19139 originator(mp->cur_exp)=mp_metapost_user;
19140 mp->cur_type=mp_path_type;
19143 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19144 mp->cur_type=mp_pen_type;
19147 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19148 mp_init_edges(mp, mp->cur_exp);
19149 mp->cur_type=mp_picture_type;
19152 mp_flush_cur_exp(mp, 0);
19156 @ @<Additional cases of unary...@>=
19158 if ( mp->cur_type!=mp_known ) {
19159 mp_bad_unary(mp, char_op);
19161 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19162 mp->cur_type=mp_string_type;
19163 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19167 if ( mp->cur_type!=mp_known ) {
19168 mp_bad_unary(mp, decimal);
19170 mp->old_setting=mp->selector; mp->selector=new_string;
19171 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19172 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19178 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19179 else mp_str_to_num(mp, c);
19182 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19183 else @<Find the design size of the font whose name is |cur_exp|@>;
19186 @ @<Declare unary action...@>=
19187 void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19188 integer n; /* accumulator */
19189 ASCII_code m; /* current character */
19190 pool_pointer k; /* index into |str_pool| */
19191 int b; /* radix of conversion */
19192 boolean bad_char; /* did the string contain an invalid digit? */
19193 if ( c==ASCII_op ) {
19194 if ( length(mp->cur_exp)==0 ) n=-1;
19195 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19197 if ( c==oct_op ) b=8; else b=16;
19198 n=0; bad_char=false;
19199 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19201 if ( (m>='0')&&(m<='9') ) m=m-'0';
19202 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19203 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19204 else { bad_char=true; m=0; };
19205 if ( (int)m>=b ) { bad_char=true; m=0; };
19206 if ( n<32768 / b ) n=n*b+m; else n=32767;
19208 @<Give error messages if |bad_char| or |n>=4096|@>;
19210 mp_flush_cur_exp(mp, n*unity);
19213 @ @<Give error messages if |bad_char|...@>=
19215 exp_err("String contains illegal digits");
19216 @.String contains illegal digits@>
19218 help1("I zeroed out characters that weren't in the range 0..7.");
19220 help1("I zeroed out characters that weren't hex digits.");
19222 mp_put_get_error(mp);
19225 if ( mp->internal[mp_warning_check]>0 ) {
19226 print_err("Number too large (");
19227 mp_print_int(mp, n); mp_print_char(mp, xord(')'));
19228 @.Number too large@>
19229 help2("I have trouble with numbers greater than 4095; watch out.",
19230 "(Set warningcheck:=0 to suppress this message.)");
19231 mp_put_get_error(mp);
19235 @ The length operation is somewhat unusual in that it applies to a variety
19236 of different types of operands.
19238 @<Additional cases of unary...@>=
19240 switch (mp->cur_type) {
19241 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19242 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19243 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19244 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19246 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19247 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19248 value(x_part_loc(value(mp->cur_exp))),
19249 value(y_part_loc(value(mp->cur_exp)))));
19250 else mp_bad_unary(mp, c);
19255 @ @<Declare unary action...@>=
19256 scaled mp_path_length (MP mp) { /* computes the length of the current path */
19257 scaled n; /* the path length so far */
19258 pointer p; /* traverser */
19260 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
19261 do { p=mp_link(p); n=n+unity; } while (p!=mp->cur_exp);
19265 @ @<Declare unary action...@>=
19266 scaled mp_pict_length (MP mp) {
19267 /* counts interior components in picture |cur_exp| */
19268 scaled n; /* the count so far */
19269 pointer p; /* traverser */
19271 p=mp_link(dummy_loc(mp->cur_exp));
19273 if ( is_start_or_stop(p) )
19274 if ( mp_skip_1component(mp, p)==null ) p=mp_link(p);
19275 while ( p!=null ) {
19276 skip_component(p) return n;
19283 @ Implement |turningnumber|
19285 @<Additional cases of unary...@>=
19287 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19288 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19289 else if ( left_type(mp->cur_exp)==mp_endpoint )
19290 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19292 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19295 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19296 argument is |origin|.
19298 @<Declare unary action...@>=
19299 angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19300 if ( (! ((xpar==0) && (ypar==0))) )
19301 return mp_n_arg(mp, xpar,ypar);
19306 @ The actual turning number is (for the moment) computed in a C function
19307 that receives eight integers corresponding to the four controlling points,
19308 and returns a single angle. Besides those, we have to account for discrete
19309 moves at the actual points.
19311 @d mp_floor(a) (a>=0 ? (int)a : -(int)(-a))
19312 @d bezier_error (720*(256*256*16))+1
19313 @d mp_sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19314 @d mp_out(A) (double)((A)/(256*256*16))
19315 @d divisor (256*256)
19316 @d double2angle(a) (int)mp_floor(a*256.0*256.0*16.0)
19318 @<Declare unary action...@>=
19319 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19320 integer CX,integer CY,integer DX,integer DY);
19323 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19324 integer CX,integer CY,integer DX,integer DY) {
19326 integer deltax,deltay;
19327 double ax,ay,bx,by,cx,cy,dx,dy;
19328 angle xi = 0, xo = 0, xm = 0;
19330 ax=(double)(AX/divisor); ay=(double)(AY/divisor);
19331 bx=(double)(BX/divisor); by=(double)(BY/divisor);
19332 cx=(double)(CX/divisor); cy=(double)(CY/divisor);
19333 dx=(double)(DX/divisor); dy=(double)(DY/divisor);
19335 deltax = (BX-AX); deltay = (BY-AY);
19336 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19337 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19338 xi = mp_an_angle(mp,deltax,deltay);
19340 deltax = (CX-BX); deltay = (CY-BY);
19341 xm = mp_an_angle(mp,deltax,deltay);
19343 deltax = (DX-CX); deltay = (DY-CY);
19344 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19345 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19346 xo = mp_an_angle(mp,deltax,deltay);
19348 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19349 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19350 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19352 if ((a==0)&&(c==0)) {
19353 res = (b==0 ? 0 : (mp_out(xo)-mp_out(xi)));
19354 } else if ((a==0)||(c==0)) {
19355 if ((mp_sign(b) == mp_sign(a)) || (mp_sign(b) == mp_sign(c))) {
19356 res = mp_out(xo)-mp_out(xi); /* ? */
19359 else if (res>180.0)
19362 res = mp_out(xo)-mp_out(xi); /* ? */
19364 } else if ((mp_sign(a)*mp_sign(c))<0) {
19365 res = mp_out(xo)-mp_out(xi); /* ? */
19368 else if (res>180.0)
19371 if (mp_sign(a) == mp_sign(b)) {
19372 res = mp_out(xo)-mp_out(xi); /* ? */
19375 else if (res>180.0)
19378 if ((b*b) == (4*a*c)) {
19379 res = (double)bezier_error;
19380 } else if ((b*b) < (4*a*c)) {
19381 res = mp_out(xo)-mp_out(xi); /* ? */
19382 if (res<=0.0 &&res>-180.0)
19384 else if (res>=0.0 && res<180.0)
19387 res = mp_out(xo)-mp_out(xi);
19390 else if (res>180.0)
19395 return double2angle(res);
19399 @d p_nextnext mp_link(mp_link(p))
19400 @d p_next mp_link(p)
19401 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19403 @<Declare unary action...@>=
19404 scaled mp_new_turn_cycles (MP mp,pointer c) {
19405 angle res,ang; /* the angles of intermediate results */
19406 scaled turns; /* the turn counter */
19407 pointer p; /* for running around the path */
19408 integer xp,yp; /* coordinates of next point */
19409 integer x,y; /* helper coordinates */
19410 angle in_angle,out_angle; /* helper angles */
19411 unsigned old_setting; /* saved |selector| setting */
19415 old_setting = mp->selector; mp->selector=term_only;
19416 if ( mp->internal[mp_tracing_commands]>unity ) {
19417 mp_begin_diagnostic(mp);
19418 mp_print_nl(mp, "");
19419 mp_end_diagnostic(mp, false);
19422 xp = x_coord(p_next); yp = y_coord(p_next);
19423 ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
19424 left_x(p_next), left_y(p_next), xp, yp);
19425 if ( ang>seven_twenty_deg ) {
19426 print_err("Strange path");
19428 mp->selector=old_setting;
19432 if ( res > one_eighty_deg ) {
19433 res = res - three_sixty_deg;
19434 turns = turns + unity;
19436 if ( res <= -one_eighty_deg ) {
19437 res = res + three_sixty_deg;
19438 turns = turns - unity;
19440 /* incoming angle at next point */
19441 x = left_x(p_next); y = left_y(p_next);
19442 if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
19443 if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
19444 in_angle = mp_an_angle(mp, xp - x, yp - y);
19445 /* outgoing angle at next point */
19446 x = right_x(p_next); y = right_y(p_next);
19447 if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
19448 if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
19449 out_angle = mp_an_angle(mp, x - xp, y- yp);
19450 ang = (out_angle - in_angle);
19454 if ( res >= one_eighty_deg ) {
19455 res = res - three_sixty_deg;
19456 turns = turns + unity;
19458 if ( res <= -one_eighty_deg ) {
19459 res = res + three_sixty_deg;
19460 turns = turns - unity;
19465 mp->selector=old_setting;
19470 @ This code is based on Bogus\l{}av Jackowski's
19471 |emergency_turningnumber| macro, with some minor changes by Taco
19472 Hoekwater. The macro code looked more like this:
19474 vardef turning\_number primary p =
19475 ~~save res, ang, turns;
19477 ~~if length p <= 2:
19478 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19480 ~~~~for t = 0 upto length p-1 :
19481 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19482 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19483 ~~~~~~if angc > 180: angc := angc - 360; fi;
19484 ~~~~~~if angc < -180: angc := angc + 360; fi;
19485 ~~~~~~res := res + angc;
19490 The general idea is to calculate only the sum of the angles of
19491 straight lines between the points, of a path, not worrying about cusps
19492 or self-intersections in the segments at all. If the segment is not
19493 well-behaved, the result is not necesarily correct. But the old code
19494 was not always correct either, and worse, it sometimes failed for
19495 well-behaved paths as well. All known bugs that were triggered by the
19496 original code no longer occur with this code, and it runs roughly 3
19497 times as fast because the algorithm is much simpler.
19499 @ It is possible to overflow the return value of the |turn_cycles|
19500 function when the path is sufficiently long and winding, but I am not
19501 going to bother testing for that. In any case, it would only return
19502 the looped result value, which is not a big problem.
19504 The macro code for the repeat loop was a bit nicer to look
19505 at than the pascal code, because it could use |point -1 of p|. In
19506 pascal, the fastest way to loop around the path is not to look
19507 backward once, but forward twice. These defines help hide the trick.
19509 @d p_to mp_link(mp_link(p))
19510 @d p_here mp_link(p)
19513 @<Declare unary action...@>=
19514 scaled mp_turn_cycles (MP mp,pointer c) {
19515 angle res,ang; /* the angles of intermediate results */
19516 scaled turns; /* the turn counter */
19517 pointer p; /* for running around the path */
19518 res=0; turns= 0; p=c;
19520 ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
19521 y_coord(p_to) - y_coord(p_here))
19522 - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
19523 y_coord(p_here) - y_coord(p_from));
19526 if ( res >= three_sixty_deg ) {
19527 res = res - three_sixty_deg;
19528 turns = turns + unity;
19530 if ( res <= -three_sixty_deg ) {
19531 res = res + three_sixty_deg;
19532 turns = turns - unity;
19539 @ @<Declare unary action...@>=
19540 scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19542 scaled saved_t_o; /* tracing\_online saved */
19543 if ( (mp_link(c)==c)||(mp_link(mp_link(c))==c) ) {
19544 if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
19549 nval = mp_new_turn_cycles(mp, c);
19550 oval = mp_turn_cycles(mp, c);
19551 if ( nval!=oval ) {
19552 saved_t_o=mp->internal[mp_tracing_online];
19553 mp->internal[mp_tracing_online]=unity;
19554 mp_begin_diagnostic(mp);
19555 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19556 " The current computed value is ");
19557 mp_print_scaled(mp, nval);
19558 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19559 mp_print_scaled(mp, oval);
19560 mp_end_diagnostic(mp, false);
19561 mp->internal[mp_tracing_online]=saved_t_o;
19567 @ @<Declare unary action...@>=
19568 scaled mp_count_turns (MP mp,pointer c) {
19569 pointer p; /* a knot in envelope spec |c| */
19570 integer t; /* total pen offset changes counted */
19573 t=t+info(p)-zero_off;
19576 return ((t / 3)*unity);
19579 @ @d type_range(A,B) {
19580 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19581 mp_flush_cur_exp(mp, true_code);
19582 else mp_flush_cur_exp(mp, false_code);
19583 mp->cur_type=mp_boolean_type;
19586 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19587 else mp_flush_cur_exp(mp, false_code);
19588 mp->cur_type=mp_boolean_type;
19591 @<Additional cases of unary operators@>=
19592 case mp_boolean_type:
19593 type_range(mp_boolean_type,mp_unknown_boolean); break;
19594 case mp_string_type:
19595 type_range(mp_string_type,mp_unknown_string); break;
19597 type_range(mp_pen_type,mp_unknown_pen); break;
19599 type_range(mp_path_type,mp_unknown_path); break;
19600 case mp_picture_type:
19601 type_range(mp_picture_type,mp_unknown_picture); break;
19602 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19604 type_test(c); break;
19605 case mp_numeric_type:
19606 type_range(mp_known,mp_independent); break;
19607 case known_op: case unknown_op:
19608 mp_test_known(mp, c); break;
19610 @ @<Declare unary action procedures@>=
19611 void mp_test_known (MP mp,quarterword c) {
19612 int b; /* is the current expression known? */
19613 pointer p,q; /* locations in a big node */
19615 switch (mp->cur_type) {
19616 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19617 case mp_pen_type: case mp_path_type: case mp_picture_type:
19621 case mp_transform_type:
19622 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19623 p=value(mp->cur_exp);
19624 q=p+mp->big_node_size[mp->cur_type];
19627 if ( type(q)!=mp_known )
19636 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19637 else mp_flush_cur_exp(mp, true_code+false_code-b);
19638 mp->cur_type=mp_boolean_type;
19641 @ @<Additional cases of unary operators@>=
19643 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19644 else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19645 else mp_flush_cur_exp(mp, false_code);
19646 mp->cur_type=mp_boolean_type;
19649 @ @<Additional cases of unary operators@>=
19651 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19652 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19653 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19656 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19658 @^data structure assumptions@>
19660 @<Additional cases of unary operators@>=
19666 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19667 else if ( mp_link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19668 else if ( type(mp_link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19669 mp_flush_cur_exp(mp, true_code);
19670 else mp_flush_cur_exp(mp, false_code);
19671 mp->cur_type=mp_boolean_type;
19674 @ @<Additional cases of unary operators@>=
19676 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19677 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19679 mp->cur_type=mp_pen_type;
19680 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19684 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19686 mp->cur_type=mp_path_type;
19687 mp_make_path(mp, mp->cur_exp);
19691 if ( mp->cur_type==mp_path_type ) {
19692 p=mp_htap_ypoc(mp, mp->cur_exp);
19693 if ( right_type(p)==mp_endpoint ) p=mp_link(p);
19694 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19695 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19696 else mp_bad_unary(mp, reverse);
19699 @ The |pair_value| routine changes the current expression to a
19700 given ordered pair of values.
19702 @<Declare unary action procedures@>=
19703 void mp_pair_value (MP mp,scaled x, scaled y) {
19704 pointer p; /* a pair node */
19705 p=mp_get_node(mp, value_node_size);
19706 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19707 type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19709 type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19710 type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19713 @ @<Additional cases of unary operators@>=
19715 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19716 else mp_pair_value(mp, minx,miny);
19719 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19720 else mp_pair_value(mp, maxx,miny);
19723 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19724 else mp_pair_value(mp, minx,maxy);
19727 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19728 else mp_pair_value(mp, maxx,maxy);
19731 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19732 box of the current expression. The boolean result is |false| if the expression
19733 has the wrong type.
19735 @<Declare unary action procedures@>=
19736 boolean mp_get_cur_bbox (MP mp) {
19737 switch (mp->cur_type) {
19738 case mp_picture_type:
19739 mp_set_bbox(mp, mp->cur_exp,true);
19740 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19741 minx=0; maxx=0; miny=0; maxy=0;
19743 minx=minx_val(mp->cur_exp);
19744 maxx=maxx_val(mp->cur_exp);
19745 miny=miny_val(mp->cur_exp);
19746 maxy=maxy_val(mp->cur_exp);
19750 mp_path_bbox(mp, mp->cur_exp);
19753 mp_pen_bbox(mp, mp->cur_exp);
19761 @ @<Additional cases of unary operators@>=
19763 case close_from_op:
19764 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19765 else mp_do_read_or_close(mp,c);
19768 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19769 a line from the file or to close the file.
19771 @<Declare unary action procedures@>=
19772 void mp_do_read_or_close (MP mp,quarterword c) {
19773 readf_index n,n0; /* indices for searching |rd_fname| */
19774 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19775 call |start_read_input| and |goto found| or |not_found|@>;
19776 mp_begin_file_reading(mp);
19778 if ( mp_input_ln(mp, mp->rd_file[n] ) )
19780 mp_end_file_reading(mp);
19782 @<Record the end of file and set |cur_exp| to a dummy value@>;
19785 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19788 mp_flush_cur_exp(mp, 0);
19789 mp_finish_read(mp);
19792 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19795 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19800 fn = str(mp->cur_exp);
19801 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19804 } else if ( c==close_from_op ) {
19807 if ( n0==mp->read_files ) {
19808 if ( mp->read_files<mp->max_read_files ) {
19809 incr(mp->read_files);
19814 l = mp->max_read_files + (mp->max_read_files/4);
19815 rd_file = xmalloc((l+1), sizeof(void *));
19816 rd_fname = xmalloc((l+1), sizeof(char *));
19817 for (k=0;k<=l;k++) {
19818 if (k<=mp->max_read_files) {
19819 rd_file[k]=mp->rd_file[k];
19820 rd_fname[k]=mp->rd_fname[k];
19826 xfree(mp->rd_file); xfree(mp->rd_fname);
19827 mp->max_read_files = l;
19828 mp->rd_file = rd_file;
19829 mp->rd_fname = rd_fname;
19833 if ( mp_start_read_input(mp,fn,n) )
19838 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19840 if ( c==close_from_op ) {
19841 (mp->close_file)(mp,mp->rd_file[n]);
19846 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19847 xfree(mp->rd_fname[n]);
19848 mp->rd_fname[n]=NULL;
19849 if ( n==mp->read_files-1 ) mp->read_files=n;
19850 if ( c==close_from_op )
19852 mp_flush_cur_exp(mp, mp->eof_line);
19853 mp->cur_type=mp_string_type
19855 @ The string denoting end-of-file is a one-byte string at position zero, by definition
19858 str_number eof_line;
19863 @ Finally, we have the operations that combine a capsule~|p|
19864 with the current expression.
19866 @d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
19868 @c @<Declare binary action procedures@>
19869 void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
19871 @<Recycle any sidestepped |independent| capsules@>;
19873 void mp_do_binary (MP mp,pointer p, quarterword c) {
19874 pointer q,r,rr; /* for list manipulation */
19875 pointer old_p,old_exp; /* capsules to recycle */
19876 integer v; /* for numeric manipulation */
19878 if ( mp->internal[mp_tracing_commands]>two ) {
19879 @<Trace the current binary operation@>;
19881 @<Sidestep |independent| cases in capsule |p|@>;
19882 @<Sidestep |independent| cases in the current expression@>;
19884 case plus: case minus:
19885 @<Add or subtract the current expression from |p|@>;
19887 @<Additional cases of binary operators@>;
19888 }; /* there are no other cases */
19889 mp_recycle_value(mp, p);
19890 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
19891 mp_finish_binary(mp, old_p, old_exp);
19894 @ @<Declare binary action...@>=
19895 void mp_bad_binary (MP mp,pointer p, quarterword c) {
19896 mp_disp_err(mp, p,"");
19897 exp_err("Not implemented: ");
19898 @.Not implemented...@>
19899 if ( c>=min_of ) mp_print_op(mp, c);
19900 mp_print_known_or_unknown_type(mp, type(p),p);
19901 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
19902 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
19903 help3("I'm afraid I don't know how to apply that operation to that",
19904 "combination of types. Continue, and I'll return the second",
19905 "argument (see above) as the result of the operation.");
19906 mp_put_get_error(mp);
19908 void mp_bad_envelope_pen (MP mp) {
19909 mp_disp_err(mp, null,"");
19910 exp_err("Not implemented: envelope(elliptical pen)of(path)");
19911 @.Not implemented...@>
19912 help3("I'm afraid I don't know how to apply that operation to that",
19913 "combination of types. Continue, and I'll return the second",
19914 "argument (see above) as the result of the operation.");
19915 mp_put_get_error(mp);
19918 @ @<Trace the current binary operation@>=
19920 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
19921 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
19922 mp_print_char(mp,xord(')')); mp_print_op(mp,c); mp_print_char(mp,xord('('));
19923 mp_print_exp(mp,null,0); mp_print(mp,")}");
19924 mp_end_diagnostic(mp, false);
19927 @ Several of the binary operations are potentially complicated by the
19928 fact that |independent| values can sneak into capsules. For example,
19929 we've seen an instance of this difficulty in the unary operation
19930 of negation. In order to reduce the number of cases that need to be
19931 handled, we first change the two operands (if necessary)
19932 to rid them of |independent| components. The original operands are
19933 put into capsules called |old_p| and |old_exp|, which will be
19934 recycled after the binary operation has been safely carried out.
19936 @<Recycle any sidestepped |independent| capsules@>=
19937 if ( old_p!=null ) {
19938 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
19940 if ( old_exp!=null ) {
19941 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
19944 @ A big node is considered to be ``tarnished'' if it contains at least one
19945 independent component. We will define a simple function called `|tarnished|'
19946 that returns |null| if and only if its argument is not tarnished.
19948 @<Sidestep |independent| cases in capsule |p|@>=
19950 case mp_transform_type:
19951 case mp_color_type:
19952 case mp_cmykcolor_type:
19954 old_p=mp_tarnished(mp, p);
19956 case mp_independent: old_p=mp_void; break;
19957 default: old_p=null; break;
19959 if ( old_p!=null ) {
19960 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
19961 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
19964 @ @<Sidestep |independent| cases in the current expression@>=
19965 switch (mp->cur_type) {
19966 case mp_transform_type:
19967 case mp_color_type:
19968 case mp_cmykcolor_type:
19970 old_exp=mp_tarnished(mp, mp->cur_exp);
19972 case mp_independent:old_exp=mp_void; break;
19973 default: old_exp=null; break;
19975 if ( old_exp!=null ) {
19976 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
19979 @ @<Declare binary action...@>=
19980 pointer mp_tarnished (MP mp,pointer p) {
19981 pointer q; /* beginning of the big node */
19982 pointer r; /* current position in the big node */
19983 q=value(p); r=q+mp->big_node_size[type(p)];
19986 if ( type(r)==mp_independent ) return mp_void;
19991 @ @<Add or subtract the current expression from |p|@>=
19992 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
19993 mp_bad_binary(mp, p,c);
19995 if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
19996 mp_add_or_subtract(mp, p,null,c);
19998 if ( mp->cur_type!=type(p) ) {
19999 mp_bad_binary(mp, p,c);
20001 q=value(p); r=value(mp->cur_exp);
20002 rr=r+mp->big_node_size[mp->cur_type];
20004 mp_add_or_subtract(mp, q,r,c);
20011 @ The first argument to |add_or_subtract| is the location of a value node
20012 in a capsule or pair node that will soon be recycled. The second argument
20013 is either a location within a pair or transform node of |cur_exp|,
20014 or it is null (which means that |cur_exp| itself should be the second
20015 argument). The third argument is either |plus| or |minus|.
20017 The sum or difference of the numeric quantities will replace the second
20018 operand. Arithmetic overflow may go undetected; users aren't supposed to
20019 be monkeying around with really big values.
20020 @^overflow in arithmetic@>
20022 @<Declare binary action...@>=
20023 @<Declare the procedure called |dep_finish|@>
20024 void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
20025 quarterword s,t; /* operand types */
20026 pointer r; /* list traverser */
20027 integer v; /* second operand value */
20030 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
20033 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
20035 if ( t==mp_known ) {
20036 if ( c==minus ) negate(v);
20037 if ( type(p)==mp_known ) {
20038 v=mp_slow_add(mp, value(p),v);
20039 if ( q==null ) mp->cur_exp=v; else value(q)=v;
20042 @<Add a known value to the constant term of |dep_list(p)|@>;
20044 if ( c==minus ) mp_negate_dep_list(mp, v);
20045 @<Add operand |p| to the dependency list |v|@>;
20049 @ @<Add a known value to the constant term of |dep_list(p)|@>=
20051 while ( info(r)!=null ) r=mp_link(r);
20052 value(r)=mp_slow_add(mp, value(r),v);
20054 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
20055 name_type(q)=mp_capsule;
20057 dep_list(q)=dep_list(p); type(q)=type(p);
20058 prev_dep(q)=prev_dep(p); mp_link(prev_dep(p))=q;
20059 type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
20061 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
20062 nice to retain the extra accuracy of |fraction| coefficients.
20063 But we have to handle both kinds, and mixtures too.
20065 @<Add operand |p| to the dependency list |v|@>=
20066 if ( type(p)==mp_known ) {
20067 @<Add the known |value(p)| to the constant term of |v|@>;
20069 s=type(p); r=dep_list(p);
20070 if ( t==mp_dependent ) {
20071 if ( s==mp_dependent ) {
20072 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
20073 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
20074 } /* |fix_needed| will necessarily be false */
20075 t=mp_proto_dependent;
20076 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
20078 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
20079 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
20081 @<Output the answer, |v| (which might have become |known|)@>;
20084 @ @<Add the known |value(p)| to the constant term of |v|@>=
20086 while ( info(v)!=null ) v=mp_link(v);
20087 value(v)=mp_slow_add(mp, value(p),value(v));
20090 @ @<Output the answer, |v| (which might have become |known|)@>=
20091 if ( q!=null ) mp_dep_finish(mp, v,q,t);
20092 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
20094 @ Here's the current situation: The dependency list |v| of type |t|
20095 should either be put into the current expression (if |q=null|) or
20096 into location |q| within a pair node (otherwise). The destination (|cur_exp|
20097 or |q|) formerly held a dependency list with the same
20098 final pointer as the list |v|.
20100 @<Declare the procedure called |dep_finish|@>=
20101 void mp_dep_finish (MP mp, pointer v, pointer q, quarterword t) {
20102 pointer p; /* the destination */
20103 scaled vv; /* the value, if it is |known| */
20104 if ( q==null ) p=mp->cur_exp; else p=q;
20105 dep_list(p)=v; type(p)=t;
20106 if ( info(v)==null ) {
20109 mp_flush_cur_exp(mp, vv);
20111 mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
20113 } else if ( q==null ) {
20116 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20119 @ Let's turn now to the six basic relations of comparison.
20121 @<Additional cases of binary operators@>=
20122 case less_than: case less_or_equal: case greater_than:
20123 case greater_or_equal: case equal_to: case unequal_to:
20124 check_arith; /* at this point |arith_error| should be |false|? */
20125 if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20126 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20127 } else if ( mp->cur_type!=type(p) ) {
20128 mp_bad_binary(mp, p,c); goto DONE;
20129 } else if ( mp->cur_type==mp_string_type ) {
20130 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20131 } else if ((mp->cur_type==mp_unknown_string)||
20132 (mp->cur_type==mp_unknown_boolean) ) {
20133 @<Check if unknowns have been equated@>;
20134 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20135 @<Reduce comparison of big nodes to comparison of scalars@>;
20136 } else if ( mp->cur_type==mp_boolean_type ) {
20137 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20139 mp_bad_binary(mp, p,c); goto DONE;
20141 @<Compare the current expression with zero@>;
20143 mp->arith_error=false; /* ignore overflow in comparisons */
20146 @ @<Compare the current expression with zero@>=
20147 if ( mp->cur_type!=mp_known ) {
20148 if ( mp->cur_type<mp_known ) {
20149 mp_disp_err(mp, p,"");
20150 help1("The quantities shown above have not been equated.")
20152 help2("Oh dear. I can\'t decide if the expression above is positive,",
20153 "negative, or zero. So this comparison test won't be `true'.");
20155 exp_err("Unknown relation will be considered false");
20156 @.Unknown relation...@>
20157 mp_put_get_flush_error(mp, false_code);
20160 case less_than: boolean_reset(mp->cur_exp<0); break;
20161 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20162 case greater_than: boolean_reset(mp->cur_exp>0); break;
20163 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20164 case equal_to: boolean_reset(mp->cur_exp==0); break;
20165 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20166 }; /* there are no other cases */
20168 mp->cur_type=mp_boolean_type
20170 @ When two unknown strings are in the same ring, we know that they are
20171 equal. Otherwise, we don't know whether they are equal or not, so we
20174 @<Check if unknowns have been equated@>=
20176 q=value(mp->cur_exp);
20177 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20178 if ( q==p ) mp_flush_cur_exp(mp, 0);
20181 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20183 q=value(p); r=value(mp->cur_exp);
20184 rr=r+mp->big_node_size[mp->cur_type]-2;
20185 while (1) { mp_add_or_subtract(mp, q,r,minus);
20186 if ( type(r)!=mp_known ) break;
20187 if ( value(r)!=0 ) break;
20188 if ( r==rr ) break;
20191 mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
20194 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20196 @<Additional cases of binary operators@>=
20199 if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20200 mp_bad_binary(mp, p,c);
20201 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20204 @ @<Additional cases of binary operators@>=
20206 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20207 mp_bad_binary(mp, p,times);
20208 } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
20209 @<Multiply when at least one operand is known@>;
20210 } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
20211 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20212 (type(p)>mp_pair_type)) ) {
20213 mp_hard_times(mp, p);
20216 mp_bad_binary(mp, p,times);
20220 @ @<Multiply when at least one operand is known@>=
20222 if ( type(p)==mp_known ) {
20223 v=value(p); mp_free_node(mp, p,value_node_size);
20225 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20227 if ( mp->cur_type==mp_known ) {
20228 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20229 } else if ( (mp->cur_type==mp_pair_type)||
20230 (mp->cur_type==mp_color_type)||
20231 (mp->cur_type==mp_cmykcolor_type) ) {
20232 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20234 p=p-2; mp_dep_mult(mp, p,v,true);
20235 } while (p!=value(mp->cur_exp));
20237 mp_dep_mult(mp, null,v,true);
20242 @ @<Declare binary action...@>=
20243 void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20244 pointer q; /* the dependency list being multiplied by |v| */
20245 quarterword s,t; /* its type, before and after */
20248 } else if ( type(p)!=mp_known ) {
20251 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20252 else value(p)=mp_take_fraction(mp, value(p),v);
20255 t=type(q); q=dep_list(q); s=t;
20256 if ( t==mp_dependent ) if ( v_is_scaled )
20257 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20258 t=mp_proto_dependent;
20259 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20260 mp_dep_finish(mp, q,p,t);
20263 @ Here is a routine that is similar to |times|; but it is invoked only
20264 internally, when |v| is a |fraction| whose magnitude is at most~1,
20265 and when |cur_type>=mp_color_type|.
20267 @c void mp_frac_mult (MP mp,scaled n, scaled d) {
20268 /* multiplies |cur_exp| by |n/d| */
20269 pointer p; /* a pair node */
20270 pointer old_exp; /* a capsule to recycle */
20271 fraction v; /* |n/d| */
20272 if ( mp->internal[mp_tracing_commands]>two ) {
20273 @<Trace the fraction multiplication@>;
20275 switch (mp->cur_type) {
20276 case mp_transform_type:
20277 case mp_color_type:
20278 case mp_cmykcolor_type:
20280 old_exp=mp_tarnished(mp, mp->cur_exp);
20282 case mp_independent: old_exp=mp_void; break;
20283 default: old_exp=null; break;
20285 if ( old_exp!=null ) {
20286 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20288 v=mp_make_fraction(mp, n,d);
20289 if ( mp->cur_type==mp_known ) {
20290 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20291 } else if ( mp->cur_type<=mp_pair_type ) {
20292 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20295 mp_dep_mult(mp, p,v,false);
20296 } while (p!=value(mp->cur_exp));
20298 mp_dep_mult(mp, null,v,false);
20300 if ( old_exp!=null ) {
20301 mp_recycle_value(mp, old_exp);
20302 mp_free_node(mp, old_exp,value_node_size);
20306 @ @<Trace the fraction multiplication@>=
20308 mp_begin_diagnostic(mp);
20309 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,xord('/'));
20310 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20312 mp_end_diagnostic(mp, false);
20315 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20317 @<Declare binary action procedures@>=
20318 void mp_hard_times (MP mp,pointer p) {
20319 pointer q; /* a copy of the dependent variable |p| */
20320 pointer r; /* a component of the big node for the nice color or pair */
20321 scaled v; /* the known value for |r| */
20322 if ( type(p)<=mp_pair_type ) {
20323 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20324 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20325 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20330 if ( r==value(mp->cur_exp) )
20332 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20333 mp_dep_mult(mp, r,v,true);
20335 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20336 mp_link(prev_dep(p))=r;
20337 mp_free_node(mp, p,value_node_size);
20338 mp_dep_mult(mp, r,v,true);
20341 @ @<Additional cases of binary operators@>=
20343 if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
20344 mp_bad_binary(mp, p,over);
20346 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20348 @<Squeal about division by zero@>;
20350 if ( mp->cur_type==mp_known ) {
20351 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20352 } else if ( mp->cur_type<=mp_pair_type ) {
20353 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20355 p=p-2; mp_dep_div(mp, p,v);
20356 } while (p!=value(mp->cur_exp));
20358 mp_dep_div(mp, null,v);
20365 @ @<Declare binary action...@>=
20366 void mp_dep_div (MP mp,pointer p, scaled v) {
20367 pointer q; /* the dependency list being divided by |v| */
20368 quarterword s,t; /* its type, before and after */
20369 if ( p==null ) q=mp->cur_exp;
20370 else if ( type(p)!=mp_known ) q=p;
20371 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20372 t=type(q); q=dep_list(q); s=t;
20373 if ( t==mp_dependent )
20374 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20375 t=mp_proto_dependent;
20376 q=mp_p_over_v(mp, q,v,s,t);
20377 mp_dep_finish(mp, q,p,t);
20380 @ @<Squeal about division by zero@>=
20382 exp_err("Division by zero");
20383 @.Division by zero@>
20384 help2("You're trying to divide the quantity shown above the error",
20385 "message by zero. I'm going to divide it by one instead.");
20386 mp_put_get_error(mp);
20389 @ @<Additional cases of binary operators@>=
20392 if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
20393 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20394 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20395 } else mp_bad_binary(mp, p,c);
20398 @ The next few sections of the program deal with affine transformations
20399 of coordinate data.
20401 @<Additional cases of binary operators@>=
20402 case rotated_by: case slanted_by:
20403 case scaled_by: case shifted_by: case transformed_by:
20404 case x_scaled: case y_scaled: case z_scaled:
20405 if ( type(p)==mp_path_type ) {
20406 path_trans(c,p); binary_return;
20407 } else if ( type(p)==mp_pen_type ) {
20409 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20410 /* rounding error could destroy convexity */
20412 } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
20413 mp_big_trans(mp, p,c);
20414 } else if ( type(p)==mp_picture_type ) {
20415 mp_do_edges_trans(mp, p,c); binary_return;
20417 mp_bad_binary(mp, p,c);
20421 @ Let |c| be one of the eight transform operators. The procedure call
20422 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20423 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20424 change at all if |c=transformed_by|.)
20426 Then, if all components of the resulting transform are |known|, they are
20427 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20428 and |cur_exp| is changed to the known value zero.
20430 @<Declare binary action...@>=
20431 void mp_set_up_trans (MP mp,quarterword c) {
20432 pointer p,q,r; /* list manipulation registers */
20433 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20434 @<Put the current transform into |cur_exp|@>;
20436 @<If the current transform is entirely known, stash it in global variables;
20437 otherwise |return|@>;
20446 scaled ty; /* current transform coefficients */
20448 @ @<Put the current transform...@>=
20450 p=mp_stash_cur_exp(mp);
20451 mp->cur_exp=mp_id_transform(mp);
20452 mp->cur_type=mp_transform_type;
20453 q=value(mp->cur_exp);
20455 @<For each of the eight cases, change the relevant fields of |cur_exp|
20457 but do nothing if capsule |p| doesn't have the appropriate type@>;
20458 }; /* there are no other cases */
20459 mp_disp_err(mp, p,"Improper transformation argument");
20460 @.Improper transformation argument@>
20461 help3("The expression shown above has the wrong type,",
20462 "so I can\'t transform anything using it.",
20463 "Proceed, and I'll omit the transformation.");
20464 mp_put_get_error(mp);
20466 mp_recycle_value(mp, p);
20467 mp_free_node(mp, p,value_node_size);
20470 @ @<If the current transform is entirely known, ...@>=
20471 q=value(mp->cur_exp); r=q+transform_node_size;
20474 if ( type(r)!=mp_known ) return;
20476 mp->txx=value(xx_part_loc(q));
20477 mp->txy=value(xy_part_loc(q));
20478 mp->tyx=value(yx_part_loc(q));
20479 mp->tyy=value(yy_part_loc(q));
20480 mp->tx=value(x_part_loc(q));
20481 mp->ty=value(y_part_loc(q));
20482 mp_flush_cur_exp(mp, 0)
20484 @ @<For each of the eight cases...@>=
20486 if ( type(p)==mp_known )
20487 @<Install sines and cosines, then |goto done|@>;
20490 if ( type(p)>mp_pair_type ) {
20491 mp_install(mp, xy_part_loc(q),p); goto DONE;
20495 if ( type(p)>mp_pair_type ) {
20496 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20501 if ( type(p)==mp_pair_type ) {
20502 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20503 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20507 if ( type(p)>mp_pair_type ) {
20508 mp_install(mp, xx_part_loc(q),p); goto DONE;
20512 if ( type(p)>mp_pair_type ) {
20513 mp_install(mp, yy_part_loc(q),p); goto DONE;
20517 if ( type(p)==mp_pair_type )
20518 @<Install a complex multiplier, then |goto done|@>;
20520 case transformed_by:
20524 @ @<Install sines and cosines, then |goto done|@>=
20525 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20526 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20527 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20528 value(xy_part_loc(q))=-value(yx_part_loc(q));
20529 value(yy_part_loc(q))=value(xx_part_loc(q));
20533 @ @<Install a complex multiplier, then |goto done|@>=
20536 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20537 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20538 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20539 if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20540 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20541 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20545 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20546 insists that the transformation be entirely known.
20548 @<Declare binary action...@>=
20549 void mp_set_up_known_trans (MP mp,quarterword c) {
20550 mp_set_up_trans(mp, c);
20551 if ( mp->cur_type!=mp_known ) {
20552 exp_err("Transform components aren't all known");
20553 @.Transform components...@>
20554 help3("I'm unable to apply a partially specified transformation",
20555 "except to a fully known pair or transform.",
20556 "Proceed, and I'll omit the transformation.");
20557 mp_put_get_flush_error(mp, 0);
20558 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20559 mp->tx=0; mp->ty=0;
20563 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20564 coordinates in locations |p| and~|q|.
20566 @<Declare binary action...@>=
20567 void mp_trans (MP mp,pointer p, pointer q) {
20568 scaled v; /* the new |x| value */
20569 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20570 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20571 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20572 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20576 @ The simplest transformation procedure applies a transform to all
20577 coordinates of a path. The |path_trans(c)(p)| macro applies
20578 a transformation defined by |cur_exp| and the transform operator |c|
20581 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20582 mp_unstash_cur_exp(mp, (B));
20583 mp_do_path_trans(mp, mp->cur_exp); }
20585 @<Declare binary action...@>=
20586 void mp_do_path_trans (MP mp,pointer p) {
20587 pointer q; /* list traverser */
20590 if ( left_type(q)!=mp_endpoint )
20591 mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
20592 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20593 if ( right_type(q)!=mp_endpoint )
20594 mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
20595 @^data structure assumptions@>
20600 @ Transforming a pen is very similar, except that there are no |left_type|
20601 and |right_type| fields.
20603 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20604 mp_unstash_cur_exp(mp, (B));
20605 mp_do_pen_trans(mp, mp->cur_exp); }
20607 @<Declare binary action...@>=
20608 void mp_do_pen_trans (MP mp,pointer p) {
20609 pointer q; /* list traverser */
20610 if ( pen_is_elliptical(p) ) {
20611 mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
20612 mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
20616 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20617 @^data structure assumptions@>
20622 @ The next transformation procedure applies to edge structures. It will do
20623 any transformation, but the results may be substandard if the picture contains
20624 text that uses downloaded bitmap fonts. The binary action procedure is
20625 |do_edges_trans|, but we also need a function that just scales a picture.
20626 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20627 should be thought of as procedures that update an edge structure |h|, except
20628 that they have to return a (possibly new) structure because of the need to call
20631 @<Declare binary action...@>=
20632 pointer mp_edges_trans (MP mp, pointer h) {
20633 pointer q; /* the object being transformed */
20634 pointer r,s; /* for list manipulation */
20635 scaled sx,sy; /* saved transformation parameters */
20636 scaled sqdet; /* square root of determinant for |dash_scale| */
20637 integer sgndet; /* sign of the determinant */
20638 scaled v; /* a temporary value */
20639 h=mp_private_edges(mp, h);
20640 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20641 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20642 if ( dash_list(h)!=null_dash ) {
20643 @<Try to transform the dash list of |h|@>;
20645 @<Make the bounding box of |h| unknown if it can't be updated properly
20646 without scanning the whole structure@>;
20647 q=mp_link(dummy_loc(h));
20648 while ( q!=null ) {
20649 @<Transform graphical object |q|@>;
20654 void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20655 mp_set_up_known_trans(mp, c);
20656 value(p)=mp_edges_trans(mp, value(p));
20657 mp_unstash_cur_exp(mp, p);
20659 void mp_scale_edges (MP mp) {
20660 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20661 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20662 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20665 @ @<Try to transform the dash list of |h|@>=
20666 if ( (mp->txy!=0)||(mp->tyx!=0)||
20667 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20668 mp_flush_dash_list(mp, h);
20670 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20671 @<Scale the dash list by |txx| and shift it by |tx|@>;
20672 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20675 @ @<Reverse the dash list of |h|@>=
20678 dash_list(h)=null_dash;
20679 while ( r!=null_dash ) {
20681 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20682 mp_link(s)=dash_list(h);
20687 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20689 while ( r!=null_dash ) {
20690 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20691 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20695 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20696 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20697 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20698 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20699 mp_init_bbox(mp, h);
20702 if ( minx_val(h)<=maxx_val(h) ) {
20703 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20710 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20712 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20713 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20716 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20719 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20721 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20722 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20723 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20724 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20725 if ( mp->txx+mp->txy<0 ) {
20726 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20728 if ( mp->tyx+mp->tyy<0 ) {
20729 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20733 @ Now we ready for the main task of transforming the graphical objects in edge
20736 @<Transform graphical object |q|@>=
20738 case mp_fill_code: case mp_stroked_code:
20739 mp_do_path_trans(mp, path_p(q));
20740 @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20742 case mp_start_clip_code: case mp_start_bounds_code:
20743 mp_do_path_trans(mp, path_p(q));
20747 @<Transform the compact transformation starting at |r|@>;
20749 case mp_stop_clip_code: case mp_stop_bounds_code:
20751 } /* there are no other cases */
20753 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20754 The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
20755 since the \ps\ output procedures will try to compensate for the transformation
20756 we are applying to |pen_p(q)|. Since this compensation is based on the square
20757 root of the determinant, |sqdet| is the appropriate factor.
20759 @<Transform |pen_p(q)|, making sure...@>=
20760 if ( pen_p(q)!=null ) {
20761 sx=mp->tx; sy=mp->ty;
20762 mp->tx=0; mp->ty=0;
20763 mp_do_pen_trans(mp, pen_p(q));
20764 if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
20765 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20766 if ( ! pen_is_elliptical(pen_p(q)) )
20768 pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
20769 /* this unreverses the pen */
20770 mp->tx=sx; mp->ty=sy;
20773 @ This uses the fact that transformations are stored in the order
20774 |(tx,ty,txx,txy,tyx,tyy)|.
20775 @^data structure assumptions@>
20777 @<Transform the compact transformation starting at |r|@>=
20778 mp_trans(mp, r,r+1);
20779 sx=mp->tx; sy=mp->ty;
20780 mp->tx=0; mp->ty=0;
20781 mp_trans(mp, r+2,r+4);
20782 mp_trans(mp, r+3,r+5);
20783 mp->tx=sx; mp->ty=sy
20785 @ The hard cases of transformation occur when big nodes are involved,
20786 and when some of their components are unknown.
20788 @<Declare binary action...@>=
20789 @<Declare subroutines needed by |big_trans|@>
20790 void mp_big_trans (MP mp,pointer p, quarterword c) {
20791 pointer q,r,pp,qq; /* list manipulation registers */
20792 quarterword s; /* size of a big node */
20793 s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
20796 if ( type(r)!=mp_known ) {
20797 @<Transform an unknown big node and |return|@>;
20800 @<Transform a known big node@>;
20801 } /* node |p| will now be recycled by |do_binary| */
20803 @ @<Transform an unknown big node and |return|@>=
20805 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20806 r=value(mp->cur_exp);
20807 if ( mp->cur_type==mp_transform_type ) {
20808 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20809 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20810 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20811 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20813 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20814 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20818 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20819 and let |q| point to a another value field. The |bilin1| procedure
20820 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20822 @<Declare subroutines needed by |big_trans|@>=
20823 void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20824 scaled u, scaled delta) {
20825 pointer r; /* list traverser */
20826 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20828 if ( type(q)==mp_known ) {
20829 delta+=mp_take_scaled(mp, value(q),u);
20831 @<Ensure that |type(p)=mp_proto_dependent|@>;
20832 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20833 mp_proto_dependent,type(q));
20836 if ( type(p)==mp_known ) {
20840 while ( info(r)!=null ) r=mp_link(r);
20842 if ( r!=dep_list(p) ) value(r)=delta;
20843 else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
20845 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20848 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
20849 if ( type(p)!=mp_proto_dependent ) {
20850 if ( type(p)==mp_known )
20851 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
20853 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
20854 mp_proto_dependent,true);
20855 type(p)=mp_proto_dependent;
20858 @ @<Transform a known big node@>=
20859 mp_set_up_trans(mp, c);
20860 if ( mp->cur_type==mp_known ) {
20861 @<Transform known by known@>;
20863 pp=mp_stash_cur_exp(mp); qq=value(pp);
20864 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20865 if ( mp->cur_type==mp_transform_type ) {
20866 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
20867 value(xy_part_loc(q)),yx_part_loc(qq),null);
20868 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
20869 value(xx_part_loc(q)),yx_part_loc(qq),null);
20870 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
20871 value(yy_part_loc(q)),xy_part_loc(qq),null);
20872 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
20873 value(yx_part_loc(q)),xy_part_loc(qq),null);
20875 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
20876 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
20877 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
20878 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
20879 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
20882 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
20883 at |dep_final|. The following procedure adds |v| times another
20884 numeric quantity to~|p|.
20886 @<Declare subroutines needed by |big_trans|@>=
20887 void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
20888 if ( type(r)==mp_known ) {
20889 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
20891 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
20892 mp_proto_dependent,type(r));
20893 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20897 @ The |bilin2| procedure is something like |bilin1|, but with known
20898 and unknown quantities reversed. Parameter |p| points to a value field
20899 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
20900 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
20901 unless it is |null| (which stands for zero). Location~|p| will be
20902 replaced by $p\cdot t+v\cdot u+q$.
20904 @<Declare subroutines needed by |big_trans|@>=
20905 void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
20906 pointer u, pointer q) {
20907 scaled vv; /* temporary storage for |value(p)| */
20908 vv=value(p); type(p)=mp_proto_dependent;
20909 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
20911 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
20912 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
20913 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
20914 if ( dep_list(p)==mp->dep_final ) {
20915 vv=value(mp->dep_final); mp_recycle_value(mp, p);
20916 type(p)=mp_known; value(p)=vv;
20920 @ @<Transform known by known@>=
20922 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20923 if ( mp->cur_type==mp_transform_type ) {
20924 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
20925 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
20926 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
20927 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
20929 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
20930 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
20933 @ Finally, in |bilin3| everything is |known|.
20935 @<Declare subroutines needed by |big_trans|@>=
20936 void mp_bilin3 (MP mp,pointer p, scaled t,
20937 scaled v, scaled u, scaled delta) {
20939 delta+=mp_take_scaled(mp, value(p),t);
20942 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
20943 else value(p)=delta;
20946 @ @<Additional cases of binary operators@>=
20948 if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
20949 else mp_bad_binary(mp, p,concatenate);
20952 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
20953 mp_chop_string(mp, value(p));
20954 else mp_bad_binary(mp, p,substring_of);
20957 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
20958 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
20959 mp_chop_path(mp, value(p));
20960 else mp_bad_binary(mp, p,subpath_of);
20963 @ @<Declare binary action...@>=
20964 void mp_cat (MP mp,pointer p) {
20965 str_number a,b; /* the strings being concatenated */
20966 pool_pointer k; /* index into |str_pool| */
20967 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
20968 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
20969 append_char(mp->str_pool[k]);
20971 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
20972 append_char(mp->str_pool[k]);
20974 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
20977 @ @<Declare binary action...@>=
20978 void mp_chop_string (MP mp,pointer p) {
20979 integer a, b; /* start and stop points */
20980 integer l; /* length of the original string */
20981 integer k; /* runs from |a| to |b| */
20982 str_number s; /* the original string */
20983 boolean reversed; /* was |a>b|? */
20984 a=mp_round_unscaled(mp, value(x_part_loc(p)));
20985 b=mp_round_unscaled(mp, value(y_part_loc(p)));
20986 if ( a<=b ) reversed=false;
20987 else { reversed=true; k=a; a=b; b=k; };
20988 s=mp->cur_exp; l=length(s);
20999 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
21000 append_char(mp->str_pool[k]);
21003 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
21004 append_char(mp->str_pool[k]);
21007 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
21010 @ @<Declare binary action...@>=
21011 void mp_chop_path (MP mp,pointer p) {
21012 pointer q; /* a knot in the original path */
21013 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
21014 scaled a,b,k,l; /* indices for chopping */
21015 boolean reversed; /* was |a>b|? */
21016 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
21017 if ( a<=b ) reversed=false;
21018 else { reversed=true; k=a; a=b; b=k; };
21019 @<Dispense with the cases |a<0| and/or |b>l|@>;
21021 while ( a>=unity ) {
21022 q=mp_link(q); a=a-unity; b=b-unity;
21025 @<Construct a path from |pp| to |qq| of length zero@>;
21027 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
21029 left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; mp_link(qq)=pp;
21030 mp_toss_knot_list(mp, mp->cur_exp);
21032 mp->cur_exp=mp_link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
21038 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
21040 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21041 a=0; if ( b<0 ) b=0;
21043 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
21047 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21048 b=l; if ( a>l ) a=l;
21056 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
21058 pp=mp_copy_knot(mp, q); qq=pp;
21060 q=mp_link(q); rr=qq; qq=mp_copy_knot(mp, q); mp_link(rr)=qq; b=b-unity;
21063 ss=pp; pp=mp_link(pp);
21064 mp_split_cubic(mp, ss,a*010000); pp=mp_link(ss);
21065 mp_free_node(mp, ss,knot_node_size);
21067 b=mp_make_scaled(mp, b,unity-a); rr=pp;
21071 mp_split_cubic(mp, rr,(b+unity)*010000);
21072 mp_free_node(mp, qq,knot_node_size);
21077 @ @<Construct a path from |pp| to |qq| of length zero@>=
21079 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=mp_link(q); };
21080 pp=mp_copy_knot(mp, q); qq=pp;
21083 @ @<Additional cases of binary operators@>=
21084 case point_of: case precontrol_of: case postcontrol_of:
21085 if ( mp->cur_type==mp_pair_type )
21086 mp_pair_to_path(mp);
21087 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21088 mp_find_point(mp, value(p),c);
21090 mp_bad_binary(mp, p,c);
21092 case pen_offset_of:
21093 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
21094 mp_set_up_offset(mp, value(p));
21096 mp_bad_binary(mp, p,pen_offset_of);
21098 case direction_time_of:
21099 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21100 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
21101 mp_set_up_direction_time(mp, value(p));
21103 mp_bad_binary(mp, p,direction_time_of);
21106 if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
21107 mp_bad_binary(mp, p,envelope_of);
21109 mp_set_up_envelope(mp, p);
21112 @ @<Declare binary action...@>=
21113 void mp_set_up_offset (MP mp,pointer p) {
21114 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
21115 mp_pair_value(mp, mp->cur_x,mp->cur_y);
21117 void mp_set_up_direction_time (MP mp,pointer p) {
21118 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
21119 value(y_part_loc(p)),mp->cur_exp));
21121 void mp_set_up_envelope (MP mp,pointer p) {
21122 quarterword ljoin, lcap;
21124 pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
21125 /* TODO: accept elliptical pens for straight paths */
21126 if (pen_is_elliptical(value(p))) {
21127 mp_bad_envelope_pen(mp);
21129 mp->cur_type = mp_path_type;
21132 if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
21133 else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
21135 if ( mp->internal[mp_linecap]>unity ) lcap=2;
21136 else if ( mp->internal[mp_linecap]>0 ) lcap=1;
21138 if ( mp->internal[mp_miterlimit]<unity )
21141 miterlim=mp->internal[mp_miterlimit];
21142 mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
21143 mp->cur_type = mp_path_type;
21146 @ @<Declare binary action...@>=
21147 void mp_find_point (MP mp,scaled v, quarterword c) {
21148 pointer p; /* the path */
21149 scaled n; /* its length */
21151 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
21152 do { p=mp_link(p); n=n+unity; } while (p!=mp->cur_exp);
21155 } else if ( v<0 ) {
21156 if ( left_type(p)==mp_endpoint ) v=0;
21157 else v=n-1-((-v-1) % n);
21158 } else if ( v>n ) {
21159 if ( left_type(p)==mp_endpoint ) v=n;
21163 while ( v>=unity ) { p=mp_link(p); v=v-unity; };
21165 @<Insert a fractional node by splitting the cubic@>;
21167 @<Set the current expression to the desired path coordinates@>;
21170 @ @<Insert a fractional node...@>=
21171 { mp_split_cubic(mp, p,v*010000); p=mp_link(p); }
21173 @ @<Set the current expression to the desired path coordinates...@>=
21176 mp_pair_value(mp, x_coord(p),y_coord(p));
21178 case precontrol_of:
21179 if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21180 else mp_pair_value(mp, left_x(p),left_y(p));
21182 case postcontrol_of:
21183 if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21184 else mp_pair_value(mp, right_x(p),right_y(p));
21186 } /* there are no other cases */
21188 @ @<Additional cases of binary operators@>=
21190 if ( mp->cur_type==mp_pair_type )
21191 mp_pair_to_path(mp);
21192 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21193 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21195 mp_bad_binary(mp, p,c);
21198 @ @<Additional cases of bin...@>=
21200 if ( type(p)==mp_pair_type ) {
21201 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21202 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21204 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21205 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
21206 mp_path_intersection(mp, value(p),mp->cur_exp);
21207 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21209 mp_bad_binary(mp, p,intersect);
21213 @ @<Additional cases of bin...@>=
21215 if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
21216 mp_bad_binary(mp, p,in_font);
21217 else { mp_do_infont(mp, p); binary_return; }
21220 @ Function |new_text_node| owns the reference count for its second argument
21221 (the text string) but not its first (the font name).
21223 @<Declare binary action...@>=
21224 void mp_do_infont (MP mp,pointer p) {
21226 q=mp_get_node(mp, edge_header_size);
21227 mp_init_edges(mp, q);
21228 mp_link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
21229 obj_tail(q)=mp_link(obj_tail(q));
21230 mp_free_node(mp, p,value_node_size);
21231 mp_flush_cur_exp(mp, q);
21232 mp->cur_type=mp_picture_type;
21235 @* \[40] Statements and commands.
21236 The chief executive of \MP\ is the |do_statement| routine, which
21237 contains the master switch that causes all the various pieces of \MP\
21238 to do their things, in the right order.
21240 In a sense, this is the grand climax of the program: It applies all the
21241 tools that we have worked so hard to construct. In another sense, this is
21242 the messiest part of the program: It necessarily refers to other pieces
21243 of code all over the place, so that a person can't fully understand what is
21244 going on without paging back and forth to be reminded of conventions that
21245 are defined elsewhere. We are now at the hub of the web.
21247 The structure of |do_statement| itself is quite simple. The first token
21248 of the statement is fetched using |get_x_next|. If it can be the first
21249 token of an expression, we look for an equation, an assignment, or a
21250 title. Otherwise we use a \&{case} construction to branch at high speed to
21251 the appropriate routine for various and sundry other types of commands,
21252 each of which has an ``action procedure'' that does the necessary work.
21254 The program uses the fact that
21255 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21256 to interpret a statement that starts with, e.g., `\&{string}',
21257 as a type declaration rather than a boolean expression.
21259 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21260 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21261 if ( mp->cur_cmd>max_primary_command ) {
21262 @<Worry about bad statement@>;
21263 } else if ( mp->cur_cmd>max_statement_command ) {
21264 @<Do an equation, assignment, title, or
21265 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21267 @<Do a statement that doesn't begin with an expression@>;
21269 if ( mp->cur_cmd<semicolon )
21270 @<Flush unparsable junk that was found after the statement@>;
21274 @ @<Declarations@>=
21275 @<Declare action procedures for use by |do_statement|@>
21277 @ The only command codes |>max_primary_command| that can be present
21278 at the beginning of a statement are |semicolon| and higher; these
21279 occur when the statement is null.
21281 @<Worry about bad statement@>=
21283 if ( mp->cur_cmd<semicolon ) {
21284 print_err("A statement can't begin with `");
21285 @.A statement can't begin with x@>
21286 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, xord('\''));
21287 help5("I was looking for the beginning of a new statement.",
21288 "If you just proceed without changing anything, I'll ignore",
21289 "everything up to the next `;'. Please insert a semicolon",
21290 "now in front of anything that you don't want me to delete.",
21291 "(See Chapter 27 of The METAFONTbook for an example.)");
21292 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21293 mp_back_error(mp); mp_get_x_next(mp);
21297 @ The help message printed here says that everything is flushed up to
21298 a semicolon, but actually the commands |end_group| and |stop| will
21299 also terminate a statement.
21301 @<Flush unparsable junk that was found after the statement@>=
21303 print_err("Extra tokens will be flushed");
21304 @.Extra tokens will be flushed@>
21305 help6("I've just read as much of that statement as I could fathom,",
21306 "so a semicolon should have been next. It's very puzzling...",
21307 "but I'll try to get myself back together, by ignoring",
21308 "everything up to the next `;'. Please insert a semicolon",
21309 "now in front of anything that you don't want me to delete.",
21310 "(See Chapter 27 of The METAFONTbook for an example.)");
21311 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21312 mp_back_error(mp); mp->scanner_status=flushing;
21315 @<Decrease the string reference count...@>;
21316 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21317 mp->scanner_status=normal;
21320 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21321 |cur_type=mp_vacuous| unless the statement was simply an expression;
21322 in the latter case, |cur_type| and |cur_exp| should represent that
21325 @<Do a statement that doesn't...@>=
21327 if ( mp->internal[mp_tracing_commands]>0 )
21329 switch (mp->cur_cmd ) {
21330 case type_name:mp_do_type_declaration(mp); break;
21332 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21333 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21335 @<Cases of |do_statement| that invoke particular commands@>;
21336 } /* there are no other cases */
21337 mp->cur_type=mp_vacuous;
21340 @ The most important statements begin with expressions.
21342 @<Do an equation, assignment, title, or...@>=
21344 mp->var_flag=assignment; mp_scan_expression(mp);
21345 if ( mp->cur_cmd<end_group ) {
21346 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21347 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21348 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21349 else if ( mp->cur_type!=mp_vacuous ){
21350 exp_err("Isolated expression");
21351 @.Isolated expression@>
21352 help3("I couldn't find an `=' or `:=' after the",
21353 "expression that is shown above this error message,",
21354 "so I guess I'll just ignore it and carry on.");
21355 mp_put_get_error(mp);
21357 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21363 if ( mp->internal[mp_tracing_titles]>0 ) {
21364 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21368 @ Equations and assignments are performed by the pair of mutually recursive
21370 routines |do_equation| and |do_assignment|. These routines are called when
21371 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21372 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21373 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21374 will be equal to the right-hand side (which will normally be equal
21375 to the left-hand side).
21377 @<Declare action procedures for use by |do_statement|@>=
21378 @<Declare the procedure called |try_eq|@>
21379 @<Declare the procedure called |make_eq|@>
21380 void mp_do_equation (MP mp) ;
21383 void mp_do_equation (MP mp) {
21384 pointer lhs; /* capsule for the left-hand side */
21385 pointer p; /* temporary register */
21386 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21387 mp->var_flag=assignment; mp_scan_expression(mp);
21388 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21389 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21390 if ( mp->internal[mp_tracing_commands]>two )
21391 @<Trace the current equation@>;
21392 if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
21393 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21394 }; /* in this case |make_eq| will change the pair to a path */
21395 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21398 @ And |do_assignment| is similar to |do_equation|:
21401 void mp_do_assignment (MP mp);
21403 @ @<Declare action procedures for use by |do_statement|@>=
21404 void mp_do_assignment (MP mp) ;
21407 void mp_do_assignment (MP mp) {
21408 pointer lhs; /* token list for the left-hand side */
21409 pointer p; /* where the left-hand value is stored */
21410 pointer q; /* temporary capsule for the right-hand value */
21411 if ( mp->cur_type!=mp_token_list ) {
21412 exp_err("Improper `:=' will be changed to `='");
21414 help2("I didn't find a variable name at the left of the `:=',",
21415 "so I'm going to pretend that you said `=' instead.");
21416 mp_error(mp); mp_do_equation(mp);
21418 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21419 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21420 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21421 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21422 if ( mp->internal[mp_tracing_commands]>two )
21423 @<Trace the current assignment@>;
21424 if ( info(lhs)>hash_end ) {
21425 @<Assign the current expression to an internal variable@>;
21427 @<Assign the current expression to the variable |lhs|@>;
21429 mp_flush_node_list(mp, lhs);
21433 @ @<Trace the current equation@>=
21435 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21436 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21437 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21440 @ @<Trace the current assignment@>=
21442 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21443 if ( info(lhs)>hash_end )
21444 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21446 mp_show_token_list(mp, lhs,null,1000,0);
21447 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21448 mp_print_char(mp, xord('}')); mp_end_diagnostic(mp, false);
21451 @ @<Assign the current expression to an internal variable@>=
21452 if ( mp->cur_type==mp_known ) {
21453 mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
21455 exp_err("Internal quantity `");
21456 @.Internal quantity...@>
21457 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21458 mp_print(mp, "' must receive a known value");
21459 help2("I can\'t set an internal quantity to anything but a known",
21460 "numeric value, so I'll have to ignore this assignment.");
21461 mp_put_get_error(mp);
21464 @ @<Assign the current expression to the variable |lhs|@>=
21466 p=mp_find_variable(mp, lhs);
21468 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21469 mp_recycle_value(mp, p);
21470 type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21471 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21473 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21478 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21479 a pointer to a capsule that is to be equated to the current expression.
21481 @<Declare the procedure called |make_eq|@>=
21482 void mp_make_eq (MP mp,pointer lhs) ;
21486 @c void mp_make_eq (MP mp,pointer lhs) {
21487 quarterword t; /* type of the left-hand side */
21488 pointer p,q; /* pointers inside of big nodes */
21489 integer v=0; /* value of the left-hand side */
21492 if ( t<=mp_pair_type ) v=value(lhs);
21494 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21495 is incompatible with~|t|@>;
21496 } /* all cases have been listed */
21497 @<Announce that the equation cannot be performed@>;
21499 check_arith; mp_recycle_value(mp, lhs);
21500 mp_free_node(mp, lhs,value_node_size);
21503 @ @<Announce that the equation cannot be performed@>=
21504 mp_disp_err(mp, lhs,"");
21505 exp_err("Equation cannot be performed (");
21506 @.Equation cannot be performed@>
21507 if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
21508 else mp_print(mp, "numeric");
21509 mp_print_char(mp, xord('='));
21510 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21511 else mp_print(mp, "numeric");
21512 mp_print_char(mp, xord(')'));
21513 help2("I'm sorry, but I don't know how to make such things equal.",
21514 "(See the two expressions just above the error message.)");
21515 mp_put_get_error(mp)
21517 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21518 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21519 case mp_path_type: case mp_picture_type:
21520 if ( mp->cur_type==t+unknown_tag ) {
21521 mp_nonlinear_eq(mp, v,mp->cur_exp,false);
21522 mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
21523 } else if ( mp->cur_type==t ) {
21524 @<Report redundant or inconsistent equation and |goto done|@>;
21527 case unknown_types:
21528 if ( mp->cur_type==t-unknown_tag ) {
21529 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21530 } else if ( mp->cur_type==t ) {
21531 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21532 } else if ( mp->cur_type==mp_pair_type ) {
21533 if ( t==mp_unknown_path ) {
21534 mp_pair_to_path(mp); goto RESTART;
21538 case mp_transform_type: case mp_color_type:
21539 case mp_cmykcolor_type: case mp_pair_type:
21540 if ( mp->cur_type==t ) {
21541 @<Do multiple equations and |goto done|@>;
21544 case mp_known: case mp_dependent:
21545 case mp_proto_dependent: case mp_independent:
21546 if ( mp->cur_type>=mp_known ) {
21547 mp_try_eq(mp, lhs,null); goto DONE;
21553 @ @<Report redundant or inconsistent equation and |goto done|@>=
21555 if ( mp->cur_type<=mp_string_type ) {
21556 if ( mp->cur_type==mp_string_type ) {
21557 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21560 } else if ( v!=mp->cur_exp ) {
21563 @<Exclaim about a redundant equation@>; goto DONE;
21565 print_err("Redundant or inconsistent equation");
21566 @.Redundant or inconsistent equation@>
21567 help2("An equation between already-known quantities can't help.",
21568 "But don't worry; continue and I'll just ignore it.");
21569 mp_put_get_error(mp); goto DONE;
21571 print_err("Inconsistent equation");
21572 @.Inconsistent equation@>
21573 help2("The equation I just read contradicts what was said before.",
21574 "But don't worry; continue and I'll just ignore it.");
21575 mp_put_get_error(mp); goto DONE;
21578 @ @<Do multiple equations and |goto done|@>=
21580 p=v+mp->big_node_size[t];
21581 q=value(mp->cur_exp)+mp->big_node_size[t];
21583 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21588 @ The first argument to |try_eq| is the location of a value node
21589 in a capsule that will soon be recycled. The second argument is
21590 either a location within a pair or transform node pointed to by
21591 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21592 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21593 but to equate the two operands.
21595 @<Declare the procedure called |try_eq|@>=
21596 void mp_try_eq (MP mp,pointer l, pointer r) ;
21599 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21600 pointer p; /* dependency list for right operand minus left operand */
21601 int t; /* the type of list |p| */
21602 pointer q; /* the constant term of |p| is here */
21603 pointer pp; /* dependency list for right operand */
21604 int tt; /* the type of list |pp| */
21605 boolean copied; /* have we copied a list that ought to be recycled? */
21606 @<Remove the left operand from its container, negate it, and
21607 put it into dependency list~|p| with constant term~|q|@>;
21608 @<Add the right operand to list |p|@>;
21609 if ( info(p)==null ) {
21610 @<Deal with redundant or inconsistent equation@>;
21612 mp_linear_eq(mp, p,t);
21613 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21614 if ( type(mp->cur_exp)==mp_known ) {
21615 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21616 mp_free_node(mp, pp,value_node_size);
21622 @ @<Remove the left operand from its container, negate it, and...@>=
21624 if ( t==mp_known ) {
21625 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21626 } else if ( t==mp_independent ) {
21627 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21630 p=dep_list(l); q=p;
21633 if ( info(q)==null ) break;
21636 mp_link(prev_dep(l))=mp_link(q); prev_dep(mp_link(q))=prev_dep(l);
21640 @ @<Deal with redundant or inconsistent equation@>=
21642 if ( abs(value(p))>64 ) { /* off by .001 or more */
21643 print_err("Inconsistent equation");
21644 @.Inconsistent equation@>
21645 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21646 mp_print_char(mp, xord(')'));
21647 help2("The equation I just read contradicts what was said before.",
21648 "But don't worry; continue and I'll just ignore it.");
21649 mp_put_get_error(mp);
21650 } else if ( r==null ) {
21651 @<Exclaim about a redundant equation@>;
21653 mp_free_node(mp, p,dep_node_size);
21656 @ @<Add the right operand to list |p|@>=
21658 if ( mp->cur_type==mp_known ) {
21659 value(q)=value(q)+mp->cur_exp; goto DONE1;
21662 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21663 else pp=dep_list(mp->cur_exp);
21666 if ( type(r)==mp_known ) {
21667 value(q)=value(q)+value(r); goto DONE1;
21670 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21671 else pp=dep_list(r);
21674 if ( tt!=mp_independent ) copied=false;
21675 else { copied=true; tt=mp_dependent; };
21676 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21677 if ( copied ) mp_flush_node_list(mp, pp);
21680 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21681 mp->watch_coefs=false;
21683 p=mp_p_plus_q(mp, p,pp,t);
21684 } else if ( t==mp_proto_dependent ) {
21685 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21688 while ( info(q)!=null ) {
21689 value(q)=mp_round_fraction(mp, value(q)); q=mp_link(q);
21691 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21693 mp->watch_coefs=true;
21695 @ Our next goal is to process type declarations. For this purpose it's
21696 convenient to have a procedure that scans a $\langle\,$declared
21697 variable$\,\rangle$ and returns the corresponding token list. After the
21698 following procedure has acted, the token after the declared variable
21699 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21702 @<Declare the function called |scan_declared_variable|@>=
21703 pointer mp_scan_declared_variable (MP mp) {
21704 pointer x; /* hash address of the variable's root */
21705 pointer h,t; /* head and tail of the token list to be returned */
21706 pointer l; /* hash address of left bracket */
21707 mp_get_symbol(mp); x=mp->cur_sym;
21708 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21709 h=mp_get_avail(mp); info(h)=x; t=h;
21712 if ( mp->cur_sym==0 ) break;
21713 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21714 if ( mp->cur_cmd==left_bracket ) {
21715 @<Descend past a collective subscript@>;
21720 mp_link(t)=mp_get_avail(mp); t=mp_link(t); info(t)=mp->cur_sym;
21722 if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
21723 if ( equiv(x)==null ) mp_new_root(mp, x);
21727 @ If the subscript isn't collective, we don't accept it as part of the
21730 @<Descend past a collective subscript@>=
21732 l=mp->cur_sym; mp_get_x_next(mp);
21733 if ( mp->cur_cmd!=right_bracket ) {
21734 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21736 mp->cur_sym=collective_subscript;
21740 @ Type declarations are introduced by the following primitive operations.
21743 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21744 @:numeric_}{\&{numeric} primitive@>
21745 mp_primitive(mp, "string",type_name,mp_string_type);
21746 @:string_}{\&{string} primitive@>
21747 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21748 @:boolean_}{\&{boolean} primitive@>
21749 mp_primitive(mp, "path",type_name,mp_path_type);
21750 @:path_}{\&{path} primitive@>
21751 mp_primitive(mp, "pen",type_name,mp_pen_type);
21752 @:pen_}{\&{pen} primitive@>
21753 mp_primitive(mp, "picture",type_name,mp_picture_type);
21754 @:picture_}{\&{picture} primitive@>
21755 mp_primitive(mp, "transform",type_name,mp_transform_type);
21756 @:transform_}{\&{transform} primitive@>
21757 mp_primitive(mp, "color",type_name,mp_color_type);
21758 @:color_}{\&{color} primitive@>
21759 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21760 @:color_}{\&{rgbcolor} primitive@>
21761 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21762 @:color_}{\&{cmykcolor} primitive@>
21763 mp_primitive(mp, "pair",type_name,mp_pair_type);
21764 @:pair_}{\&{pair} primitive@>
21766 @ @<Cases of |print_cmd...@>=
21767 case type_name: mp_print_type(mp, m); break;
21769 @ Now we are ready to handle type declarations, assuming that a
21770 |type_name| has just been scanned.
21772 @<Declare action procedures for use by |do_statement|@>=
21773 void mp_do_type_declaration (MP mp) ;
21776 void mp_do_type_declaration (MP mp) {
21777 quarterword t; /* the type being declared */
21778 pointer p; /* token list for a declared variable */
21779 pointer q; /* value node for the variable */
21780 if ( mp->cur_mod>=mp_transform_type )
21783 t=mp->cur_mod+unknown_tag;
21785 p=mp_scan_declared_variable(mp);
21786 mp_flush_variable(mp, equiv(info(p)),mp_link(p),false);
21787 q=mp_find_variable(mp, p);
21789 type(q)=t; value(q)=null;
21791 print_err("Declared variable conflicts with previous vardef");
21792 @.Declared variable conflicts...@>
21793 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.",
21794 "Proceed, and I'll ignore the illegal redeclaration.");
21795 mp_put_get_error(mp);
21797 mp_flush_list(mp, p);
21798 if ( mp->cur_cmd<comma ) {
21799 @<Flush spurious symbols after the declared variable@>;
21801 } while (! end_of_statement);
21804 @ @<Flush spurious symbols after the declared variable@>=
21806 print_err("Illegal suffix of declared variable will be flushed");
21807 @.Illegal suffix...flushed@>
21808 help5("Variables in declarations must consist entirely of",
21809 "names and collective subscripts, e.g., `x[]a'.",
21810 "Are you trying to use a reserved word in a variable name?",
21811 "I'm going to discard the junk I found here,",
21812 "up to the next comma or the end of the declaration.");
21813 if ( mp->cur_cmd==numeric_token )
21814 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21815 mp_put_get_error(mp); mp->scanner_status=flushing;
21818 @<Decrease the string reference count...@>;
21819 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21820 mp->scanner_status=normal;
21823 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21824 until coming to the end of the user's program.
21825 Each execution of |do_statement| concludes with
21826 |cur_cmd=semicolon|, |end_group|, or |stop|.
21828 @c void mp_main_control (MP mp) {
21830 mp_do_statement(mp);
21831 if ( mp->cur_cmd==end_group ) {
21832 print_err("Extra `endgroup'");
21833 @.Extra `endgroup'@>
21834 help2("I'm not currently working on a `begingroup',",
21835 "so I had better not try to end anything.");
21836 mp_flush_error(mp, 0);
21838 } while (mp->cur_cmd!=stop);
21840 int mp_run (MP mp) {
21842 if (mp->history < mp_fatal_error_stop ) {
21843 @<Install and test the non-local jump buffer@>;
21844 mp_main_control(mp); /* come to life */
21845 mp_final_cleanup(mp); /* prepare for death */
21846 mp_close_files_and_terminate(mp);
21848 return mp->history;
21851 @ For |mp_execute|, we need to define a structure to store the
21852 redirected input and output. This structure holds the five relevant
21853 streams: the three informational output streams, the PostScript
21854 generation stream, and the input stream. These streams have many
21855 things in common, so it makes sense to give them their own structure
21858 \item{fptr} is a virtual file pointer
21859 \item{data} is the data this stream holds
21860 \item{cur} is a cursor pointing into |data|
21861 \item{size} is the allocated length of the data stream
21862 \item{used} is the actual length of the data stream
21864 There are small differences between input and output: |term_in| never
21865 uses |used|, whereas the other four never use |cur|.
21867 @<Exported types@>=
21877 mp_stream term_out;
21878 mp_stream error_out;
21882 struct mp_edge_object *edges;
21885 @ We need a function to clear an output stream, this is called at the
21886 beginning of |mp_execute|. We also need one for destroying an output
21887 stream, this is called just before a stream is (re)opened.
21890 static void mp_reset_stream(mp_stream *str) {
21896 static void mp_free_stream(mp_stream *str) {
21898 mp_reset_stream(str);
21901 @ @<Declarations@>=
21902 static void mp_reset_stream(mp_stream *str);
21903 static void mp_free_stream(mp_stream *str);
21905 @ The global instance contains a pointer instead of the actual structure
21906 even though it is essentially static, because that makes it is easier to move
21910 mp_run_data run_data;
21912 @ Another type is needed: the indirection will overload some of the
21913 file pointer objects in the instance (but not all). For clarity, an
21914 indirect object is used that wraps a |FILE *|.
21917 typedef struct File {
21921 @ Here are all of the functions that need to be overloaded for |mp_execute|.
21924 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype);
21925 static int mplib_get_char(void *f, mp_run_data * mplib_data);
21926 static void mplib_unget_char(void *f, mp_run_data * mplib_data, int c);
21927 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size);
21928 static void mplib_write_ascii_file(MP mp, void *ff, const char *s);
21929 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size);
21930 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size);
21931 static void mplib_close_file(MP mp, void *ff);
21932 static int mplib_eof_file(MP mp, void *ff);
21933 static void mplib_flush_file(MP mp, void *ff);
21934 static void mplib_shipout_backend(MP mp, int h);
21936 @ The |xmalloc(1,1)| calls make sure the stored indirection values are unique.
21938 @d reset_stream(a) do {
21939 mp_reset_stream(&(a));
21941 ff->f = xmalloc(1,1);
21947 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype)
21949 File *ff = xmalloc(1, sizeof(File));
21950 mp_run_data *run = mp_rundata(mp);
21952 if (ftype == mp_filetype_terminal) {
21953 if (fmode[0] == 'r') {
21955 ff->f = xmalloc(1,1);
21956 run->term_in.fptr = ff->f;
21959 reset_stream(run->term_out);
21961 } else if (ftype == mp_filetype_error) {
21962 reset_stream(run->error_out);
21963 } else if (ftype == mp_filetype_log) {
21964 reset_stream(run->log_out);
21965 } else if (ftype == mp_filetype_postscript) {
21966 mp_free_stream(&(run->ps_out));
21967 ff->f = xmalloc(1,1);
21968 run->ps_out.fptr = ff->f;
21971 char *f = (mp->find_file)(mp, fname, fmode, ftype);
21974 realmode[0] = *fmode;
21977 ff->f = fopen(f, realmode);
21979 if ((fmode[0] == 'r') && (ff->f == NULL)) {
21987 static int mplib_get_char(void *f, mp_run_data * run)
21990 if (f == run->term_in.fptr && run->term_in.data != NULL) {
21991 if (run->term_in.size == 0) {
21992 if (run->term_in.cur != NULL) {
21993 run->term_in.cur = NULL;
21995 xfree(run->term_in.data);
21999 run->term_in.size--;
22000 c = *(run->term_in.cur)++;
22008 static void mplib_unget_char(void *f, mp_run_data * run, int c)
22010 if (f == run->term_in.fptr && run->term_in.cur != NULL) {
22011 run->term_in.size++;
22012 run->term_in.cur--;
22019 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size)
22024 size_t len = 0, lim = 128;
22025 mp_run_data *run = mp_rundata(mp);
22026 FILE *f = ((File *) ff)->f;
22030 c = mplib_get_char(f, run);
22036 while (c != EOF && c != '\n' && c != '\r') {
22038 s = xrealloc(s, (lim + (lim >> 2)),1);
22044 c = mplib_get_char(f, run);
22047 c = mplib_get_char(f, run);
22048 if (c != EOF && c != '\n')
22049 mplib_unget_char(f, run, c);
22057 static void mp_append_string (MP mp, mp_stream *a,const char *b) {
22058 size_t l = strlen(b);
22059 if ((a->used+l)>=a->size) {
22060 a->size += 256+(a->size)/5+l;
22061 a->data = xrealloc(a->data,a->size,1);
22063 (void)strcpy(a->data+a->used,b);
22068 static void mplib_write_ascii_file(MP mp, void *ff, const char *s)
22071 void *f = ((File *) ff)->f;
22072 mp_run_data *run = mp_rundata(mp);
22074 if (f == run->term_out.fptr) {
22075 mp_append_string(mp,&(run->term_out), s);
22076 } else if (f == run->error_out.fptr) {
22077 mp_append_string(mp,&(run->error_out), s);
22078 } else if (f == run->log_out.fptr) {
22079 mp_append_string(mp,&(run->log_out), s);
22080 } else if (f == run->ps_out.fptr) {
22081 mp_append_string(mp,&(run->ps_out), s);
22083 fprintf((FILE *) f, "%s", s);
22089 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size)
22094 FILE *f = ((File *) ff)->f;
22096 len = fread(*data, 1, *size, f);
22101 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size)
22105 FILE *f = ((File *) ff)->f;
22107 (void)fwrite(s, size, 1, f);
22111 static void mplib_close_file(MP mp, void *ff)
22114 mp_run_data *run = mp_rundata(mp);
22115 void *f = ((File *) ff)->f;
22117 if (f != run->term_out.fptr
22118 && f != run->error_out.fptr
22119 && f != run->log_out.fptr
22120 && f != run->ps_out.fptr
22121 && f != run->term_in.fptr) {
22129 static int mplib_eof_file(MP mp, void *ff)
22132 mp_run_data *run = mp_rundata(mp);
22133 FILE *f = ((File *) ff)->f;
22136 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22137 return (run->term_in.size == 0);
22144 static void mplib_flush_file(MP mp, void *ff)
22151 static void mplib_shipout_backend(MP mp, int h)
22153 mp_edge_object *hh = mp_gr_export(mp, h);
22155 mp_run_data *run = mp_rundata(mp);
22156 if (run->edges==NULL) {
22159 mp_edge_object *p = run->edges;
22160 while (p->_next!=NULL) { p = p->_next; }
22167 @ This is where we fill them all in.
22168 @<Prepare function pointers for non-interactive use@>=
22170 mp->open_file = mplib_open_file;
22171 mp->close_file = mplib_close_file;
22172 mp->eof_file = mplib_eof_file;
22173 mp->flush_file = mplib_flush_file;
22174 mp->write_ascii_file = mplib_write_ascii_file;
22175 mp->read_ascii_file = mplib_read_ascii_file;
22176 mp->write_binary_file = mplib_write_binary_file;
22177 mp->read_binary_file = mplib_read_binary_file;
22178 mp->shipout_backend = mplib_shipout_backend;
22181 @ Perhaps this is the most important API function in the library.
22183 @<Exported function ...@>=
22184 mp_run_data *mp_rundata (MP mp) ;
22187 mp_run_data *mp_rundata (MP mp) {
22188 return &(mp->run_data);
22192 mp_free_stream(&(mp->run_data.term_in));
22193 mp_free_stream(&(mp->run_data.term_out));
22194 mp_free_stream(&(mp->run_data.log_out));
22195 mp_free_stream(&(mp->run_data.error_out));
22196 mp_free_stream(&(mp->run_data.ps_out));
22198 @ @<Finish non-interactive use@>=
22199 xfree(mp->term_out);
22200 xfree(mp->term_in);
22201 xfree(mp->err_out);
22203 @ @<Start non-interactive work@>=
22204 @<Initialize the output routines@>;
22205 mp->input_ptr=0; mp->max_in_stack=0;
22206 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
22207 mp->param_ptr=0; mp->max_param_stack=0;
22208 start = loc = iindex = 0; mp->first = 0;
22209 line=0; name=is_term;
22210 mp->mpx_name[0]=absent;
22211 mp->force_eof=false;
22213 mp->scanner_status=normal;
22214 if (mp->mem_ident==NULL) {
22215 if ( ! mp_load_mem_file(mp) ) {
22216 (mp->close_file)(mp, mp->mem_file);
22217 mp->history = mp_fatal_error_stop;
22218 return mp->history;
22220 (mp->close_file)(mp, mp->mem_file);
22222 mp_fix_date_and_time(mp);
22223 if (mp->random_seed==0)
22224 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
22225 mp_init_randoms(mp, mp->random_seed);
22226 @<Initialize the print |selector|...@>;
22227 mp_open_log_file(mp);
22229 mp_init_map_file(mp, mp->troff_mode);
22230 mp->history=mp_spotless; /* ready to go! */
22231 if (mp->troff_mode) {
22232 mp->internal[mp_gtroffmode]=unity;
22233 mp->internal[mp_prologues]=unity;
22235 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
22236 mp->cur_sym=mp->start_sym; mp_back_input(mp);
22240 int mp_execute (MP mp, char *s, size_t l) {
22242 mp_reset_stream(&(mp->run_data.term_out));
22243 mp_reset_stream(&(mp->run_data.log_out));
22244 mp_reset_stream(&(mp->run_data.error_out));
22245 mp_reset_stream(&(mp->run_data.ps_out));
22246 if (mp->finished) {
22247 return mp->history;
22248 } else if (!mp->noninteractive) {
22249 mp->history = mp_fatal_error_stop ;
22250 return mp->history;
22252 if (mp->history < mp_fatal_error_stop ) {
22253 mp->jump_buf = &buf;
22254 if (setjmp(*(mp->jump_buf)) != 0) {
22255 return mp->history;
22257 if (s==NULL) { /* this signals EOF */
22258 mp_final_cleanup(mp); /* prepare for death */
22259 mp_close_files_and_terminate(mp);
22260 return mp->history;
22263 mp->term_offset=0; mp->file_offset=0;
22264 /* Perhaps some sort of warning here when |data| is not
22265 * yet exhausted would be nice ... this happens after errors
22267 if (mp->run_data.term_in.data)
22268 xfree(mp->run_data.term_in.data);
22269 mp->run_data.term_in.data = xstrdup(s);
22270 mp->run_data.term_in.cur = mp->run_data.term_in.data;
22271 mp->run_data.term_in.size = l;
22272 if (mp->run_state == 0) {
22273 mp->selector=term_only;
22274 @<Start non-interactive work@>;
22277 (void)mp_input_ln(mp,mp->term_in);
22278 mp_firm_up_the_line(mp);
22279 mp->buffer[limit]=xord('%');
22280 mp->first=(size_t)(limit+1);
22283 mp_do_statement(mp);
22284 } while (mp->cur_cmd!=stop);
22285 mp_final_cleanup(mp);
22286 mp_close_files_and_terminate(mp);
22288 return mp->history;
22291 @ This function cleans up
22293 int mp_finish (MP mp) {
22294 int history = mp->history;
22295 if (!mp->finished) {
22296 if (mp->history < mp_fatal_error_stop ) {
22298 mp->jump_buf = &buf;
22299 if (setjmp(*(mp->jump_buf)) != 0) {
22300 history = mp->history;
22301 mp_close_files_and_terminate(mp);
22304 mp_final_cleanup(mp); /* prepare for death */
22305 mp_close_files_and_terminate(mp);
22313 @ People may want to know the library version
22315 const char * mp_metapost_version (void) {
22316 return metapost_version;
22319 @ @<Exported function headers@>=
22320 int mp_run (MP mp);
22321 int mp_execute (MP mp, char *s, size_t l);
22322 int mp_finish (MP mp);
22323 const char * mp_metapost_version (void);
22326 mp_primitive(mp, "end",stop,0);
22327 @:end_}{\&{end} primitive@>
22328 mp_primitive(mp, "dump",stop,1);
22329 @:dump_}{\&{dump} primitive@>
22331 @ @<Cases of |print_cmd...@>=
22333 if ( m==0 ) mp_print(mp, "end");
22334 else mp_print(mp, "dump");
22338 Let's turn now to statements that are classified as ``commands'' because
22339 of their imperative nature. We'll begin with simple ones, so that it
22340 will be clear how to hook command processing into the |do_statement| routine;
22341 then we'll tackle the tougher commands.
22343 Here's one of the simplest:
22345 @<Cases of |do_statement|...@>=
22346 case mp_random_seed: mp_do_random_seed(mp); break;
22348 @ @<Declare action procedures for use by |do_statement|@>=
22349 void mp_do_random_seed (MP mp) ;
22351 @ @c void mp_do_random_seed (MP mp) {
22353 if ( mp->cur_cmd!=assignment ) {
22354 mp_missing_err(mp, ":=");
22356 help1("Always say `randomseed:=<numeric expression>'.");
22359 mp_get_x_next(mp); mp_scan_expression(mp);
22360 if ( mp->cur_type!=mp_known ) {
22361 exp_err("Unknown value will be ignored");
22362 @.Unknown value...ignored@>
22363 help2("Your expression was too random for me to handle,",
22364 "so I won't change the random seed just now.");
22365 mp_put_get_flush_error(mp, 0);
22367 @<Initialize the random seed to |cur_exp|@>;
22371 @ @<Initialize the random seed to |cur_exp|@>=
22373 mp_init_randoms(mp, mp->cur_exp);
22374 if ( mp->selector>=log_only && mp->selector<write_file) {
22375 mp->old_setting=mp->selector; mp->selector=log_only;
22376 mp_print_nl(mp, "{randomseed:=");
22377 mp_print_scaled(mp, mp->cur_exp);
22378 mp_print_char(mp, xord('}'));
22379 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
22383 @ And here's another simple one (somewhat different in flavor):
22385 @<Cases of |do_statement|...@>=
22387 mp_print_ln(mp); mp->interaction=mp->cur_mod;
22388 @<Initialize the print |selector| based on |interaction|@>;
22389 if ( mp->log_opened ) mp->selector=mp->selector+2;
22394 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
22395 @:mp_batch_mode_}{\&{batchmode} primitive@>
22396 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
22397 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
22398 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
22399 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
22400 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
22401 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
22403 @ @<Cases of |print_cmd_mod|...@>=
22406 case mp_batch_mode: mp_print(mp, "batchmode"); break;
22407 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
22408 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
22409 default: mp_print(mp, "errorstopmode"); break;
22413 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
22415 @<Cases of |do_statement|...@>=
22416 case protection_command: mp_do_protection(mp); break;
22419 mp_primitive(mp, "inner",protection_command,0);
22420 @:inner_}{\&{inner} primitive@>
22421 mp_primitive(mp, "outer",protection_command,1);
22422 @:outer_}{\&{outer} primitive@>
22424 @ @<Cases of |print_cmd...@>=
22425 case protection_command:
22426 if ( m==0 ) mp_print(mp, "inner");
22427 else mp_print(mp, "outer");
22430 @ @<Declare action procedures for use by |do_statement|@>=
22431 void mp_do_protection (MP mp) ;
22433 @ @c void mp_do_protection (MP mp) {
22434 int m; /* 0 to unprotect, 1 to protect */
22435 halfword t; /* the |eq_type| before we change it */
22438 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
22440 if ( t>=outer_tag )
22441 eq_type(mp->cur_sym)=t-outer_tag;
22442 } else if ( t<outer_tag ) {
22443 eq_type(mp->cur_sym)=t+outer_tag;
22446 } while (mp->cur_cmd==comma);
22449 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
22450 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
22451 declaration assigns the command code |left_delimiter| to `\.{(}' and
22452 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
22453 hash address of its mate.
22455 @<Cases of |do_statement|...@>=
22456 case delimiters: mp_def_delims(mp); break;
22458 @ @<Declare action procedures for use by |do_statement|@>=
22459 void mp_def_delims (MP mp) ;
22461 @ @c void mp_def_delims (MP mp) {
22462 pointer l_delim,r_delim; /* the new delimiter pair */
22463 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
22464 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
22465 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
22466 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
22470 @ Here is a procedure that is called when \MP\ has reached a point
22471 where some right delimiter is mandatory.
22473 @<Declare the procedure called |check_delimiter|@>=
22474 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
22475 if ( mp->cur_cmd==right_delimiter )
22476 if ( mp->cur_mod==l_delim )
22478 if ( mp->cur_sym!=r_delim ) {
22479 mp_missing_err(mp, str(text(r_delim)));
22481 help2("I found no right delimiter to match a left one. So I've",
22482 "put one in, behind the scenes; this may fix the problem.");
22485 print_err("The token `"); mp_print_text(r_delim);
22486 @.The token...delimiter@>
22487 mp_print(mp, "' is no longer a right delimiter");
22488 help3("Strange: This token has lost its former meaning!",
22489 "I'll read it as a right delimiter this time;",
22490 "but watch out, I'll probably miss it later.");
22495 @ The next four commands save or change the values associated with tokens.
22497 @<Cases of |do_statement|...@>=
22500 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
22501 } while (mp->cur_cmd==comma);
22503 case interim_command: mp_do_interim(mp); break;
22504 case let_command: mp_do_let(mp); break;
22505 case new_internal: mp_do_new_internal(mp); break;
22507 @ @<Declare action procedures for use by |do_statement|@>=
22508 void mp_do_statement (MP mp);
22509 void mp_do_interim (MP mp);
22511 @ @c void mp_do_interim (MP mp) {
22513 if ( mp->cur_cmd!=internal_quantity ) {
22514 print_err("The token `");
22515 @.The token...quantity@>
22516 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
22517 else mp_print_text(mp->cur_sym);
22518 mp_print(mp, "' isn't an internal quantity");
22519 help1("Something like `tracingonline' should follow `interim'.");
22522 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
22524 mp_do_statement(mp);
22527 @ The following procedure is careful not to undefine the left-hand symbol
22528 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
22530 @<Declare action procedures for use by |do_statement|@>=
22531 void mp_do_let (MP mp) ;
22533 @ @c void mp_do_let (MP mp) {
22534 pointer l; /* hash location of the left-hand symbol */
22535 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
22536 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
22537 mp_missing_err(mp, "=");
22539 help3("You should have said `let symbol = something'.",
22540 "But don't worry; I'll pretend that an equals sign",
22541 "was present. The next token I read will be `something'.");
22545 switch (mp->cur_cmd) {
22546 case defined_macro: case secondary_primary_macro:
22547 case tertiary_secondary_macro: case expression_tertiary_macro:
22548 add_mac_ref(mp->cur_mod);
22553 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
22554 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
22555 else equiv(l)=mp->cur_mod;
22559 @ @<Declarations@>=
22560 void mp_grow_internals (MP mp, int l);
22561 void mp_do_new_internal (MP mp) ;
22564 void mp_grow_internals (MP mp, int l) {
22568 if ( hash_end+l>max_halfword ) {
22569 mp_confusion(mp, "out of memory space"); /* can't be reached */
22571 int_name = xmalloc ((l+1),sizeof(char *));
22572 internal = xmalloc ((l+1),sizeof(scaled));
22573 for (k=0;k<=l; k++ ) {
22574 if (k<=mp->max_internal) {
22575 internal[k]=mp->internal[k];
22576 int_name[k]=mp->int_name[k];
22582 xfree(mp->internal); xfree(mp->int_name);
22583 mp->int_name = int_name;
22584 mp->internal = internal;
22585 mp->max_internal = l;
22589 void mp_do_new_internal (MP mp) {
22591 if ( mp->int_ptr==mp->max_internal ) {
22592 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal/4)));
22594 mp_get_clear_symbol(mp); incr(mp->int_ptr);
22595 eq_type(mp->cur_sym)=internal_quantity;
22596 equiv(mp->cur_sym)=mp->int_ptr;
22597 if(mp->int_name[mp->int_ptr]!=NULL)
22598 xfree(mp->int_name[mp->int_ptr]);
22599 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
22600 mp->internal[mp->int_ptr]=0;
22602 } while (mp->cur_cmd==comma);
22605 @ @<Dealloc variables@>=
22606 for (k=0;k<=mp->max_internal;k++) {
22607 xfree(mp->int_name[k]);
22609 xfree(mp->internal);
22610 xfree(mp->int_name);
22613 @ The various `\&{show}' commands are distinguished by modifier fields
22616 @d show_token_code 0 /* show the meaning of a single token */
22617 @d show_stats_code 1 /* show current memory and string usage */
22618 @d show_code 2 /* show a list of expressions */
22619 @d show_var_code 3 /* show a variable and its descendents */
22620 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22623 mp_primitive(mp, "showtoken",show_command,show_token_code);
22624 @:show_token_}{\&{showtoken} primitive@>
22625 mp_primitive(mp, "showstats",show_command,show_stats_code);
22626 @:show_stats_}{\&{showstats} primitive@>
22627 mp_primitive(mp, "show",show_command,show_code);
22628 @:show_}{\&{show} primitive@>
22629 mp_primitive(mp, "showvariable",show_command,show_var_code);
22630 @:show_var_}{\&{showvariable} primitive@>
22631 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22632 @:show_dependencies_}{\&{showdependencies} primitive@>
22634 @ @<Cases of |print_cmd...@>=
22637 case show_token_code:mp_print(mp, "showtoken"); break;
22638 case show_stats_code:mp_print(mp, "showstats"); break;
22639 case show_code:mp_print(mp, "show"); break;
22640 case show_var_code:mp_print(mp, "showvariable"); break;
22641 default: mp_print(mp, "showdependencies"); break;
22645 @ @<Cases of |do_statement|...@>=
22646 case show_command:mp_do_show_whatever(mp); break;
22648 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22649 if it's |show_code|, complicated structures are abbreviated, otherwise
22652 @<Declare action procedures for use by |do_statement|@>=
22653 void mp_do_show (MP mp) ;
22655 @ @c void mp_do_show (MP mp) {
22657 mp_get_x_next(mp); mp_scan_expression(mp);
22658 mp_print_nl(mp, ">> ");
22660 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22661 } while (mp->cur_cmd==comma);
22664 @ @<Declare action procedures for use by |do_statement|@>=
22665 void mp_disp_token (MP mp) ;
22667 @ @c void mp_disp_token (MP mp) {
22668 mp_print_nl(mp, "> ");
22670 if ( mp->cur_sym==0 ) {
22671 @<Show a numeric or string or capsule token@>;
22673 mp_print_text(mp->cur_sym); mp_print_char(mp, xord('='));
22674 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22675 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22676 if ( mp->cur_cmd==defined_macro ) {
22677 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22678 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22683 @ @<Show a numeric or string or capsule token@>=
22685 if ( mp->cur_cmd==numeric_token ) {
22686 mp_print_scaled(mp, mp->cur_mod);
22687 } else if ( mp->cur_cmd==capsule_token ) {
22688 mp_print_capsule(mp,mp->cur_mod);
22690 mp_print_char(mp, xord('"'));
22691 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, xord('"'));
22692 delete_str_ref(mp->cur_mod);
22696 @ The following cases of |print_cmd_mod| might arise in connection
22697 with |disp_token|, although they don't necessarily correspond to
22700 @<Cases of |print_cmd_...@>=
22701 case left_delimiter:
22702 case right_delimiter:
22703 if ( c==left_delimiter ) mp_print(mp, "left");
22704 else mp_print(mp, "right");
22705 mp_print(mp, " delimiter that matches ");
22709 if ( m==null ) mp_print(mp, "tag");
22710 else mp_print(mp, "variable");
22712 case defined_macro:
22713 mp_print(mp, "macro:");
22715 case secondary_primary_macro:
22716 case tertiary_secondary_macro:
22717 case expression_tertiary_macro:
22718 mp_print_cmd_mod(mp, macro_def,c);
22719 mp_print(mp, "'d macro:");
22720 mp_print_ln(mp); mp_show_token_list(mp, mp_link(mp_link(m)),null,1000,0);
22723 mp_print(mp, "[repeat the loop]");
22725 case internal_quantity:
22726 mp_print(mp, mp->int_name[m]);
22729 @ @<Declare action procedures for use by |do_statement|@>=
22730 void mp_do_show_token (MP mp) ;
22732 @ @c void mp_do_show_token (MP mp) {
22734 get_t_next; mp_disp_token(mp);
22736 } while (mp->cur_cmd==comma);
22739 @ @<Declare action procedures for use by |do_statement|@>=
22740 void mp_do_show_stats (MP mp) ;
22742 @ @c void mp_do_show_stats (MP mp) {
22743 mp_print_nl(mp, "Memory usage ");
22744 @.Memory usage...@>
22745 mp_print_int(mp, mp->var_used); mp_print_char(mp, xord('&')); mp_print_int(mp, mp->dyn_used);
22746 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22747 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22748 mp_print_nl(mp, "String usage ");
22749 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22750 mp_print_char(mp, xord('&')); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22751 mp_print(mp, " (");
22752 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, xord('&'));
22753 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22754 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22758 @ Here's a recursive procedure that gives an abbreviated account
22759 of a variable, for use by |do_show_var|.
22761 @<Declare action procedures for use by |do_statement|@>=
22762 void mp_disp_var (MP mp,pointer p) ;
22764 @ @c void mp_disp_var (MP mp,pointer p) {
22765 pointer q; /* traverses attributes and subscripts */
22766 int n; /* amount of macro text to show */
22767 if ( type(p)==mp_structured ) {
22768 @<Descend the structure@>;
22769 } else if ( type(p)>=mp_unsuffixed_macro ) {
22770 @<Display a variable macro@>;
22771 } else if ( type(p)!=undefined ){
22772 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22773 mp_print_char(mp, xord('='));
22774 mp_print_exp(mp, p,0);
22778 @ @<Descend the structure@>=
22781 do { mp_disp_var(mp, q); q=mp_link(q); } while (q!=end_attr);
22783 while ( name_type(q)==mp_subscr ) {
22784 mp_disp_var(mp, q); q=mp_link(q);
22788 @ @<Display a variable macro@>=
22790 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22791 if ( type(p)>mp_unsuffixed_macro )
22792 mp_print(mp, "@@#"); /* |suffixed_macro| */
22793 mp_print(mp, "=macro:");
22794 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22795 else n=mp->max_print_line-mp->file_offset-15;
22796 mp_show_macro(mp, value(p),null,n);
22799 @ @<Declare action procedures for use by |do_statement|@>=
22800 void mp_do_show_var (MP mp) ;
22802 @ @c void mp_do_show_var (MP mp) {
22805 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22806 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22807 mp_disp_var(mp, mp->cur_mod); goto DONE;
22812 } while (mp->cur_cmd==comma);
22815 @ @<Declare action procedures for use by |do_statement|@>=
22816 void mp_do_show_dependencies (MP mp) ;
22818 @ @c void mp_do_show_dependencies (MP mp) {
22819 pointer p; /* link that runs through all dependencies */
22820 p=mp_link(dep_head);
22821 while ( p!=dep_head ) {
22822 if ( mp_interesting(mp, p) ) {
22823 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22824 if ( type(p)==mp_dependent ) mp_print_char(mp, xord('='));
22825 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22826 mp_print_dependency(mp, dep_list(p),type(p));
22829 while ( info(p)!=null ) p=mp_link(p);
22835 @ Finally we are ready for the procedure that governs all of the
22838 @<Declare action procedures for use by |do_statement|@>=
22839 void mp_do_show_whatever (MP mp) ;
22841 @ @c void mp_do_show_whatever (MP mp) {
22842 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
22843 switch (mp->cur_mod) {
22844 case show_token_code:mp_do_show_token(mp); break;
22845 case show_stats_code:mp_do_show_stats(mp); break;
22846 case show_code:mp_do_show(mp); break;
22847 case show_var_code:mp_do_show_var(mp); break;
22848 case show_dependencies_code:mp_do_show_dependencies(mp); break;
22849 } /* there are no other cases */
22850 if ( mp->internal[mp_showstopping]>0 ){
22853 if ( mp->interaction<mp_error_stop_mode ) {
22854 help0; decr(mp->error_count);
22856 help1("This isn't an error message; I'm just showing something.");
22858 if ( mp->cur_cmd==semicolon ) mp_error(mp);
22859 else mp_put_get_error(mp);
22863 @ The `\&{addto}' command needs the following additional primitives:
22865 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
22866 @d contour_code 1 /* command modifier for `\&{contour}' */
22867 @d also_code 2 /* command modifier for `\&{also}' */
22869 @ Pre and postscripts need two new identifiers:
22871 @d with_pre_script 11
22872 @d with_post_script 13
22875 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
22876 @:double_path_}{\&{doublepath} primitive@>
22877 mp_primitive(mp, "contour",thing_to_add,contour_code);
22878 @:contour_}{\&{contour} primitive@>
22879 mp_primitive(mp, "also",thing_to_add,also_code);
22880 @:also_}{\&{also} primitive@>
22881 mp_primitive(mp, "withpen",with_option,mp_pen_type);
22882 @:with_pen_}{\&{withpen} primitive@>
22883 mp_primitive(mp, "dashed",with_option,mp_picture_type);
22884 @:dashed_}{\&{dashed} primitive@>
22885 mp_primitive(mp, "withprescript",with_option,with_pre_script);
22886 @:with_pre_script_}{\&{withprescript} primitive@>
22887 mp_primitive(mp, "withpostscript",with_option,with_post_script);
22888 @:with_post_script_}{\&{withpostscript} primitive@>
22889 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
22890 @:with_color_}{\&{withoutcolor} primitive@>
22891 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
22892 @:with_color_}{\&{withgreyscale} primitive@>
22893 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
22894 @:with_color_}{\&{withcolor} primitive@>
22895 /* \&{withrgbcolor} is an alias for \&{withcolor} */
22896 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
22897 @:with_color_}{\&{withrgbcolor} primitive@>
22898 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
22899 @:with_color_}{\&{withcmykcolor} primitive@>
22901 @ @<Cases of |print_cmd...@>=
22903 if ( m==contour_code ) mp_print(mp, "contour");
22904 else if ( m==double_path_code ) mp_print(mp, "doublepath");
22905 else mp_print(mp, "also");
22908 if ( m==mp_pen_type ) mp_print(mp, "withpen");
22909 else if ( m==with_pre_script ) mp_print(mp, "withprescript");
22910 else if ( m==with_post_script ) mp_print(mp, "withpostscript");
22911 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
22912 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
22913 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
22914 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
22915 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
22916 else mp_print(mp, "dashed");
22919 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
22920 updates the list of graphical objects starting at |p|. Each $\langle$with
22921 clause$\rangle$ updates all graphical objects whose |type| is compatible.
22922 Other objects are ignored.
22924 @<Declare action procedures for use by |do_statement|@>=
22925 void mp_scan_with_list (MP mp,pointer p) ;
22927 @ @c void mp_scan_with_list (MP mp,pointer p) {
22928 quarterword t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
22929 pointer q; /* for list manipulation */
22930 unsigned old_setting; /* saved |selector| setting */
22931 pointer k; /* for finding the near-last item in a list */
22932 str_number s; /* for string cleanup after combining */
22933 pointer cp,pp,dp,ap,bp;
22934 /* objects being updated; |void| initially; |null| to suppress update */
22935 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
22937 while ( mp->cur_cmd==with_option ){
22940 if ( t!=mp_no_model ) mp_scan_expression(mp);
22941 if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
22942 ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
22943 ((t==mp_uninitialized_model)&&
22944 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
22945 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
22946 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
22947 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
22948 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
22949 ((t==mp_pen_type)&&(mp->cur_type!=t))||
22950 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
22951 @<Complain about improper type@>;
22952 } else if ( t==mp_uninitialized_model ) {
22953 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22955 @<Transfer a color from the current expression to object~|cp|@>;
22956 mp_flush_cur_exp(mp, 0);
22957 } else if ( t==mp_rgb_model ) {
22958 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22960 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
22961 mp_flush_cur_exp(mp, 0);
22962 } else if ( t==mp_cmyk_model ) {
22963 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22965 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
22966 mp_flush_cur_exp(mp, 0);
22967 } else if ( t==mp_grey_model ) {
22968 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22970 @<Transfer a greyscale from the current expression to object~|cp|@>;
22971 mp_flush_cur_exp(mp, 0);
22972 } else if ( t==mp_no_model ) {
22973 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22975 @<Transfer a noncolor from the current expression to object~|cp|@>;
22976 } else if ( t==mp_pen_type ) {
22977 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
22979 if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
22980 pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
22982 } else if ( t==with_pre_script ) {
22985 while ( (ap!=null)&&(! has_color(ap)) )
22988 if ( pre_script(ap)!=null ) { /* build a new,combined string */
22990 old_setting=mp->selector;
22991 mp->selector=new_string;
22992 str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
22993 mp_print_str(mp, mp->cur_exp);
22994 append_char(13); /* a forced \ps\ newline */
22995 mp_print_str(mp, pre_script(ap));
22996 pre_script(ap)=mp_make_string(mp);
22998 mp->selector=old_setting;
23000 pre_script(ap)=mp->cur_exp;
23002 mp->cur_type=mp_vacuous;
23004 } else if ( t==with_post_script ) {
23008 while ( mp_link(k)!=null ) {
23010 if ( has_color(k) ) bp=k;
23013 if ( post_script(bp)!=null ) {
23015 old_setting=mp->selector;
23016 mp->selector=new_string;
23017 str_room(length(post_script(bp))+length(mp->cur_exp)+2);
23018 mp_print_str(mp, post_script(bp));
23019 append_char(13); /* a forced \ps\ newline */
23020 mp_print_str(mp, mp->cur_exp);
23021 post_script(bp)=mp_make_string(mp);
23023 mp->selector=old_setting;
23025 post_script(bp)=mp->cur_exp;
23027 mp->cur_type=mp_vacuous;
23030 if ( dp==mp_void ) {
23031 @<Make |dp| a stroked node in list~|p|@>;
23034 if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
23035 dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
23036 dash_scale(dp)=unity;
23037 mp->cur_type=mp_vacuous;
23041 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
23045 @ @<Complain about improper type@>=
23046 { exp_err("Improper type");
23048 help2("Next time say `withpen <known pen expression>';",
23049 "I'll ignore the bad `with' clause and look for another.");
23050 if ( t==with_pre_script )
23051 mp->help_line[1]="Next time say `withprescript <known string expression>';";
23052 else if ( t==with_post_script )
23053 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
23054 else if ( t==mp_picture_type )
23055 mp->help_line[1]="Next time say `dashed <known picture expression>';";
23056 else if ( t==mp_uninitialized_model )
23057 mp->help_line[1]="Next time say `withcolor <known color expression>';";
23058 else if ( t==mp_rgb_model )
23059 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
23060 else if ( t==mp_cmyk_model )
23061 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
23062 else if ( t==mp_grey_model )
23063 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
23064 mp_put_get_flush_error(mp, 0);
23067 @ Forcing the color to be between |0| and |unity| here guarantees that no
23068 picture will ever contain a color outside the legal range for \ps\ graphics.
23070 @<Transfer a color from the current expression to object~|cp|@>=
23071 { if ( mp->cur_type==mp_color_type )
23072 @<Transfer a rgbcolor from the current expression to object~|cp|@>
23073 else if ( mp->cur_type==mp_cmykcolor_type )
23074 @<Transfer a cmykcolor from the current expression to object~|cp|@>
23075 else if ( mp->cur_type==mp_known )
23076 @<Transfer a greyscale from the current expression to object~|cp|@>
23077 else if ( mp->cur_exp==false_code )
23078 @<Transfer a noncolor from the current expression to object~|cp|@>;
23081 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
23082 { q=value(mp->cur_exp);
23087 red_val(cp)=value(red_part_loc(q));
23088 green_val(cp)=value(green_part_loc(q));
23089 blue_val(cp)=value(blue_part_loc(q));
23090 color_model(cp)=mp_rgb_model;
23091 if ( red_val(cp)<0 ) red_val(cp)=0;
23092 if ( green_val(cp)<0 ) green_val(cp)=0;
23093 if ( blue_val(cp)<0 ) blue_val(cp)=0;
23094 if ( red_val(cp)>unity ) red_val(cp)=unity;
23095 if ( green_val(cp)>unity ) green_val(cp)=unity;
23096 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
23099 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
23100 { q=value(mp->cur_exp);
23101 cyan_val(cp)=value(cyan_part_loc(q));
23102 magenta_val(cp)=value(magenta_part_loc(q));
23103 yellow_val(cp)=value(yellow_part_loc(q));
23104 black_val(cp)=value(black_part_loc(q));
23105 color_model(cp)=mp_cmyk_model;
23106 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
23107 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
23108 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
23109 if ( black_val(cp)<0 ) black_val(cp)=0;
23110 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
23111 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
23112 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
23113 if ( black_val(cp)>unity ) black_val(cp)=unity;
23116 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
23123 color_model(cp)=mp_grey_model;
23124 if ( grey_val(cp)<0 ) grey_val(cp)=0;
23125 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
23128 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
23135 color_model(cp)=mp_no_model;
23138 @ @<Make |cp| a colored object in object list~|p|@>=
23140 while ( cp!=null ){
23141 if ( has_color(cp) ) break;
23146 @ @<Make |pp| an object in list~|p| that needs a pen@>=
23148 while ( pp!=null ) {
23149 if ( has_pen(pp) ) break;
23154 @ @<Make |dp| a stroked node in list~|p|@>=
23156 while ( dp!=null ) {
23157 if ( type(dp)==mp_stroked_code ) break;
23162 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
23163 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
23164 if ( pp>mp_void ) {
23165 @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
23167 if ( dp>mp_void ) {
23168 @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
23172 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
23174 while ( q!=null ) {
23175 if ( has_color(q) ) {
23176 red_val(q)=red_val(cp);
23177 green_val(q)=green_val(cp);
23178 blue_val(q)=blue_val(cp);
23179 black_val(q)=black_val(cp);
23180 color_model(q)=color_model(cp);
23186 @ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
23188 while ( q!=null ) {
23189 if ( has_pen(q) ) {
23190 if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
23191 pen_p(q)=copy_pen(pen_p(pp));
23197 @ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
23199 while ( q!=null ) {
23200 if ( type(q)==mp_stroked_code ) {
23201 if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
23202 dash_p(q)=dash_p(dp);
23203 dash_scale(q)=unity;
23204 if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
23210 @ One of the things we need to do when we've parsed an \&{addto} or
23211 similar command is find the header of a supposed \&{picture} variable, given
23212 a token list for that variable. Since the edge structure is about to be
23213 updated, we use |private_edges| to make sure that this is possible.
23215 @<Declare action procedures for use by |do_statement|@>=
23216 pointer mp_find_edges_var (MP mp, pointer t) ;
23218 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
23220 pointer cur_edges; /* the return value */
23221 p=mp_find_variable(mp, t); cur_edges=null;
23223 mp_obliterated(mp, t); mp_put_get_error(mp);
23224 } else if ( type(p)!=mp_picture_type ) {
23225 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
23226 @.Variable x is the wrong type@>
23227 mp_print(mp, " is the wrong type (");
23228 mp_print_type(mp, type(p)); mp_print_char(mp, xord(')'));
23229 help2("I was looking for a \"known\" picture variable.",
23230 "So I'll not change anything just now.");
23231 mp_put_get_error(mp);
23233 value(p)=mp_private_edges(mp, value(p));
23234 cur_edges=value(p);
23236 mp_flush_node_list(mp, t);
23240 @ @<Cases of |do_statement|...@>=
23241 case add_to_command: mp_do_add_to(mp); break;
23242 case bounds_command:mp_do_bounds(mp); break;
23245 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
23246 @:clip_}{\&{clip} primitive@>
23247 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
23248 @:set_bounds_}{\&{setbounds} primitive@>
23250 @ @<Cases of |print_cmd...@>=
23251 case bounds_command:
23252 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
23253 else mp_print(mp, "setbounds");
23256 @ The following function parses the beginning of an \&{addto} or \&{clip}
23257 command: it expects a variable name followed by a token with |cur_cmd=sep|
23258 and then an expression. The function returns the token list for the variable
23259 and stores the command modifier for the separator token in the global variable
23260 |last_add_type|. We must be careful because this variable might get overwritten
23261 any time we call |get_x_next|.
23264 quarterword last_add_type;
23265 /* command modifier that identifies the last \&{addto} command */
23267 @ @<Declare action procedures for use by |do_statement|@>=
23268 pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
23270 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
23271 pointer lhv; /* variable to add to left */
23272 quarterword add_type=0; /* value to be returned in |last_add_type| */
23274 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
23275 if ( mp->cur_type!=mp_token_list ) {
23276 @<Abandon edges command because there's no variable@>;
23278 lhv=mp->cur_exp; add_type=mp->cur_mod;
23279 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
23281 mp->last_add_type=add_type;
23285 @ @<Abandon edges command because there's no variable@>=
23286 { exp_err("Not a suitable variable");
23287 @.Not a suitable variable@>
23288 help4("At this point I needed to see the name of a picture variable.",
23289 "(Or perhaps you have indeed presented me with one; I might",
23290 "have missed it, if it wasn't followed by the proper token.)",
23291 "So I'll not change anything just now.");
23292 mp_put_get_flush_error(mp, 0);
23295 @ Here is an example of how to use |start_draw_cmd|.
23297 @<Declare action procedures for use by |do_statement|@>=
23298 void mp_do_bounds (MP mp) ;
23300 @ @c void mp_do_bounds (MP mp) {
23301 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23302 pointer p; /* for list manipulation */
23303 integer m; /* initial value of |cur_mod| */
23305 lhv=mp_start_draw_cmd(mp, to_token);
23307 lhe=mp_find_edges_var(mp, lhv);
23309 mp_flush_cur_exp(mp, 0);
23310 } else if ( mp->cur_type!=mp_path_type ) {
23311 exp_err("Improper `clip'");
23312 @.Improper `addto'@>
23313 help2("This expression should have specified a known path.",
23314 "So I'll not change anything just now.");
23315 mp_put_get_flush_error(mp, 0);
23316 } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
23317 @<Complain about a non-cycle@>;
23319 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
23324 @ @<Complain about a non-cycle@>=
23325 { print_err("Not a cycle");
23327 help2("That contour should have ended with `..cycle' or `&cycle'.",
23328 "So I'll not change anything just now."); mp_put_get_error(mp);
23331 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
23332 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
23333 mp_link(p)=mp_link(dummy_loc(lhe));
23334 mp_link(dummy_loc(lhe))=p;
23335 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
23336 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
23337 type(p)=stop_type(m);
23338 mp_link(obj_tail(lhe))=p;
23340 mp_init_bbox(mp, lhe);
23343 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
23344 cases to deal with.
23346 @<Declare action procedures for use by |do_statement|@>=
23347 void mp_do_add_to (MP mp) ;
23349 @ @c void mp_do_add_to (MP mp) {
23350 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23351 pointer p; /* the graphical object or list for |scan_with_list| to update */
23352 pointer e; /* an edge structure to be merged */
23353 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
23354 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
23356 if ( add_type==also_code ) {
23357 @<Make sure the current expression is a suitable picture and set |e| and |p|
23360 @<Create a graphical object |p| based on |add_type| and the current
23363 mp_scan_with_list(mp, p);
23364 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
23368 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
23369 setting |e:=null| prevents anything from being added to |lhe|.
23371 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
23374 if ( mp->cur_type!=mp_picture_type ) {
23375 exp_err("Improper `addto'");
23376 @.Improper `addto'@>
23377 help2("This expression should have specified a known picture.",
23378 "So I'll not change anything just now.");
23379 mp_put_get_flush_error(mp, 0);
23381 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
23382 p=mp_link(dummy_loc(e));
23386 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
23387 attempts to add to the edge structure.
23389 @<Create a graphical object |p| based on |add_type| and the current...@>=
23391 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
23392 if ( mp->cur_type!=mp_path_type ) {
23393 exp_err("Improper `addto'");
23394 @.Improper `addto'@>
23395 help2("This expression should have specified a known path.",
23396 "So I'll not change anything just now.");
23397 mp_put_get_flush_error(mp, 0);
23398 } else if ( add_type==contour_code ) {
23399 if ( left_type(mp->cur_exp)==mp_endpoint ) {
23400 @<Complain about a non-cycle@>;
23402 p=mp_new_fill_node(mp, mp->cur_exp);
23403 mp->cur_type=mp_vacuous;
23406 p=mp_new_stroked_node(mp, mp->cur_exp);
23407 mp->cur_type=mp_vacuous;
23411 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
23412 lhe=mp_find_edges_var(mp, lhv);
23414 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
23415 if ( e!=null ) delete_edge_ref(e);
23416 } else if ( add_type==also_code ) {
23418 @<Merge |e| into |lhe| and delete |e|@>;
23422 } else if ( p!=null ) {
23423 mp_link(obj_tail(lhe))=p;
23425 if ( add_type==double_path_code )
23426 if ( pen_p(p)==null )
23427 pen_p(p)=mp_get_pen_circle(mp, 0);
23430 @ @<Merge |e| into |lhe| and delete |e|@>=
23431 { if ( mp_link(dummy_loc(e))!=null ) {
23432 mp_link(obj_tail(lhe))=mp_link(dummy_loc(e));
23433 obj_tail(lhe)=obj_tail(e);
23434 obj_tail(e)=dummy_loc(e);
23435 mp_link(dummy_loc(e))=null;
23436 mp_flush_dash_list(mp, lhe);
23438 mp_toss_edges(mp, e);
23441 @ @<Cases of |do_statement|...@>=
23442 case ship_out_command: mp_do_ship_out(mp); break;
23444 @ @<Declare action procedures for use by |do_statement|@>=
23445 @<Declare the \ps\ output procedures@>
23446 void mp_do_ship_out (MP mp) ;
23448 @ @c void mp_do_ship_out (MP mp) {
23449 integer c; /* the character code */
23450 mp_get_x_next(mp); mp_scan_expression(mp);
23451 if ( mp->cur_type!=mp_picture_type ) {
23452 @<Complain that it's not a known picture@>;
23454 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
23455 if ( c<0 ) c=c+256;
23456 @<Store the width information for character code~|c|@>;
23457 mp_ship_out(mp, mp->cur_exp);
23458 mp_flush_cur_exp(mp, 0);
23462 @ @<Complain that it's not a known picture@>=
23464 exp_err("Not a known picture");
23465 help1("I can only output known pictures.");
23466 mp_put_get_flush_error(mp, 0);
23469 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
23472 @<Cases of |do_statement|...@>=
23473 case every_job_command:
23474 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
23478 halfword start_sym; /* a symbolic token to insert at beginning of job */
23483 @ Finally, we have only the ``message'' commands remaining.
23486 @d err_message_code 1
23488 @d filename_template_code 3
23489 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
23490 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
23492 mp->pool_ptr = mp->pool_ptr - g;
23494 mp_print_char(mp, xord('0'));
23497 mp_print_int(mp, (A));
23502 mp_primitive(mp, "message",message_command,message_code);
23503 @:message_}{\&{message} primitive@>
23504 mp_primitive(mp, "errmessage",message_command,err_message_code);
23505 @:err_message_}{\&{errmessage} primitive@>
23506 mp_primitive(mp, "errhelp",message_command,err_help_code);
23507 @:err_help_}{\&{errhelp} primitive@>
23508 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
23509 @:filename_template_}{\&{filenametemplate} primitive@>
23511 @ @<Cases of |print_cmd...@>=
23512 case message_command:
23513 if ( m<err_message_code ) mp_print(mp, "message");
23514 else if ( m==err_message_code ) mp_print(mp, "errmessage");
23515 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
23516 else mp_print(mp, "errhelp");
23519 @ @<Cases of |do_statement|...@>=
23520 case message_command: mp_do_message(mp); break;
23522 @ @<Declare action procedures for use by |do_statement|@>=
23523 @<Declare a procedure called |no_string_err|@>
23524 void mp_do_message (MP mp) ;
23527 @c void mp_do_message (MP mp) {
23528 int m; /* the type of message */
23529 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
23530 if ( mp->cur_type!=mp_string_type )
23531 mp_no_string_err(mp, "A message should be a known string expression.");
23535 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
23537 case err_message_code:
23538 @<Print string |cur_exp| as an error message@>;
23540 case err_help_code:
23541 @<Save string |cur_exp| as the |err_help|@>;
23543 case filename_template_code:
23544 @<Save the filename template@>;
23546 } /* there are no other cases */
23548 mp_flush_cur_exp(mp, 0);
23551 @ @<Declare a procedure called |no_string_err|@>=
23552 void mp_no_string_err (MP mp, const char *s) {
23553 exp_err("Not a string");
23556 mp_put_get_error(mp);
23559 @ The global variable |err_help| is zero when the user has most recently
23560 given an empty help string, or if none has ever been given.
23562 @<Save string |cur_exp| as the |err_help|@>=
23564 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
23565 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
23566 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
23569 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
23570 \&{errhelp}, we don't want to give a long help message each time. So we
23571 give a verbose explanation only once.
23574 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
23576 @ @<Set init...@>=mp->long_help_seen=false;
23578 @ @<Print string |cur_exp| as an error message@>=
23580 print_err(""); mp_print_str(mp, mp->cur_exp);
23581 if ( mp->err_help!=0 ) {
23582 mp->use_err_help=true;
23583 } else if ( mp->long_help_seen ) {
23584 help1("(That was another `errmessage'.)") ;
23586 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
23587 help4("This error message was generated by an `errmessage'",
23588 "command, so I can\'t give any explicit help.",
23589 "Pretend that you're Miss Marple: Examine all clues,",
23591 "and deduce the truth by inspired guesses.");
23593 mp_put_get_error(mp); mp->use_err_help=false;
23596 @ @<Cases of |do_statement|...@>=
23597 case write_command: mp_do_write(mp); break;
23599 @ @<Declare action procedures for use by |do_statement|@>=
23600 void mp_do_write (MP mp) ;
23602 @ @c void mp_do_write (MP mp) {
23603 str_number t; /* the line of text to be written */
23604 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
23605 unsigned old_setting; /* for saving |selector| during output */
23607 mp_scan_expression(mp);
23608 if ( mp->cur_type!=mp_string_type ) {
23609 mp_no_string_err(mp, "The text to be written should be a known string expression");
23610 } else if ( mp->cur_cmd!=to_token ) {
23611 print_err("Missing `to' clause");
23612 help1("A write command should end with `to <filename>'");
23613 mp_put_get_error(mp);
23615 t=mp->cur_exp; mp->cur_type=mp_vacuous;
23617 mp_scan_expression(mp);
23618 if ( mp->cur_type!=mp_string_type )
23619 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23621 @<Write |t| to the file named by |cur_exp|@>;
23625 mp_flush_cur_exp(mp, 0);
23628 @ @<Write |t| to the file named by |cur_exp|@>=
23630 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23631 |cur_exp| must be inserted@>;
23632 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23633 @<Record the end of file on |wr_file[n]|@>;
23635 old_setting=mp->selector;
23636 mp->selector=n+write_file;
23637 mp_print_str(mp, t); mp_print_ln(mp);
23638 mp->selector = old_setting;
23642 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23644 char *fn = str(mp->cur_exp);
23646 n0=mp->write_files;
23647 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23648 if ( n==0 ) { /* bottom reached */
23649 if ( n0==mp->write_files ) {
23650 if ( mp->write_files<mp->max_write_files ) {
23651 incr(mp->write_files);
23656 l = mp->max_write_files + (mp->max_write_files/4);
23657 wr_file = xmalloc((l+1),sizeof(void *));
23658 wr_fname = xmalloc((l+1),sizeof(char *));
23659 for (k=0;k<=l;k++) {
23660 if (k<=mp->max_write_files) {
23661 wr_file[k]=mp->wr_file[k];
23662 wr_fname[k]=mp->wr_fname[k];
23668 xfree(mp->wr_file); xfree(mp->wr_fname);
23669 mp->max_write_files = l;
23670 mp->wr_file = wr_file;
23671 mp->wr_fname = wr_fname;
23675 mp_open_write_file(mp, fn ,n);
23678 if ( mp->wr_fname[n]==NULL ) n0=n;
23683 @ @<Record the end of file on |wr_file[n]|@>=
23684 { (mp->close_file)(mp,mp->wr_file[n]);
23685 xfree(mp->wr_fname[n]);
23686 if ( n==mp->write_files-1 ) mp->write_files=n;
23690 @* \[42] Writing font metric data.
23691 \TeX\ gets its knowledge about fonts from font metric files, also called
23692 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23693 but other programs know about them too. One of \MP's duties is to
23694 write \.{TFM} files so that the user's fonts can readily be
23695 applied to typesetting.
23696 @:TFM files}{\.{TFM} files@>
23697 @^font metric files@>
23699 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23700 Since the number of bytes is always a multiple of~4, we could
23701 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23702 byte interpretation. The format of \.{TFM} files was designed by
23703 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23704 @^Ramshaw, Lyle Harold@>
23705 of information in a compact but useful form.
23708 void * tfm_file; /* the font metric output goes here */
23709 char * metric_file_name; /* full name of the font metric file */
23711 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23712 integers that give the lengths of the various subsequent portions
23713 of the file. These twelve integers are, in order:
23714 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23715 |lf|&length of the entire file, in words;\cr
23716 |lh|&length of the header data, in words;\cr
23717 |bc|&smallest character code in the font;\cr
23718 |ec|&largest character code in the font;\cr
23719 |nw|&number of words in the width table;\cr
23720 |nh|&number of words in the height table;\cr
23721 |nd|&number of words in the depth table;\cr
23722 |ni|&number of words in the italic correction table;\cr
23723 |nl|&number of words in the lig/kern table;\cr
23724 |nk|&number of words in the kern table;\cr
23725 |ne|&number of words in the extensible character table;\cr
23726 |np|&number of font parameter words.\cr}}$$
23727 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23729 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23730 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23731 and as few as 0 characters (if |bc=ec+1|).
23733 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23734 16 or more bits, the most significant bytes appear first in the file.
23735 This is called BigEndian order.
23736 @^BigEndian order@>
23738 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23741 The most important data type used here is a |fix_word|, which is
23742 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23743 quantity, with the two's complement of the entire word used to represent
23744 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23745 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23746 the smallest is $-2048$. We will see below, however, that all but two of
23747 the |fix_word| values must lie between $-16$ and $+16$.
23749 @ The first data array is a block of header information, which contains
23750 general facts about the font. The header must contain at least two words,
23751 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23752 header information of use to other software routines might also be
23753 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23754 For example, 16 more words of header information are in use at the Xerox
23755 Palo Alto Research Center; the first ten specify the character coding
23756 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23757 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23758 last gives the ``face byte.''
23760 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23761 the \.{GF} output file. This helps ensure consistency between files,
23762 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23763 should match the check sums on actual fonts that are used. The actual
23764 relation between this check sum and the rest of the \.{TFM} file is not
23765 important; the check sum is simply an identification number with the
23766 property that incompatible fonts almost always have distinct check sums.
23769 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23770 font, in units of \TeX\ points. This number must be at least 1.0; it is
23771 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23772 font, i.e., a font that was designed to look best at a 10-point size,
23773 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23774 $\delta$ \.{pt}', the effect is to override the design size and replace it
23775 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23776 the font image by a factor of $\delta$ divided by the design size. {\sl
23777 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23778 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23779 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23780 since many fonts have a design size equal to one em. The other dimensions
23781 must be less than 16 design-size units in absolute value; thus,
23782 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23783 \.{TFM} file whose first byte might be something besides 0 or 255.
23786 @ Next comes the |char_info| array, which contains one |char_info_word|
23787 per character. Each word in this part of the file contains six fields
23788 packed into four bytes as follows.
23790 \yskip\hang first byte: |width_index| (8 bits)\par
23791 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23793 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23795 \hang fourth byte: |remainder| (8 bits)\par
23797 The actual width of a character is \\{width}|[width_index]|, in design-size
23798 units; this is a device for compressing information, since many characters
23799 have the same width. Since it is quite common for many characters
23800 to have the same height, depth, or italic correction, the \.{TFM} format
23801 imposes a limit of 16 different heights, 16 different depths, and
23802 64 different italic corrections.
23804 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23805 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23806 value of zero. The |width_index| should never be zero unless the
23807 character does not exist in the font, since a character is valid if and
23808 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23810 @ The |tag| field in a |char_info_word| has four values that explain how to
23811 interpret the |remainder| field.
23813 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23814 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23815 program starting at location |remainder| in the |lig_kern| array.\par
23816 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23817 characters of ascending sizes, and not the largest in the chain. The
23818 |remainder| field gives the character code of the next larger character.\par
23819 \hang|tag=3| (|ext_tag|) means that this character code represents an
23820 extensible character, i.e., a character that is built up of smaller pieces
23821 so that it can be made arbitrarily large. The pieces are specified in
23822 |exten[remainder]|.\par
23824 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23825 unless they are used in special circumstances in math formulas. For example,
23826 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23827 operation looks for both |list_tag| and |ext_tag|.
23829 @d no_tag 0 /* vanilla character */
23830 @d lig_tag 1 /* character has a ligature/kerning program */
23831 @d list_tag 2 /* character has a successor in a charlist */
23832 @d ext_tag 3 /* character is extensible */
23834 @ The |lig_kern| array contains instructions in a simple programming language
23835 that explains what to do for special letter pairs. Each word in this array is a
23836 |lig_kern_command| of four bytes.
23838 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23839 step if the byte is 128 or more, otherwise the next step is obtained by
23840 skipping this number of intervening steps.\par
23841 \hang second byte: |next_char|, ``if |next_char| follows the current character,
23842 then perform the operation and stop, otherwise continue.''\par
23843 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
23844 a kern step otherwise.\par
23845 \hang fourth byte: |remainder|.\par
23848 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
23849 between the current character and |next_char|. This amount is
23850 often negative, so that the characters are brought closer together
23851 by kerning; but it might be positive.
23853 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
23854 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
23855 |remainder| is inserted between the current character and |next_char|;
23856 then the current character is deleted if $b=0$, and |next_char| is
23857 deleted if $c=0$; then we pass over $a$~characters to reach the next
23858 current character (which may have a ligature/kerning program of its own).
23860 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
23861 the |next_char| byte is the so-called right boundary character of this font;
23862 the value of |next_char| need not lie between |bc| and~|ec|.
23863 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
23864 there is a special ligature/kerning program for a left boundary character,
23865 beginning at location |256*op_byte+remainder|.
23866 The interpretation is that \TeX\ puts implicit boundary characters
23867 before and after each consecutive string of characters from the same font.
23868 These implicit characters do not appear in the output, but they can affect
23869 ligatures and kerning.
23871 If the very first instruction of a character's |lig_kern| program has
23872 |skip_byte>128|, the program actually begins in location
23873 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
23874 arrays, because the first instruction must otherwise
23875 appear in a location |<=255|.
23877 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
23879 $$\hbox{|256*op_byte+remainder<nl|.}$$
23880 If such an instruction is encountered during
23881 normal program execution, it denotes an unconditional halt; no ligature
23882 command is performed.
23885 /* value indicating `\.{STOP}' in a lig/kern program */
23886 @d kern_flag (128) /* op code for a kern step */
23887 @d skip_byte(A) mp->lig_kern[(A)].b0
23888 @d next_char(A) mp->lig_kern[(A)].b1
23889 @d op_byte(A) mp->lig_kern[(A)].b2
23890 @d rem_byte(A) mp->lig_kern[(A)].b3
23892 @ Extensible characters are specified by an |extensible_recipe|, which
23893 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
23894 order). These bytes are the character codes of individual pieces used to
23895 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
23896 present in the built-up result. For example, an extensible vertical line is
23897 like an extensible bracket, except that the top and bottom pieces are missing.
23899 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
23900 if the piece isn't present. Then the extensible characters have the form
23901 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
23902 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
23903 The width of the extensible character is the width of $R$; and the
23904 height-plus-depth is the sum of the individual height-plus-depths of the
23905 components used, since the pieces are butted together in a vertical list.
23907 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
23908 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
23909 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
23910 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
23912 @ The final portion of a \.{TFM} file is the |param| array, which is another
23913 sequence of |fix_word| values.
23915 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
23916 to help position accents. For example, |slant=.25| means that when you go
23917 up one unit, you also go .25 units to the right. The |slant| is a pure
23918 number; it is the only |fix_word| other than the design size itself that is
23919 not scaled by the design size.
23922 \hang|param[2]=space| is the normal spacing between words in text.
23923 Note that character 040 in the font need not have anything to do with
23926 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
23928 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
23930 \hang|param[5]=x_height| is the size of one ex in the font; it is also
23931 the height of letters for which accents don't have to be raised or lowered.
23933 \hang|param[6]=quad| is the size of one em in the font.
23935 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
23939 If fewer than seven parameters are present, \TeX\ sets the missing parameters
23944 @d space_stretch_code 3
23945 @d space_shrink_code 4
23948 @d extra_space_code 7
23950 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
23951 information, and it does this all at once at the end of a job.
23952 In order to prepare for such frenetic activity, it squirrels away the
23953 necessary facts in various arrays as information becomes available.
23955 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
23956 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
23957 |tfm_ital_corr|. Other information about a character (e.g., about
23958 its ligatures or successors) is accessible via the |char_tag| and
23959 |char_remainder| arrays. Other information about the font as a whole
23960 is kept in additional arrays called |header_byte|, |lig_kern|,
23961 |kern|, |exten|, and |param|.
23963 @d max_tfm_int 32510
23964 @d undefined_label max_tfm_int /* an undefined local label */
23967 #define TFM_ITEMS 257
23969 eight_bits ec; /* smallest and largest character codes shipped out */
23970 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
23971 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
23972 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
23973 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
23974 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
23975 int char_tag[TFM_ITEMS]; /* |remainder| category */
23976 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
23977 char *header_byte; /* bytes of the \.{TFM} header */
23978 int header_last; /* last initialized \.{TFM} header byte */
23979 int header_size; /* size of the \.{TFM} header */
23980 four_quarters *lig_kern; /* the ligature/kern table */
23981 short nl; /* the number of ligature/kern steps so far */
23982 scaled *kern; /* distinct kerning amounts */
23983 short nk; /* the number of distinct kerns so far */
23984 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
23985 short ne; /* the number of extensible characters so far */
23986 scaled *param; /* \&{fontinfo} parameters */
23987 short np; /* the largest \&{fontinfo} parameter specified so far */
23988 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
23989 short skip_table[TFM_ITEMS]; /* local label status */
23990 boolean lk_started; /* has there been a lig/kern step in this command yet? */
23991 integer bchar; /* right boundary character */
23992 short bch_label; /* left boundary starting location */
23993 short ll;short lll; /* registers used for lig/kern processing */
23994 short label_loc[257]; /* lig/kern starting addresses */
23995 eight_bits label_char[257]; /* characters for |label_loc| */
23996 short label_ptr; /* highest position occupied in |label_loc| */
23998 @ @<Allocate or initialize ...@>=
23999 mp->header_size = 128; /* just for init */
24000 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
24002 @ @<Dealloc variables@>=
24003 xfree(mp->header_byte);
24004 xfree(mp->lig_kern);
24009 for (k=0;k<= 255;k++ ) {
24010 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
24011 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
24012 mp->skip_table[k]=undefined_label;
24014 memset(mp->header_byte,0,(size_t)mp->header_size);
24015 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
24016 mp->internal[mp_boundary_char]=-unity;
24017 mp->bch_label=undefined_label;
24018 mp->label_loc[0]=-1; mp->label_ptr=0;
24020 @ @<Declarations@>=
24021 scaled mp_tfm_check (MP mp,quarterword m) ;
24024 scaled mp_tfm_check (MP mp,quarterword m) {
24025 if ( abs(mp->internal[m])>=fraction_half ) {
24026 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
24027 @.Enormous charwd...@>
24028 @.Enormous chardp...@>
24029 @.Enormous charht...@>
24030 @.Enormous charic...@>
24031 @.Enormous designsize...@>
24032 mp_print(mp, " has been reduced");
24033 help1("Font metric dimensions must be less than 2048pt.");
24034 mp_put_get_error(mp);
24035 if ( mp->internal[m]>0 ) return (fraction_half-1);
24036 else return (1-fraction_half);
24038 return mp->internal[m];
24042 @ @<Store the width information for character code~|c|@>=
24043 if ( c<mp->bc ) mp->bc=(eight_bits)c;
24044 if ( c>mp->ec ) mp->ec=(eight_bits)c;
24045 mp->char_exists[c]=true;
24046 mp->tfm_width[c]=mp_tfm_check(mp,mp_char_wd);
24047 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
24048 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
24049 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
24051 @ Now let's consider \MP's special \.{TFM}-oriented commands.
24053 @<Cases of |do_statement|...@>=
24054 case tfm_command: mp_do_tfm_command(mp); break;
24056 @ @d char_list_code 0
24057 @d lig_table_code 1
24058 @d extensible_code 2
24059 @d header_byte_code 3
24060 @d font_dimen_code 4
24063 mp_primitive(mp, "charlist",tfm_command,char_list_code);
24064 @:char_list_}{\&{charlist} primitive@>
24065 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
24066 @:lig_table_}{\&{ligtable} primitive@>
24067 mp_primitive(mp, "extensible",tfm_command,extensible_code);
24068 @:extensible_}{\&{extensible} primitive@>
24069 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
24070 @:header_byte_}{\&{headerbyte} primitive@>
24071 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
24072 @:font_dimen_}{\&{fontdimen} primitive@>
24074 @ @<Cases of |print_cmd...@>=
24077 case char_list_code:mp_print(mp, "charlist"); break;
24078 case lig_table_code:mp_print(mp, "ligtable"); break;
24079 case extensible_code:mp_print(mp, "extensible"); break;
24080 case header_byte_code:mp_print(mp, "headerbyte"); break;
24081 default: mp_print(mp, "fontdimen"); break;
24085 @ @<Declare action procedures for use by |do_statement|@>=
24086 eight_bits mp_get_code (MP mp) ;
24088 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
24089 integer c; /* the code value found */
24090 mp_get_x_next(mp); mp_scan_expression(mp);
24091 if ( mp->cur_type==mp_known ) {
24092 c=mp_round_unscaled(mp, mp->cur_exp);
24093 if ( c>=0 ) if ( c<256 ) return (eight_bits)c;
24094 } else if ( mp->cur_type==mp_string_type ) {
24095 if ( length(mp->cur_exp)==1 ) {
24096 c=mp->str_pool[mp->str_start[mp->cur_exp]];
24097 return (eight_bits)c;
24100 exp_err("Invalid code has been replaced by 0");
24101 @.Invalid code...@>
24102 help2("I was looking for a number between 0 and 255, or for a",
24103 "string of length 1. Didn't find it; will use 0 instead.");
24104 mp_put_get_flush_error(mp, 0); c=0;
24105 return (eight_bits)c;
24108 @ @<Declare action procedures for use by |do_statement|@>=
24109 void mp_set_tag (MP mp,halfword c, quarterword t, halfword r) ;
24111 @ @c void mp_set_tag (MP mp,halfword c, quarterword t, halfword r) {
24112 if ( mp->char_tag[c]==no_tag ) {
24113 mp->char_tag[c]=t; mp->char_remainder[c]=r;
24115 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
24116 mp->label_char[mp->label_ptr]=(eight_bits)c;
24119 @<Complain about a character tag conflict@>;
24123 @ @<Complain about a character tag conflict@>=
24125 print_err("Character ");
24126 if ( (c>' ')&&(c<127) ) mp_print_char(mp,xord(c));
24127 else if ( c==256 ) mp_print(mp, "||");
24128 else { mp_print(mp, "code "); mp_print_int(mp, c); };
24129 mp_print(mp, " is already ");
24130 @.Character c is already...@>
24131 switch (mp->char_tag[c]) {
24132 case lig_tag: mp_print(mp, "in a ligtable"); break;
24133 case list_tag: mp_print(mp, "in a charlist"); break;
24134 case ext_tag: mp_print(mp, "extensible"); break;
24135 } /* there are no other cases */
24136 help2("It's not legal to label a character more than once.",
24137 "So I'll not change anything just now.");
24138 mp_put_get_error(mp);
24141 @ @<Declare action procedures for use by |do_statement|@>=
24142 void mp_do_tfm_command (MP mp) ;
24144 @ @c void mp_do_tfm_command (MP mp) {
24145 int c,cc; /* character codes */
24146 int k; /* index into the |kern| array */
24147 int j; /* index into |header_byte| or |param| */
24148 switch (mp->cur_mod) {
24149 case char_list_code:
24151 /* we will store a list of character successors */
24152 while ( mp->cur_cmd==colon ) {
24153 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
24156 case lig_table_code:
24157 if (mp->lig_kern==NULL)
24158 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
24159 if (mp->kern==NULL)
24160 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
24161 @<Store a list of ligature/kern steps@>;
24163 case extensible_code:
24164 @<Define an extensible recipe@>;
24166 case header_byte_code:
24167 case font_dimen_code:
24168 c=mp->cur_mod; mp_get_x_next(mp);
24169 mp_scan_expression(mp);
24170 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
24171 exp_err("Improper location");
24172 @.Improper location@>
24173 help2("I was looking for a known, positive number.",
24174 "For safety's sake I'll ignore the present command.");
24175 mp_put_get_error(mp);
24177 j=mp_round_unscaled(mp, mp->cur_exp);
24178 if ( mp->cur_cmd!=colon ) {
24179 mp_missing_err(mp, ":");
24181 help1("A colon should follow a headerbyte or fontinfo location.");
24184 if ( c==header_byte_code ) {
24185 @<Store a list of header bytes@>;
24187 if (mp->param==NULL)
24188 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
24189 @<Store a list of font dimensions@>;
24193 } /* there are no other cases */
24196 @ @<Store a list of ligature/kern steps@>=
24198 mp->lk_started=false;
24201 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
24202 @<Process a |skip_to| command and |goto done|@>;
24203 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
24204 else { mp_back_input(mp); c=mp_get_code(mp); };
24205 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
24206 @<Record a label in a lig/kern subprogram and |goto continue|@>;
24208 if ( mp->cur_cmd==lig_kern_token ) {
24209 @<Compile a ligature/kern command@>;
24211 print_err("Illegal ligtable step");
24212 @.Illegal ligtable step@>
24213 help1("I was looking for `=:' or `kern' here.");
24214 mp_back_error(mp); next_char(mp->nl)=qi(0);
24215 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
24216 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
24218 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
24220 if ( mp->cur_cmd==comma ) goto CONTINUE;
24221 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
24226 mp_primitive(mp, "=:",lig_kern_token,0);
24227 @:=:_}{\.{=:} primitive@>
24228 mp_primitive(mp, "=:|",lig_kern_token,1);
24229 @:=:/_}{\.{=:\char'174} primitive@>
24230 mp_primitive(mp, "=:|>",lig_kern_token,5);
24231 @:=:/>_}{\.{=:\char'174>} primitive@>
24232 mp_primitive(mp, "|=:",lig_kern_token,2);
24233 @:=:/_}{\.{\char'174=:} primitive@>
24234 mp_primitive(mp, "|=:>",lig_kern_token,6);
24235 @:=:/>_}{\.{\char'174=:>} primitive@>
24236 mp_primitive(mp, "|=:|",lig_kern_token,3);
24237 @:=:/_}{\.{\char'174=:\char'174} primitive@>
24238 mp_primitive(mp, "|=:|>",lig_kern_token,7);
24239 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
24240 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
24241 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
24242 mp_primitive(mp, "kern",lig_kern_token,128);
24243 @:kern_}{\&{kern} primitive@>
24245 @ @<Cases of |print_cmd...@>=
24246 case lig_kern_token:
24248 case 0:mp_print(mp, "=:"); break;
24249 case 1:mp_print(mp, "=:|"); break;
24250 case 2:mp_print(mp, "|=:"); break;
24251 case 3:mp_print(mp, "|=:|"); break;
24252 case 5:mp_print(mp, "=:|>"); break;
24253 case 6:mp_print(mp, "|=:>"); break;
24254 case 7:mp_print(mp, "|=:|>"); break;
24255 case 11:mp_print(mp, "|=:|>>"); break;
24256 default: mp_print(mp, "kern"); break;
24260 @ Local labels are implemented by maintaining the |skip_table| array,
24261 where |skip_table[c]| is either |undefined_label| or the address of the
24262 most recent lig/kern instruction that skips to local label~|c|. In the
24263 latter case, the |skip_byte| in that instruction will (temporarily)
24264 be zero if there were no prior skips to this label, or it will be the
24265 distance to the prior skip.
24267 We may need to cancel skips that span more than 127 lig/kern steps.
24269 @d cancel_skips(A) mp->ll=(A);
24271 mp->lll=qo(skip_byte(mp->ll));
24272 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
24273 } while (mp->lll!=0)
24274 @d skip_error(A) { print_err("Too far to skip");
24275 @.Too far to skip@>
24276 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
24277 mp_error(mp); cancel_skips((A));
24280 @<Process a |skip_to| command and |goto done|@>=
24283 if ( mp->nl-mp->skip_table[c]>128 ) {
24284 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
24286 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
24287 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
24288 mp->skip_table[c]=mp->nl-1; goto DONE;
24291 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
24293 if ( mp->cur_cmd==colon ) {
24294 if ( c==256 ) mp->bch_label=mp->nl;
24295 else mp_set_tag(mp, c,lig_tag,mp->nl);
24296 } else if ( mp->skip_table[c]<undefined_label ) {
24297 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
24299 mp->lll=qo(skip_byte(mp->ll));
24300 if ( mp->nl-mp->ll>128 ) {
24301 skip_error(mp->ll); goto CONTINUE;
24303 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
24304 } while (mp->lll!=0);
24309 @ @<Compile a ligature/kern...@>=
24311 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
24312 if ( mp->cur_mod<128 ) { /* ligature op */
24313 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
24315 mp_get_x_next(mp); mp_scan_expression(mp);
24316 if ( mp->cur_type!=mp_known ) {
24317 exp_err("Improper kern");
24319 help2("The amount of kern should be a known numeric value.",
24320 "I'm zeroing this one. Proceed, with fingers crossed.");
24321 mp_put_get_flush_error(mp, 0);
24323 mp->kern[mp->nk]=mp->cur_exp;
24325 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
24327 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
24330 op_byte(mp->nl)=kern_flag+(k / 256);
24331 rem_byte(mp->nl)=qi((k % 256));
24333 mp->lk_started=true;
24336 @ @d missing_extensible_punctuation(A)
24337 { mp_missing_err(mp, (A));
24338 @.Missing `\char`\#'@>
24339 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
24342 @<Define an extensible recipe@>=
24344 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
24345 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
24346 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
24347 ext_top(mp->ne)=qi(mp_get_code(mp));
24348 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24349 ext_mid(mp->ne)=qi(mp_get_code(mp));
24350 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24351 ext_bot(mp->ne)=qi(mp_get_code(mp));
24352 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24353 ext_rep(mp->ne)=qi(mp_get_code(mp));
24357 @ The header could contain ASCII zeroes, so can't use |strdup|.
24359 @<Store a list of header bytes@>=
24361 if ( j>=mp->header_size ) {
24362 size_t l = (size_t)(mp->header_size + (mp->header_size/4));
24363 char *t = xmalloc(l,1);
24365 memcpy(t,mp->header_byte,(size_t)mp->header_size);
24366 xfree (mp->header_byte);
24367 mp->header_byte = t;
24368 mp->header_size = (int)l;
24370 mp->header_byte[j]=(char)mp_get_code(mp);
24371 incr(j); incr(mp->header_last);
24372 } while (mp->cur_cmd==comma)
24374 @ @<Store a list of font dimensions@>=
24376 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
24377 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
24378 mp_get_x_next(mp); mp_scan_expression(mp);
24379 if ( mp->cur_type!=mp_known ){
24380 exp_err("Improper font parameter");
24381 @.Improper font parameter@>
24382 help1("I'm zeroing this one. Proceed, with fingers crossed.");
24383 mp_put_get_flush_error(mp, 0);
24385 mp->param[j]=mp->cur_exp; incr(j);
24386 } while (mp->cur_cmd==comma)
24388 @ OK: We've stored all the data that is needed for the \.{TFM} file.
24389 All that remains is to output it in the correct format.
24391 An interesting problem needs to be solved in this connection, because
24392 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
24393 and 64~italic corrections. If the data has more distinct values than
24394 this, we want to meet the necessary restrictions by perturbing the
24395 given values as little as possible.
24397 \MP\ solves this problem in two steps. First the values of a given
24398 kind (widths, heights, depths, or italic corrections) are sorted;
24399 then the list of sorted values is perturbed, if necessary.
24401 The sorting operation is facilitated by having a special node of
24402 essentially infinite |value| at the end of the current list.
24404 @<Initialize table entries...@>=
24405 value(inf_val)=fraction_four;
24407 @ Straight linear insertion is good enough for sorting, since the lists
24408 are usually not terribly long. As we work on the data, the current list
24409 will start at |mp_link(temp_head)| and end at |inf_val|; the nodes in this
24410 list will be in increasing order of their |value| fields.
24412 Given such a list, the |sort_in| function takes a value and returns a pointer
24413 to where that value can be found in the list. The value is inserted in
24414 the proper place, if necessary.
24416 At the time we need to do these operations, most of \MP's work has been
24417 completed, so we will have plenty of memory to play with. The value nodes
24418 that are allocated for sorting will never be returned to free storage.
24420 @d clear_the_list mp_link(temp_head)=inf_val
24422 @c pointer mp_sort_in (MP mp,scaled v) {
24423 pointer p,q,r; /* list manipulation registers */
24427 if ( v<=value(q) ) break;
24430 if ( v<value(q) ) {
24431 r=mp_get_node(mp, value_node_size); value(r)=v; mp_link(r)=q; mp_link(p)=r;
24436 @ Now we come to the interesting part, where we reduce the list if necessary
24437 until it has the required size. The |min_cover| routine is basic to this
24438 process; it computes the minimum number~|m| such that the values of the
24439 current sorted list can be covered by |m|~intervals of width~|d|. It
24440 also sets the global value |perturbation| to the smallest value $d'>d$
24441 such that the covering found by this algorithm would be different.
24443 In particular, |min_cover(0)| returns the number of distinct values in the
24444 current list and sets |perturbation| to the minimum distance between
24447 @c integer mp_min_cover (MP mp,scaled d) {
24448 pointer p; /* runs through the current list */
24449 scaled l; /* the least element covered by the current interval */
24450 integer m; /* lower bound on the size of the minimum cover */
24451 m=0; p=mp_link(temp_head); mp->perturbation=el_gordo;
24452 while ( p!=inf_val ){
24453 incr(m); l=value(p);
24454 do { p=mp_link(p); } while (value(p)<=l+d);
24455 if ( value(p)-l<mp->perturbation )
24456 mp->perturbation=value(p)-l;
24462 scaled perturbation; /* quantity related to \.{TFM} rounding */
24463 integer excess; /* the list is this much too long */
24465 @ The smallest |d| such that a given list can be covered with |m| intervals
24466 is determined by the |threshold| routine, which is sort of an inverse
24467 to |min_cover|. The idea is to increase the interval size rapidly until
24468 finding the range, then to go sequentially until the exact borderline has
24471 @c scaled mp_threshold (MP mp,integer m) {
24472 scaled d; /* lower bound on the smallest interval size */
24473 mp->excess=mp_min_cover(mp, 0)-m;
24474 if ( mp->excess<=0 ) {
24478 d=mp->perturbation;
24479 } while (mp_min_cover(mp, d+d)>m);
24480 while ( mp_min_cover(mp, d)>m )
24481 d=mp->perturbation;
24486 @ The |skimp| procedure reduces the current list to at most |m| entries,
24487 by changing values if necessary. It also sets |info(p):=k| if |value(p)|
24488 is the |k|th distinct value on the resulting list, and it sets
24489 |perturbation| to the maximum amount by which a |value| field has
24490 been changed. The size of the resulting list is returned as the
24493 @c integer mp_skimp (MP mp,integer m) {
24494 scaled d; /* the size of intervals being coalesced */
24495 pointer p,q,r; /* list manipulation registers */
24496 scaled l; /* the least value in the current interval */
24497 scaled v; /* a compromise value */
24498 d=mp_threshold(mp, m); mp->perturbation=0;
24499 q=temp_head; m=0; p=mp_link(temp_head);
24500 while ( p!=inf_val ) {
24501 incr(m); l=value(p); info(p)=m;
24502 if ( value(mp_link(p))<=l+d ) {
24503 @<Replace an interval of values by its midpoint@>;
24510 @ @<Replace an interval...@>=
24513 p=mp_link(p); info(p)=m;
24514 decr(mp->excess); if ( mp->excess==0 ) d=0;
24515 } while (value(mp_link(p))<=l+d);
24516 v=l+halfp(value(p)-l);
24517 if ( value(p)-v>mp->perturbation )
24518 mp->perturbation=value(p)-v;
24521 r=mp_link(r); value(r)=v;
24523 mp_link(q)=p; /* remove duplicate values from the current list */
24526 @ A warning message is issued whenever something is perturbed by
24527 more than 1/16\thinspace pt.
24529 @c void mp_tfm_warning (MP mp,quarterword m) {
24530 mp_print_nl(mp, "(some ");
24531 mp_print(mp, mp->int_name[m]);
24532 @.some charwds...@>
24533 @.some chardps...@>
24534 @.some charhts...@>
24535 @.some charics...@>
24536 mp_print(mp, " values had to be adjusted by as much as ");
24537 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
24540 @ Here's an example of how we use these routines.
24541 The width data needs to be perturbed only if there are 256 distinct
24542 widths, but \MP\ must check for this case even though it is
24545 An integer variable |k| will be defined when we use this code.
24546 The |dimen_head| array will contain pointers to the sorted
24547 lists of dimensions.
24549 @<Massage the \.{TFM} widths@>=
24551 for (k=mp->bc;k<=mp->ec;k++) {
24552 if ( mp->char_exists[k] )
24553 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
24555 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=mp_link(temp_head);
24556 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
24559 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
24561 @ Heights, depths, and italic corrections are different from widths
24562 not only because their list length is more severely restricted, but
24563 also because zero values do not need to be put into the lists.
24565 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
24567 for (k=mp->bc;k<=mp->ec;k++) {
24568 if ( mp->char_exists[k] ) {
24569 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
24570 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
24573 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=mp_link(temp_head);
24574 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
24576 for (k=mp->bc;k<=mp->ec;k++) {
24577 if ( mp->char_exists[k] ) {
24578 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
24579 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
24582 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=mp_link(temp_head);
24583 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
24585 for (k=mp->bc;k<=mp->ec;k++) {
24586 if ( mp->char_exists[k] ) {
24587 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
24588 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
24591 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=mp_link(temp_head);
24592 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
24594 @ @<Initialize table entries...@>=
24595 value(zero_val)=0; info(zero_val)=0;
24597 @ Bytes 5--8 of the header are set to the design size, unless the user has
24598 some crazy reason for specifying them differently.
24601 Error messages are not allowed at the time this procedure is called,
24602 so a warning is printed instead.
24604 The value of |max_tfm_dimen| is calculated so that
24605 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
24606 < \\{three\_bytes}.$$
24608 @d three_bytes 0100000000 /* $2^{24}$ */
24611 void mp_fix_design_size (MP mp) {
24612 scaled d; /* the design size */
24613 d=mp->internal[mp_design_size];
24614 if ( (d<unity)||(d>=fraction_half) ) {
24616 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24617 @.illegal design size...@>
24618 d=040000000; mp->internal[mp_design_size]=d;
24620 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24621 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24622 mp->header_byte[4]=d / 04000000;
24623 mp->header_byte[5]=(d / 4096) % 256;
24624 mp->header_byte[6]=(d / 16) % 256;
24625 mp->header_byte[7]=(d % 16)*16;
24627 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
24628 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24631 @ The |dimen_out| procedure computes a |fix_word| relative to the
24632 design size. If the data was out of range, it is corrected and the
24633 global variable |tfm_changed| is increased by~one.
24635 @c integer mp_dimen_out (MP mp,scaled x) {
24636 if ( abs(x)>mp->max_tfm_dimen ) {
24637 incr(mp->tfm_changed);
24638 if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
24640 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24645 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24646 integer tfm_changed; /* the number of data entries that were out of bounds */
24648 @ If the user has not specified any of the first four header bytes,
24649 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24650 from the |tfm_width| data relative to the design size.
24653 @c void mp_fix_check_sum (MP mp) {
24654 eight_bits k; /* runs through character codes */
24655 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24656 integer x; /* hash value used in check sum computation */
24657 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24658 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24659 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24660 mp->header_byte[0]=(char)B1; mp->header_byte[1]=(char)B2;
24661 mp->header_byte[2]=(char)B3; mp->header_byte[3]=(char)B4;
24666 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24667 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24668 for (k=mp->bc;k<=mp->ec;k++) {
24669 if ( mp->char_exists[k] ) {
24670 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24671 B1=(eight_bits)((B1+B1+x) % 255);
24672 B2=(eight_bits)((B2+B2+x) % 253);
24673 B3=(eight_bits)((B3+B3+x) % 251);
24674 B4=(eight_bits)((B4+B4+x) % 247);
24678 @ Finally we're ready to actually write the \.{TFM} information.
24679 Here are some utility routines for this purpose.
24681 @d tfm_out(A) do { /* output one byte to |tfm_file| */
24682 unsigned char s=(unsigned char)(A);
24683 (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
24686 @c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24687 tfm_out(x / 256); tfm_out(x % 256);
24689 void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24690 if ( x>=0 ) tfm_out(x / three_bytes);
24692 x=x+010000000000; /* use two's complement for negative values */
24694 tfm_out((x / three_bytes) + 128);
24696 x=x % three_bytes; tfm_out(x / unity);
24697 x=x % unity; tfm_out(x / 0400);
24700 void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24701 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24702 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24705 @ @<Finish the \.{TFM} file@>=
24706 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24707 mp_pack_job_name(mp, ".tfm");
24708 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24709 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24710 mp->metric_file_name=xstrdup(mp->name_of_file);
24711 @<Output the subfile sizes and header bytes@>;
24712 @<Output the character information bytes, then
24713 output the dimensions themselves@>;
24714 @<Output the ligature/kern program@>;
24715 @<Output the extensible character recipes and the font metric parameters@>;
24716 if ( mp->internal[mp_tracing_stats]>0 )
24717 @<Log the subfile sizes of the \.{TFM} file@>;
24718 mp_print_nl(mp, "Font metrics written on ");
24719 mp_print(mp, mp->metric_file_name); mp_print_char(mp, xord('.'));
24720 @.Font metrics written...@>
24721 (mp->close_file)(mp,mp->tfm_file)
24723 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24726 @<Output the subfile sizes and header bytes@>=
24728 LH=(k+3) / 4; /* this is the number of header words */
24729 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24730 @<Compute the ligature/kern program offset and implant the
24731 left boundary label@>;
24732 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24733 +lk_offset+mp->nk+mp->ne+mp->np);
24734 /* this is the total number of file words that will be output */
24735 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24736 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24737 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24738 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24739 mp_tfm_two(mp, mp->np);
24740 for (k=0;k< 4*LH;k++) {
24741 tfm_out(mp->header_byte[k]);
24744 @ @<Output the character information bytes...@>=
24745 for (k=mp->bc;k<=mp->ec;k++) {
24746 if ( ! mp->char_exists[k] ) {
24747 mp_tfm_four(mp, 0);
24749 tfm_out(info(mp->tfm_width[k])); /* the width index */
24750 tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
24751 tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24752 tfm_out(mp->char_remainder[k]);
24756 for (k=1;k<=4;k++) {
24757 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24758 while ( p!=inf_val ) {
24759 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=mp_link(p);
24764 @ We need to output special instructions at the beginning of the
24765 |lig_kern| array in order to specify the right boundary character
24766 and/or to handle starting addresses that exceed 255. The |label_loc|
24767 and |label_char| arrays have been set up to record all the
24768 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24769 \le|label_loc|[|label_ptr]|$.
24771 @<Compute the ligature/kern program offset...@>=
24772 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24773 if ((mp->bchar<0)||(mp->bchar>255))
24774 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24775 else { mp->lk_started=true; lk_offset=1; };
24776 @<Find the minimum |lk_offset| and adjust all remainders@>;
24777 if ( mp->bch_label<undefined_label )
24778 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24779 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24780 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24781 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24784 @ @<Find the minimum |lk_offset|...@>=
24785 k=mp->label_ptr; /* pointer to the largest unallocated label */
24786 if ( mp->label_loc[k]+lk_offset>255 ) {
24787 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24789 mp->char_remainder[mp->label_char[k]]=lk_offset;
24790 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24791 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24793 incr(lk_offset); decr(k);
24794 } while (! (lk_offset+mp->label_loc[k]<256));
24795 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24797 if ( lk_offset>0 ) {
24799 mp->char_remainder[mp->label_char[k]]
24800 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24805 @ @<Output the ligature/kern program@>=
24806 for (k=0;k<= 255;k++ ) {
24807 if ( mp->skip_table[k]<undefined_label ) {
24808 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24809 @.local label l:: was missing@>
24810 cancel_skips(mp->skip_table[k]);
24813 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24814 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24816 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24817 mp->ll=mp->label_loc[mp->label_ptr];
24818 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24819 else { tfm_out(255); tfm_out(mp->bchar); };
24820 mp_tfm_two(mp, mp->ll+lk_offset);
24822 decr(mp->label_ptr);
24823 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24826 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24827 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24829 @ @<Output the extensible character recipes...@>=
24830 for (k=0;k<=mp->ne-1;k++)
24831 mp_tfm_qqqq(mp, mp->exten[k]);
24832 for (k=1;k<=mp->np;k++) {
24834 if ( abs(mp->param[1])<fraction_half ) {
24835 mp_tfm_four(mp, mp->param[1]*16);
24837 incr(mp->tfm_changed);
24838 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
24839 else mp_tfm_four(mp, -el_gordo);
24842 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
24845 if ( mp->tfm_changed>0 ) {
24846 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
24847 @.a font metric dimension...@>
24849 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
24850 @.font metric dimensions...@>
24851 mp_print(mp, " font metric dimensions");
24853 mp_print(mp, " had to be decreased)");
24856 @ @<Log the subfile sizes of the \.{TFM} file@>=
24860 if ( mp->bch_label<undefined_label ) decr(mp->nl);
24861 mp_snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
24862 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
24866 @* \[43] Reading font metric data.
24868 \MP\ isn't a typesetting program but it does need to find the bounding box
24869 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
24870 well as write them.
24875 @ All the width, height, and depth information is stored in an array called
24876 |font_info|. This array is allocated sequentially and each font is stored
24877 as a series of |char_info| words followed by the width, height, and depth
24878 tables. Since |font_name| entries are permanent, their |str_ref| values are
24879 set to |max_str_ref|.
24882 typedef unsigned int font_number; /* |0..font_max| */
24884 @ The |font_info| array is indexed via a group directory arrays.
24885 For example, the |char_info| data for character~|c| in font~|f| will be
24886 in |font_info[char_base[f]+c].qqqq|.
24889 font_number font_max; /* maximum font number for included text fonts */
24890 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
24891 memory_word *font_info; /* height, width, and depth data */
24892 char **font_enc_name; /* encoding names, if any */
24893 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
24894 size_t next_fmem; /* next unused entry in |font_info| */
24895 font_number last_fnum; /* last font number used so far */
24896 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
24897 char **font_name; /* name as specified in the \&{infont} command */
24898 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
24899 font_number last_ps_fnum; /* last valid |font_ps_name| index */
24900 eight_bits *font_bc;
24901 eight_bits *font_ec; /* first and last character code */
24902 int *char_base; /* base address for |char_info| */
24903 int *width_base; /* index for zeroth character width */
24904 int *height_base; /* index for zeroth character height */
24905 int *depth_base; /* index for zeroth character depth */
24906 pointer *font_sizes;
24908 @ @<Allocate or initialize ...@>=
24909 mp->font_mem_size = 10000;
24910 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
24911 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
24912 mp->last_fnum = null_font;
24914 @ @<Dealloc variables@>=
24915 for (k=1;k<=(int)mp->last_fnum;k++) {
24916 xfree(mp->font_enc_name[k]);
24917 xfree(mp->font_name[k]);
24918 xfree(mp->font_ps_name[k]);
24920 xfree(mp->font_info);
24921 xfree(mp->font_enc_name);
24922 xfree(mp->font_ps_name_fixed);
24923 xfree(mp->font_dsize);
24924 xfree(mp->font_name);
24925 xfree(mp->font_ps_name);
24926 xfree(mp->font_bc);
24927 xfree(mp->font_ec);
24928 xfree(mp->char_base);
24929 xfree(mp->width_base);
24930 xfree(mp->height_base);
24931 xfree(mp->depth_base);
24932 xfree(mp->font_sizes);
24936 void mp_reallocate_fonts (MP mp, font_number l) {
24938 XREALLOC(mp->font_enc_name, l, char *);
24939 XREALLOC(mp->font_ps_name_fixed, l, boolean);
24940 XREALLOC(mp->font_dsize, l, scaled);
24941 XREALLOC(mp->font_name, l, char *);
24942 XREALLOC(mp->font_ps_name, l, char *);
24943 XREALLOC(mp->font_bc, l, eight_bits);
24944 XREALLOC(mp->font_ec, l, eight_bits);
24945 XREALLOC(mp->char_base, l, int);
24946 XREALLOC(mp->width_base, l, int);
24947 XREALLOC(mp->height_base, l, int);
24948 XREALLOC(mp->depth_base, l, int);
24949 XREALLOC(mp->font_sizes, l, pointer);
24950 for (f=(mp->last_fnum+1);f<=l;f++) {
24951 mp->font_enc_name[f]=NULL;
24952 mp->font_ps_name_fixed[f] = false;
24953 mp->font_name[f]=NULL;
24954 mp->font_ps_name[f]=NULL;
24955 mp->font_sizes[f]=null;
24960 @ @<Declare |mp_reallocate| functions@>=
24961 void mp_reallocate_fonts (MP mp, font_number l);
24964 @ A |null_font| containing no characters is useful for error recovery. Its
24965 |font_name| entry starts out empty but is reset each time an erroneous font is
24966 found. This helps to cut down on the number of duplicate error messages without
24967 wasting a lot of space.
24969 @d null_font 0 /* the |font_number| for an empty font */
24971 @<Set initial...@>=
24972 mp->font_dsize[null_font]=0;
24973 mp->font_bc[null_font]=1;
24974 mp->font_ec[null_font]=0;
24975 mp->char_base[null_font]=0;
24976 mp->width_base[null_font]=0;
24977 mp->height_base[null_font]=0;
24978 mp->depth_base[null_font]=0;
24980 mp->last_fnum=null_font;
24981 mp->last_ps_fnum=null_font;
24982 mp->font_name[null_font]=(char *)"nullfont";
24983 mp->font_ps_name[null_font]=(char *)"";
24984 mp->font_ps_name_fixed[null_font] = false;
24985 mp->font_enc_name[null_font]=NULL;
24986 mp->font_sizes[null_font]=null;
24988 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
24989 the |width index|; the |b1| field contains the height
24990 index; the |b2| fields contains the depth index, and the |b3| field used only
24991 for temporary storage. (It is used to keep track of which characters occur in
24992 an edge structure that is being shipped out.)
24993 The corresponding words in the width, height, and depth tables are stored as
24994 |scaled| values in units of \ps\ points.
24996 With the macros below, the |char_info| word for character~|c| in font~|f| is
24997 |char_info(f,c)| and the width is
24998 $$\hbox{|char_width(f,char_info(f,c)).sc|.}$$
25000 @d char_info(A,B) mp->font_info[mp->char_base[(A)]+(B)].qqqq
25001 @d char_width(A,B) mp->font_info[mp->width_base[(A)]+(B).b0].sc
25002 @d char_height(A,B) mp->font_info[mp->height_base[(A)]+(B).b1].sc
25003 @d char_depth(A,B) mp->font_info[mp->depth_base[(A)]+(B).b2].sc
25004 @d ichar_exists(A) ((A).b0>0)
25006 @ The |font_ps_name| for a built-in font should be what PostScript expects.
25007 A preliminary name is obtained here from the \.{TFM} name as given in the
25008 |fname| argument. This gets updated later from an external table if necessary.
25010 @<Declare text measuring subroutines@>=
25011 @<Declare subroutines for parsing file names@>
25012 font_number mp_read_font_info (MP mp, char *fname) {
25013 boolean file_opened; /* has |tfm_infile| been opened? */
25014 font_number n; /* the number to return */
25015 halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
25016 size_t whd_size; /* words needed for heights, widths, and depths */
25017 int i,ii; /* |font_info| indices */
25018 int jj; /* counts bytes to be ignored */
25019 scaled z; /* used to compute the design size */
25021 /* height, width, or depth as a fraction of design size times $2^{-8}$ */
25022 eight_bits h_and_d; /* height and depth indices being unpacked */
25023 unsigned char tfbyte; /* a byte read from the file */
25025 @<Open |tfm_infile| for input@>;
25026 @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
25027 otherwise |goto bad_tfm| or |goto done| as appropriate@>;
25029 @<Complain that the \.{TFM} file is bad@>;
25031 if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
25032 if ( n!=null_font ) {
25033 mp->font_ps_name[n]=mp_xstrdup(mp,fname);
25034 mp->font_name[n]=mp_xstrdup(mp,fname);
25039 @ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
25040 precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
25041 @.TFtoPL@> @.PLtoTF@>
25042 and \.{PLtoTF} can be used to debug \.{TFM} files.
25044 @<Complain that the \.{TFM} file is bad@>=
25045 print_err("Font ");
25046 mp_print(mp, fname);
25047 if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
25048 else mp_print(mp, " not usable: TFM file not found");
25049 help3("I wasn't able to read the size data for this font so this",
25050 "`infont' operation won't produce anything. If the font name",
25051 "is right, you might ask an expert to make a TFM file");
25053 mp->help_line[0]="is right, try asking an expert to fix the TFM file";
25056 @ @<Read data from |tfm_infile|; if there is no room, say so...@>=
25057 @<Read the \.{TFM} size fields@>;
25058 @<Use the size fields to allocate space in |font_info|@>;
25059 @<Read the \.{TFM} header@>;
25060 @<Read the character data and the width, height, and depth tables and
25063 @ A bad \.{TFM} file can be shorter than it claims to be. The code given here
25064 might try to read past the end of the file if this happens. Changes will be
25065 needed if it causes a system error to refer to |tfm_infile^| or call
25066 |get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
25067 @^system dependencies@>
25068 of |tfget| could be changed to
25069 ``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
25073 void *tfbyte_ptr = &tfbyte;
25074 (mp->read_binary_file)(mp,mp->tfm_infile,&tfbyte_ptr,&wanted);
25075 if (wanted==0) goto BAD_TFM;
25077 @d read_two(A) { (A)=tfbyte;
25078 if ( (A)>127 ) goto BAD_TFM;
25079 tfget; (A)=(A)*0400+tfbyte;
25081 @d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
25083 @<Read the \.{TFM} size fields@>=
25084 tfget; read_two(lf);
25085 tfget; read_two(tfm_lh);
25086 tfget; read_two(bc);
25087 tfget; read_two(ec);
25088 if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
25089 tfget; read_two(nw);
25090 tfget; read_two(nh);
25091 tfget; read_two(nd);
25092 whd_size=(size_t)((ec+1-bc)+nw+nh+nd);
25093 if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
25096 @ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
25097 necessary to apply the |so| and |qo| macros when looking up the width of a
25098 character in the string pool. In order to ensure nonnegative |char_base|
25099 values when |bc>0|, it may be necessary to reserve a few unused |font_info|
25102 @<Use the size fields to allocate space in |font_info|@>=
25103 if ( mp->next_fmem<(size_t)bc)
25104 mp->next_fmem=(size_t)bc; /* ensure nonnegative |char_base| */
25105 if (mp->last_fnum==mp->font_max)
25106 mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max/4)));
25107 while (mp->next_fmem+whd_size>=mp->font_mem_size) {
25108 size_t l = mp->font_mem_size+(mp->font_mem_size/4);
25109 memory_word *font_info;
25110 font_info = xmalloc ((l+1),sizeof(memory_word));
25111 memset (font_info,0,sizeof(memory_word)*(l+1));
25112 memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
25113 xfree(mp->font_info);
25114 mp->font_info = font_info;
25115 mp->font_mem_size = l;
25117 incr(mp->last_fnum);
25119 mp->font_bc[n]=(eight_bits)bc;
25120 mp->font_ec[n]=(eight_bits)ec;
25121 mp->char_base[n]=(int)(mp->next_fmem-bc);
25122 mp->width_base[n]=(int)(mp->next_fmem+ec-bc+1);
25123 mp->height_base[n]=mp->width_base[n]+nw;
25124 mp->depth_base[n]=mp->height_base[n]+nh;
25125 mp->next_fmem=mp->next_fmem+whd_size;
25128 @ @<Read the \.{TFM} header@>=
25129 if ( tfm_lh<2 ) goto BAD_TFM;
25131 tfget; read_two(z);
25132 tfget; z=z*0400+tfbyte;
25133 tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
25134 mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
25135 /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
25136 tf_ignore(4*(tfm_lh-2))
25138 @ @<Read the character data and the width, height, and depth tables...@>=
25139 ii=mp->width_base[n];
25140 i=mp->char_base[n]+bc;
25142 tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
25143 tfget; h_and_d=tfbyte;
25144 mp->font_info[i].qqqq.b1=qi(h_and_d / 16);
25145 mp->font_info[i].qqqq.b2=qi(h_and_d % 16);
25149 while ( i<(int)mp->next_fmem ) {
25150 @<Read a four byte dimension, scale it by the design size, store it in
25151 |font_info[i]|, and increment |i|@>;
25155 @ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
25156 interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
25157 we can multiply it by sixteen and think of it as a |fraction| that has been
25158 divided by sixteen. This cancels the extra scale factor contained in
25161 @<Read a four byte dimension, scale it by the design size, store it in...@>=
25164 if ( d>=0200 ) d=d-0400;
25165 tfget; d=d*0400+tfbyte;
25166 tfget; d=d*0400+tfbyte;
25167 tfget; d=d*0400+tfbyte;
25168 mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
25172 @ This function does no longer use the file name parser, because |fname| is
25173 a C string already.
25174 @<Open |tfm_infile| for input@>=
25176 mp_ptr_scan_file(mp, fname);
25177 if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); }
25178 if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
25180 mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
25181 if ( !mp->tfm_infile ) goto BAD_TFM;
25184 @ When we have a font name and we don't know whether it has been loaded yet,
25185 we scan the |font_name| array before calling |read_font_info|.
25187 @<Declare text measuring subroutines@>=
25188 font_number mp_find_font (MP mp, char *f) {
25190 for (n=0;n<=mp->last_fnum;n++) {
25191 if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
25196 n = mp_read_font_info(mp, f);
25201 @ This is an interface function for getting the width of character,
25202 as a double in ps units
25204 @c double mp_get_char_dimension (MP mp, char *fname, int c, int t) {
25209 for (n=0;n<=mp->last_fnum;n++) {
25210 if (mp_xstrcmp(fname,mp->font_name[n])==0 ) {
25217 cc = char_info(f,c);
25218 if (! ichar_exists(cc) )
25221 w = (double)char_width(f,cc);
25223 w = (double)char_height(f,cc);
25225 w = (double)char_depth(f,cc);
25226 return w/655.35*(72.27/72);
25229 @ @<Exported function ...@>=
25230 double mp_get_char_dimension (MP mp, char *fname, int n, int t);
25233 @ One simple application of |find_font| is the implementation of the |font_size|
25234 operator that gets the design size for a given font name.
25236 @<Find the design size of the font whose name is |cur_exp|@>=
25237 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
25239 @ If we discover that the font doesn't have a requested character, we omit it
25240 from the bounding box computation and expect the \ps\ interpreter to drop it.
25241 This routine issues a warning message if the user has asked for it.
25243 @<Declare text measuring subroutines@>=
25244 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
25245 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
25246 mp_begin_diagnostic(mp);
25247 if ( mp->selector==log_only ) incr(mp->selector);
25248 mp_print_nl(mp, "Missing character: There is no ");
25249 @.Missing character@>
25250 mp_print_str(mp, mp->str_pool[k]);
25251 mp_print(mp, " in font ");
25252 mp_print(mp, mp->font_name[f]); mp_print_char(mp, xord('!'));
25253 mp_end_diagnostic(mp, false);
25257 @ The whole purpose of saving the height, width, and depth information is to be
25258 able to find the bounding box of an item of text in an edge structure. The
25259 |set_text_box| procedure takes a text node and adds this information.
25261 @<Declare text measuring subroutines@>=
25262 void mp_set_text_box (MP mp,pointer p) {
25263 font_number f; /* |font_n(p)| */
25264 ASCII_code bc,ec; /* range of valid characters for font |f| */
25265 pool_pointer k,kk; /* current character and character to stop at */
25266 four_quarters cc; /* the |char_info| for the current character */
25267 scaled h,d; /* dimensions of the current character */
25269 height_val(p)=-el_gordo;
25270 depth_val(p)=-el_gordo;
25271 f=(font_number)font_n(p);
25274 kk=str_stop(text_p(p));
25275 k=mp->str_start[text_p(p)];
25277 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
25279 @<Set the height and depth to zero if the bounding box is empty@>;
25282 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
25284 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
25285 mp_lost_warning(mp, f,k);
25287 cc=char_info(f,mp->str_pool[k]);
25288 if ( ! ichar_exists(cc) ) {
25289 mp_lost_warning(mp, f,k);
25291 width_val(p)=width_val(p)+char_width(f,cc);
25292 h=char_height(f,cc);
25293 d=char_depth(f,cc);
25294 if ( h>height_val(p) ) height_val(p)=h;
25295 if ( d>depth_val(p) ) depth_val(p)=d;
25301 @ Let's hope modern compilers do comparisons correctly when the difference would
25304 @<Set the height and depth to zero if the bounding box is empty@>=
25305 if ( height_val(p)<-depth_val(p) ) {
25310 @ The new primitives fontmapfile and fontmapline.
25312 @<Declare action procedures for use by |do_statement|@>=
25313 void mp_do_mapfile (MP mp) ;
25314 void mp_do_mapline (MP mp) ;
25316 @ @c void mp_do_mapfile (MP mp) {
25317 mp_get_x_next(mp); mp_scan_expression(mp);
25318 if ( mp->cur_type!=mp_string_type ) {
25319 @<Complain about improper map operation@>;
25321 mp_map_file(mp,mp->cur_exp);
25324 void mp_do_mapline (MP mp) {
25325 mp_get_x_next(mp); mp_scan_expression(mp);
25326 if ( mp->cur_type!=mp_string_type ) {
25327 @<Complain about improper map operation@>;
25329 mp_map_line(mp,mp->cur_exp);
25333 @ @<Complain about improper map operation@>=
25335 exp_err("Unsuitable expression");
25336 help1("Only known strings can be map files or map lines.");
25337 mp_put_get_error(mp);
25340 @ To print |scaled| value to PDF output we need some subroutines to ensure
25343 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
25346 scaled one_bp; /* scaled value corresponds to 1bp */
25347 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
25348 scaled one_hundred_inch; /* scaled value corresponds to 100in */
25349 integer ten_pow[10]; /* $10^0..10^9$ */
25350 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
25353 mp->one_bp = 65782; /* 65781.76 */
25354 mp->one_hundred_bp = 6578176;
25355 mp->one_hundred_inch = 473628672;
25356 mp->ten_pow[0] = 1;
25357 for (i = 1;i<= 9; i++ ) {
25358 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
25361 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
25363 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
25367 if ( s < 0 ) { sign = -sign; s = -s; }
25368 if ( m < 0 ) { sign = -sign; m = -m; }
25370 mp_confusion(mp, "arithmetic: divided by zero");
25371 else if ( m >= (max_integer / 10) )
25372 mp_confusion(mp, "arithmetic: number too big");
25375 for (i = 1;i<=dd;i++) {
25376 q = 10*q + (10*r) / m;
25379 if ( 2*r >= m ) { incr(q); r = r - m; }
25380 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
25384 @* \[44] Shipping pictures out.
25385 The |ship_out| procedure, to be described below, is given a pointer to
25386 an edge structure. Its mission is to output a file containing the \ps\
25387 description of an edge structure.
25389 @ Each time an edge structure is shipped out we write a new \ps\ output
25390 file named according to the current \&{charcode}.
25391 @:char_code_}{\&{charcode} primitive@>
25393 This is the only backend function that remains in the main |mpost.w| file.
25394 There are just too many variable accesses needed for status reporting
25395 etcetera to make it worthwile to move the code to |psout.w|.
25397 @<Internal library declarations@>=
25398 void mp_open_output_file (MP mp) ;
25401 char *mp_set_output_file_name (MP mp, integer c) {
25402 char *ss = NULL; /* filename extension proposal */
25403 char *nn = NULL; /* temp string for str() */
25404 unsigned old_setting; /* previous |selector| setting */
25405 pool_pointer i; /* indexes into |filename_template| */
25406 integer cc; /* a temporary integer for template building */
25407 integer f,g=0; /* field widths */
25408 if ( mp->job_name==NULL ) mp_open_log_file(mp);
25409 if ( mp->filename_template==0 ) {
25410 char *s; /* a file extension derived from |c| */
25414 @<Use |c| to compute the file extension |s|@>;
25415 mp_pack_job_name(mp, s);
25417 ss = xstrdup(mp->name_of_file);
25418 } else { /* initializations */
25419 str_number s, n; /* a file extension derived from |c| */
25420 old_setting=mp->selector;
25421 mp->selector=new_string;
25423 i = mp->str_start[mp->filename_template];
25424 n = null_str; /* initialize */
25425 while ( i<str_stop(mp->filename_template) ) {
25426 if ( mp->str_pool[i]=='%' ) {
25429 if ( i<str_stop(mp->filename_template) ) {
25430 if ( mp->str_pool[i]=='j' ) {
25431 mp_print(mp, mp->job_name);
25432 } else if ( mp->str_pool[i]=='d' ) {
25433 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
25434 print_with_leading_zeroes(cc);
25435 } else if ( mp->str_pool[i]=='m' ) {
25436 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
25437 print_with_leading_zeroes(cc);
25438 } else if ( mp->str_pool[i]=='y' ) {
25439 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
25440 print_with_leading_zeroes(cc);
25441 } else if ( mp->str_pool[i]=='H' ) {
25442 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
25443 print_with_leading_zeroes(cc);
25444 } else if ( mp->str_pool[i]=='M' ) {
25445 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
25446 print_with_leading_zeroes(cc);
25447 } else if ( mp->str_pool[i]=='c' ) {
25448 if ( c<0 ) mp_print(mp, "ps");
25449 else print_with_leading_zeroes(c);
25450 } else if ( (mp->str_pool[i]>='0') &&
25451 (mp->str_pool[i]<='9') ) {
25453 f = (f*10) + mp->str_pool[i]-'0';
25456 mp_print_str(mp, mp->str_pool[i]);
25460 if ( mp->str_pool[i]=='.' )
25462 n = mp_make_string(mp);
25463 mp_print_str(mp, mp->str_pool[i]);
25467 s = mp_make_string(mp);
25468 mp->selector= old_setting;
25469 if (length(n)==0) {
25475 mp_pack_file_name(mp, nn,"",ss);
25483 char * mp_get_output_file_name (MP mp) {
25485 char *saved_name; /* saved |name_of_file| */
25486 saved_name = xstrdup(mp->name_of_file);
25487 f = xstrdup(mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code])));
25488 mp_pack_file_name(mp, saved_name,NULL,NULL);
25493 void mp_open_output_file (MP mp) {
25494 char *ss; /* filename extension proposal */
25495 integer c; /* \&{charcode} rounded to the nearest integer */
25496 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25497 ss = mp_set_output_file_name(mp, c);
25498 while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
25499 mp_prompt_file_name(mp, "file name for output",ss);
25501 @<Store the true output file name if appropriate@>;
25504 @ The file extension created here could be up to five characters long in
25505 extreme cases so it may have to be shortened on some systems.
25506 @^system dependencies@>
25508 @<Use |c| to compute the file extension |s|@>=
25511 mp_snprintf(s,7,".%i",(int)c);
25514 @ The user won't want to see all the output file names so we only save the
25515 first and last ones and a count of how many there were. For this purpose
25516 files are ordered primarily by \&{charcode} and secondarily by order of
25518 @:char_code_}{\&{charcode} primitive@>
25520 @<Store the true output file name if appropriate@>=
25521 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
25522 mp->first_output_code=c;
25523 xfree(mp->first_file_name);
25524 mp->first_file_name=xstrdup(mp->name_of_file);
25526 if ( c>=mp->last_output_code ) {
25527 mp->last_output_code=c;
25528 xfree(mp->last_file_name);
25529 mp->last_file_name=xstrdup(mp->name_of_file);
25533 char * first_file_name;
25534 char * last_file_name; /* full file names */
25535 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
25536 @:char_code_}{\&{charcode} primitive@>
25537 integer total_shipped; /* total number of |ship_out| operations completed */
25540 mp->first_file_name=xstrdup("");
25541 mp->last_file_name=xstrdup("");
25542 mp->first_output_code=32768;
25543 mp->last_output_code=-32768;
25544 mp->total_shipped=0;
25546 @ @<Dealloc variables@>=
25547 xfree(mp->first_file_name);
25548 xfree(mp->last_file_name);
25550 @ @<Begin the progress report for the output of picture~|c|@>=
25551 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
25552 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, xord(' '));
25553 mp_print_char(mp, xord('['));
25554 if ( c>=0 ) mp_print_int(mp, c)
25556 @ @<End progress report@>=
25557 mp_print_char(mp, xord(']'));
25559 incr(mp->total_shipped)
25561 @ @<Explain what output files were written@>=
25562 if ( mp->total_shipped>0 ) {
25563 mp_print_nl(mp, "");
25564 mp_print_int(mp, mp->total_shipped);
25565 if (mp->noninteractive) {
25566 mp_print(mp, " figure");
25567 if ( mp->total_shipped>1 ) mp_print_char(mp, xord('s'));
25568 mp_print(mp, " created.");
25570 mp_print(mp, " output file");
25571 if ( mp->total_shipped>1 ) mp_print_char(mp, xord('s'));
25572 mp_print(mp, " written: ");
25573 mp_print(mp, mp->first_file_name);
25574 if ( mp->total_shipped>1 ) {
25575 if ( 31+strlen(mp->first_file_name)+
25576 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
25578 mp_print(mp, " .. ");
25579 mp_print(mp, mp->last_file_name);
25584 @ @<Internal library declarations@>=
25585 boolean mp_has_font_size(MP mp, font_number f );
25588 boolean mp_has_font_size(MP mp, font_number f ) {
25589 return (mp->font_sizes[f]!=null);
25592 @ The \&{special} command saves up lines of text to be printed during the next
25593 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25596 pointer last_pending; /* the last token in a list of pending specials */
25599 mp->last_pending=spec_head;
25601 @ @<Cases of |do_statement|...@>=
25602 case special_command:
25603 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25604 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25608 @ @<Declare action procedures for use by |do_statement|@>=
25609 void mp_do_special (MP mp) ;
25611 @ @c void mp_do_special (MP mp) {
25612 mp_get_x_next(mp); mp_scan_expression(mp);
25613 if ( mp->cur_type!=mp_string_type ) {
25614 @<Complain about improper special operation@>;
25616 mp_link(mp->last_pending)=mp_stash_cur_exp(mp);
25617 mp->last_pending=mp_link(mp->last_pending);
25618 mp_link(mp->last_pending)=null;
25622 @ @<Complain about improper special operation@>=
25624 exp_err("Unsuitable expression");
25625 help1("Only known strings are allowed for output as specials.");
25626 mp_put_get_error(mp);
25629 @ On the export side, we need an extra object type for special strings.
25631 @<Graphical object codes@>=
25634 @ @<Export pending specials@>=
25635 p=mp_link(spec_head);
25636 while ( p!=null ) {
25637 mp_special_object *tp;
25638 tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
25639 gr_pre_script(tp) = str(value(p));
25640 if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
25641 else gr_link(hp) = (mp_graphic_object *)tp;
25642 hp = (mp_graphic_object *)tp;
25645 mp_flush_token_list(mp, mp_link(spec_head));
25646 mp_link(spec_head)=null;
25647 mp->last_pending=spec_head
25649 @ We are now ready for the main output procedure. Note that the |selector|
25650 setting is saved in a global variable so that |begin_diagnostic| can access it.
25652 @<Declare the \ps\ output procedures@>=
25653 void mp_ship_out (MP mp, pointer h) ;
25655 @ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
25657 @d export_color(q,p)
25658 if ( color_model(p)==mp_uninitialized_model ) {
25659 gr_color_model(q) = (unsigned char)(mp->internal[mp_default_color_model]/65536);
25660 gr_cyan_val(q) = 0;
25661 gr_magenta_val(q) = 0;
25662 gr_yellow_val(q) = 0;
25663 gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
25665 gr_color_model(q) = (unsigned char)color_model(p);
25666 gr_cyan_val(q) = cyan_val(p);
25667 gr_magenta_val(q) = magenta_val(p);
25668 gr_yellow_val(q) = yellow_val(p);
25669 gr_black_val(q) = black_val(p);
25672 @d export_scripts(q,p)
25673 if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
25674 if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
25677 struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
25678 pointer p; /* the current graphical object */
25679 integer t; /* a temporary value */
25680 integer c; /* a rounded charcode */
25681 scaled d_width; /* the current pen width */
25682 mp_edge_object *hh; /* the first graphical object */
25683 mp_graphic_object *hq; /* something |hp| points to */
25684 mp_text_object *tt;
25685 mp_fill_object *tf;
25686 mp_stroked_object *ts;
25687 mp_clip_object *tc;
25688 mp_bounds_object *tb;
25689 mp_graphic_object *hp = NULL; /* the current graphical object */
25690 mp_set_bbox(mp, h, true);
25691 hh = xmalloc(1,sizeof(mp_edge_object));
25695 hh->_minx = minx_val(h);
25696 hh->_miny = miny_val(h);
25697 hh->_maxx = maxx_val(h);
25698 hh->_maxy = maxy_val(h);
25699 hh->_filename = mp_get_output_file_name(mp);
25700 c = mp_round_unscaled(mp,mp->internal[mp_char_code]);
25702 hh->_width = mp->internal[mp_char_wd];
25703 hh->_height = mp->internal[mp_char_ht];
25704 hh->_depth = mp->internal[mp_char_dp];
25705 hh->_ital_corr = mp->internal[mp_char_ic];
25706 @<Export pending specials@>;
25707 p=mp_link(dummy_loc(h));
25708 while ( p!=null ) {
25709 hq = mp_new_graphic_object(mp,type(p));
25712 tf = (mp_fill_object *)hq;
25713 gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
25714 d_width = mp_get_pen_scale(mp, pen_p(p));
25715 if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
25716 gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
25719 pc = mp_copy_path(mp, path_p(p));
25720 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25721 gr_path_p(tf) = mp_export_knot_list(mp,pp);
25722 mp_toss_knot_list(mp, pp);
25723 pc = mp_htap_ypoc(mp, path_p(p));
25724 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25725 gr_htap_p(tf) = mp_export_knot_list(mp,pp);
25726 mp_toss_knot_list(mp, pp);
25728 export_color(tf,p) ;
25729 export_scripts(tf,p);
25730 gr_ljoin_val(tf) = (unsigned char)ljoin_val(p);
25731 gr_miterlim_val(tf) = miterlim_val(p);
25733 case mp_stroked_code:
25734 ts = (mp_stroked_object *)hq;
25735 gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
25736 d_width = mp_get_pen_scale(mp, pen_p(p));
25737 if (pen_is_elliptical(pen_p(p))) {
25738 gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
25741 pc=mp_copy_path(mp, path_p(p));
25743 if ( left_type(pc)!=mp_endpoint ) {
25744 left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
25745 right_type(pc)=mp_endpoint;
25749 pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
25750 gr_path_p(ts) = mp_export_knot_list(mp,pc);
25751 mp_toss_knot_list(mp, pc);
25753 export_color(ts,p) ;
25754 export_scripts(ts,p);
25755 gr_ljoin_val(ts) = (unsigned char)ljoin_val(p);
25756 gr_miterlim_val(ts) = miterlim_val(p);
25757 gr_lcap_val(ts) = (unsigned char)lcap_val(p);
25758 gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
25761 tt = (mp_text_object *)hq;
25762 gr_text_p(tt) = str(text_p(p));
25763 gr_font_n(tt) = (unsigned int)font_n(p);
25764 gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
25765 gr_font_dsize(tt) = (unsigned int)mp->font_dsize[font_n(p)];
25766 export_color(tt,p) ;
25767 export_scripts(tt,p);
25768 gr_width_val(tt) = width_val(p);
25769 gr_height_val(tt) = height_val(p);
25770 gr_depth_val(tt) = depth_val(p);
25771 gr_tx_val(tt) = tx_val(p);
25772 gr_ty_val(tt) = ty_val(p);
25773 gr_txx_val(tt) = txx_val(p);
25774 gr_txy_val(tt) = txy_val(p);
25775 gr_tyx_val(tt) = tyx_val(p);
25776 gr_tyy_val(tt) = tyy_val(p);
25778 case mp_start_clip_code:
25779 tc = (mp_clip_object *)hq;
25780 gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
25782 case mp_start_bounds_code:
25783 tb = (mp_bounds_object *)hq;
25784 gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
25786 case mp_stop_clip_code:
25787 case mp_stop_bounds_code:
25788 /* nothing to do here */
25791 if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
25798 @ @<Exported function ...@>=
25799 struct mp_edge_object *mp_gr_export(MP mp, int h);
25801 @ This function is now nearly trivial.
25804 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25805 integer c; /* \&{charcode} rounded to the nearest integer */
25806 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25807 @<Begin the progress report for the output of picture~|c|@>;
25808 (mp->shipout_backend) (mp, h);
25809 @<End progress report@>;
25810 if ( mp->internal[mp_tracing_output]>0 )
25811 mp_print_edges(mp, h," (just shipped out)",true);
25814 @ @<Declarations@>=
25815 void mp_shipout_backend (MP mp, pointer h);
25818 void mp_shipout_backend (MP mp, pointer h) {
25819 mp_edge_object *hh; /* the first graphical object */
25820 hh = mp_gr_export(mp,h);
25821 (void)mp_gr_ship_out (hh,
25822 (mp->internal[mp_prologues]/65536),
25823 (mp->internal[mp_procset]/65536),
25825 mp_gr_toss_objects(hh);
25828 @ @<Exported types@>=
25829 typedef void (*mp_backend_writer)(MP, int);
25831 @ @<Option variables@>=
25832 mp_backend_writer shipout_backend;
25834 @ Now that we've finished |ship_out|, let's look at the other commands
25835 by which a user can send things to the \.{GF} file.
25837 @ @<Determine if a character has been shipped out@>=
25839 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
25840 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
25841 boolean_reset(mp->char_exists[mp->cur_exp]);
25842 mp->cur_type=mp_boolean_type;
25848 @ @<Allocate or initialize ...@>=
25849 mp_backend_initialize(mp);
25852 mp_backend_free(mp);
25855 @* \[45] Dumping and undumping the tables.
25856 After \.{INIMP} has seen a collection of macros, it
25857 can write all the necessary information on an auxiliary file so
25858 that production versions of \MP\ are able to initialize their
25859 memory at high speed. The present section of the program takes
25860 care of such output and input. We shall consider simultaneously
25861 the processes of storing and restoring,
25862 so that the inverse relation between them is clear.
25865 The global variable |mem_ident| is a string that is printed right
25866 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
25867 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
25868 for example, `\.{(mem=plain 1990.4.14)}', showing the year,
25869 month, and day that the mem file was created. We have |mem_ident=0|
25870 before \MP's tables are loaded.
25876 mp->mem_ident=NULL;
25878 @ @<Initialize table entries...@>=
25879 mp->mem_ident=xstrdup(" (INIMP)");
25881 @ @<Declare act...@>=
25882 void mp_store_mem_file (MP mp) ;
25884 @ @c void mp_store_mem_file (MP mp) {
25885 integer k; /* all-purpose index */
25886 pointer p,q; /* all-purpose pointers */
25887 integer x; /* something to dump */
25888 four_quarters w; /* four ASCII codes */
25890 @<Create the |mem_ident|, open the mem file,
25891 and inform the user that dumping has begun@>;
25892 @<Dump constants for consistency check@>;
25893 @<Dump the string pool@>;
25894 @<Dump the dynamic memory@>;
25895 @<Dump the table of equivalents and the hash table@>;
25896 @<Dump a few more things and the closing check word@>;
25897 @<Close the mem file@>;
25900 @ Corresponding to the procedure that dumps a mem file, we also have a function
25901 that reads~one~in. The function returns |false| if the dumped mem is
25902 incompatible with the present \MP\ table sizes, etc.
25904 @d too_small(A) { wake_up_terminal;
25905 wterm_ln("---! Must increase the "); wterm((A));
25906 @.Must increase the x@>
25911 boolean mp_load_mem_file (MP mp) {
25912 integer k; /* all-purpose index */
25913 pointer p,q; /* all-purpose pointers */
25914 integer x; /* something undumped */
25915 str_number s; /* some temporary string */
25916 four_quarters w; /* four ASCII codes */
25918 /* |@<Undump constants for consistency check@>;| read earlier */
25919 @<Undump the string pool@>;
25920 @<Undump the dynamic memory@>;
25921 @<Undump the table of equivalents and the hash table@>;
25922 @<Undump a few more things and the closing check word@>;
25923 return true; /* it worked! */
25926 wterm_ln("(Fatal mem file error; I'm stymied)\n");
25927 @.Fatal mem file error@>
25931 @ @<Declarations@>=
25932 boolean mp_load_mem_file (MP mp) ;
25934 @ Mem files consist of |memory_word| items, and we use the following
25935 macros to dump words of different types:
25937 @d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25938 @d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
25939 @d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25940 @d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25941 @d dump_string(A) { dump_int((int)(strlen(A)+1));
25942 (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
25945 void * mem_file; /* for input or output of mem information */
25947 @ The inverse macros are slightly more complicated, since we need to check
25948 the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
25949 read an integer value |x| that is supposed to be in the range |a<=x<=b|.
25952 size_t wanted = sizeof(A);
25954 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25955 if (wanted!=sizeof(A)) goto OFF_BASE;
25959 size_t wanted = sizeof(A);
25961 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25962 if (wanted!=sizeof(A)) goto OFF_BASE;
25965 @d undump_wd(A) { mgetw(WW); A=WW; }
25966 @d undump_int(A) { int cint; mgeti(cint); A=cint; }
25967 @d undump_hh(A) { mgetw(WW); A=WW.hh; }
25968 @d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
25969 @d undump_strings(A,B,C) {
25970 undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
25971 @d undump(A,B,C) { undump_int(x);
25972 if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
25973 @d undump_size(A,B,C,D) { undump_int(x);
25974 if (x<(A)) goto OFF_BASE;
25975 if (x>(B)) too_small((C)); else D=x; }
25976 @d undump_string(A) {
25981 the_wanted = (size_t)XX;
25982 the_string = xmalloc(XX,1);
25983 (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
25984 A = (char *)the_string;
25985 if (the_wanted!=(size_t)XX) goto OFF_BASE;
25988 @ The next few sections of the program should make it clear how we use the
25989 dump/undump macros.
25991 @<Dump constants for consistency check@>=
25992 dump_int(mp->mem_top);
25993 dump_int(mp->hash_size);
25994 dump_int(mp->hash_prime)
25995 dump_int(mp->param_size);
25996 dump_int(mp->max_in_open);
25998 @ Sections of a \.{WEB} program that are ``commented out'' still contribute
25999 strings to the string pool; therefore \.{INIMP} and \MP\ will have
26000 the same strings. (And it is, of course, a good thing that they do.)
26004 @<Undump constants for consistency check@>=
26005 undump_int(x); mp->mem_top = x;
26006 undump_int(x); mp->hash_size = x;
26007 undump_int(x); mp->hash_prime = x;
26008 undump_int(x); mp->param_size = x;
26009 undump_int(x); mp->max_in_open = x;
26011 @ We do string pool compaction to avoid dumping unused strings.
26014 w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
26015 w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
26018 @<Dump the string pool@>=
26019 mp_do_compaction(mp, mp->pool_size);
26020 dump_int(mp->pool_ptr);
26021 dump_int(mp->max_str_ptr);
26022 dump_int(mp->str_ptr);
26024 while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
26027 while ( k<=mp->max_str_ptr ) {
26028 dump_int(mp->next_str[k]); incr(k);
26032 dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
26033 if ( k==mp->str_ptr ) {
26040 while (k+4<mp->pool_ptr ) {
26041 dump_four_ASCII; k=k+4;
26043 k=mp->pool_ptr-4; dump_four_ASCII;
26044 mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
26045 mp_print(mp, " strings of total length ");
26046 mp_print_int(mp, mp->pool_ptr)
26048 @ @d undump_four_ASCII
26050 mp->str_pool[k]=(ASCII_code)qo(w.b0); mp->str_pool[k+1]=(ASCII_code)qo(w.b1);
26051 mp->str_pool[k+2]=(ASCII_code)qo(w.b2); mp->str_pool[k+3]=(ASCII_code)qo(w.b3)
26053 @<Undump the string pool@>=
26054 undump_int(mp->pool_ptr);
26055 mp_reallocate_pool(mp, mp->pool_ptr) ;
26056 undump_int(mp->max_str_ptr);
26057 mp_reallocate_strings (mp,mp->max_str_ptr) ;
26058 undump(0,mp->max_str_ptr,mp->str_ptr);
26059 undump(0,mp->max_str_ptr+1,s);
26060 for (k=0;k<=s-1;k++)
26061 mp->next_str[k]=k+1;
26062 for (k=s;k<=mp->max_str_ptr;k++)
26063 undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
26064 mp->fixed_str_use=0;
26067 undump(0,mp->pool_ptr,mp->str_start[k]);
26068 if ( k==mp->str_ptr ) break;
26069 mp->str_ref[k]=max_str_ref;
26070 incr(mp->fixed_str_use);
26071 mp->last_fixed_str=k; k=mp->next_str[k];
26074 while ( k+4<mp->pool_ptr ) {
26075 undump_four_ASCII; k=k+4;
26077 k=mp->pool_ptr-4; undump_four_ASCII;
26078 mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
26079 mp->max_pool_ptr=mp->pool_ptr;
26080 mp->strs_used_up=mp->fixed_str_use;
26081 mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
26082 mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
26083 mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
26085 @ By sorting the list of available spaces in the variable-size portion of
26086 |mem|, we are usually able to get by without having to dump very much
26087 of the dynamic memory.
26089 We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
26090 information even when it has not been gathering statistics.
26092 @<Dump the dynamic memory@>=
26093 mp_sort_avail(mp); mp->var_used=0;
26094 dump_int(mp->lo_mem_max); dump_int(mp->rover);
26095 p=0; q=mp->rover; x=0;
26097 for (k=p;k<= q+1;k++)
26098 dump_wd(mp->mem[k]);
26099 x=x+q+2-p; mp->var_used=mp->var_used+q-p;
26100 p=q+node_size(q); q=rmp_link(q);
26101 } while (q!=mp->rover);
26102 mp->var_used=mp->var_used+mp->lo_mem_max-p;
26103 mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
26104 for (k=p;k<= mp->lo_mem_max;k++ )
26105 dump_wd(mp->mem[k]);
26106 x=x+mp->lo_mem_max+1-p;
26107 dump_int(mp->hi_mem_min); dump_int(mp->avail);
26108 for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
26109 dump_wd(mp->mem[k]);
26110 x=x+mp->mem_end+1-mp->hi_mem_min;
26112 while ( p!=null ) {
26113 decr(mp->dyn_used); p=mp_link(p);
26115 dump_int(mp->var_used); dump_int(mp->dyn_used);
26116 mp_print_ln(mp); mp_print_int(mp, x);
26117 mp_print(mp, " memory locations dumped; current usage is ");
26118 mp_print_int(mp, mp->var_used); mp_print_char(mp, xord('&')); mp_print_int(mp, mp->dyn_used)
26120 @ @<Undump the dynamic memory@>=
26121 undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
26122 undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
26125 for (k=p;k<= q+1; k++)
26126 undump_wd(mp->mem[k]);
26128 if ( (p>mp->lo_mem_max)||((q>=rmp_link(q))&&(rmp_link(q)!=mp->rover)) )
26131 } while (q!=mp->rover);
26132 for (k=p;k<=mp->lo_mem_max;k++ )
26133 undump_wd(mp->mem[k]);
26134 undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
26135 undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
26136 mp->last_pending=spec_head;
26137 for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
26138 undump_wd(mp->mem[k]);
26139 undump_int(mp->var_used); undump_int(mp->dyn_used)
26141 @ A different scheme is used to compress the hash table, since its lower region
26142 is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
26143 words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
26144 packed for |p>=hash_used|, so the remaining entries are output in~a~block.
26146 @<Dump the table of equivalents and the hash table@>=
26147 dump_int(mp->hash_used);
26148 mp->st_count=frozen_inaccessible-1-mp->hash_used;
26149 for (p=1;p<=mp->hash_used;p++) {
26150 if ( text(p)!=0 ) {
26151 dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
26154 for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
26155 dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
26157 dump_int(mp->st_count);
26158 mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
26160 @ @<Undump the table of equivalents and the hash table@>=
26161 undump(1,frozen_inaccessible,mp->hash_used);
26164 undump(p+1,mp->hash_used,p);
26165 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26166 } while (p!=mp->hash_used);
26167 for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
26168 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26170 undump_int(mp->st_count)
26172 @ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
26173 to prevent them appearing again.
26175 @<Dump a few more things and the closing check word@>=
26176 dump_int(mp->max_internal);
26177 dump_int(mp->int_ptr);
26178 for (k=1;k<= mp->int_ptr;k++ ) {
26179 dump_int(mp->internal[k]);
26180 dump_string(mp->int_name[k]);
26182 dump_int(mp->start_sym);
26183 dump_int(mp->interaction);
26184 dump_string(mp->mem_ident);
26185 dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
26186 mp->internal[mp_tracing_stats]=0
26188 @ @<Undump a few more things and the closing check word@>=
26190 if (x>mp->max_internal) mp_grow_internals(mp,x);
26191 undump_int(mp->int_ptr);
26192 for (k=1;k<= mp->int_ptr;k++) {
26193 undump_int(mp->internal[k]);
26194 undump_string(mp->int_name[k]);
26196 undump(0,frozen_inaccessible,mp->start_sym);
26197 if (mp->interaction==mp_unspecified_mode) {
26198 undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
26200 undump(mp_unspecified_mode,mp_error_stop_mode,x);
26202 undump_string(mp->mem_ident);
26203 undump(1,hash_end,mp->bg_loc);
26204 undump(1,hash_end,mp->eg_loc);
26205 undump_int(mp->serial_no);
26207 if (x!=69073) goto OFF_BASE
26209 @ @<Create the |mem_ident|...@>=
26211 char *tmp = xmalloc(11,1);
26212 xfree(mp->mem_ident);
26213 mp->mem_ident = xmalloc(256,1);
26214 mp_snprintf(tmp,11,"%04d.%02d.%02d",
26215 (int)mp_round_unscaled(mp, mp->internal[mp_year]),
26216 (int)mp_round_unscaled(mp, mp->internal[mp_month]),
26217 (int)mp_round_unscaled(mp, mp->internal[mp_day]));
26218 mp_snprintf(mp->mem_ident,256," (mem=%s %s)",mp->job_name, tmp);
26220 mp_pack_job_name(mp, ".mem");
26221 while (! mp_w_open_out(mp, &mp->mem_file) )
26222 mp_prompt_file_name(mp, "mem file name", ".mem");
26223 mp_print_nl(mp, "Beginning to dump on file ");
26224 @.Beginning to dump...@>
26225 mp_print(mp, mp->name_of_file);
26226 mp_print_nl(mp, mp->mem_ident);
26229 @ @<Dealloc variables@>=
26230 xfree(mp->mem_ident);
26232 @ @<Close the mem file@>=
26233 (mp->close_file)(mp,mp->mem_file)
26235 @* \[46] The main program.
26236 This is it: the part of \MP\ that executes all those procedures we have
26239 Well---almost. We haven't put the parsing subroutines into the
26240 program yet; and we'd better leave space for a few more routines that may
26241 have been forgotten.
26243 @c @<Declare the basic parsing subroutines@>
26244 @<Declare miscellaneous procedures that were declared |forward|@>
26245 @<Last-minute procedures@>
26247 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
26249 has to be run first; it initializes everything from scratch, without
26250 reading a mem file, and it has the capability of dumping a mem file.
26251 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
26253 to input a mem file in order to get started. \.{VIRMP} typically has
26254 a bit more memory capacity than \.{INIMP}, because it does not need the
26255 space consumed by the dumping/undumping routines and the numerous calls on
26258 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
26259 the best implementations therefore allow for production versions of \MP\ that
26260 not only avoid the loading routine for object code, they also have
26261 a mem file pre-loaded.
26263 @ @<Option variables@>=
26264 int ini_version; /* are we iniMP? */
26266 @ @<Set |ini_version|@>=
26267 mp->ini_version = (opt->ini_version ? true : false);
26269 @ The code below make the final chosen hash size the next larger
26270 multiple of 2 from the requested size, and this array is a list of
26271 suitable prime numbers to go with such values.
26273 The top limit is chosen such that it is definately lower than
26274 |max_halfword-3*param_size|, because |param_size| cannot be larger
26275 than |max_halfword/sizeof(pointer)|.
26278 static int mp_prime_choices[] =
26279 { 12289, 24593, 49157, 98317,
26280 196613, 393241, 786433, 1572869,
26281 3145739, 6291469, 12582917, 25165843,
26282 50331653, 100663319 };
26284 @ @<Find constant sizes@>=
26285 if (mp->ini_version) {
26287 set_value(mp->mem_top,opt->main_memory,5000);
26288 mp->mem_max = mp->mem_top;
26289 set_value(mp->param_size,opt->param_size,150);
26290 set_value(mp->max_in_open,opt->max_in_open,10);
26291 if (opt->hash_size>0x8000000)
26292 opt->hash_size=0x8000000;
26293 set_value(mp->hash_size,(2*opt->hash_size-1),16384);
26294 mp->hash_size = mp->hash_size>>i;
26295 while (mp->hash_size>=2) {
26296 mp->hash_size /= 2;
26299 mp->hash_size = mp->hash_size << i;
26300 if (mp->hash_size>0x8000000)
26301 mp->hash_size=0x8000000;
26302 mp->hash_prime=mp_prime_choices[(i-14)];
26305 if (mp->command_line != NULL && *(mp->command_line) == '&') {
26307 char *cmd = mp->command_line+1;
26308 xfree(mp->mem_name); /* just in case */
26309 mp->mem_name = mp_xstrdup(mp,cmd);
26310 while (*cmd && *cmd!=' ') cmd++;
26311 if (*cmd==' ') *cmd++ = '\0';
26313 s = mp_xstrdup(mp,cmd);
26315 xfree(mp->command_line);
26316 mp->command_line = s;
26318 if (mp->mem_name == NULL) {
26319 mp->mem_name = mp_xstrdup(mp,"plain");
26321 if (mp_open_mem_file(mp)) {
26322 @<Undump constants for consistency check@>;
26323 set_value(mp->mem_max,opt->main_memory,mp->mem_top);
26327 wterm_ln("(Fatal mem file error; I'm stymied)\n");
26328 mp->history = mp_fatal_error_stop;
26334 @ Here we do whatever is needed to complete \MP's job gracefully on the
26335 local operating system. The code here might come into play after a fatal
26336 error; it must therefore consist entirely of ``safe'' operations that
26337 cannot produce error messages. For example, it would be a mistake to call
26338 |str_room| or |make_string| at this time, because a call on |overflow|
26339 might lead to an infinite loop.
26340 @^system dependencies@>
26342 This program doesn't bother to close the input files that may still be open.
26344 @ @<Last-minute...@>=
26345 void mp_close_files_and_terminate (MP mp) {
26346 integer k; /* all-purpose index */
26347 integer LH; /* the length of the \.{TFM} header, in words */
26348 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
26349 pointer p; /* runs through a list of \.{TFM} dimensions */
26350 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
26351 if ( mp->internal[mp_tracing_stats]>0 )
26352 @<Output statistics about this job@>;
26354 @<Do all the finishing work on the \.{TFM} file@>;
26355 @<Explain what output files were written@>;
26356 if ( mp->log_opened && ! mp->noninteractive ){
26358 (mp->close_file)(mp,mp->log_file);
26359 mp->selector=mp->selector-2;
26360 if ( mp->selector==term_only ) {
26361 mp_print_nl(mp, "Transcript written on ");
26362 @.Transcript written...@>
26363 mp_print(mp, mp->log_name); mp_print_char(mp, xord('.'));
26367 mp->finished = true;
26370 @ @<Declarations@>=
26371 void mp_close_files_and_terminate (MP mp) ;
26373 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
26374 if (mp->rd_fname!=NULL) {
26375 for (k=0;k<=(int)mp->read_files-1;k++ ) {
26376 if ( mp->rd_fname[k]!=NULL ) {
26377 (mp->close_file)(mp,mp->rd_file[k]);
26378 xfree(mp->rd_fname[k]);
26382 if (mp->wr_fname!=NULL) {
26383 for (k=0;k<=(int)mp->write_files-1;k++) {
26384 if ( mp->wr_fname[k]!=NULL ) {
26385 (mp->close_file)(mp,mp->wr_file[k]);
26386 xfree(mp->wr_fname[k]);
26392 for (k=0;k<(int)mp->max_read_files;k++ ) {
26393 if ( mp->rd_fname[k]!=NULL ) {
26394 (mp->close_file)(mp,mp->rd_file[k]);
26395 xfree(mp->rd_fname[k]);
26398 xfree(mp->rd_file);
26399 xfree(mp->rd_fname);
26400 for (k=0;k<(int)mp->max_write_files;k++) {
26401 if ( mp->wr_fname[k]!=NULL ) {
26402 (mp->close_file)(mp,mp->wr_file[k]);
26403 xfree(mp->wr_fname[k]);
26406 xfree(mp->wr_file);
26407 xfree(mp->wr_fname);
26410 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
26412 We reclaim all of the variable-size memory at this point, so that
26413 there is no chance of another memory overflow after the memory capacity
26414 has already been exceeded.
26416 @<Do all the finishing work on the \.{TFM} file@>=
26417 if ( mp->internal[mp_fontmaking]>0 ) {
26418 @<Make the dynamic memory into one big available node@>;
26419 @<Massage the \.{TFM} widths@>;
26420 mp_fix_design_size(mp); mp_fix_check_sum(mp);
26421 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
26422 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
26423 @<Finish the \.{TFM} file@>;
26426 @ @<Make the dynamic memory into one big available node@>=
26427 mp->rover=lo_mem_stat_max+1; mp_link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26428 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26429 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26430 lmp_link(mp->rover)=mp->rover; rmp_link(mp->rover)=mp->rover;
26431 mp_link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
26433 @ The present section goes directly to the log file instead of using
26434 |print| commands, because there's no need for these strings to take
26435 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26437 @<Output statistics...@>=
26438 if ( mp->log_opened ) {
26441 wlog_ln("Here is how much of MetaPost's memory you used:");
26442 @.Here is how much...@>
26443 mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26444 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26445 (int)(mp->max_strings-1-mp->init_str_use));
26447 mp_snprintf(s,128," %i string characters out of %i",
26448 (int)mp->max_pl_used-mp->init_pool_ptr,
26449 (int)mp->pool_size-mp->init_pool_ptr);
26451 mp_snprintf(s,128," %i words of memory out of %i",
26452 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26455 mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26457 mp_snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
26458 (int)mp->max_in_stack,(int)mp->int_ptr,
26459 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26460 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26462 mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26463 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26467 @ It is nice to have have some of the stats available from the API.
26469 @<Exported function ...@>=
26470 int mp_memory_usage (MP mp );
26471 int mp_hash_usage (MP mp );
26472 int mp_param_usage (MP mp );
26473 int mp_open_usage (MP mp );
26476 int mp_memory_usage (MP mp ) {
26477 return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
26479 int mp_hash_usage (MP mp ) {
26480 return (int)mp->st_count;
26482 int mp_param_usage (MP mp ) {
26483 return (int)mp->max_param_stack;
26485 int mp_open_usage (MP mp ) {
26486 return (int)mp->max_in_stack;
26489 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26492 @<Last-minute...@>=
26493 void mp_final_cleanup (MP mp) {
26494 quarterword c; /* 0 for \&{end}, 1 for \&{dump} */
26496 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26497 while ( mp->input_ptr>0 ) {
26498 if ( token_state ) mp_end_token_list(mp);
26499 else mp_end_file_reading(mp);
26501 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26502 while ( mp->open_parens>0 ) {
26503 mp_print(mp, " )"); decr(mp->open_parens);
26505 while ( mp->cond_ptr!=null ) {
26506 mp_print_nl(mp, "(end occurred when ");
26507 @.end occurred...@>
26508 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26509 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26510 if ( mp->if_line!=0 ) {
26511 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26513 mp_print(mp, " was incomplete)");
26514 mp->if_line=if_line_field(mp->cond_ptr);
26515 mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=mp_link(mp->cond_ptr);
26517 if ( mp->history!=mp_spotless )
26518 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26519 if ( mp->selector==term_and_log ) {
26520 mp->selector=term_only;
26521 mp_print_nl(mp, "(see the transcript file for additional information)");
26522 @.see the transcript file...@>
26523 mp->selector=term_and_log;
26526 if (mp->ini_version) {
26527 mp_store_mem_file(mp); return;
26529 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26530 @.dump...only by INIMP@>
26534 @ @<Declarations@>=
26535 void mp_final_cleanup (MP mp) ;
26536 void mp_init_prim (MP mp) ;
26537 void mp_init_tab (MP mp) ;
26539 @ @<Last-minute...@>=
26540 void mp_init_prim (MP mp) { /* initialize all the primitives */
26544 void mp_init_tab (MP mp) { /* initialize other tables */
26545 integer k; /* all-purpose index */
26546 @<Initialize table entries (done by \.{INIMP} only)@>;
26550 @ When we begin the following code, \MP's tables may still contain garbage;
26551 thus we must proceed cautiously to get bootstrapped in.
26553 But when we finish this part of the program, \MP\ is ready to call on the
26554 |main_control| routine to do its work.
26556 @<Get the first line...@>=
26558 @<Initialize the input routines@>;
26559 if (mp->mem_ident==NULL) {
26560 if ( ! mp_load_mem_file(mp) ) {
26561 (mp->close_file)(mp, mp->mem_file);
26562 mp->history = mp_fatal_error_stop;
26565 (mp->close_file)(mp, mp->mem_file);
26567 @<Initializations following first line@>;
26570 @ @<Initializations following first line@>=
26571 mp->buffer[limit]=(ASCII_code)'%';
26572 mp_fix_date_and_time(mp);
26573 if (mp->random_seed==0)
26574 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
26575 mp_init_randoms(mp, mp->random_seed);
26576 @<Initialize the print |selector|...@>;
26577 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26578 mp_start_input(mp); /* \&{input} assumed */
26580 @ @<Run inimpost commands@>=
26582 mp_get_strings_started(mp);
26583 mp_init_tab(mp); /* initialize the tables */
26584 mp_init_prim(mp); /* call |primitive| for each primitive */
26585 mp->init_str_use=mp->max_str_ptr=mp->str_ptr;
26586 mp->init_pool_ptr=mp->max_pool_ptr=mp->pool_ptr;
26587 mp_fix_date_and_time(mp);
26590 @ Saving the filename template
26592 @<Save the filename template@>=
26594 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26595 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26597 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26601 @* \[47] Debugging.
26604 @* \[48] System-dependent changes.
26605 This section should be replaced, if necessary, by any special
26606 modification of the program
26607 that are necessary to make \MP\ work at a particular installation.
26608 It is usually best to design your change file so that all changes to
26609 previous sections preserve the section numbering; then everybody's version
26610 will be consistent with the published program. More extensive changes,
26611 which introduce new sections, can be inserted here; then only the index
26612 itself will get a new section number.
26613 @^system dependencies@>
26616 Here is where you can find all uses of each identifier in the program,
26617 with underlined entries pointing to where the identifier was defined.
26618 If the identifier is only one letter long, however, you get to see only
26619 the underlined entries. {\sl All references are to section numbers instead of
26622 This index also lists error messages and other aspects of the program
26623 that you might want to look up some day. For example, the entry
26624 for ``system dependencies'' lists all sections that should receive
26625 special attention from people who are installing \MP\ in a new
26626 operating environment. A list of various things that can't happen appears
26627 under ``this can't happen''.
26628 Approximately 25 sections are listed under ``inner loop''; these account
26629 for more than 60\pct! of \MP's running time, exclusive of input and output.