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\vbv="026A % synonym for `\|'
39 \def\vb{\relax\ifmmode\vbv\else$\vbv$\fi}
41 \def\(#1){} % this is used to make section names sort themselves better
42 \def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
49 This is \MP\ by John Hobby, a graphics-language processor based on D. E. Knuth's \MF.
51 Much of the original Pascal version of this program was copied with
52 permission from MF.web Version 1.9. It interprets a language very
53 similar to D.E. Knuth's METAFONT, but with changes designed to make it
54 more suitable for PostScript output.
56 The main purpose of the following program is to explain the algorithms of \MP\
57 as clearly as possible. However, the program has been written so that it
58 can be tuned to run efficiently in a wide variety of operating environments
59 by making comparatively few changes. Such flexibility is possible because
60 the documentation that follows is written in the \.{WEB} language, which is
61 at a higher level than C.
63 A large piece of software like \MP\ has inherent complexity that cannot
64 be reduced below a certain level of difficulty, although each individual
65 part is fairly simple by itself. The \.{WEB} language is intended to make
66 the algorithms as readable as possible, by reflecting the way the
67 individual program pieces fit together and by providing the
68 cross-references that connect different parts. Detailed comments about
69 what is going on, and about why things were done in certain ways, have
70 been liberally sprinkled throughout the program. These comments explain
71 features of the implementation, but they rarely attempt to explain the
72 \MP\ language itself, since the reader is supposed to be familiar with
73 {\sl The {\logos METAFONT\/}book} as well as the manual
75 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
76 {\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
77 AT\AM T Bell Laboratories.
79 @ The present implementation is a preliminary version, but the possibilities
80 for new features are limited by the desire to remain as nearly compatible
81 with \MF\ as possible.
83 On the other hand, the \.{WEB} description can be extended without changing
84 the core of the program, and it has been designed so that such
85 extensions are not extremely difficult to make.
86 The |banner| string defined here should be changed whenever \MP\
87 undergoes any modifications, so that it will be clear which version of
88 \MP\ might be the guilty party when a problem arises.
90 @^system dependencies@>
92 @d default_banner "This is MetaPost, Version 1.086" /* printed when \MP\ starts */
97 #define metapost_version "1.086"
98 #define metapost_magic (('M'*256) + 'P')*65536 + 1086
100 @ The external library header for \MP\ is |mplib.h|. It contains a
101 few typedefs and the header defintions for the externally used
104 The most important of the typedefs is the definition of the structure
105 |MP_options|, that acts as a small, configurable front-end to the fairly
106 large |MP_instance| structure.
109 typedef struct MP_instance * MP;
111 typedef struct MP_options {
114 @<Exported function headers@>
116 @ The internal header file is much longer: it not only lists the complete
117 |MP_instance|, but also a lot of functions that have to be available to
118 the \ps\ backend, that is defined in a separate \.{WEB} file.
120 The variables from |MP_options| are included inside the |MP_instance|
125 typedef struct psout_data_struct * psout_data;
133 @<Types in the outer block@>
134 @<Constants in the outer block@>
135 # ifndef LIBAVL_ALLOCATOR
136 # define LIBAVL_ALLOCATOR
137 struct libavl_allocator {
138 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
139 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
142 typedef struct MP_instance {
146 @<Internal library declarations@>
156 #include <unistd.h> /* for access() */
158 #include <time.h> /* for struct tm \& co */
160 #include "mplibps.h" /* external header */
161 #include "mpmp.h" /* internal header */
162 #include "mppsout.h" /* internal header */
163 extern font_number mp_read_font_info (MP mp, char *fname); /* tfmin.w */
166 @<Basic printing procedures@>
167 @<Error handling procedures@>
169 @ Here are the functions that set up the \MP\ instance.
172 MP_options *mp_options (void);
173 MP mp_initialize (MP_options *opt);
176 MP_options *mp_options (void) {
178 size_t l = sizeof(MP_options);
182 opt->ini_version = true;
187 @ @<Internal library declarations@>=
188 @<Declare subroutines for parsing file names@>
190 @ The whole instance structure is initialized with zeroes,
191 this greatly reduces the number of statements needed in
192 the |Allocate or initialize variables| block.
194 @d set_callback_option(A) do { mp->A = mp_##A;
195 if (opt->A!=NULL) mp->A = opt->A;
199 static MP mp_do_new (jmp_buf *buf) {
200 MP mp = malloc(sizeof(MP_instance));
205 memset(mp,0,sizeof(MP_instance));
211 static void mp_free (MP mp) {
212 int k; /* loop variable */
213 @<Dealloc variables@>
214 if (mp->noninteractive) {
215 @<Finish non-interactive use@>;
222 static void mp_do_initialize ( MP mp) {
223 @<Local variables for initialization@>
224 @<Set initial values of key variables@>
227 @ This procedure gets things started properly.
229 MP mp_initialize (MP_options *opt) {
231 jmp_buf *buf = malloc(sizeof(jmp_buf));
232 if (buf == NULL || setjmp(*buf) != 0)
237 mp->userdata=opt->userdata;
238 @<Set |ini_version|@>;
239 mp->noninteractive=opt->noninteractive;
240 set_callback_option(find_file);
241 set_callback_option(open_file);
242 set_callback_option(read_ascii_file);
243 set_callback_option(read_binary_file);
244 set_callback_option(close_file);
245 set_callback_option(eof_file);
246 set_callback_option(flush_file);
247 set_callback_option(write_ascii_file);
248 set_callback_option(write_binary_file);
249 set_callback_option(shipout_backend);
250 if (opt->banner && *(opt->banner)) {
251 mp->banner = xstrdup(opt->banner);
253 mp->banner = xstrdup(default_banner);
255 if (opt->command_line && *(opt->command_line))
256 mp->command_line = xstrdup(opt->command_line);
257 if (mp->noninteractive) {
258 @<Prepare function pointers for non-interactive use@>;
260 /* open the terminal for output */
262 @<Find constant sizes@>;
263 @<Allocate or initialize variables@>
264 mp_reallocate_memory(mp,mp->mem_max);
265 mp_reallocate_paths(mp,1000);
266 mp_reallocate_fonts(mp,8);
267 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
268 @<Check the ``constant'' values...@>;
271 mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
272 "---case %i",(int)mp->bad);
273 do_fprintf(mp->err_out,(char *)ss);
277 mp_do_initialize(mp); /* erase preloaded mem */
278 if (mp->ini_version) {
279 @<Run inimpost commands@>;
281 if (!mp->noninteractive) {
282 @<Initialize the output routines@>;
283 @<Get the first line of input and prepare to start@>;
284 @<Initializations after first line is read@>;
286 mp->history=mp_spotless;
291 @ @<Initializations after first line is read@>=
293 mp_init_map_file(mp, mp->troff_mode);
294 mp->history=mp_spotless; /* ready to go! */
295 if (mp->troff_mode) {
296 mp->internal[mp_gtroffmode]=unity;
297 mp->internal[mp_prologues]=unity;
299 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
300 mp->cur_sym=mp->start_sym; mp_back_input(mp);
303 @ @<Exported function headers@>=
304 extern MP_options *mp_options (void);
305 extern MP mp_initialize (MP_options *opt) ;
306 extern int mp_status(MP mp);
307 extern void *mp_userdata(MP mp);
310 int mp_status(MP mp) { return mp->history; }
313 void *mp_userdata(MP mp) { return mp->userdata; }
315 @ The overall \MP\ program begins with the heading just shown, after which
316 comes a bunch of procedure declarations and function declarations.
317 Finally we will get to the main program, which begins with the
318 comment `|start_here|'. If you want to skip down to the
319 main program now, you can look up `|start_here|' in the index.
320 But the author suggests that the best way to understand this program
321 is to follow pretty much the order of \MP's components as they appear in the
322 \.{WEB} description you are now reading, since the present ordering is
323 intended to combine the advantages of the ``bottom up'' and ``top down''
324 approaches to the problem of understanding a somewhat complicated system.
326 @ Some of the code below is intended to be used only when diagnosing the
327 strange behavior that sometimes occurs when \MP\ is being installed or
328 when system wizards are fooling around with \MP\ without quite knowing
329 what they are doing. Such code will not normally be compiled; it is
330 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
332 @ This program has two important variations: (1) There is a long and slow
333 version called \.{INIMP}, which does the extra calculations needed to
335 initialize \MP's internal tables; and (2)~there is a shorter and faster
336 production version, which cuts the initialization to a bare minimum.
338 Which is which is decided at runtime.
340 @ The following parameters can be changed at compile time to extend or
341 reduce \MP's capacity. They may have different values in \.{INIMP} and
342 in production versions of \MP.
344 @^system dependencies@>
347 #define file_name_size 255 /* file names shouldn't be longer than this */
348 #define bistack_size 1500 /* size of stack for bisection algorithms;
349 should probably be left at this value */
351 @ Like the preceding parameters, the following quantities can be changed
352 to extend or reduce \MP's capacity. But if they are changed,
353 it is necessary to rerun the initialization program \.{INIMP}
355 to generate new tables for the production \MP\ program.
356 One can't simply make helter-skelter changes to the following constants,
357 since certain rather complex initialization
358 numbers are computed from them.
361 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
362 int pool_size; /* maximum number of characters in strings, including all
363 error messages and help texts, and the names of all identifiers */
364 int mem_max; /* greatest index in \MP's internal |mem| array;
365 must be strictly less than |max_halfword|;
366 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
367 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
368 must not be greater than |mem_max| */
369 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
371 @ @<Option variables@>=
372 int error_line; /* width of context lines on terminal error messages */
373 int half_error_line; /* width of first lines of contexts in terminal
374 error messages; should be between 30 and |error_line-15| */
375 int max_print_line; /* width of longest text lines output; should be at least 60 */
376 unsigned hash_size; /* maximum number of symbolic tokens,
377 must be less than |max_halfword-3*param_size| */
378 int param_size; /* maximum number of simultaneous macro parameters */
379 int max_in_open; /* maximum number of input files and error insertions that
380 can be going on simultaneously */
381 int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
382 void *userdata; /* this allows the calling application to setup local */
383 char *banner; /* the banner that is printed to the screen and log */
385 @ @<Dealloc variables@>=
389 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
394 set_value(mp->error_line,opt->error_line,79);
395 set_value(mp->half_error_line,opt->half_error_line,50);
396 if (mp->half_error_line>mp->error_line-15 )
397 mp->half_error_line = mp->error_line-15;
398 set_value(mp->max_print_line,opt->max_print_line,100);
400 @ In case somebody has inadvertently made bad settings of the ``constants,''
401 \MP\ checks them using a global variable called |bad|.
403 This is the second of many sections of \MP\ where global variables are
407 integer bad; /* is some ``constant'' wrong? */
409 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
410 or something similar. (We can't do that until |max_halfword| has been defined.)
412 In case you are wondering about the non-consequtive values of |bad|: some
413 of the things that used to be WEB constants are now runtime variables
414 with checking at assignment time.
416 @<Check the ``constant'' values for consistency@>=
418 if ( mp->mem_top<=1100 ) mp->bad=4;
420 @ Some |goto| labels are used by the following definitions. The label
421 `|restart|' is occasionally used at the very beginning of a procedure; and
422 the label `|reswitch|' is occasionally used just prior to a |case|
423 statement in which some cases change the conditions and we wish to branch
424 to the newly applicable case. Loops that are set up with the |loop|
425 construction defined below are commonly exited by going to `|done|' or to
426 `|found|' or to `|not_found|', and they are sometimes repeated by going to
427 `|continue|'. If two or more parts of a subroutine start differently but
428 end up the same, the shared code may be gathered together at
431 @ Here are some macros for common programming idioms.
433 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
434 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
435 @d negate(A) (A)=-(A) /* change the sign of a variable */
436 @d double(A) (A)=(A)+(A)
438 @d do_nothing /* empty statement */
440 @* \[2] The character set.
441 In order to make \MP\ readily portable to a wide variety of
442 computers, all of its input text is converted to an internal eight-bit
443 code that includes standard ASCII, the ``American Standard Code for
444 Information Interchange.'' This conversion is done immediately when each
445 character is read in. Conversely, characters are converted from ASCII to
446 the user's external representation just before they are output to a
450 Such an internal code is relevant to users of \MP\ only with respect to
451 the \&{char} and \&{ASCII} operations, and the comparison of strings.
453 @ Characters of text that have been converted to \MP's internal form
454 are said to be of type |ASCII_code|, which is a subrange of the integers.
457 typedef unsigned char ASCII_code; /* eight-bit numbers */
459 @ The present specification of \MP\ has been written under the assumption
460 that the character set contains at least the letters and symbols associated
461 with ASCII codes 040 through 0176; all of these characters are now
462 available on most computer terminals.
465 typedef unsigned char text_char; /* the data type of characters in text files */
467 @ @<Local variables for init...@>=
470 @ The \MP\ processor converts between ASCII code and
471 the user's external character set by means of arrays |xord| and |xchr|
472 that are analogous to Pascal's |ord| and |chr| functions.
475 #define xchr(A) mp->xchr[(A)]
476 #define xord(A) mp->xord[(A)]
479 ASCII_code xord[256]; /* specifies conversion of input characters */
480 text_char xchr[256]; /* specifies conversion of output characters */
482 @ The core system assumes all 8-bit is acceptable. If it is not,
483 a change file has to alter the below section.
484 @^system dependencies@>
486 Additionally, people with extended character sets can
487 assign codes arbitrarily, giving an |xchr| equivalent to whatever
488 characters the users of \MP\ are allowed to have in their input files.
489 Appropriate changes to \MP's |char_class| table should then be made.
490 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
491 codes, called the |char_class|.) Such changes make portability of programs
492 more difficult, so they should be introduced cautiously if at all.
493 @^character set dependencies@>
494 @^system dependencies@>
497 for (i=0;i<=0377;i++) { xchr(i)=(text_char)i; }
499 @ The following system-independent code makes the |xord| array contain a
500 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
501 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
502 |j| or more; hence, standard ASCII code numbers will be used instead of
503 codes below 040 in case there is a coincidence.
506 for (i=0;i<=255;i++) {
509 for (i=0200;i<=0377;i++) { xord(xchr(i))=(ASCII_code)i;}
510 for (i=0;i<=0176;i++) { xord(xchr(i))=(ASCII_code)i;}
512 @* \[3] Input and output.
513 The bane of portability is the fact that different operating systems treat
514 input and output quite differently, perhaps because computer scientists
515 have not given sufficient attention to this problem. People have felt somehow
516 that input and output are not part of ``real'' programming. Well, it is true
517 that some kinds of programming are more fun than others. With existing
518 input/output conventions being so diverse and so messy, the only sources of
519 joy in such parts of the code are the rare occasions when one can find a
520 way to make the program a little less bad than it might have been. We have
521 two choices, either to attack I/O now and get it over with, or to postpone
522 I/O until near the end. Neither prospect is very attractive, so let's
525 The basic operations we need to do are (1)~inputting and outputting of
526 text, to or from a file or the user's terminal; (2)~inputting and
527 outputting of eight-bit bytes, to or from a file; (3)~instructing the
528 operating system to initiate (``open'') or to terminate (``close'') input or
529 output from a specified file; (4)~testing whether the end of an input
530 file has been reached; (5)~display of bits on the user's screen.
531 The bit-display operation will be discussed in a later section; we shall
532 deal here only with more traditional kinds of I/O.
534 @ Finding files happens in a slightly roundabout fashion: the \MP\
535 instance object contains a field that holds a function pointer that finds a
536 file, and returns its name, or NULL. For this, it receives three
537 parameters: the non-qualified name |fname|, the intended |fopen|
538 operation type |fmode|, and the type of the file |ftype|.
540 The file types that are passed on in |ftype| can be used to
541 differentiate file searches if a library like kpathsea is used,
542 the fopen mode is passed along for the same reason.
545 typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
547 @ @<Exported types@>=
549 mp_filetype_terminal = 0, /* the terminal */
550 mp_filetype_error, /* the terminal */
551 mp_filetype_program , /* \MP\ language input */
552 mp_filetype_log, /* the log file */
553 mp_filetype_postscript, /* the postscript output */
554 mp_filetype_memfile, /* memory dumps */
555 mp_filetype_metrics, /* TeX font metric files */
556 mp_filetype_fontmap, /* PostScript font mapping files */
557 mp_filetype_font, /* PostScript type1 font programs */
558 mp_filetype_encoding, /* PostScript font encoding files */
559 mp_filetype_text /* first text file for readfrom and writeto primitives */
561 typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
562 typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
563 typedef char *(*mp_file_reader)(MP, void *, size_t *);
564 typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
565 typedef void (*mp_file_closer)(MP, void *);
566 typedef int (*mp_file_eoftest)(MP, void *);
567 typedef void (*mp_file_flush)(MP, void *);
568 typedef void (*mp_file_writer)(MP, void *, const char *);
569 typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
571 @ @<Option variables@>=
572 mp_file_finder find_file;
573 mp_file_opener open_file;
574 mp_file_reader read_ascii_file;
575 mp_binfile_reader read_binary_file;
576 mp_file_closer close_file;
577 mp_file_eoftest eof_file;
578 mp_file_flush flush_file;
579 mp_file_writer write_ascii_file;
580 mp_binfile_writer write_binary_file;
582 @ The default function for finding files is |mp_find_file|. It is
583 pretty stupid: it will only find files in the current directory.
585 This function may disappear altogether, it is currently only
586 used for the default font map file.
589 static char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
591 if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
592 return mp_strdup(fname);
597 @ Because |mp_find_file| is used so early, it has to be in the helpers
601 static char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
602 static void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
603 static char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
604 static void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
605 static void mp_close_file (MP mp, void *f) ;
606 static int mp_eof_file (MP mp, void *f) ;
607 static void mp_flush_file (MP mp, void *f) ;
608 static void mp_write_ascii_file (MP mp, void *f, const char *s) ;
609 static void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
611 @ The function to open files can now be very short.
614 void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
617 realmode[0] = *fmode;
620 if (ftype==mp_filetype_terminal) {
621 return (fmode[0] == 'r' ? stdin : stdout);
622 } else if (ftype==mp_filetype_error) {
624 } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
625 return (void *)fopen(fname, realmode);
630 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
633 char name_of_file[file_name_size+1]; /* the name of a system file */
634 int name_length;/* this many characters are actually
635 relevant in |name_of_file| (the rest are blank) */
637 @ @<Option variables@>=
638 int print_found_names; /* configuration parameter */
640 @ If this parameter is true, the terminal and log will report the found
641 file names for input files instead of the requested ones.
642 It is off by default because it creates an extra filename lookup.
644 @<Allocate or initialize ...@>=
645 mp->print_found_names = (opt->print_found_names>0 ? true : false);
647 @ \MP's file-opening procedures return |false| if no file identified by
648 |name_of_file| could be opened.
650 The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
651 It is not used for opening a mem file for read, because that file name
655 if (mp->print_found_names) {
656 char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
658 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
659 strncpy(mp->name_of_file,s,file_name_size);
665 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
668 return (*f ? true : false)
671 static boolean mp_a_open_in (MP mp, void **f, int ftype) {
672 /* open a text file for input */
676 boolean mp_w_open_in (MP mp, void **f) {
677 /* open a word file for input */
678 *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
679 return (*f ? true : false);
682 static boolean mp_a_open_out (MP mp, void **f, int ftype) {
683 /* open a text file for output */
687 static boolean mp_b_open_out (MP mp, void **f, int ftype) {
688 /* open a binary file for output */
692 boolean mp_w_open_out (MP mp, void **f) {
693 /* open a word file for output */
694 int ftype = mp_filetype_memfile;
698 @ @<Internal library ...@>=
699 boolean mp_w_open_out (MP mp, void **f);
702 static char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
704 size_t len = 0, lim = 128;
706 FILE *f = (FILE *)ff;
708 (void) mp; /* for -Wunused */
715 if (s==NULL) return NULL;
716 while (c!=EOF && c!='\n' && c!='\r') {
718 s =realloc(s, (lim+(lim>>2)));
719 if (s==NULL) return NULL;
727 if (c!=EOF && c!='\n')
736 void mp_write_ascii_file (MP mp, void *f, const char *s) {
744 void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
748 len = fread(*data,1,*size,(FILE *)f);
753 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
756 (void)fwrite(s,size,1,(FILE *)f);
761 void mp_close_file (MP mp, void *f) {
768 int mp_eof_file (MP mp, void *f) {
771 return feof((FILE *)f);
777 void mp_flush_file (MP mp, void *f) {
783 @ Input from text files is read one line at a time, using a routine called
784 |input_ln|. This function is defined in terms of global variables called
785 |buffer|, |first|, and |last| that will be described in detail later; for
786 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
787 values, and that |first| and |last| are indices into this array
788 representing the beginning and ending of a line of text.
791 size_t buf_size; /* maximum number of characters simultaneously present in
792 current lines of open files */
793 ASCII_code *buffer; /* lines of characters being read */
794 size_t first; /* the first unused position in |buffer| */
795 size_t last; /* end of the line just input to |buffer| */
796 size_t max_buf_stack; /* largest index used in |buffer| */
798 @ @<Allocate or initialize ...@>=
800 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
802 @ @<Dealloc variables@>=
806 static void mp_reallocate_buffer(MP mp, size_t l) {
808 if (l>max_halfword) {
809 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
811 buffer = xmalloc((l+1),sizeof(ASCII_code));
812 memcpy(buffer,mp->buffer,(mp->buf_size+1));
814 mp->buffer = buffer ;
818 @ The |input_ln| function brings the next line of input from the specified
819 field into available positions of the buffer array and returns the value
820 |true|, unless the file has already been entirely read, in which case it
821 returns |false| and sets |last:=first|. In general, the |ASCII_code|
822 numbers that represent the next line of the file are input into
823 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
824 global variable |last| is set equal to |first| plus the length of the
825 line. Trailing blanks are removed from the line; thus, either |last=first|
826 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
829 The variable |max_buf_stack|, which is used to keep track of how large
830 the |buf_size| parameter must be to accommodate the present job, is
831 also kept up to date by |input_ln|.
834 static boolean mp_input_ln (MP mp, void *f ) {
835 /* inputs the next line or returns |false| */
838 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
839 s = (mp->read_ascii_file)(mp,f, &size);
843 mp->last = mp->first+size;
844 if ( mp->last>=mp->max_buf_stack ) {
845 mp->max_buf_stack=mp->last+1;
846 while ( mp->max_buf_stack>=mp->buf_size ) {
847 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
850 memcpy((mp->buffer+mp->first),s,size);
851 /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
857 @ The user's terminal acts essentially like other files of text, except
858 that it is used both for input and for output. When the terminal is
859 considered an input file, the file variable is called |term_in|, and when it
860 is considered an output file the file variable is |term_out|.
861 @^system dependencies@>
864 void * term_in; /* the terminal as an input file */
865 void * term_out; /* the terminal as an output file */
866 void * err_out; /* the terminal as an output file */
868 @ Here is how to open the terminal files. In the default configuration,
869 nothing happens except that the command line (if there is one) is copied
870 to the input buffer. The variable |command_line| will be filled by the
871 |main| procedure. The copying can not be done earlier in the program
872 logic because in the |INI| version, the |buffer| is also used for primitive
875 @d t_open_out do {/* open the terminal for text output */
876 mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
877 mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
879 @d t_open_in do { /* open the terminal for text input */
880 mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
881 if (mp->command_line!=NULL) {
882 mp->last = strlen(mp->command_line);
883 strncpy((char *)mp->buffer,mp->command_line,mp->last);
884 xfree(mp->command_line);
890 @<Option variables@>=
893 @ Sometimes it is necessary to synchronize the input/output mixture that
894 happens on the user's terminal, and three system-dependent
895 procedures are used for this
896 purpose. The first of these, |update_terminal|, is called when we want
897 to make sure that everything we have output to the terminal so far has
898 actually left the computer's internal buffers and been sent.
899 The second, |clear_terminal|, is called when we wish to cancel any
900 input that the user may have typed ahead (since we are about to
901 issue an unexpected error message). The third, |wake_up_terminal|,
902 is supposed to revive the terminal if the user has disabled it by
903 some instruction to the operating system. The following macros show how
904 these operations can be specified:
905 @^system dependencies@>
908 #define update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
909 #define clear_terminal do_nothing /* clear the terminal input buffer */
910 #define wake_up_terminal (mp->flush_file)(mp,mp->term_out)
911 /* cancel the user's cancellation of output */
913 @ We need a special routine to read the first line of \MP\ input from
914 the user's terminal. This line is different because it is read before we
915 have opened the transcript file; there is sort of a ``chicken and
916 egg'' problem here. If the user types `\.{input cmr10}' on the first
917 line, or if some macro invoked by that line does such an \.{input},
918 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
919 commands are performed during the first line of terminal input, the transcript
920 file will acquire its default name `\.{mpout.log}'. (The transcript file
921 will not contain error messages generated by the first line before the
922 first \.{input} command.)
924 The first line is even more special. It's nice to let the user start
925 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
926 such a case, \MP\ will operate as if the first line of input were
927 `\.{cmr10}', i.e., the first line will consist of the remainder of the
928 command line, after the part that invoked \MP.
930 @ Different systems have different ways to get started. But regardless of
931 what conventions are adopted, the routine that initializes the terminal
932 should satisfy the following specifications:
934 \yskip\textindent{1)}It should open file |term_in| for input from the
935 terminal. (The file |term_out| will already be open for output to the
938 \textindent{2)}If the user has given a command line, this line should be
939 considered the first line of terminal input. Otherwise the
940 user should be prompted with `\.{**}', and the first line of input
941 should be whatever is typed in response.
943 \textindent{3)}The first line of input, which might or might not be a
944 command line, should appear in locations |first| to |last-1| of the
947 \textindent{4)}The global variable |loc| should be set so that the
948 character to be read next by \MP\ is in |buffer[loc]|. This
949 character should not be blank, and we should have |loc<last|.
951 \yskip\noindent(It may be necessary to prompt the user several times
952 before a non-blank line comes in. The prompt is `\.{**}' instead of the
953 later `\.*' because the meaning is slightly different: `\.{input}' need
954 not be typed immediately after~`\.{**}'.)
956 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
959 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
962 loc = 0; mp->first = 0;
966 if (!mp->noninteractive) {
967 wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
970 if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
971 do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
972 @.End of file on the terminal@>
975 loc=(halfword)mp->first;
976 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
978 if ( loc<(int)mp->last ) {
979 return true; /* return unless the line was all blank */
981 if (!mp->noninteractive) {
982 do_fprintf(mp->term_out,"Please type the name of your input file.\n");
988 static boolean mp_init_terminal (MP mp) ;
991 @* \[4] String handling.
992 Symbolic token names and diagnostic messages are variable-length strings
993 of eight-bit characters. Many strings \MP\ uses are simply literals
994 in the compiled source, like the error messages and the names of the
995 internal parameters. Other strings are used or defined from the \MP\ input
996 language, and these have to be interned.
998 \MP\ uses strings more extensively than \MF\ does, but the necessary
999 operations can still be handled with a fairly simple data structure.
1000 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
1001 of the strings, and the array |str_start| contains indices of the starting
1002 points of each string. Strings are referred to by integer numbers, so that
1003 string number |s| comprises the characters |str_pool[j]| for
1004 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
1005 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
1006 location. The first string number not currently in use is |str_ptr|
1007 and |next_str[str_ptr]| begins a list of free string numbers. String
1008 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
1009 string currently being constructed.
1011 String numbers 0 to 255 are reserved for strings that correspond to single
1012 ASCII characters. This is in accordance with the conventions of \.{WEB},
1014 which converts single-character strings into the ASCII code number of the
1015 single character involved, while it converts other strings into integers
1016 and builds a string pool file. Thus, when the string constant \.{"."} appears
1017 in the program below, \.{WEB} converts it into the integer 46, which is the
1018 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
1019 into some integer greater than~255. String number 46 will presumably be the
1020 single character `\..'\thinspace; but some ASCII codes have no standard visible
1021 representation, and \MP\ may need to be able to print an arbitrary
1022 ASCII character, so the first 256 strings are used to specify exactly what
1023 should be printed for each of the 256 possibilities.
1026 typedef int pool_pointer; /* for variables that point into |str_pool| */
1027 typedef int str_number; /* for variables that point into |str_start| */
1030 ASCII_code *str_pool; /* the characters */
1031 pool_pointer *str_start; /* the starting pointers */
1032 str_number *next_str; /* for linking strings in order */
1033 pool_pointer pool_ptr; /* first unused position in |str_pool| */
1034 str_number str_ptr; /* number of the current string being created */
1035 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
1036 str_number init_str_use; /* the initial number of strings in use */
1037 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
1038 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
1040 @ @<Allocate or initialize ...@>=
1041 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
1042 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
1043 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
1045 @ @<Dealloc variables@>=
1046 xfree(mp->str_pool);
1047 xfree(mp->str_start);
1048 xfree(mp->next_str);
1050 @ Most printing is done from |char *|s, but sometimes not. Here are
1051 functions that convert an internal string into a |char *| for use
1052 by the printing routines, and vice versa.
1054 @d str(A) mp_str(mp,A)
1055 @d rts(A) mp_rts(mp,A)
1059 int mp_xstrcmp (const char *a, const char *b);
1060 char * mp_str (MP mp, str_number s);
1063 static str_number mp_rts (MP mp, const char *s);
1064 static str_number mp_make_string (MP mp);
1067 int mp_xstrcmp (const char *a, const char *b) {
1068 if (a==NULL && b==NULL)
1077 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1078 very good: it does not handle nesting over more than one level.
1081 char * mp_str (MP mp, str_number ss) {
1084 if (ss==mp->str_ptr) {
1087 len = (size_t)length(ss);
1088 s = xmalloc(len+1,sizeof(char));
1089 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1094 str_number mp_rts (MP mp, const char *s) {
1095 int r; /* the new string */
1096 int old; /* a possible string in progress */
1100 } else if (strlen(s)==1) {
1104 str_room((integer)strlen(s));
1105 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1106 old = mp_make_string(mp);
1111 r = mp_make_string(mp);
1113 str_room(length(old));
1114 while (i<length(old)) {
1115 append_char((mp->str_start[old]+i));
1117 mp_flush_string(mp,old);
1123 @ Except for |strs_used_up|, the following string statistics are only
1124 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1128 integer strs_used_up; /* strings in use or unused but not reclaimed */
1129 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1130 integer strs_in_use; /* total number of strings actually in use */
1131 integer max_pl_used; /* maximum |pool_in_use| so far */
1132 integer max_strs_used; /* maximum |strs_in_use| so far */
1134 @ Several of the elementary string operations are performed using \.{WEB}
1135 macros instead of functions, because many of the
1136 operations are done quite frequently and we want to avoid the
1137 overhead of procedure calls. For example, here is
1138 a simple macro that computes the length of a string.
1141 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string \# */
1142 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1144 @ The length of the current string is called |cur_length|. If we decide that
1145 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1146 |cur_length| becomes zero.
1148 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1149 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1151 @ Strings are created by appending character codes to |str_pool|.
1152 The |append_char| macro, defined here, does not check to see if the
1153 value of |pool_ptr| has gotten too high; this test is supposed to be
1154 made before |append_char| is used.
1156 To test if there is room to append |l| more characters to |str_pool|,
1157 we shall write |str_room(l)|, which tries to make sure there is enough room
1158 by compacting the string pool if necessary. If this does not work,
1159 |do_compaction| aborts \MP\ and gives an apologetic error message.
1161 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1162 { mp->str_pool[mp->pool_ptr]=(ASCII_code)(A); incr(mp->pool_ptr);
1164 @d str_room(A) /* make sure that the pool hasn't overflowed */
1165 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1166 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1167 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1170 @ The following routine is similar to |str_room(1)| but it uses the
1171 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1172 string space is exhausted.
1175 static void mp_unit_str_room (MP mp);
1178 void mp_unit_str_room (MP mp) {
1179 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1180 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1183 @ \MP's string expressions are implemented in a brute-force way: Every
1184 new string or substring that is needed is simply copied into the string pool.
1185 Space is eventually reclaimed by a procedure called |do_compaction| with
1186 the aid of a simple system system of reference counts.
1187 @^reference counts@>
1189 The number of references to string number |s| will be |str_ref[s]|. The
1190 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1191 positive number of references; such strings will never be recycled. If
1192 a string is ever referred to more than 126 times, simultaneously, we
1193 put it in this category. Hence a single byte suffices to store each |str_ref|.
1195 @d max_str_ref 127 /* ``infinite'' number of references */
1196 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]); }
1201 @ @<Allocate or initialize ...@>=
1202 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1204 @ @<Dealloc variables@>=
1207 @ Here's what we do when a string reference disappears:
1209 @d delete_str_ref(A) {
1210 if ( mp->str_ref[(A)]<max_str_ref ) {
1211 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1212 else mp_flush_string(mp, (A));
1217 static void mp_flush_string (MP mp,str_number s) ;
1219 @ We can't flush the first set of static strings at all, so there
1220 is no point in trying
1223 void mp_flush_string (MP mp,str_number s) {
1225 mp->pool_in_use=mp->pool_in_use-length(s);
1226 decr(mp->strs_in_use);
1227 if ( mp->next_str[s]!=mp->str_ptr ) {
1231 decr(mp->strs_used_up);
1233 mp->pool_ptr=mp->str_start[mp->str_ptr];
1237 @ C literals cannot be simply added, they need to be set so they can't
1240 @d intern(A) mp_intern(mp,(A))
1243 str_number mp_intern (MP mp, const char *s) {
1246 mp->str_ref[r] = max_str_ref;
1251 static str_number mp_intern (MP mp, const char *s);
1254 @ Once a sequence of characters has been appended to |str_pool|, it
1255 officially becomes a string when the function |make_string| is called.
1256 This function returns the identification number of the new string as its
1259 When getting the next unused string number from the linked list, we pretend
1261 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1262 are linked sequentially even though the |next_str| entries have not been
1263 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1264 |do_compaction| is responsible for making sure of this.
1267 static str_number mp_make_string (MP mp);
1270 str_number mp_make_string (MP mp) { /* current string enters the pool */
1271 str_number s; /* the new string */
1274 mp->str_ptr=mp->next_str[s];
1275 if ( mp->str_ptr>mp->max_str_ptr ) {
1276 if ( mp->str_ptr==mp->max_strings ) {
1278 mp_do_compaction(mp, 0);
1281 mp->max_str_ptr=mp->str_ptr;
1282 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1286 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1287 incr(mp->strs_used_up);
1288 incr(mp->strs_in_use);
1289 mp->pool_in_use=mp->pool_in_use+length(s);
1290 if ( mp->pool_in_use>mp->max_pl_used )
1291 mp->max_pl_used=mp->pool_in_use;
1292 if ( mp->strs_in_use>mp->max_strs_used )
1293 mp->max_strs_used=mp->strs_in_use;
1297 @ The most interesting string operation is string pool compaction. The idea
1298 is to recover unused space in the |str_pool| array by recopying the strings
1299 to close the gaps created when some strings become unused. All string
1300 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1301 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1302 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1303 with |needed=mp->pool_size| supresses all overflow tests.
1305 The compaction process starts with |last_fixed_str| because all lower numbered
1306 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1309 str_number last_fixed_str; /* last permanently allocated string */
1310 str_number fixed_str_use; /* number of permanently allocated strings */
1312 @ @<Internal library ...@>=
1313 void mp_do_compaction (MP mp, pool_pointer needed) ;
1316 void mp_do_compaction (MP mp, pool_pointer needed) {
1317 str_number str_use; /* a count of strings in use */
1318 str_number r,s,t; /* strings being manipulated */
1319 pool_pointer p,q; /* destination and source for copying string characters */
1320 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1321 r=mp->last_fixed_str;
1324 while ( s!=mp->str_ptr ) {
1325 while ( mp->str_ref[s]==0 ) {
1326 @<Advance |s| and add the old |s| to the list of free string numbers;
1327 then |break| if |s=str_ptr|@>;
1329 r=s; s=mp->next_str[s];
1331 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1332 after the end of the string@>;
1335 @<Move the current string back so that it starts at |p|@>;
1336 if ( needed<mp->pool_size ) {
1337 @<Make sure that there is room for another string with |needed| characters@>;
1339 @<Account for the compaction and make sure the statistics agree with the
1341 mp->strs_used_up=str_use;
1344 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1345 t=mp->next_str[mp->last_fixed_str];
1346 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1347 incr(mp->fixed_str_use);
1348 mp->last_fixed_str=t;
1351 str_use=mp->fixed_str_use
1353 @ Because of the way |flush_string| has been written, it should never be
1354 necessary to |break| here. The extra line of code seems worthwhile to
1355 preserve the generality of |do_compaction|.
1357 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1362 mp->next_str[t]=mp->next_str[mp->str_ptr];
1363 mp->next_str[mp->str_ptr]=t;
1364 if ( s==mp->str_ptr ) goto DONE;
1367 @ The string currently starts at |str_start[r]| and ends just before
1368 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1369 to locate the next string.
1371 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1374 while ( q<mp->str_start[s] ) {
1375 mp->str_pool[p]=mp->str_pool[q];
1379 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1380 we do this, anything between them should be moved.
1382 @ @<Move the current string back so that it starts at |p|@>=
1383 q=mp->str_start[mp->str_ptr];
1384 mp->str_start[mp->str_ptr]=p;
1385 while ( q<mp->pool_ptr ) {
1386 mp->str_pool[p]=mp->str_pool[q];
1391 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1393 @<Make sure that there is room for another string with |needed| char...@>=
1394 if ( str_use>=mp->max_strings-1 )
1395 mp_reallocate_strings (mp,str_use);
1396 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1397 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1398 mp->max_pool_ptr=mp->pool_ptr+needed;
1401 @ @<Internal library ...@>=
1402 void mp_reallocate_strings (MP mp, str_number str_use) ;
1403 void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1406 void mp_reallocate_strings (MP mp, str_number str_use) {
1407 while ( str_use>=mp->max_strings-1 ) {
1408 int l = mp->max_strings + (mp->max_strings/4);
1409 XREALLOC (mp->str_ref, l, int);
1410 XREALLOC (mp->str_start, l, pool_pointer);
1411 XREALLOC (mp->next_str, l, str_number);
1412 mp->max_strings = l;
1415 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1416 while ( needed>mp->pool_size ) {
1417 int l = mp->pool_size + (mp->pool_size/4);
1418 XREALLOC (mp->str_pool, l, ASCII_code);
1423 @ @<Account for the compaction and make sure the statistics agree with...@>=
1424 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1425 mp_confusion(mp, "string");
1426 @:this can't happen string}{\quad string@>
1427 incr(mp->pact_count);
1428 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1429 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1431 @ A few more global variables are needed to keep track of statistics when
1432 |stat| $\ldots$ |tats| blocks are not commented out.
1435 integer pact_count; /* number of string pool compactions so far */
1436 integer pact_chars; /* total number of characters moved during compactions */
1437 integer pact_strs; /* total number of strings moved during compactions */
1439 @ @<Initialize compaction statistics@>=
1444 @ The following subroutine compares string |s| with another string of the
1445 same length that appears in |buffer| starting at position |k|;
1446 the result is |true| if and only if the strings are equal.
1449 static boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1450 /* test equality of strings */
1451 pool_pointer j; /* running index */
1453 while ( j<str_stop(s) ) {
1454 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1460 @ Here is a similar routine, but it compares two strings in the string pool,
1461 and it does not assume that they have the same length. If the first string
1462 is lexicographically greater than, less than, or equal to the second,
1463 the result is respectively positive, negative, or zero.
1466 static integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1467 /* test equality of strings */
1468 pool_pointer j,k; /* running indices */
1469 integer ls,lt; /* lengths */
1470 integer l; /* length remaining to test */
1471 ls=length(s); lt=length(t);
1472 if ( ls<=lt ) l=ls; else l=lt;
1473 j=mp->str_start[s]; k=mp->str_start[t];
1475 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1476 return (mp->str_pool[j]-mp->str_pool[k]);
1483 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1484 and |str_ptr| are computed by the \.{INIMP} program, based in part
1485 on the information that \.{WEB} has output while processing \MP.
1490 void mp_get_strings_started (MP mp) {
1491 /* initializes the string pool,
1492 but returns |false| if something goes wrong */
1493 int k; /* small indices or counters */
1494 str_number g; /* a new string */
1495 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1498 mp->pool_in_use=0; mp->strs_in_use=0;
1499 mp->max_pl_used=0; mp->max_strs_used=0;
1500 @<Initialize compaction statistics@>;
1502 @<Make the first 256 strings@>;
1503 g=mp_make_string(mp); /* string 256 == "" */
1504 mp->str_ref[g]=max_str_ref;
1505 mp->last_fixed_str=mp->str_ptr-1;
1506 mp->fixed_str_use=mp->str_ptr;
1511 static void mp_get_strings_started (MP mp);
1513 @ The first 256 strings will consist of a single character only.
1515 @<Make the first 256...@>=
1516 for (k=0;k<=255;k++) {
1518 g=mp_make_string(mp);
1519 mp->str_ref[g]=max_str_ref;
1522 @ The first 128 strings will contain 95 standard ASCII characters, and the
1523 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1524 unless a system-dependent change is made here. Installations that have
1525 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1526 would like string 032 to be printed as the single character 032 instead
1527 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1528 even people with an extended character set will want to represent string
1529 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1530 to produce visible strings instead of tabs or line-feeds or carriage-returns
1531 or bell-rings or characters that are treated anomalously in text files.
1533 The boolean expression defined here should be |true| unless \MP\ internal
1534 code number~|k| corresponds to a non-troublesome visible symbol in the
1535 local character set.
1536 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1537 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1539 @^character set dependencies@>
1540 @^system dependencies@>
1542 @<Character |k| cannot be printed@>=
1545 @* \[5] On-line and off-line printing.
1546 Messages that are sent to a user's terminal and to the transcript-log file
1547 are produced by several `|print|' procedures. These procedures will
1548 direct their output to a variety of places, based on the setting of
1549 the global variable |selector|, which has the following possible
1553 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1556 \hang |log_only|, prints only on the transcript file.
1558 \hang |term_only|, prints only on the terminal.
1560 \hang |no_print|, doesn't print at all. This is used only in rare cases
1561 before the transcript file is open.
1563 \hang |pseudo|, puts output into a cyclic buffer that is used
1564 by the |show_context| routine; when we get to that routine we shall discuss
1565 the reasoning behind this curious mode.
1567 \hang |new_string|, appends the output to the current string in the
1570 \hang |>=write_file| prints on one of the files used for the \&{write}
1571 @:write_}{\&{write} primitive@>
1575 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1576 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1577 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1578 relations are not used when |selector| could be |pseudo|, or |new_string|.
1579 We need not check for unprintable characters when |selector<pseudo|.
1581 Three additional global variables, |tally|, |term_offset| and |file_offset|
1582 record the number of characters that have been printed
1583 since they were most recently cleared to zero. We use |tally| to record
1584 the length of (possibly very long) stretches of printing; |term_offset|,
1585 and |file_offset|, on the other hand, keep track of how many
1586 characters have appeared so far on the current line that has been output
1587 to the terminal, the transcript file, or the \ps\ output file, respectively.
1589 @d new_string 0 /* printing is deflected to the string pool */
1590 @d pseudo 2 /* special |selector| setting for |show_context| */
1591 @d no_print 3 /* |selector| setting that makes data disappear */
1592 @d term_only 4 /* printing is destined for the terminal only */
1593 @d log_only 5 /* printing is destined for the transcript file only */
1594 @d term_and_log 6 /* normal |selector| setting */
1595 @d write_file 7 /* first write file selector */
1598 void * log_file; /* transcript of \MP\ session */
1599 void * ps_file; /* the generic font output goes here */
1600 unsigned int selector; /* where to print a message */
1601 unsigned char dig[23]; /* digits in a number, for rounding */
1602 integer tally; /* the number of characters recently printed */
1603 unsigned int term_offset;
1604 /* the number of characters on the current terminal line */
1605 unsigned int file_offset;
1606 /* the number of characters on the current file line */
1607 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1608 integer trick_count; /* threshold for pseudoprinting, explained later */
1609 integer first_count; /* another variable for pseudoprinting */
1611 @ @<Allocate or initialize ...@>=
1612 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1614 @ @<Dealloc variables@>=
1615 xfree(mp->trick_buf);
1617 @ @<Initialize the output routines@>=
1618 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
1620 @ Macro abbreviations for output to the terminal and to the log file are
1621 defined here for convenience. Some systems need special conventions
1622 for terminal output, and it is possible to adhere to those conventions
1623 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1624 @^system dependencies@>
1627 #define do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
1628 #define wterm(A) do_fprintf(mp->term_out,(A))
1629 #define wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0'; wterm((char *)ss);}
1630 #define wterm_cr do_fprintf(mp->term_out,"\n")
1631 #define wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
1632 #define wlog(A) do_fprintf(mp->log_file,(A))
1633 #define wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0'; wlog((char *)ss);}
1634 #define wlog_cr do_fprintf(mp->log_file, "\n")
1635 #define wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
1638 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1639 use an array |wr_file| that will be declared later.
1641 @d mp_print_text(A) mp_print_str(mp,text((A)))
1643 @<Internal library ...@>=
1644 void mp_print (MP mp, const char *s);
1645 void mp_print_ln (MP mp);
1646 void mp_print_visible_char (MP mp, ASCII_code s);
1647 void mp_print_char (MP mp, ASCII_code k);
1648 void mp_print_str (MP mp, str_number s);
1649 void mp_print_nl (MP mp, const char *s);
1650 void mp_print_two (MP mp,scaled x, scaled y) ;
1651 void mp_print_scaled (MP mp,scaled s);
1653 @ @<Basic print...@>=
1654 void mp_print_ln (MP mp) { /* prints an end-of-line */
1655 switch (mp->selector) {
1658 mp->term_offset=0; mp->file_offset=0;
1661 wlog_cr; mp->file_offset=0;
1664 wterm_cr; mp->term_offset=0;
1671 do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1673 } /* note that |tally| is not affected */
1675 @ The |print_visible_char| procedure sends one character to the desired
1676 destination, using the |xchr| array to map it into an external character
1677 compatible with |input_ln|. (It assumes that it is always called with
1678 a visible ASCII character.) All printing comes through |print_ln| or
1679 |print_char|, which ultimately calls |print_visible_char|, hence these
1680 routines are the ones that limit lines to at most |max_print_line| characters.
1681 But we must make an exception for the \ps\ output file since it is not safe
1682 to cut up lines arbitrarily in \ps.
1684 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1685 |do_compaction| and |do_compaction| can call the error routines. Actually,
1686 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1688 @<Basic printing...@>=
1689 void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1690 switch (mp->selector) {
1692 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1693 incr(mp->term_offset); incr(mp->file_offset);
1694 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1695 wterm_cr; mp->term_offset=0;
1697 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1698 wlog_cr; mp->file_offset=0;
1702 wlog_chr(xchr(s)); incr(mp->file_offset);
1703 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1706 wterm_chr(xchr(s)); incr(mp->term_offset);
1707 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1712 if ( mp->tally<mp->trick_count )
1713 mp->trick_buf[mp->tally % mp->error_line]=s;
1716 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1717 mp_unit_str_room(mp);
1718 if ( mp->pool_ptr>=mp->pool_size )
1719 goto DONE; /* drop characters if string space is full */
1724 { text_char ss[2]; ss[0] = xchr(s); ss[1]=0;
1725 do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
1732 @ The |print_char| procedure sends one character to the desired destination.
1733 File names and string expressions might contain |ASCII_code| values that
1734 can't be printed using |print_visible_char|. These characters will be
1735 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1736 (This procedure assumes that it is safe to bypass all checks for unprintable
1737 characters when |selector| is in the range |0..max_write_files-1|.
1738 The user might want to write unprintable characters.
1740 @<Basic printing...@>=
1741 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1742 if ( mp->selector<pseudo || mp->selector>=write_file) {
1743 mp_print_visible_char(mp, k);
1744 } else if ( @<Character |k| cannot be printed@> ) {
1747 mp_print_visible_char(mp, k+0100);
1748 } else if ( k<0200 ) {
1749 mp_print_visible_char(mp, k-0100);
1751 int l; /* small index or counter */
1753 mp_print_visible_char(mp, xord(l<10 ? l+'0' : l-10+'a'));
1755 mp_print_visible_char(mp, xord(l<10 ? l+'0' : l-10+'a'));
1758 mp_print_visible_char(mp, k);
1762 @ An entire string is output by calling |print|. Note that if we are outputting
1763 the single standard ASCII character \.c, we could call |print("c")|, since
1764 |"c"=99| is the number of a single-character string, as explained above. But
1765 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1766 routine when it knows that this is safe. (The present implementation
1767 assumes that it is always safe to print a visible ASCII character.)
1768 @^system dependencies@>
1771 static void mp_do_print (MP mp, const char *ss, size_t len) { /* prints string |s| */
1774 mp_print_char(mp, xord((int)ss[j])); j++;
1780 void mp_print (MP mp, const char *ss) {
1781 if (ss==NULL) return;
1782 mp_do_print(mp, ss,strlen(ss));
1784 void mp_print_str (MP mp, str_number s) {
1785 pool_pointer j; /* current character code position */
1786 if ( (s<0)||(s>mp->max_str_ptr) ) {
1787 mp_do_print(mp,"???",3); /* this can't happen */
1791 mp_do_print(mp, (char *)(mp->str_pool+j), (size_t)(str_stop(s)-j));
1795 @ Here is the very first thing that \MP\ prints: a headline that identifies
1796 the version number and base name. The |term_offset| variable is temporarily
1797 incorrect, but the discrepancy is not serious since we assume that the banner
1798 and mem identifier together will occupy at most |max_print_line|
1799 character positions.
1801 @<Initialize the output...@>=
1803 if (mp->mem_ident!=NULL)
1804 mp_print(mp,mp->mem_ident);
1808 @ The procedure |print_nl| is like |print|, but it makes sure that the
1809 string appears at the beginning of a new line.
1812 void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1813 switch(mp->selector) {
1815 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1818 if ( mp->file_offset>0 ) mp_print_ln(mp);
1821 if ( mp->term_offset>0 ) mp_print_ln(mp);
1827 } /* there are no other cases */
1831 @ The following procedure, which prints out the decimal representation of a
1832 given integer |n|, assumes that all integers fit nicely into a |int|.
1833 @^system dependencies@>
1836 void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1838 mp_snprintf(s,12,"%d", (int)n);
1842 @ @<Internal library ...@>=
1843 void mp_print_int (MP mp,integer n);
1845 @ \MP\ also makes use of a trivial procedure to print two digits. The
1846 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1849 static void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1851 mp_print_char(mp, xord('0'+(n / 10)));
1852 mp_print_char(mp, xord('0'+(n % 10)));
1857 static void mp_print_dd (MP mp,integer n);
1859 @ Here is a procedure that asks the user to type a line of input,
1860 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1861 The input is placed into locations |first| through |last-1| of the
1862 |buffer| array, and echoed on the transcript file if appropriate.
1864 This procedure is never called when |interaction<mp_scroll_mode|.
1866 @d prompt_input(A) do {
1867 if (!mp->noninteractive) {
1868 wake_up_terminal; mp_print(mp, (A));
1871 } while (0) /* prints a string and gets a line of input */
1874 void mp_term_input (MP mp) { /* gets a line from the terminal */
1875 size_t k; /* index into |buffer| */
1876 if (mp->noninteractive) {
1877 if (!mp_input_ln(mp, mp->term_in ))
1878 longjmp(*(mp->jump_buf),1); /* chunk finished */
1879 mp->buffer[mp->last]=xord('%');
1881 update_terminal; /* Now the user sees the prompt for sure */
1882 if (!mp_input_ln(mp, mp->term_in )) {
1883 mp_fatal_error(mp, "End of file on the terminal!");
1884 @.End of file on the terminal@>
1886 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1887 decr(mp->selector); /* prepare to echo the input */
1888 if ( mp->last!=mp->first ) {
1889 for (k=mp->first;k<=mp->last-1;k++) {
1890 mp_print_char(mp, mp->buffer[k]);
1894 mp->buffer[mp->last]=xord('%');
1895 incr(mp->selector); /* restore previous status */
1899 @* \[6] Reporting errors.
1900 When something anomalous is detected, \MP\ typically does something like this:
1901 $$\vbox{\halign{#\hfil\cr
1902 |print_err("Something anomalous has been detected");|\cr
1903 |help3("This is the first line of my offer to help.")|\cr
1904 |("This is the second line. I'm trying to")|\cr
1905 |("explain the best way for you to proceed.");|\cr
1907 A two-line help message would be given using |help2|, etc.; these informal
1908 helps should use simple vocabulary that complements the words used in the
1909 official error message that was printed. (Outside the U.S.A., the help
1910 messages should preferably be translated into the local vernacular. Each
1911 line of help is at most 60 characters long, in the present implementation,
1912 so that |max_print_line| will not be exceeded.)
1914 The |print_err| procedure supplies a `\.!' before the official message,
1915 and makes sure that the terminal is awake if a stop is going to occur.
1916 The |error| procedure supplies a `\..' after the official message, then it
1917 shows the location of the error; and if |interaction=error_stop_mode|,
1918 it also enters into a dialog with the user, during which time the help
1919 message may be printed.
1920 @^system dependencies@>
1922 @ The global variable |interaction| has four settings, representing increasing
1923 amounts of user interaction:
1926 enum mp_interaction_mode {
1927 mp_unspecified_mode=0, /* extra value for command-line switch */
1928 mp_batch_mode, /* omits all stops and omits terminal output */
1929 mp_nonstop_mode, /* omits all stops */
1930 mp_scroll_mode, /* omits error stops */
1931 mp_error_stop_mode /* stops at every opportunity to interact */
1934 @ @<Option variables@>=
1935 int interaction; /* current level of interaction */
1936 int noninteractive; /* do we have a terminal? */
1938 @ Set it here so it can be overwritten by the commandline
1940 @<Allocate or initialize ...@>=
1941 mp->interaction=opt->interaction;
1942 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
1943 mp->interaction=mp_error_stop_mode;
1944 if (mp->interaction<mp_unspecified_mode)
1945 mp->interaction=mp_batch_mode;
1949 @d print_err(A) mp_print_err(mp,(A))
1952 void mp_print_err(MP mp, const char * A);
1955 void mp_print_err(MP mp, const char * A) {
1956 if ( mp->interaction==mp_error_stop_mode )
1958 mp_print_nl(mp, "! ");
1964 @ \MP\ is careful not to call |error| when the print |selector| setting
1965 might be unusual. The only possible values of |selector| at the time of
1968 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
1969 and |log_file| not yet open);
1971 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
1973 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
1975 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
1977 @<Initialize the print |selector| based on |interaction|@>=
1978 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
1980 @ A global variable |deletions_allowed| is set |false| if the |get_next|
1981 routine is active when |error| is called; this ensures that |get_next|
1982 will never be called recursively.
1985 The global variable |history| records the worst level of error that
1986 has been detected. It has four possible values: |spotless|, |warning_issued|,
1987 |error_message_issued|, and |fatal_error_stop|.
1989 Another global variable, |error_count|, is increased by one when an
1990 |error| occurs without an interactive dialog, and it is reset to zero at
1991 the end of every statement. If |error_count| reaches 100, \MP\ decides
1992 that there is no point in continuing further.
1995 enum mp_history_state {
1996 mp_spotless=0, /* |history| value when nothing has been amiss yet */
1997 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
1998 mp_error_message_issued, /* |history| value when |error| has been called */
1999 mp_fatal_error_stop, /* |history| value when termination was premature */
2000 mp_system_error_stop /* |history| value when termination was due to disaster */
2004 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
2005 int history; /* has the source input been clean so far? */
2006 int error_count; /* the number of scrolled errors since the last statement ended */
2008 @ The value of |history| is initially |fatal_error_stop|, but it will
2009 be changed to |spotless| if \MP\ survives the initialization process.
2011 @<Allocate or ...@>=
2012 mp->deletions_allowed=true; /* |history| is initialized elsewhere */
2014 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2015 error procedures near the beginning of the program. But the error procedures
2016 in turn use some other procedures, which need to be declared |forward|
2017 before we get to |error| itself.
2019 It is possible for |error| to be called recursively if some error arises
2020 when |get_next| is being used to delete a token, and/or if some fatal error
2021 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2023 is never more than two levels deep.
2026 static void mp_get_next (MP mp);
2027 static void mp_term_input (MP mp);
2028 static void mp_show_context (MP mp);
2029 static void mp_begin_file_reading (MP mp);
2030 static void mp_open_log_file (MP mp);
2031 static void mp_clear_for_error_prompt (MP mp);
2034 void mp_normalize_selector (MP mp);
2036 @ Individual lines of help are recorded in the array |help_line|, which
2037 contains entries in positions |0..(help_ptr-1)|. They should be printed
2038 in reverse order, i.e., with |help_line[0]| appearing last.
2040 @d hlp1(A) mp->help_line[0]=A; }
2041 @d hlp2(A,B) mp->help_line[1]=A; hlp1(B)
2042 @d hlp3(A,B,C) mp->help_line[2]=A; hlp2(B,C)
2043 @d hlp4(A,B,C,D) mp->help_line[3]=A; hlp3(B,C,D)
2044 @d hlp5(A,B,C,D,E) mp->help_line[4]=A; hlp4(B,C,D,E)
2045 @d hlp6(A,B,C,D,E,F) mp->help_line[5]=A; hlp5(B,C,D,E,F)
2046 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2047 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2048 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2049 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2050 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2051 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2052 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2055 const char * help_line[6]; /* helps for the next |error| */
2056 unsigned int help_ptr; /* the number of help lines present */
2057 boolean use_err_help; /* should the |err_help| string be shown? */
2058 str_number err_help; /* a string set up by \&{errhelp} */
2059 str_number filename_template; /* a string set up by \&{filenametemplate} */
2061 @ @<Allocate or ...@>=
2062 mp->use_err_help=false;
2064 @ The |jump_out| procedure just cuts across all active procedure levels and
2065 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2066 whole program. It is used when there is no recovery from a particular error.
2068 The program uses a |jump_buf| to handle this, this is initialized at three
2069 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2070 of |mp_run|. Those are the only library enty points.
2072 @^system dependencies@>
2077 @ If the array of internals is still |NULL| when |jump_out| is called, a
2078 crash occured during initialization, and it is not safe to run the normal
2082 static void mp_jump_out (MP mp) {
2083 if (mp->internal!=NULL && mp->history < mp_system_error_stop)
2084 mp_close_files_and_terminate(mp);
2085 longjmp(*(mp->jump_buf),1);
2088 @ Here now is the general |error| routine.
2091 void mp_error (MP mp) { /* completes the job of error reporting */
2092 ASCII_code c; /* what the user types */
2093 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2094 pool_pointer j; /* character position being printed */
2095 if ( mp->history<mp_error_message_issued )
2096 mp->history=mp_error_message_issued;
2097 mp_print_char(mp, xord('.')); mp_show_context(mp);
2098 if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
2099 @<Get user's advice and |return|@>;
2101 incr(mp->error_count);
2102 if ( mp->error_count==100 ) {
2103 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2104 @.That makes 100 errors...@>
2105 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2107 @<Put help message on the transcript file@>;
2109 void mp_warn (MP mp, const char *msg) {
2110 unsigned saved_selector = mp->selector;
2111 mp_normalize_selector(mp);
2112 mp_print_nl(mp,"Warning: ");
2115 mp->selector = saved_selector;
2118 @ @<Exported function ...@>=
2119 extern void mp_error (MP mp);
2120 extern void mp_warn (MP mp, const char *msg);
2123 @ @<Get user's advice...@>=
2126 mp_clear_for_error_prompt(mp); prompt_input("? ");
2128 if ( mp->last==mp->first ) return;
2129 c=mp->buffer[mp->first];
2130 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2131 @<Interpret code |c| and |return| if done@>;
2134 @ It is desirable to provide an `\.E' option here that gives the user
2135 an easy way to return from \MP\ to the system editor, with the offending
2136 line ready to be edited. But such an extension requires some system
2137 wizardry, so the present implementation simply types out the name of the
2139 edited and the relevant line number.
2140 @^system dependencies@>
2143 typedef void (*mp_editor_cmd)(MP, char *, int);
2145 @ @<Option variables@>=
2146 mp_editor_cmd run_editor;
2148 @ @<Allocate or initialize ...@>=
2149 set_callback_option(run_editor);
2152 static void mp_run_editor (MP mp, char *fname, int fline);
2155 void mp_run_editor (MP mp, char *fname, int fline) {
2156 char *s = xmalloc(256,1);
2157 mp_snprintf(s, 256,"You want to edit file %s at line %d\n", fname, fline);
2159 @.You want to edit file x@>
2163 There is a secret `\.D' option available when the debugging routines haven't
2167 @<Interpret code |c| and |return| if done@>=
2169 case '0': case '1': case '2': case '3': case '4':
2170 case '5': case '6': case '7': case '8': case '9':
2171 if ( mp->deletions_allowed ) {
2172 @<Delete |c-"0"| tokens and |continue|@>;
2176 if ( mp->file_ptr>0 ){
2177 mp->interaction=mp_scroll_mode;
2178 mp_close_files_and_terminate(mp);
2179 (mp->run_editor)(mp,
2180 str(mp->input_stack[mp->file_ptr].name_field),
2186 @<Print the help information and |continue|@>;
2189 @<Introduce new material from the terminal and |return|@>;
2191 case 'Q': case 'R': case 'S':
2192 @<Change the interaction level and |return|@>;
2195 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2200 @<Print the menu of available options@>
2202 @ @<Print the menu...@>=
2204 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2205 @.Type <return> to proceed...@>
2206 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2207 mp_print_nl(mp, "I to insert something, ");
2208 if ( mp->file_ptr>0 )
2209 mp_print(mp, "E to edit your file,");
2210 if ( mp->deletions_allowed )
2211 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2212 mp_print_nl(mp, "H for help, X to quit.");
2215 @ Here the author of \MP\ apologizes for making use of the numerical
2216 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2217 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2218 @^Knuth, Donald Ervin@>
2220 @<Change the interaction...@>=
2222 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2223 mp_print(mp, "OK, entering ");
2225 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2226 case 'R': mp_print(mp, "nonstopmode"); break;
2227 case 'S': mp_print(mp, "scrollmode"); break;
2228 } /* there are no other cases */
2229 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2232 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2233 contain the material inserted by the user; otherwise another prompt will
2234 be given. In order to understand this part of the program fully, you need
2235 to be familiar with \MP's input stacks.
2237 @<Introduce new material...@>=
2239 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2240 if ( mp->last>mp->first+1 ) {
2241 loc=(halfword)(mp->first+1); mp->buffer[mp->first]=xord(' ');
2243 prompt_input("insert>"); loc=(halfword)mp->first;
2246 mp->first=mp->last+1; mp->cur_input.limit_field=(halfword)mp->last; return;
2249 @ We allow deletion of up to 99 tokens at a time.
2251 @<Delete |c-"0"| tokens...@>=
2253 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2254 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2255 c=xord(c*10+mp->buffer[mp->first+1]-'0'*11);
2259 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2260 @<Decrease the string reference count, if the current token is a string@>;
2263 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2264 help2("I have just deleted some text, as you asked.",
2265 "You can now delete more, or insert, or whatever.");
2266 mp_show_context(mp);
2270 @ @<Print the help info...@>=
2272 if ( mp->use_err_help ) {
2273 @<Print the string |err_help|, possibly on several lines@>;
2274 mp->use_err_help=false;
2276 if ( mp->help_ptr==0 ) {
2277 help2("Sorry, I don't know how to help in this situation.",
2278 "Maybe you should try asking a human?");
2281 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2282 } while (mp->help_ptr!=0);
2284 help4("Sorry, I already gave what help I could...",
2285 "Maybe you should try asking a human?",
2286 "An error might have occurred before I noticed any problems.",
2287 "``If all else fails, read the instructions.''");
2291 @ @<Print the string |err_help|, possibly on several lines@>=
2292 j=mp->str_start[mp->err_help];
2293 while ( j<str_stop(mp->err_help) ) {
2294 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2295 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2296 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2297 else { j++; mp_print_char(mp, xord('%')); };
2301 @ @<Put help message on the transcript file@>=
2302 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2303 if ( mp->use_err_help ) {
2304 mp_print_nl(mp, "");
2305 @<Print the string |err_help|, possibly on several lines@>;
2307 while ( mp->help_ptr>0 ){
2308 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2312 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2315 @ In anomalous cases, the print selector might be in an unknown state;
2316 the following subroutine is called to fix things just enough to keep
2317 running a bit longer.
2320 void mp_normalize_selector (MP mp) {
2321 if ( mp->log_opened ) mp->selector=term_and_log;
2322 else mp->selector=term_only;
2323 if ( mp->job_name==NULL) mp_open_log_file(mp);
2324 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2327 @ The following procedure prints \MP's last words before dying.
2329 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2330 mp->interaction=mp_scroll_mode; /* no more interaction */
2331 if ( mp->log_opened ) mp_error(mp);
2332 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2336 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2337 mp_normalize_selector(mp);
2338 print_err("Emergency stop"); help1(s); succumb;
2342 @ @<Exported function ...@>=
2343 extern void mp_fatal_error (MP mp, const char *s);
2346 @ Here is the most dreaded error message.
2349 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2351 mp_normalize_selector(mp);
2352 mp_snprintf(msg, 256, "MetaPost capacity exceeded, sorry [%s=%d]",s,(int)n);
2353 @.MetaPost capacity exceeded ...@>
2355 help2("If you really absolutely need more capacity,",
2356 "you can ask a wizard to enlarge me.");
2360 @ @<Internal library declarations@>=
2361 void mp_overflow (MP mp, const char *s, integer n);
2363 @ The program might sometime run completely amok, at which point there is
2364 no choice but to stop. If no previous error has been detected, that's bad
2365 news; a message is printed that is really intended for the \MP\
2366 maintenance person instead of the user (unless the user has been
2367 particularly diabolical). The index entries for `this can't happen' may
2368 help to pinpoint the problem.
2371 @<Internal library ...@>=
2372 void mp_confusion (MP mp, const char *s);
2374 @ Consistency check violated; |s| tells where.
2376 void mp_confusion (MP mp, const char *s) {
2378 mp_normalize_selector(mp);
2379 if ( mp->history<mp_error_message_issued ) {
2380 mp_snprintf(msg, 256, "This can't happen (%s)",s);
2381 @.This can't happen@>
2383 help1("I'm broken. Please show this to someone who can fix can fix");
2385 print_err("I can\'t go on meeting you like this");
2386 @.I can't go on...@>
2387 help2("One of your faux pas seems to have wounded me deeply...",
2388 "in fact, I'm barely conscious. Please fix it and try again.");
2393 @ Users occasionally want to interrupt \MP\ while it's running.
2394 If the runtime system allows this, one can implement
2395 a routine that sets the global variable |interrupt| to some nonzero value
2396 when such an interrupt is signaled. Otherwise there is probably at least
2397 a way to make |interrupt| nonzero using the C debugger.
2398 @^system dependencies@>
2401 @d check_interrupt { if ( mp->interrupt!=0 )
2402 mp_pause_for_instructions(mp); }
2405 integer interrupt; /* should \MP\ pause for instructions? */
2406 boolean OK_to_interrupt; /* should interrupts be observed? */
2407 integer run_state; /* are we processing input ?*/
2408 boolean finished; /* set true by |close_files_and_terminate| */
2410 @ @<Allocate or ...@>=
2411 mp->OK_to_interrupt=true;
2414 @ When an interrupt has been detected, the program goes into its
2415 highest interaction level and lets the user have the full flexibility of
2416 the |error| routine. \MP\ checks for interrupts only at times when it is
2420 static void mp_pause_for_instructions (MP mp) {
2421 if ( mp->OK_to_interrupt ) {
2422 mp->interaction=mp_error_stop_mode;
2423 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2425 print_err("Interruption");
2428 "Try to insert some instructions for me (e.g.,`I show x'),",
2429 "unless you just want to quit by typing `X'.");
2430 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2435 @ Many of \MP's error messages state that a missing token has been
2436 inserted behind the scenes. We can save string space and program space
2437 by putting this common code into a subroutine.
2440 static void mp_missing_err (MP mp, const char *s) {
2442 mp_snprintf(msg, 256, "Missing `%s' has been inserted", s);
2443 @.Missing...inserted@>
2447 @* \[7] Arithmetic with scaled numbers.
2448 The principal computations performed by \MP\ are done entirely in terms of
2449 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2450 program can be carried out in exactly the same way on a wide variety of
2451 computers, including some small ones.
2454 But C does not rigidly define the |/| operation in the case of negative
2455 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2456 computers and |-n| on others (is this true ?). There are two principal
2457 types of arithmetic: ``translation-preserving,'' in which the identity
2458 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2459 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2460 different results, although the differences should be negligible when the
2461 language is being used properly. The \TeX\ processor has been defined
2462 carefully so that both varieties of arithmetic will produce identical
2463 output, but it would be too inefficient to constrain \MP\ in a similar way.
2465 @d el_gordo 0x7fffffff /* $2^{31}-1$, the largest value that \MP\ likes */
2468 @ One of \MP's most common operations is the calculation of
2469 $\lfloor{a+b\over2}\rfloor$,
2470 the midpoint of two given integers |a| and~|b|. The most decent way to do
2471 this is to write `|(a+b)/2|'; but on many machines it is more efficient
2472 to calculate `|(a+b)>>1|'.
2474 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2475 in this program. If \MP\ is being implemented with languages that permit
2476 binary shifting, the |half| macro should be changed to make this operation
2477 as efficient as possible. Since some systems have shift operators that can
2478 only be trusted to work on positive numbers, there is also a macro |halfp|
2479 that is used only when the quantity being halved is known to be positive
2482 @d half(A) ((A) / 2)
2483 @d halfp(A) (integer)((unsigned)(A) >> 1)
2485 @ A single computation might use several subroutine calls, and it is
2486 desirable to avoid producing multiple error messages in case of arithmetic
2487 overflow. So the routines below set the global variable |arith_error| to |true|
2488 instead of reporting errors directly to the user.
2489 @^overflow in arithmetic@>
2492 boolean arith_error; /* has arithmetic overflow occurred recently? */
2494 @ @<Allocate or ...@>=
2495 mp->arith_error=false;
2497 @ At crucial points the program will say |check_arith|, to test if
2498 an arithmetic error has been detected.
2500 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2503 static void mp_clear_arith (MP mp) {
2504 print_err("Arithmetic overflow");
2505 @.Arithmetic overflow@>
2506 help4("Uh, oh. A little while ago one of the quantities that I was",
2507 "computing got too large, so I'm afraid your answers will be",
2508 "somewhat askew. You'll probably have to adopt different",
2509 "tactics next time. But I shall try to carry on anyway.");
2511 mp->arith_error=false;
2514 @ Addition is not always checked to make sure that it doesn't overflow,
2515 but in places where overflow isn't too unlikely the |slow_add| routine
2518 @c static integer mp_slow_add (MP mp,integer x, integer y) {
2520 if ( y<=el_gordo-x ) {
2523 mp->arith_error=true;
2526 } else if ( -y<=el_gordo+x ) {
2529 mp->arith_error=true;
2534 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2535 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2536 positions from the right end of a binary computer word.
2538 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2539 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2540 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2541 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2542 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2543 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2546 typedef integer scaled; /* this type is used for scaled integers */
2548 @ The following function is used to create a scaled integer from a given decimal
2549 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2550 given in |dig[i]|, and the calculation produces a correctly rounded result.
2553 static scaled mp_round_decimals (MP mp,quarterword k) {
2554 /* converts a decimal fraction */
2555 unsigned a = 0; /* the accumulator */
2557 a=(a+mp->dig[k]*two) / 10;
2559 return (scaled)halfp(a+1);
2562 @ Conversely, here is a procedure analogous to |print_int|. If the output
2563 of this procedure is subsequently read by \MP\ and converted by the
2564 |round_decimals| routine above, it turns out that the original value will
2565 be reproduced exactly. A decimal point is printed only if the value is
2566 not an integer. If there is more than one way to print the result with
2567 the optimum number of digits following the decimal point, the closest
2568 possible value is given.
2570 The invariant relation in the \&{repeat} loop is that a sequence of
2571 decimal digits yet to be printed will yield the original number if and only if
2572 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2573 We can stop if and only if $f=0$ satisfies this condition; the loop will
2574 terminate before $s$ can possibly become zero.
2576 @<Basic printing...@>=
2577 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2578 scaled delta; /* amount of allowable inaccuracy */
2580 mp_print_char(mp, xord('-'));
2581 negate(s); /* print the sign, if negative */
2583 mp_print_int(mp, s / unity); /* print the integer part */
2587 mp_print_char(mp, xord('.'));
2590 s=s+0100000-(delta / 2); /* round the final digit */
2591 mp_print_char(mp, xord('0'+(s / unity)));
2598 @ We often want to print two scaled quantities in parentheses,
2599 separated by a comma.
2601 @<Basic printing...@>=
2602 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2603 mp_print_char(mp, xord('('));
2604 mp_print_scaled(mp, x);
2605 mp_print_char(mp, xord(','));
2606 mp_print_scaled(mp, y);
2607 mp_print_char(mp, xord(')'));
2610 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2611 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2612 arithmetic with 28~significant bits of precision. A |fraction| denotes
2613 a scaled integer whose binary point is assumed to be 28 bit positions
2616 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2617 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2618 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2619 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2620 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2623 typedef integer fraction; /* this type is used for scaled fractions */
2625 @ In fact, the two sorts of scaling discussed above aren't quite
2626 sufficient; \MP\ has yet another, used internally to keep track of angles
2627 in units of $2^{-20}$ degrees.
2629 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2630 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2631 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2632 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2635 typedef integer angle; /* this type is used for scaled angles */
2637 @ The |make_fraction| routine produces the |fraction| equivalent of
2638 |p/q|, given integers |p| and~|q|; it computes the integer
2639 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2640 positive. If |p| and |q| are both of the same scaled type |t|,
2641 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2642 and it's also possible to use the subroutine ``backwards,'' using
2643 the relation |make_fraction(t,fraction)=t| between scaled types.
2645 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2646 sets |arith_error:=true|. Most of \MP's internal computations have
2647 been designed to avoid this sort of error.
2649 If this subroutine were programmed in assembly language on a typical
2650 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2651 double-precision product can often be input to a fixed-point division
2652 instruction. But when we are restricted to int-eger arithmetic it
2653 is necessary either to resort to multiple-precision maneuvering
2654 or to use a simple but slow iteration. The multiple-precision technique
2655 would be about three times faster than the code adopted here, but it
2656 would be comparatively long and tricky, involving about sixteen
2657 additional multiplications and divisions.
2659 This operation is part of \MP's ``inner loop''; indeed, it will
2660 consume nearly 10\pct! of the running time (exclusive of input and output)
2661 if the code below is left unchanged. A machine-dependent recoding
2662 will therefore make \MP\ run faster. The present implementation
2663 is highly portable, but slow; it avoids multiplication and division
2664 except in the initial stage. System wizards should be careful to
2665 replace it with a routine that is guaranteed to produce identical
2666 results in all cases.
2667 @^system dependencies@>
2669 As noted below, a few more routines should also be replaced by machine-dependent
2670 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2671 such changes aren't advisable; simplicity and robustness are
2672 preferable to trickery, unless the cost is too high.
2675 @<Internal library declarations@>=
2676 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2679 static fraction mp_make_fraction (MP mp,integer p, integer q);
2681 @ If FIXPT is not defined, we need these preprocessor values
2683 @d TWEXP31 2147483648.0
2684 @d TWEXP28 268435456.0
2686 @d TWEXP_16 (1.0/65536.0)
2687 @d TWEXP_28 (1.0/268435456.0)
2691 fraction mp_make_fraction (MP mp,integer p, integer q) {
2693 if ( q==0 ) mp_confusion(mp, "/");
2694 @:this can't happen /}{\quad \./@>
2697 integer f; /* the fraction bits, with a leading 1 bit */
2698 integer n; /* the integer part of $\vert p/q\vert$ */
2699 boolean negative = false; /* should the result be negated? */
2701 negate(p); negative=true;
2704 negate(q); negative = ! negative;
2708 mp->arith_error=true;
2709 i= ( negative ? -el_gordo : el_gordo);
2711 n=(n-1)*fraction_one;
2712 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2713 i = (negative ? (-(f+n)) : (f+n));
2719 d = TWEXP28 * (double)p /(double)q;
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;
2728 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2730 if (d==(double)i && ( ((q>0 ? q : -q)&077777)
2731 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2738 @ The |repeat| loop here preserves the following invariant relations
2739 between |f|, |p|, and~|q|:
2740 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2741 $p_0$ is the original value of~$p$.
2743 Notice that the computation specifies
2744 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2745 Let us hope that optimizing compilers do not miss this point; a
2746 special variable |be_careful| is used to emphasize the necessary
2747 order of computation. Optimizing compilers should keep |be_careful|
2748 in a register, not store it in memory.
2751 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2753 integer be_careful; /* disables certain compiler optimizations */
2756 be_careful=p-q; p=be_careful+p;
2762 } while (f<fraction_one);
2764 if ( be_careful+p>=0 ) incr(f);
2767 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2768 given integer~|q| by a fraction~|f|. When the operands are positive, it
2769 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2772 This routine is even more ``inner loopy'' than |make_fraction|;
2773 the present implementation consumes almost 20\pct! of \MP's computation
2774 time during typical jobs, so a machine-language substitute is advisable.
2775 @^inner loop@> @^system dependencies@>
2777 @<Internal library declarations@>=
2778 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2782 integer mp_take_fraction (MP mp,integer q, fraction f) {
2783 integer p; /* the fraction so far */
2784 boolean negative; /* should the result be negated? */
2785 integer n; /* additional multiple of $q$ */
2786 integer be_careful; /* disables certain compiler optimizations */
2787 @<Reduce to the case that |f>=0| and |q>=0|@>;
2788 if ( f<fraction_one ) {
2791 n=f / fraction_one; f=f % fraction_one;
2792 if ( q<=el_gordo / n ) {
2795 mp->arith_error=true; n=el_gordo;
2799 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2800 be_careful=n-el_gordo;
2801 if ( be_careful+p>0 ){
2802 mp->arith_error=true; n=el_gordo-p;
2809 integer mp_take_fraction (MP mp,integer p, fraction q) {
2812 d = (double)p * (double)q * TWEXP_28;
2816 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2817 mp->arith_error = true;
2821 if (d==(double)i && (((p&077777)*(q&077777))&040000)!=0) --i;
2825 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2826 mp->arith_error = true;
2830 if (d==(double)i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2836 @ @<Reduce to the case that |f>=0| and |q>=0|@>=
2840 negate( f); negative=true;
2843 negate(q); negative=! negative;
2846 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2847 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2848 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2851 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2852 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2853 if ( q<fraction_four ) {
2855 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2860 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2866 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2867 analogous to |take_fraction| but with a different scaling.
2868 Given positive operands, |take_scaled|
2869 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2871 Once again it is a good idea to use a machine-language replacement if
2872 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2873 when the Computer Modern fonts are being generated.
2878 integer mp_take_scaled (MP mp,integer q, scaled f) {
2879 integer p; /* the fraction so far */
2880 boolean negative; /* should the result be negated? */
2881 integer n; /* additional multiple of $q$ */
2882 integer be_careful; /* disables certain compiler optimizations */
2883 @<Reduce to the case that |f>=0| and |q>=0|@>;
2887 n=f / unity; f=f % unity;
2888 if ( q<=el_gordo / n ) {
2891 mp->arith_error=true; n=el_gordo;
2895 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2896 be_careful=n-el_gordo;
2897 if ( be_careful+p>0 ) {
2898 mp->arith_error=true; n=el_gordo-p;
2900 return ( negative ?(-(n+p)) :(n+p));
2902 integer mp_take_scaled (MP mp,integer p, scaled q) {
2905 d = (double)p * (double)q * TWEXP_16;
2909 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2910 mp->arith_error = true;
2914 if (d==(double)i && (((p&077777)*(q&077777))&040000)!=0) --i;
2918 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2919 mp->arith_error = true;
2923 if (d==(double)i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2929 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
2930 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
2932 if ( q<fraction_four ) {
2934 p = (odd(f) ? halfp(p+q) : halfp(p));
2939 p = (odd(f) ? p+halfp(q-p) : halfp(p));
2944 @ For completeness, there's also |make_scaled|, which computes a
2945 quotient as a |scaled| number instead of as a |fraction|.
2946 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
2947 operands are positive. \ (This procedure is not used especially often,
2948 so it is not part of \MP's inner loop.)
2950 @<Internal library ...@>=
2951 scaled mp_make_scaled (MP mp,integer p, integer q) ;
2954 scaled mp_make_scaled (MP mp,integer p, integer q) {
2956 if ( q==0 ) mp_confusion(mp, "/");
2957 @:this can't happen /}{\quad \./@>
2960 integer f; /* the fraction bits, with a leading 1 bit */
2961 integer n; /* the integer part of $\vert p/q\vert$ */
2962 boolean negative; /* should the result be negated? */
2963 integer be_careful; /* disables certain compiler optimizations */
2964 if ( p>=0 ) negative=false;
2965 else { negate(p); negative=true; };
2967 negate(q); negative=! negative;
2971 mp->arith_error=true;
2972 return (negative ? (-el_gordo) : el_gordo);
2975 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
2976 i = (negative ? (-(f+n)) :(f+n));
2980 d = TWEXP16 * (double)p /(double)q;
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;
2989 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2991 if (d==(double)i && ( ((q>0 ? q : -q)&077777)
2992 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2999 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
3002 be_careful=p-q; p=be_careful+p;
3003 if ( p>=0 ) f=f+f+1;
3004 else { f+=f; p=p+q; };
3007 if ( be_careful+p>=0 ) incr(f)
3009 @ Here is a typical example of how the routines above can be used.
3010 It computes the function
3011 $${1\over3\tau}f(\theta,\phi)=
3012 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3013 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3014 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3015 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3016 fudge factor for placing the first control point of a curve that starts
3017 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3018 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3020 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3021 (It's a sum of eight terms whose absolute values can be bounded using
3022 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3023 is positive; and since the tension $\tau$ is constrained to be at least
3024 $3\over4$, the numerator is less than $16\over3$. The denominator is
3025 nonnegative and at most~6. Hence the fixed-point calculations below
3026 are guaranteed to stay within the bounds of a 32-bit computer word.
3028 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3029 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3030 $\sin\phi$, and $\cos\phi$, respectively.
3033 static fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3034 fraction cf, scaled t) {
3035 integer acc,num,denom; /* registers for intermediate calculations */
3036 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3037 acc=mp_take_fraction(mp, acc,ct-cf);
3038 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3039 /* $2^{28}\sqrt2\approx379625062.497$ */
3040 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3041 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3042 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3043 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3044 /* |make_scaled(fraction,scaled)=fraction| */
3045 if ( num / 4>=denom )
3046 return fraction_four;
3048 return mp_make_fraction(mp, num, denom);
3051 @ The following somewhat different subroutine tests rigorously if $ab$ is
3052 greater than, equal to, or less than~$cd$,
3053 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3054 The result is $+1$, 0, or~$-1$ in the three respective cases.
3056 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3059 static integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3060 integer q,r; /* temporary registers */
3061 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3063 q = a / d; r = c / b;
3065 return ( q>r ? 1 : -1);
3066 q = a % d; r = c % b;
3069 if ( q==0 ) return -1;
3071 } /* now |a>d>0| and |c>b>0| */
3074 @ @<Reduce to the case that |a...@>=
3075 if ( a<0 ) { negate(a); negate(b); };
3076 if ( c<0 ) { negate(c); negate(d); };
3079 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3083 return ( a==0 ? 0 : -1);
3084 q=a; a=c; c=q; q=-b; b=-d; d=q;
3085 } else if ( b<=0 ) {
3086 if ( b<0 ) if ( a>0 ) return -1;
3087 return (c==0 ? 0 : -1);
3090 @ We conclude this set of elementary routines with some simple rounding
3091 and truncation operations.
3093 @<Internal library declarations@>=
3094 #define mp_floor_scaled(M,i) ((i)&(-65536))
3095 #define mp_round_unscaled(M,i) (((i/32768)+1)/2)
3096 #define mp_round_fraction(M,i) (((i/2048)+1)/2)
3099 @* \[8] Algebraic and transcendental functions.
3100 \MP\ computes all of the necessary special functions from scratch, without
3101 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3103 @ To get the square root of a |scaled| number |x|, we want to calculate
3104 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3105 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3106 determines $s$ by an iterative method that maintains the invariant
3107 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3108 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3109 might, however, be zero at the start of the first iteration.
3112 static scaled mp_square_rt (MP mp,scaled x) ;
3115 scaled mp_square_rt (MP mp,scaled x) {
3116 quarterword k; /* iteration control counter */
3117 integer y; /* register for intermediate calculations */
3118 unsigned q; /* register for intermediate calculations */
3120 @<Handle square root of zero or negative argument@>;
3123 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3126 if ( x<fraction_four ) y=0;
3127 else { x=x-fraction_four; y=1; };
3129 @<Decrease |k| by 1, maintaining the invariant
3130 relations between |x|, |y|, and~|q|@>;
3132 return (scaled)(halfp(q));
3136 @ @<Handle square root of zero...@>=
3139 print_err("Square root of ");
3140 @.Square root...replaced by 0@>
3141 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3142 help2("Since I don't take square roots of negative numbers,",
3143 "I'm zeroing this one. Proceed, with fingers crossed.");
3149 @ @<Decrease |k| by 1, maintaining...@>=
3151 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3152 x=x-fraction_four; y++;
3154 x+=x; y=y+y-q; q+=q;
3155 if ( x>=fraction_four ) { x=x-fraction_four; y++; };
3156 if ( y>(int)q ){ y=y-q; q=q+2; }
3157 else if ( y<=0 ) { q=q-2; y=y+q; };
3160 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3161 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3162 @^Moler, Cleve Barry@>
3163 @^Morrison, Donald Ross@>
3164 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3165 in such a way that their Pythagorean sum remains invariant, while the
3166 smaller argument decreases.
3168 @<Internal library ...@>=
3169 integer mp_pyth_add (MP mp,integer a, integer b);
3173 integer mp_pyth_add (MP mp,integer a, integer b) {
3174 fraction r; /* register used to transform |a| and |b| */
3175 boolean big; /* is the result dangerously near $2^{31}$? */
3177 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3179 if ( a<fraction_two ) {
3182 a=a / 4; b=b / 4; big=true;
3183 }; /* we reduced the precision to avoid arithmetic overflow */
3184 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3186 if ( a<fraction_two ) {
3189 mp->arith_error=true; a=el_gordo;
3196 @ The key idea here is to reflect the vector $(a,b)$ about the
3197 line through $(a,b/2)$.
3199 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3201 r=mp_make_fraction(mp, b,a);
3202 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3204 r=mp_make_fraction(mp, r,fraction_four+r);
3205 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3209 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3210 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3213 static integer mp_pyth_sub (MP mp,integer a, integer b) {
3214 fraction r; /* register used to transform |a| and |b| */
3215 boolean big; /* is the input dangerously near $2^{31}$? */
3218 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3220 if ( a<fraction_four ) {
3223 a=(integer)halfp(a); b=(integer)halfp(b); big=true;
3225 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3226 if ( big ) double(a);
3231 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3233 r=mp_make_fraction(mp, b,a);
3234 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3236 r=mp_make_fraction(mp, r,fraction_four-r);
3237 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3240 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3243 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3244 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3245 mp_print(mp, " has been replaced by 0");
3247 help2("Since I don't take square roots of negative numbers,",
3248 "I'm zeroing this one. Proceed, with fingers crossed.");
3254 @ The subroutines for logarithm and exponential involve two tables.
3255 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3256 a bit more calculation, which the author claims to have done correctly:
3257 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3258 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3261 @d two_to_the(A) (1<<(unsigned)(A))
3264 static const integer spec_log[29] = { 0, /* special logarithms */
3265 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3266 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3267 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3269 @ @<Local variables for initialization@>=
3270 integer k; /* all-purpose loop index */
3273 @ Here is the routine that calculates $2^8$ times the natural logarithm
3274 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3275 when |x| is a given positive integer.
3277 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3278 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3279 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3280 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3281 during the calculation, and sixteen auxiliary bits to extend |y| are
3282 kept in~|z| during the initial argument reduction. (We add
3283 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3284 not become negative; also, the actual amount subtracted from~|y| is~96,
3285 not~100, because we want to add~4 for rounding before the final division by~8.)
3288 static scaled mp_m_log (MP mp,scaled x) {
3289 integer y,z; /* auxiliary registers */
3290 integer k; /* iteration counter */
3292 @<Handle non-positive logarithm@>;
3294 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3295 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3296 while ( x<fraction_four ) {
3297 double(x); y-=93032639; z-=48782;
3298 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3299 y=y+(z / unity); k=2;
3300 while ( x>fraction_four+4 ) {
3301 @<Increase |k| until |x| can be multiplied by a
3302 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3308 @ @<Increase |k| until |x| can...@>=
3310 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3311 while ( x<fraction_four+z ) { z=halfp(z+1); k++; };
3312 y+=spec_log[k]; x-=z;
3315 @ @<Handle non-positive logarithm@>=
3317 print_err("Logarithm of ");
3318 @.Logarithm...replaced by 0@>
3319 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3320 help2("Since I don't take logs of non-positive numbers,",
3321 "I'm zeroing this one. Proceed, with fingers crossed.");
3326 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3327 when |x| is |scaled|. The result is an integer approximation to
3328 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3331 static scaled mp_m_exp (MP mp,scaled x) {
3332 quarterword k; /* loop control index */
3333 integer y,z; /* auxiliary registers */
3334 if ( x>174436200 ) {
3335 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3336 mp->arith_error=true;
3338 } else if ( x<-197694359 ) {
3339 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3343 z=-8*x; y=04000000; /* $y=2^{20}$ */
3345 if ( x<=127919879 ) {
3347 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3349 z=8*(174436200-x); /* |z| is always nonnegative */
3353 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3355 return ((y+8) / 16);
3361 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3362 to multiplying |y| by $1-2^{-k}$.
3364 A subtle point (which had to be checked) was that if $x=127919879$, the
3365 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3366 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3367 and by~16 when |k=27|.
3369 @<Multiply |y| by...@>=
3372 while ( z>=spec_log[k] ) {
3374 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3379 @ The trigonometric subroutines use an auxiliary table such that
3380 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3381 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3384 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3385 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3386 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3388 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3389 returns the |angle| whose tangent points in the direction $(x,y)$.
3390 This subroutine first determines the correct octant, then solves the
3391 problem for |0<=y<=x|, then converts the result appropriately to
3392 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3393 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3394 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3396 The octants are represented in a ``Gray code,'' since that turns out
3397 to be computationally simplest.
3403 @d second_octant (first_octant+switch_x_and_y)
3404 @d third_octant (first_octant+switch_x_and_y+negate_x)
3405 @d fourth_octant (first_octant+negate_x)
3406 @d fifth_octant (first_octant+negate_x+negate_y)
3407 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3408 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3409 @d eighth_octant (first_octant+negate_y)
3412 static angle mp_n_arg (MP mp,integer x, integer y) {
3413 angle z; /* auxiliary register */
3414 integer t; /* temporary storage */
3415 quarterword k; /* loop counter */
3416 int octant; /* octant code */
3418 octant=first_octant;
3420 negate(x); octant=first_octant+negate_x;
3423 negate(y); octant=octant+negate_y;
3426 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3429 @<Handle undefined arg@>;
3431 @<Set variable |z| to the arg of $(x,y)$@>;
3432 @<Return an appropriate answer based on |z| and |octant|@>;
3436 @ @<Handle undefined arg@>=
3438 print_err("angle(0,0) is taken as zero");
3439 @.angle(0,0)...zero@>
3440 help2("The `angle' between two identical points is undefined.",
3441 "I'm zeroing this one. Proceed, with fingers crossed.");
3446 @ @<Return an appropriate answer...@>=
3448 case first_octant: return z;
3449 case second_octant: return (ninety_deg-z);
3450 case third_octant: return (ninety_deg+z);
3451 case fourth_octant: return (one_eighty_deg-z);
3452 case fifth_octant: return (z-one_eighty_deg);
3453 case sixth_octant: return (-z-ninety_deg);
3454 case seventh_octant: return (z-ninety_deg);
3455 case eighth_octant: return (-z);
3456 }; /* there are no other cases */
3459 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3460 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3463 @<Set variable |z| to the arg...@>=
3464 while ( x>=fraction_two ) {
3465 x=halfp(x); y=halfp(y);
3469 while ( x<fraction_one ) {
3472 @<Increase |z| to the arg of $(x,y)$@>;
3475 @ During the calculations of this section, variables |x| and~|y|
3476 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3477 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3478 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3479 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3480 coordinates whose angle has decreased by~$\phi$; in the special case
3481 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3482 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3483 @^Meggitt, John E.@>
3484 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3486 The initial value of |x| will be multiplied by at most
3487 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3488 there is no chance of integer overflow.
3490 @<Increase |z|...@>=
3495 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3500 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3503 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3504 and cosine of that angle. The results of this routine are
3505 stored in global integer variables |n_sin| and |n_cos|.
3508 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3510 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3511 the purpose of |n_sin_cos(z)| is to set
3512 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3513 for some rather large number~|r|. The maximum of |x| and |y|
3514 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3515 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3518 static void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3520 quarterword k; /* loop control variable */
3521 int q; /* specifies the quadrant */
3522 fraction r; /* magnitude of |(x,y)| */
3523 integer x,y,t; /* temporary registers */
3524 while ( z<0 ) z=z+three_sixty_deg;
3525 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3526 q=z / forty_five_deg; z=z % forty_five_deg;
3527 x=fraction_one; y=x;
3528 if ( ! odd(q) ) z=forty_five_deg-z;
3529 @<Subtract angle |z| from |(x,y)|@>;
3530 @<Convert |(x,y)| to the octant determined by~|q|@>;
3531 r=mp_pyth_add(mp, x,y);
3532 mp->n_cos=mp_make_fraction(mp, x,r);
3533 mp->n_sin=mp_make_fraction(mp, y,r);
3536 @ In this case the octants are numbered sequentially.
3538 @<Convert |(x,...@>=
3541 case 1: t=x; x=y; y=t; break;
3542 case 2: t=x; x=-y; y=t; break;
3543 case 3: negate(x); break;
3544 case 4: negate(x); negate(y); break;
3545 case 5: t=x; x=-y; y=-t; break;
3546 case 6: t=x; x=y; y=-t; break;
3547 case 7: negate(y); break;
3548 } /* there are no other cases */
3550 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3551 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3552 that this loop is guaranteed to terminate before the (nonexistent) value
3553 |spec_atan[27]| would be required.
3555 @<Subtract angle |z|...@>=
3558 if ( z>=spec_atan[k] ) {
3559 z=z-spec_atan[k]; t=x;
3560 x=t+y / two_to_the(k);
3561 y=y-t / two_to_the(k);
3565 if ( y<0 ) y=0 /* this precaution may never be needed */
3567 @ And now let's complete our collection of numeric utility routines
3568 by considering random number generation.
3569 \MP\ generates pseudo-random numbers with the additive scheme recommended
3570 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3571 results are random fractions between 0 and |fraction_one-1|, inclusive.
3573 There's an auxiliary array |randoms| that contains 55 pseudo-random
3574 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3575 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3576 The global variable |j_random| tells which element has most recently
3578 The global variable |random_seed| was introduced in version 0.9,
3579 for the sole reason of stressing the fact that the initial value of the
3580 random seed is system-dependant. The initialization code below will initialize
3581 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3582 is not good enough on modern fast machines that are capable of running
3583 multiple MetaPost processes within the same second.
3584 @^system dependencies@>
3587 fraction randoms[55]; /* the last 55 random values generated */
3588 int j_random; /* the number of unused |randoms| */
3590 @ @<Option variables@>=
3591 int random_seed; /* the default random seed */
3593 @ @<Allocate or initialize ...@>=
3594 mp->random_seed = (scaled)opt->random_seed;
3596 @ To consume a random fraction, the program below will say `|next_random|'
3597 and then it will fetch |randoms[j_random]|.
3599 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3600 else decr(mp->j_random); }
3603 static void mp_new_randoms (MP mp) {
3604 int k; /* index into |randoms| */
3605 fraction x; /* accumulator */
3606 for (k=0;k<=23;k++) {
3607 x=mp->randoms[k]-mp->randoms[k+31];
3608 if ( x<0 ) x=x+fraction_one;
3611 for (k=24;k<= 54;k++){
3612 x=mp->randoms[k]-mp->randoms[k-24];
3613 if ( x<0 ) x=x+fraction_one;
3620 static void mp_init_randoms (MP mp,scaled seed);
3622 @ To initialize the |randoms| table, we call the following routine.
3625 void mp_init_randoms (MP mp,scaled seed) {
3626 fraction j,jj,k; /* more or less random integers */
3627 int i; /* index into |randoms| */
3629 while ( j>=fraction_one ) j=halfp(j);
3631 for (i=0;i<=54;i++ ){
3633 if ( k<0 ) k=k+fraction_one;
3634 mp->randoms[(i*21)% 55]=j;
3638 mp_new_randoms(mp); /* ``warm up'' the array */
3641 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3642 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3644 Note that the call of |take_fraction| will produce the values 0 and~|x|
3645 with about half the probability that it will produce any other particular
3646 values between 0 and~|x|, because it rounds its answers.
3649 static scaled mp_unif_rand (MP mp,scaled x) {
3650 scaled y; /* trial value */
3651 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3652 if ( y==abs(x) ) return 0;
3653 else if ( x>0 ) return y;
3657 @ Finally, a normal deviate with mean zero and unit standard deviation
3658 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3659 {\sl The Art of Computer Programming\/}).
3662 static scaled mp_norm_rand (MP mp) {
3663 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3667 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3668 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3669 next_random; u=mp->randoms[mp->j_random];
3670 } while (abs(x)>=u);
3671 x=mp_make_fraction(mp, x,u);
3672 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3673 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3677 @* \[9] Packed data.
3678 In order to make efficient use of storage space, \MP\ bases its major data
3679 structures on a |memory_word|, which contains either a (signed) integer,
3680 possibly scaled, or a small number of fields that are one half or one
3681 quarter of the size used for storing integers.
3683 If |x| is a variable of type |memory_word|, it contains up to four
3684 fields that can be referred to as follows:
3685 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3686 |x|&.|int|&(an |integer|)\cr
3687 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3688 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3689 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3691 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3692 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3693 This is somewhat cumbersome to write, and not very readable either, but
3694 macros will be used to make the notation shorter and more transparent.
3695 The code below gives a formal definition of |memory_word| and
3696 its subsidiary types, using packed variant records. \MP\ makes no
3697 assumptions about the relative positions of the fields within a word.
3699 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3700 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3702 @ Here are the inequalities that the quarterword and halfword values
3703 must satisfy (or rather, the inequalities that they mustn't satisfy):
3705 @<Check the ``constant''...@>=
3706 if (mp->ini_version) {
3707 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3709 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3711 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3712 if ( mp->max_strings>max_halfword ) mp->bad=13;
3714 @ The macros |qi| and |qo| are used for input to and output
3715 from quarterwords. These are legacy macros.
3716 @^system dependencies@>
3718 @d qo(A) (A) /* to read eight bits from a quarterword */
3719 @d qi(A) (quarterword)(A) /* to store eight bits in a quarterword */
3721 @ The reader should study the following definitions closely:
3722 @^system dependencies@>
3724 @d sc cint /* |scaled| data is equivalent to |integer| */
3727 typedef short quarterword; /* 1/4 of a word */
3728 typedef int halfword; /* 1/2 of a word */
3733 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3740 quarterword B2, B3, B0, B1;
3755 @ When debugging, we may want to print a |memory_word| without knowing
3756 what type it is; so we print it in all modes.
3760 void mp_print_word (MP mp,memory_word w) {
3761 /* prints |w| in all ways */
3762 mp_print_int(mp, w.cint); mp_print_char(mp, xord(' '));
3763 mp_print_scaled(mp, w.sc); mp_print_char(mp, xord(' '));
3764 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3765 mp_print_int(mp, w.hh.lh); mp_print_char(mp, xord('='));
3766 mp_print_int(mp, w.hh.b0); mp_print_char(mp, xord(':'));
3767 mp_print_int(mp, w.hh.b1); mp_print_char(mp, xord(';'));
3768 mp_print_int(mp, w.hh.rh); mp_print_char(mp, xord(' '));
3769 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, xord(':'));
3770 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, xord(':'));
3771 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, xord(':'));
3772 mp_print_int(mp, w.qqqq.b3);
3776 @* \[10] Dynamic memory allocation.
3778 The \MP\ system does nearly all of its own memory allocation, so that it
3779 can readily be transported into environments that do not have automatic
3780 facilities for strings, garbage collection, etc., and so that it can be in
3781 control of what error messages the user receives. The dynamic storage
3782 requirements of \MP\ are handled by providing a large array |mem| in
3783 which consecutive blocks of words are used as nodes by the \MP\ routines.
3785 Pointer variables are indices into this array, or into another array
3786 called |eqtb| that will be explained later. A pointer variable might
3787 also be a special flag that lies outside the bounds of |mem|, so we
3788 allow pointers to assume any |halfword| value. The minimum memory
3789 index represents a null pointer.
3791 @d null 0 /* the null pointer */
3792 @d mp_void (null+1) /* a null pointer different from |null| */
3796 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3798 @ The |mem| array is divided into two regions that are allocated separately,
3799 but the dividing line between these two regions is not fixed; they grow
3800 together until finding their ``natural'' size in a particular job.
3801 Locations less than or equal to |lo_mem_max| are used for storing
3802 variable-length records consisting of two or more words each. This region
3803 is maintained using an algorithm similar to the one described in exercise
3804 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3805 appears in the allocated nodes; the program is responsible for knowing the
3806 relevant size when a node is freed. Locations greater than or equal to
3807 |hi_mem_min| are used for storing one-word records; a conventional
3808 \.{AVAIL} stack is used for allocation in this region.
3810 Locations of |mem| between |0| and |mem_top| may be dumped as part
3811 of preloaded mem files, by the \.{INIMP} preprocessor.
3813 Production versions of \MP\ may extend the memory at the top end in order to
3814 provide more space; these locations, between |mem_top| and |mem_max|,
3815 are always used for single-word nodes.
3817 The key pointers that govern |mem| allocation have a prescribed order:
3818 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3821 memory_word *mem; /* the big dynamic storage area */
3822 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3823 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3827 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3828 @d xrealloc(P,A,B) mp_xrealloc(mp,P,(size_t)A,B)
3829 @d xmalloc(A,B) mp_xmalloc(mp,(size_t)A,B)
3830 @d xstrdup(A) mp_xstrdup(mp,A)
3831 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3833 @<Declare helpers@>=
3834 extern char *mp_strdup(const char *p) ;
3835 extern void mp_xfree ( @= /*@@only@@*/ /*@@out@@*/ /*@@null@@*/ @> void *x);
3836 extern @= /*@@only@@*/ @> void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3837 extern @= /*@@only@@*/ @> void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3838 extern @= /*@@only@@*/ @> char *mp_xstrdup(MP mp, const char *s);
3839 extern void mp_do_snprintf(char *str, int size, const char *fmt, ...);
3841 @ The |max_size_test| guards against overflow, on the assumption that
3842 |size_t| is at least 31bits wide.
3844 @d max_size_test 0x7FFFFFFF
3847 char *mp_strdup(const char *p) {
3850 if (p==NULL) return NULL;
3852 r = malloc (l*sizeof(char)+1);
3855 return memcpy (r,p,(l+1));
3857 void mp_xfree (void *x) {
3858 if (x!=NULL) free(x);
3860 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3862 if ((max_size_test/size)<nmem) {
3863 do_fprintf(mp->err_out,"Memory size overflow!\n");
3864 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3866 w = realloc (p,(nmem*size));
3868 do_fprintf(mp->err_out,"Out of memory!\n");
3869 mp->history =mp_system_error_stop; mp_jump_out(mp);
3873 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
3875 if ((max_size_test/size)<nmem) {
3876 do_fprintf(mp->err_out,"Memory size overflow!\n");
3877 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3879 w = malloc (nmem*size);
3881 do_fprintf(mp->err_out,"Out of memory!\n");
3882 mp->history =mp_system_error_stop; mp_jump_out(mp);
3886 char *mp_xstrdup(MP mp, const char *s) {
3892 do_fprintf(mp->err_out,"Out of memory!\n");
3893 mp->history =mp_system_error_stop; mp_jump_out(mp);
3898 @ @<Internal library declarations@>=
3899 #ifdef HAVE_SNPRINTF
3900 #define mp_snprintf (void)snprintf
3902 #define mp_snprintf mp_do_snprintf
3905 @ This internal version is rather stupid, but good enough for its purpose.
3908 static char *mp_itoa (int i) {
3911 unsigned v = (unsigned)abs(i);
3912 memset(res,0,32*sizeof(char));
3914 char d = (char)(v % 10);
3918 res[idx--] = (char)v;
3922 return mp_strdup(res+idx);
3924 static char *mp_utoa (unsigned v) {
3927 memset(res,0,32*sizeof(char));
3929 char d = (char)(v % 10);
3933 res[idx--] = (char)v;
3934 return mp_strdup(res+idx);
3936 void mp_do_snprintf (char *str, int size, const char *format, ...) {
3940 va_start(ap, format);
3942 for (fmt=format;*fmt!='\0';fmt++) {
3948 char *s = va_arg(ap, char *);
3951 if (size-->0) res++;
3958 char *s = mp_itoa(va_arg(ap, int));
3962 if (size-->0) res++;
3969 char *s = mp_utoa(va_arg(ap, unsigned));
3973 if (size-->0) res++;
3980 if (size-->0) res++;
3984 if (size-->0) res++;
3986 if (size-->0) res++;
3991 if (size-->0) res++;
3999 @<Allocate or initialize ...@>=
4000 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
4001 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
4003 @ @<Dealloc variables@>=
4006 @ Users who wish to study the memory requirements of particular applications can
4007 can use optional special features that keep track of current and
4008 maximum memory usage. When code between the delimiters |stat| $\ldots$
4009 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
4010 report these statistics when |mp_tracing_stats| is positive.
4013 integer var_used; integer dyn_used; /* how much memory is in use */
4015 @ Let's consider the one-word memory region first, since it's the
4016 simplest. The pointer variable |mem_end| holds the highest-numbered location
4017 of |mem| that has ever been used. The free locations of |mem| that
4018 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
4019 |two_halves|, and we write |info(p)| and |mp_link(p)| for the |lh|
4020 and |rh| fields of |mem[p]| when it is of this type. The single-word
4021 free locations form a linked list
4022 $$|avail|,\;\hbox{|mp_link(avail)|},\;\hbox{|mp_link(mp_link(avail))|},\;\ldots$$
4023 terminated by |null|.
4026 #define mp_link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
4027 #define mp_info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
4030 pointer avail; /* head of the list of available one-word nodes */
4031 pointer mem_end; /* the last one-word node used in |mem| */
4033 @ If one-word memory is exhausted, it might mean that the user has forgotten
4034 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
4035 later that try to help pinpoint the trouble.
4037 @ The function |get_avail| returns a pointer to a new one-word node whose
4038 |link| field is null. However, \MP\ will halt if there is no more room left.
4042 static pointer mp_get_avail (MP mp) { /* single-word node allocation */
4043 pointer p; /* the new node being got */
4044 p=mp->avail; /* get top location in the |avail| stack */
4046 mp->avail=mp_link(mp->avail); /* and pop it off */
4047 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
4048 incr(mp->mem_end); p=mp->mem_end;
4050 decr(mp->hi_mem_min); p=mp->hi_mem_min;
4051 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
4052 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
4053 mp_overflow(mp, "main memory size",mp->mem_max);
4054 /* quit; all one-word nodes are busy */
4055 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4058 mp_link(p)=null; /* provide an oft-desired initialization of the new node */
4059 incr(mp->dyn_used);/* maintain statistics */
4063 @ Conversely, a one-word node is recycled by calling |free_avail|.
4065 @d free_avail(A) /* single-word node liberation */
4066 { mp_link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
4068 @ There's also a |fast_get_avail| routine, which saves the procedure-call
4069 overhead at the expense of extra programming. This macro is used in
4070 the places that would otherwise account for the most calls of |get_avail|.
4073 @d fast_get_avail(A) {
4074 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
4075 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4076 else { mp->avail=mp_link((A)); mp_link((A))=null; incr(mp->dyn_used); }
4079 @ The available-space list that keeps track of the variable-size portion
4080 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4081 pointed to by the roving pointer |rover|.
4083 Each empty node has size 2 or more; the first word contains the special
4084 value |max_halfword| in its |link| field and the size in its |info| field;
4085 the second word contains the two pointers for double linking.
4087 Each nonempty node also has size 2 or more. Its first word is of type
4088 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4089 Otherwise there is complete flexibility with respect to the contents
4090 of its other fields and its other words.
4092 (We require |mem_max<max_halfword| because terrible things can happen
4093 when |max_halfword| appears in the |link| field of a nonempty node.)
4095 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4096 @d is_empty(A) (mp_link((A))==empty_flag) /* tests for empty node */
4099 #define node_size mp_info /* the size field in empty variable-size nodes */
4100 #define lmp_link(A) mp_info((A)+1) /* left link in doubly-linked list of empty nodes */
4101 #define rmp_link(A) mp_link((A)+1) /* right link in doubly-linked list of empty nodes */
4104 pointer rover; /* points to some node in the list of empties */
4106 @ A call to |get_node| with argument |s| returns a pointer to a new node
4107 of size~|s|, which must be 2~or more. The |link| field of the first word
4108 of this new node is set to null. An overflow stop occurs if no suitable
4111 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4112 areas and returns the value |max_halfword|.
4114 @<Internal library declarations@>=
4115 pointer mp_get_node (MP mp,integer s) ;
4118 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4119 pointer p; /* the node currently under inspection */
4120 pointer q; /* the node physically after node |p| */
4121 integer r; /* the newly allocated node, or a candidate for this honor */
4122 integer t,tt; /* temporary registers */
4125 p=mp->rover; /* start at some free node in the ring */
4127 @<Try to allocate within node |p| and its physical successors,
4128 and |goto found| if allocation was possible@>;
4129 if (rmp_link(p)==null || (rmp_link(p)==p && p!=mp->rover)) {
4130 print_err("Free list garbled");
4131 help3("I found an entry in the list of free nodes that links",
4132 "badly. I will try to ignore the broken link, but something",
4133 "is seriously amiss. It is wise to warn the maintainers.")
4135 rmp_link(p)=mp->rover;
4137 p=rmp_link(p); /* move to the next node in the ring */
4138 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4139 if ( s==010000000000 ) {
4140 return max_halfword;
4142 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4143 if ( mp->lo_mem_max+2<=max_halfword ) {
4144 @<Grow more variable-size memory and |goto restart|@>;
4147 mp_overflow(mp, "main memory size",mp->mem_max);
4148 /* sorry, nothing satisfactory is left */
4149 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4151 mp_link(r)=null; /* this node is now nonempty */
4152 mp->var_used+=s; /* maintain usage statistics */
4156 @ The lower part of |mem| grows by 1000 words at a time, unless
4157 we are very close to going under. When it grows, we simply link
4158 a new node into the available-space list. This method of controlled
4159 growth helps to keep the |mem| usage consecutive when \MP\ is
4160 implemented on ``virtual memory'' systems.
4163 @<Grow more variable-size memory and |goto restart|@>=
4165 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4166 t=mp->lo_mem_max+1000;
4168 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4169 /* |lo_mem_max+2<=t<hi_mem_min| */
4171 if ( t>max_halfword ) t=max_halfword;
4172 p=lmp_link(mp->rover); q=mp->lo_mem_max; rmp_link(p)=q; lmp_link(mp->rover)=q;
4173 rmp_link(q)=mp->rover; lmp_link(q)=p; mp_link(q)=empty_flag;
4174 node_size(q)=t-mp->lo_mem_max;
4175 mp->lo_mem_max=t; mp_link(mp->lo_mem_max)=null; mp_info(mp->lo_mem_max)=null;
4180 @ @<Try to allocate...@>=
4181 q=p+node_size(p); /* find the physical successor */
4182 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4183 t=rmp_link(q); tt=lmp_link(q);
4185 if ( q==mp->rover ) mp->rover=t;
4186 lmp_link(t)=tt; rmp_link(tt)=t;
4191 @<Allocate from the top of node |p| and |goto found|@>;
4194 if ( rmp_link(p)!=p ) {
4195 @<Allocate entire node |p| and |goto found|@>;
4198 node_size(p)=q-p /* reset the size in case it grew */
4200 @ @<Allocate from the top...@>=
4202 node_size(p)=r-p; /* store the remaining size */
4203 mp->rover=p; /* start searching here next time */
4207 @ Here we delete node |p| from the ring, and let |rover| rove around.
4209 @<Allocate entire...@>=
4211 mp->rover=rmp_link(p); t=lmp_link(p);
4212 lmp_link(mp->rover)=t; rmp_link(t)=mp->rover;
4216 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4217 the operation |free_node(p,s)| will make its words available, by inserting
4218 |p| as a new empty node just before where |rover| now points.
4220 @<Internal library declarations@>=
4221 void mp_free_node (MP mp, pointer p, halfword s) ;
4224 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4226 pointer q; /* |lmp_link(rover)| */
4227 node_size(p)=s; mp_link(p)=empty_flag;
4229 q=lmp_link(mp->rover); lmp_link(p)=q; rmp_link(p)=mp->rover; /* set both links */
4230 lmp_link(mp->rover)=p; rmp_link(q)=p; /* insert |p| into the ring */
4231 mp->var_used-=s; /* maintain statistics */
4234 @* \[11] Memory layout.
4235 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4236 more efficient than dynamic allocation when we can get away with it. For
4237 example, locations |0| to |1| are always used to store a
4238 two-word dummy token whose second word is zero.
4239 The following macro definitions accomplish the static allocation by giving
4240 symbolic names to the fixed positions. Static variable-size nodes appear
4241 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4242 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4244 @d sentinel mp->mem_top /* end of sorted lists */
4245 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4246 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4249 #define spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4250 #define null_dash (2) /* the first two words are reserved for a null value */
4251 #define dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4252 #define zero_val (dep_head+2) /* two words for a permanently zero value */
4253 #define temp_val (zero_val+2) /* two words for a temporary value node */
4254 #define end_attr temp_val /* we use |end_attr+2| only */
4255 #define inf_val (end_attr+2) /* and |inf_val+1| only */
4256 #define bad_vardef (inf_val+2) /* two words for \&{vardef} error recovery */
4257 #define lo_mem_stat_max (bad_vardef+1) /* largest statically
4258 allocated word in the variable-size |mem| */
4259 #define hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4260 the one-word |mem| */
4262 @ The following code gets the dynamic part of |mem| off to a good start,
4263 when \MP\ is initializing itself the slow way.
4265 @<Initialize table entries (done by \.{INIMP} only)@>=
4266 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4267 mp_link(mp->rover)=empty_flag;
4268 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4269 lmp_link(mp->rover)=mp->rover; rmp_link(mp->rover)=mp->rover;
4270 mp->lo_mem_max=mp->rover+1000;
4271 mp_link(mp->lo_mem_max)=null; mp_info(mp->lo_mem_max)=null;
4272 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4273 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4275 mp->avail=null; mp->mem_end=mp->mem_top;
4276 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4277 mp->var_used=lo_mem_stat_max+1;
4278 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4280 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4281 nodes that starts at a given position, until coming to |sentinel| or a
4282 pointer that is not in the one-word region. Another procedure,
4283 |flush_node_list|, frees an entire linked list of one-word and two-word
4284 nodes, until coming to a |null| pointer.
4288 static void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4289 pointer q,r; /* list traversers */
4290 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4295 if ( r<mp->hi_mem_min ) break;
4296 } while (r!=sentinel);
4297 /* now |q| is the last node on the list */
4298 mp_link(q)=mp->avail; mp->avail=p;
4302 static void mp_flush_node_list (MP mp,pointer p) {
4303 pointer q; /* the node being recycled */
4306 if ( q<mp->hi_mem_min )
4307 mp_free_node(mp, q,2);
4313 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4314 For example, some pointers might be wrong, or some ``dead'' nodes might not
4315 have been freed when the last reference to them disappeared. Procedures
4316 |check_mem| and |search_mem| are available to help diagnose such
4317 problems. These procedures make use of two arrays called |free| and
4318 |was_free| that are present only if \MP's debugging routines have
4319 been included. (You may want to decrease the size of |mem| while you
4323 Because |boolean|s are typedef-d as ints, it is better to use
4324 unsigned chars here.
4327 unsigned char *free; /* free cells */
4328 unsigned char *was_free; /* previously free cells */
4329 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4330 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4331 boolean panicking; /* do we want to check memory constantly? */
4333 @ @<Allocate or initialize ...@>=
4334 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4335 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4337 @ @<Dealloc variables@>=
4339 xfree(mp->was_free);
4341 @ @<Allocate or ...@>=
4342 mp->was_hi_min=mp->mem_max;
4343 mp->panicking=false;
4346 static void mp_reallocate_memory(MP mp, int l) ;
4349 static void mp_reallocate_memory(MP mp, int l) {
4350 XREALLOC(mp->free, l, unsigned char);
4351 XREALLOC(mp->was_free, l, unsigned char);
4353 int newarea = l-mp->mem_max;
4354 XREALLOC(mp->mem, l, memory_word);
4355 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4357 XREALLOC(mp->mem, l, memory_word);
4358 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4361 if (mp->ini_version)
4367 @ Procedure |check_mem| makes sure that the available space lists of
4368 |mem| are well formed, and it optionally prints out all locations
4369 that are reserved now but were free the last time this procedure was called.
4372 void mp_check_mem (MP mp,boolean print_locs ) {
4373 pointer p,q,r; /* current locations of interest in |mem| */
4374 boolean clobbered; /* is something amiss? */
4375 for (p=0;p<=mp->lo_mem_max;p++) {
4376 mp->free[p]=false; /* you can probably do this faster */
4378 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4379 mp->free[p]=false; /* ditto */
4381 @<Check single-word |avail| list@>;
4382 @<Check variable-size |avail| list@>;
4383 @<Check flags of unavailable nodes@>;
4384 @<Check the list of linear dependencies@>;
4386 @<Print newly busy locations@>;
4388 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4389 mp->was_mem_end=mp->mem_end;
4390 mp->was_lo_max=mp->lo_mem_max;
4391 mp->was_hi_min=mp->hi_mem_min;
4394 @ @<Check single-word...@>=
4395 p=mp->avail; q=null; clobbered=false;
4397 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4398 else if ( mp->free[p] ) clobbered=true;
4400 mp_print_nl(mp, "AVAIL list clobbered at ");
4401 @.AVAIL list clobbered...@>
4402 mp_print_int(mp, q); break;
4404 mp->free[p]=true; q=p; p=mp_link(q);
4407 @ @<Check variable-size...@>=
4408 p=mp->rover; q=null; clobbered=false;
4410 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4411 else if ( (rmp_link(p)>=mp->lo_mem_max)||(rmp_link(p)<0) ) clobbered=true;
4412 else if ( !(is_empty(p))||(node_size(p)<2)||
4413 (p+node_size(p)>mp->lo_mem_max)|| (lmp_link(rmp_link(p))!=p) ) clobbered=true;
4415 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4416 @.Double-AVAIL list clobbered...@>
4417 mp_print_int(mp, q); break;
4419 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4420 if ( mp->free[q] ) {
4421 mp_print_nl(mp, "Doubly free location at ");
4422 @.Doubly free location...@>
4423 mp_print_int(mp, q); break;
4428 } while (p!=mp->rover)
4431 @ @<Check flags...@>=
4433 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4434 if ( is_empty(p) ) {
4435 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4438 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) p++;
4439 while ( (p<=mp->lo_mem_max) && mp->free[p] ) p++;
4442 @ @<Print newly busy...@>=
4444 @<Do intialization required before printing new busy locations@>;
4445 mp_print_nl(mp, "New busy locs:");
4447 for (p=0;p<= mp->lo_mem_max;p++ ) {
4448 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4449 @<Indicate that |p| is a new busy location@>;
4452 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4453 if ( ! mp->free[p] &&
4454 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4455 @<Indicate that |p| is a new busy location@>;
4458 @<Finish printing new busy locations@>;
4461 @ There might be many new busy locations so we are careful to print contiguous
4462 blocks compactly. During this operation |q| is the last new busy location and
4463 |r| is the start of the block containing |q|.
4465 @<Indicate that |p| is a new busy location@>=
4469 mp_print(mp, ".."); mp_print_int(mp, q);
4471 mp_print_char(mp, xord(' ')); mp_print_int(mp, p);
4477 @ @<Do intialization required before printing new busy locations@>=
4478 q=mp->mem_max; r=mp->mem_max
4480 @ @<Finish printing new busy locations@>=
4482 mp_print(mp, ".."); mp_print_int(mp, q);
4485 @ The |search_mem| procedure attempts to answer the question ``Who points
4486 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4487 that might not be of type |two_halves|. Strictly speaking, this is
4488 undefined, and it can lead to ``false drops'' (words that seem to
4489 point to |p| purely by coincidence). But for debugging purposes, we want
4490 to rule out the places that do {\sl not\/} point to |p|, so a few false
4491 drops are tolerable.
4494 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4495 integer q; /* current position being searched */
4496 for (q=0;q<=mp->lo_mem_max;q++) {
4497 if ( mp_link(q)==p ){
4498 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4500 if ( mp_info(q)==p ) {
4501 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4504 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4505 if ( mp_link(q)==p ) {
4506 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4508 if ( mp_info(q)==p ) {
4509 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4512 @<Search |eqtb| for equivalents equal to |p|@>;
4515 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4516 available space list. The list is probably very short at such times, so a
4517 simple insertion sort is used. The smallest available location will be
4518 pointed to by |rover|, the next-smallest by |rmp_link(rover)|, etc.
4520 @<Internal library ...@>=
4521 void mp_sort_avail (MP mp);
4524 void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4526 pointer p,q,r; /* indices into |mem| */
4527 pointer old_rover; /* initial |rover| setting */
4528 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4529 p=rmp_link(mp->rover); rmp_link(mp->rover)=max_halfword; old_rover=mp->rover;
4530 while ( p!=old_rover ) {
4531 @<Sort |p| into the list starting at |rover|
4532 and advance |p| to |rmp_link(p)|@>;
4535 while ( rmp_link(p)!=max_halfword ) {
4536 lmp_link(rmp_link(p))=p; p=rmp_link(p);
4538 rmp_link(p)=mp->rover; lmp_link(mp->rover)=p;
4541 @ The following |while| loop is guaranteed to
4542 terminate, since the list that starts at
4543 |rover| ends with |max_halfword| during the sorting procedure.
4546 if ( p<mp->rover ) {
4547 q=p; p=rmp_link(q); rmp_link(q)=mp->rover; mp->rover=q;
4550 while ( rmp_link(q)<p ) q=rmp_link(q);
4551 r=rmp_link(p); rmp_link(p)=rmp_link(q); rmp_link(q)=p; p=r;
4555 @* \[12] The command codes.
4556 Before we can go much further, we need to define symbolic names for the internal
4557 code numbers that represent the various commands obeyed by \MP. These codes
4558 are somewhat arbitrary, but not completely so. For example,
4559 some codes have been made adjacent so that |case| statements in the
4560 program need not consider cases that are widely spaced, or so that |case|
4561 statements can be replaced by |if| statements. A command can begin an
4562 expression if and only if its code lies between |min_primary_command| and
4563 |max_primary_command|, inclusive. The first token of a statement that doesn't
4564 begin with an expression has a command code between |min_command| and
4565 |max_statement_command|, inclusive. Anything less than |min_command| is
4566 eliminated during macro expansions, and anything no more than |max_pre_command|
4567 is eliminated when expanding \TeX\ material. Ranges such as
4568 |min_secondary_command..max_secondary_command| are used when parsing
4569 expressions, but the relative ordering within such a range is generally not
4572 The ordering of the highest-numbered commands
4573 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4574 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4575 for the smallest two commands. The ordering is also important in the ranges
4576 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4578 At any rate, here is the list, for future reference.
4580 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4581 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4582 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4583 @d max_pre_command mpx_break
4584 @d if_test 4 /* conditional text (\&{if}) */
4585 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
4586 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4587 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4588 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4589 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4590 @d relax 10 /* do nothing (\.{\char`\\}) */
4591 @d scan_tokens 11 /* put a string into the input buffer */
4592 @d expand_after 12 /* look ahead one token */
4593 @d defined_macro 13 /* a macro defined by the user */
4594 @d min_command (defined_macro+1)
4595 @d save_command 14 /* save a list of tokens (\&{save}) */
4596 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4597 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4598 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4599 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4600 @d ship_out_command 19 /* output a character (\&{shipout}) */
4601 @d add_to_command 20 /* add to edges (\&{addto}) */
4602 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4603 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4604 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4605 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4606 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4607 @d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
4608 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4609 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4610 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4611 @d special_command 30 /* output special info (\&{special})
4612 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4613 @d write_command 31 /* write text to a file (\&{write}) */
4614 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
4615 @d max_statement_command type_name
4616 @d min_primary_command type_name
4617 @d left_delimiter 33 /* the left delimiter of a matching pair */
4618 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4619 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4620 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4621 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4622 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4623 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4624 @d capsule_token 40 /* a value that has been put into a token list */
4625 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4626 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4627 @d min_suffix_token internal_quantity
4628 @d tag_token 43 /* a symbolic token without a primitive meaning */
4629 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4630 @d max_suffix_token numeric_token
4631 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4632 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4633 @d min_tertiary_command plus_or_minus
4634 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4635 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4636 @d max_tertiary_command tertiary_binary
4637 @d left_brace 48 /* the operator `\.{\char`\{}' */
4638 @d min_expression_command left_brace
4639 @d path_join 49 /* the operator `\.{..}' */
4640 @d ampersand 50 /* the operator `\.\&' */
4641 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4642 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4643 @d equals 53 /* the operator `\.=' */
4644 @d max_expression_command equals
4645 @d and_command 54 /* the operator `\&{and}' */
4646 @d min_secondary_command and_command
4647 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4648 @d slash 56 /* the operator `\./' */
4649 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4650 @d max_secondary_command secondary_binary
4651 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4652 @d controls 59 /* specify control points explicitly (\&{controls}) */
4653 @d tension 60 /* specify tension between knots (\&{tension}) */
4654 @d at_least 61 /* bounded tension value (\&{atleast}) */
4655 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4656 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4657 @d right_delimiter 64 /* the right delimiter of a matching pair */
4658 @d left_bracket 65 /* the operator `\.[' */
4659 @d right_bracket 66 /* the operator `\.]' */
4660 @d right_brace 67 /* the operator `\.{\char`\}}' */
4661 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4663 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4664 @d of_token 70 /* the operator `\&{of}' */
4665 @d to_token 71 /* the operator `\&{to}' */
4666 @d step_token 72 /* the operator `\&{step}' */
4667 @d until_token 73 /* the operator `\&{until}' */
4668 @d within_token 74 /* the operator `\&{within}' */
4669 @d lig_kern_token 75
4670 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
4671 @d assignment 76 /* the operator `\.{:=}' */
4672 @d skip_to 77 /* the operation `\&{skipto}' */
4673 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4674 @d double_colon 79 /* the operator `\.{::}' */
4675 @d colon 80 /* the operator `\.:' */
4677 @d comma 81 /* the operator `\.,', must be |colon+1| */
4678 @d end_of_statement (mp->cur_cmd>comma)
4679 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4680 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4681 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4682 @d max_command_code stop
4683 @d outer_tag (max_command_code+1) /* protection code added to command code */
4686 typedef int command_code;
4688 @ Variables and capsules in \MP\ have a variety of ``types,''
4689 distinguished by the code numbers defined here. These numbers are also
4690 not completely arbitrary. Things that get expanded must have types
4691 |>mp_independent|; a type remaining after expansion is numeric if and only if
4692 its code number is at least |numeric_type|; objects containing numeric
4693 parts must have types between |transform_type| and |pair_type|;
4694 all other types must be smaller than |transform_type|; and among the types
4695 that are not unknown or vacuous, the smallest two must be |boolean_type|
4696 and |string_type| in that order.
4698 @d undefined 0 /* no type has been declared */
4699 @d unknown_tag 1 /* this constant is added to certain type codes below */
4700 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4701 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4704 enum mp_variable_type {
4705 mp_vacuous=1, /* no expression was present */
4706 mp_boolean_type, /* \&{boolean} with a known value */
4708 mp_string_type, /* \&{string} with a known value */
4710 mp_pen_type, /* \&{pen} with a known value */
4712 mp_path_type, /* \&{path} with a known value */
4714 mp_picture_type, /* \&{picture} with a known value */
4716 mp_transform_type, /* \&{transform} variable or capsule */
4717 mp_color_type, /* \&{color} variable or capsule */
4718 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4719 mp_pair_type, /* \&{pair} variable or capsule */
4720 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4721 mp_known, /* \&{numeric} with a known value */
4722 mp_dependent, /* a linear combination with |fraction| coefficients */
4723 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4724 mp_independent, /* \&{numeric} with unknown value */
4725 mp_token_list, /* variable name or suffix argument or text argument */
4726 mp_structured, /* variable with subscripts and attributes */
4727 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4728 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4732 static void mp_print_type (MP mp,quarterword t) ;
4734 @ @<Basic printing procedures@>=
4735 void mp_print_type (MP mp,quarterword t) {
4737 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4738 case mp_boolean_type:mp_print(mp, "boolean"); break;
4739 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4740 case mp_string_type:mp_print(mp, "string"); break;
4741 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4742 case mp_pen_type:mp_print(mp, "pen"); break;
4743 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4744 case mp_path_type:mp_print(mp, "path"); break;
4745 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4746 case mp_picture_type:mp_print(mp, "picture"); break;
4747 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4748 case mp_transform_type:mp_print(mp, "transform"); break;
4749 case mp_color_type:mp_print(mp, "color"); break;
4750 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4751 case mp_pair_type:mp_print(mp, "pair"); break;
4752 case mp_known:mp_print(mp, "known numeric"); break;
4753 case mp_dependent:mp_print(mp, "dependent"); break;
4754 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4755 case mp_numeric_type:mp_print(mp, "numeric"); break;
4756 case mp_independent:mp_print(mp, "independent"); break;
4757 case mp_token_list:mp_print(mp, "token list"); break;
4758 case mp_structured:mp_print(mp, "mp_structured"); break;
4759 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4760 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4761 default: mp_print(mp, "undefined"); break;
4765 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4766 as well as a |type|. The possibilities for |name_type| are defined
4767 here; they will be explained in more detail later.
4770 enum mp_name_types {
4771 mp_root=0, /* |name_type| at the top level of a variable */
4772 mp_saved_root, /* same, when the variable has been saved */
4773 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4774 mp_subscr, /* |name_type| in a subscript node */
4775 mp_attr, /* |name_type| in an attribute node */
4776 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4777 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4778 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4779 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4780 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4781 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4782 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4783 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4784 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4785 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4786 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4787 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4788 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4789 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4790 mp_capsule, /* |name_type| in stashed-away subexpressions */
4791 mp_token /* |name_type| in a numeric token or string token */
4794 @ Primitive operations that produce values have a secondary identification
4795 code in addition to their command code; it's something like genera and species.
4796 For example, `\.*' has the command code |primary_binary|, and its
4797 secondary identification is |times|. The secondary codes start at 30 so that
4798 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4799 are used as operators as well as type identifications. The relative values
4800 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4801 and |filled_op..bounded_op|. The restrictions are that
4802 |and_op-false_code=or_op-true_code|, that the ordering of
4803 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4804 and the ordering of |filled_op..bounded_op| must match that of the code
4805 values they test for.
4807 @d true_code 30 /* operation code for \.{true} */
4808 @d false_code 31 /* operation code for \.{false} */
4809 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4810 @d null_pen_code 33 /* operation code for \.{nullpen} */
4811 @d job_name_op 34 /* operation code for \.{jobname} */
4812 @d read_string_op 35 /* operation code for \.{readstring} */
4813 @d pen_circle 36 /* operation code for \.{pencircle} */
4814 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4815 @d read_from_op 38 /* operation code for \.{readfrom} */
4816 @d close_from_op 39 /* operation code for \.{closefrom} */
4817 @d odd_op 40 /* operation code for \.{odd} */
4818 @d known_op 41 /* operation code for \.{known} */
4819 @d unknown_op 42 /* operation code for \.{unknown} */
4820 @d not_op 43 /* operation code for \.{not} */
4821 @d decimal 44 /* operation code for \.{decimal} */
4822 @d reverse 45 /* operation code for \.{reverse} */
4823 @d make_path_op 46 /* operation code for \.{makepath} */
4824 @d make_pen_op 47 /* operation code for \.{makepen} */
4825 @d oct_op 48 /* operation code for \.{oct} */
4826 @d hex_op 49 /* operation code for \.{hex} */
4827 @d ASCII_op 50 /* operation code for \.{ASCII} */
4828 @d char_op 51 /* operation code for \.{char} */
4829 @d length_op 52 /* operation code for \.{length} */
4830 @d turning_op 53 /* operation code for \.{turningnumber} */
4831 @d color_model_part 54 /* operation code for \.{colormodel} */
4832 @d x_part 55 /* operation code for \.{xpart} */
4833 @d y_part 56 /* operation code for \.{ypart} */
4834 @d xx_part 57 /* operation code for \.{xxpart} */
4835 @d xy_part 58 /* operation code for \.{xypart} */
4836 @d yx_part 59 /* operation code for \.{yxpart} */
4837 @d yy_part 60 /* operation code for \.{yypart} */
4838 @d red_part 61 /* operation code for \.{redpart} */
4839 @d green_part 62 /* operation code for \.{greenpart} */
4840 @d blue_part 63 /* operation code for \.{bluepart} */
4841 @d cyan_part 64 /* operation code for \.{cyanpart} */
4842 @d magenta_part 65 /* operation code for \.{magentapart} */
4843 @d yellow_part 66 /* operation code for \.{yellowpart} */
4844 @d black_part 67 /* operation code for \.{blackpart} */
4845 @d grey_part 68 /* operation code for \.{greypart} */
4846 @d font_part 69 /* operation code for \.{fontpart} */
4847 @d text_part 70 /* operation code for \.{textpart} */
4848 @d path_part 71 /* operation code for \.{pathpart} */
4849 @d pen_part 72 /* operation code for \.{penpart} */
4850 @d dash_part 73 /* operation code for \.{dashpart} */
4851 @d sqrt_op 74 /* operation code for \.{sqrt} */
4852 @d mp_m_exp_op 75 /* operation code for \.{mexp} */
4853 @d mp_m_log_op 76 /* operation code for \.{mlog} */
4854 @d sin_d_op 77 /* operation code for \.{sind} */
4855 @d cos_d_op 78 /* operation code for \.{cosd} */
4856 @d floor_op 79 /* operation code for \.{floor} */
4857 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4858 @d char_exists_op 81 /* operation code for \.{charexists} */
4859 @d font_size 82 /* operation code for \.{fontsize} */
4860 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4861 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4862 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4863 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4864 @d arc_length 87 /* operation code for \.{arclength} */
4865 @d angle_op 88 /* operation code for \.{angle} */
4866 @d cycle_op 89 /* operation code for \.{cycle} */
4867 @d filled_op 90 /* operation code for \.{filled} */
4868 @d stroked_op 91 /* operation code for \.{stroked} */
4869 @d textual_op 92 /* operation code for \.{textual} */
4870 @d clipped_op 93 /* operation code for \.{clipped} */
4871 @d bounded_op 94 /* operation code for \.{bounded} */
4872 @d plus 95 /* operation code for \.+ */
4873 @d minus 96 /* operation code for \.- */
4874 @d times 97 /* operation code for \.* */
4875 @d over 98 /* operation code for \./ */
4876 @d pythag_add 99 /* operation code for \.{++} */
4877 @d pythag_sub 100 /* operation code for \.{+-+} */
4878 @d or_op 101 /* operation code for \.{or} */
4879 @d and_op 102 /* operation code for \.{and} */
4880 @d less_than 103 /* operation code for \.< */
4881 @d less_or_equal 104 /* operation code for \.{<=} */
4882 @d greater_than 105 /* operation code for \.> */
4883 @d greater_or_equal 106 /* operation code for \.{>=} */
4884 @d equal_to 107 /* operation code for \.= */
4885 @d unequal_to 108 /* operation code for \.{<>} */
4886 @d concatenate 109 /* operation code for \.\& */
4887 @d rotated_by 110 /* operation code for \.{rotated} */
4888 @d slanted_by 111 /* operation code for \.{slanted} */
4889 @d scaled_by 112 /* operation code for \.{scaled} */
4890 @d shifted_by 113 /* operation code for \.{shifted} */
4891 @d transformed_by 114 /* operation code for \.{transformed} */
4892 @d x_scaled 115 /* operation code for \.{xscaled} */
4893 @d y_scaled 116 /* operation code for \.{yscaled} */
4894 @d z_scaled 117 /* operation code for \.{zscaled} */
4895 @d in_font 118 /* operation code for \.{infont} */
4896 @d intersect 119 /* operation code for \.{intersectiontimes} */
4897 @d double_dot 120 /* operation code for improper \.{..} */
4898 @d substring_of 121 /* operation code for \.{substring} */
4899 @d min_of substring_of
4900 @d subpath_of 122 /* operation code for \.{subpath} */
4901 @d direction_time_of 123 /* operation code for \.{directiontime} */
4902 @d point_of 124 /* operation code for \.{point} */
4903 @d precontrol_of 125 /* operation code for \.{precontrol} */
4904 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4905 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4906 @d arc_time_of 128 /* operation code for \.{arctime} */
4907 @d mp_version 129 /* operation code for \.{mpversion} */
4908 @d envelope_of 130 /* operation code for \.{envelope} */
4910 @c static void mp_print_op (MP mp,quarterword c) {
4911 if (c<=mp_numeric_type ) {
4912 mp_print_type(mp, c);
4915 case true_code:mp_print(mp, "true"); break;
4916 case false_code:mp_print(mp, "false"); break;
4917 case null_picture_code:mp_print(mp, "nullpicture"); break;
4918 case null_pen_code:mp_print(mp, "nullpen"); break;
4919 case job_name_op:mp_print(mp, "jobname"); break;
4920 case read_string_op:mp_print(mp, "readstring"); break;
4921 case pen_circle:mp_print(mp, "pencircle"); break;
4922 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4923 case read_from_op:mp_print(mp, "readfrom"); break;
4924 case close_from_op:mp_print(mp, "closefrom"); break;
4925 case odd_op:mp_print(mp, "odd"); break;
4926 case known_op:mp_print(mp, "known"); break;
4927 case unknown_op:mp_print(mp, "unknown"); break;
4928 case not_op:mp_print(mp, "not"); break;
4929 case decimal:mp_print(mp, "decimal"); break;
4930 case reverse:mp_print(mp, "reverse"); break;
4931 case make_path_op:mp_print(mp, "makepath"); break;
4932 case make_pen_op:mp_print(mp, "makepen"); break;
4933 case oct_op:mp_print(mp, "oct"); break;
4934 case hex_op:mp_print(mp, "hex"); break;
4935 case ASCII_op:mp_print(mp, "ASCII"); break;
4936 case char_op:mp_print(mp, "char"); break;
4937 case length_op:mp_print(mp, "length"); break;
4938 case turning_op:mp_print(mp, "turningnumber"); break;
4939 case x_part:mp_print(mp, "xpart"); break;
4940 case y_part:mp_print(mp, "ypart"); break;
4941 case xx_part:mp_print(mp, "xxpart"); break;
4942 case xy_part:mp_print(mp, "xypart"); break;
4943 case yx_part:mp_print(mp, "yxpart"); break;
4944 case yy_part:mp_print(mp, "yypart"); break;
4945 case red_part:mp_print(mp, "redpart"); break;
4946 case green_part:mp_print(mp, "greenpart"); break;
4947 case blue_part:mp_print(mp, "bluepart"); break;
4948 case cyan_part:mp_print(mp, "cyanpart"); break;
4949 case magenta_part:mp_print(mp, "magentapart"); break;
4950 case yellow_part:mp_print(mp, "yellowpart"); break;
4951 case black_part:mp_print(mp, "blackpart"); break;
4952 case grey_part:mp_print(mp, "greypart"); break;
4953 case color_model_part:mp_print(mp, "colormodel"); break;
4954 case font_part:mp_print(mp, "fontpart"); break;
4955 case text_part:mp_print(mp, "textpart"); break;
4956 case path_part:mp_print(mp, "pathpart"); break;
4957 case pen_part:mp_print(mp, "penpart"); break;
4958 case dash_part:mp_print(mp, "dashpart"); break;
4959 case sqrt_op:mp_print(mp, "sqrt"); break;
4960 case mp_m_exp_op:mp_print(mp, "mexp"); break;
4961 case mp_m_log_op:mp_print(mp, "mlog"); break;
4962 case sin_d_op:mp_print(mp, "sind"); break;
4963 case cos_d_op:mp_print(mp, "cosd"); break;
4964 case floor_op:mp_print(mp, "floor"); break;
4965 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4966 case char_exists_op:mp_print(mp, "charexists"); break;
4967 case font_size:mp_print(mp, "fontsize"); break;
4968 case ll_corner_op:mp_print(mp, "llcorner"); break;
4969 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4970 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4971 case ur_corner_op:mp_print(mp, "urcorner"); break;
4972 case arc_length:mp_print(mp, "arclength"); break;
4973 case angle_op:mp_print(mp, "angle"); break;
4974 case cycle_op:mp_print(mp, "cycle"); break;
4975 case filled_op:mp_print(mp, "filled"); break;
4976 case stroked_op:mp_print(mp, "stroked"); break;
4977 case textual_op:mp_print(mp, "textual"); break;
4978 case clipped_op:mp_print(mp, "clipped"); break;
4979 case bounded_op:mp_print(mp, "bounded"); break;
4980 case plus:mp_print_char(mp, xord('+')); break;
4981 case minus:mp_print_char(mp, xord('-')); break;
4982 case times:mp_print_char(mp, xord('*')); break;
4983 case over:mp_print_char(mp, xord('/')); break;
4984 case pythag_add:mp_print(mp, "++"); break;
4985 case pythag_sub:mp_print(mp, "+-+"); break;
4986 case or_op:mp_print(mp, "or"); break;
4987 case and_op:mp_print(mp, "and"); break;
4988 case less_than:mp_print_char(mp, xord('<')); break;
4989 case less_or_equal:mp_print(mp, "<="); break;
4990 case greater_than:mp_print_char(mp, xord('>')); break;
4991 case greater_or_equal:mp_print(mp, ">="); break;
4992 case equal_to:mp_print_char(mp, xord('=')); break;
4993 case unequal_to:mp_print(mp, "<>"); break;
4994 case concatenate:mp_print(mp, "&"); break;
4995 case rotated_by:mp_print(mp, "rotated"); break;
4996 case slanted_by:mp_print(mp, "slanted"); break;
4997 case scaled_by:mp_print(mp, "scaled"); break;
4998 case shifted_by:mp_print(mp, "shifted"); break;
4999 case transformed_by:mp_print(mp, "transformed"); break;
5000 case x_scaled:mp_print(mp, "xscaled"); break;
5001 case y_scaled:mp_print(mp, "yscaled"); break;
5002 case z_scaled:mp_print(mp, "zscaled"); break;
5003 case in_font:mp_print(mp, "infont"); break;
5004 case intersect:mp_print(mp, "intersectiontimes"); break;
5005 case substring_of:mp_print(mp, "substring"); break;
5006 case subpath_of:mp_print(mp, "subpath"); break;
5007 case direction_time_of:mp_print(mp, "directiontime"); break;
5008 case point_of:mp_print(mp, "point"); break;
5009 case precontrol_of:mp_print(mp, "precontrol"); break;
5010 case postcontrol_of:mp_print(mp, "postcontrol"); break;
5011 case pen_offset_of:mp_print(mp, "penoffset"); break;
5012 case arc_time_of:mp_print(mp, "arctime"); break;
5013 case mp_version:mp_print(mp, "mpversion"); break;
5014 case envelope_of:mp_print(mp, "envelope"); break;
5015 default: mp_print(mp, ".."); break;
5020 @ \MP\ also has a bunch of internal parameters that a user might want to
5021 fuss with. Every such parameter has an identifying code number, defined here.
5024 enum mp_given_internal {
5025 mp_tracing_titles=1, /* show titles online when they appear */
5026 mp_tracing_equations, /* show each variable when it becomes known */
5027 mp_tracing_capsules, /* show capsules too */
5028 mp_tracing_choices, /* show the control points chosen for paths */
5029 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
5030 mp_tracing_commands, /* show commands and operations before they are performed */
5031 mp_tracing_restores, /* show when a variable or internal is restored */
5032 mp_tracing_macros, /* show macros before they are expanded */
5033 mp_tracing_output, /* show digitized edges as they are output */
5034 mp_tracing_stats, /* show memory usage at end of job */
5035 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
5036 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
5037 mp_year, /* the current year (e.g., 1984) */
5038 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
5039 mp_day, /* the current day of the month */
5040 mp_time, /* the number of minutes past midnight when this job started */
5041 mp_char_code, /* the number of the next character to be output */
5042 mp_char_ext, /* the extension code of the next character to be output */
5043 mp_char_wd, /* the width of the next character to be output */
5044 mp_char_ht, /* the height of the next character to be output */
5045 mp_char_dp, /* the depth of the next character to be output */
5046 mp_char_ic, /* the italic correction of the next character to be output */
5047 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
5048 mp_pausing, /* positive to display lines on the terminal before they are read */
5049 mp_showstopping, /* positive to stop after each \&{show} command */
5050 mp_fontmaking, /* positive if font metric output is to be produced */
5051 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
5052 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
5053 mp_miterlimit, /* controls miter length as in \ps */
5054 mp_warning_check, /* controls error message when variable value is large */
5055 mp_boundary_char, /* the right boundary character for ligatures */
5056 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
5057 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
5058 mp_default_color_model, /* the default color model for unspecified items */
5059 mp_restore_clip_color,
5060 mp_procset, /* wether or not create PostScript command shortcuts */
5061 mp_gtroffmode /* whether the user specified |-troff| on the command line */
5066 @d max_given_internal mp_gtroffmode
5069 scaled *internal; /* the values of internal quantities */
5070 char **int_name; /* their names */
5071 int int_ptr; /* the maximum internal quantity defined so far */
5072 int max_internal; /* current maximum number of internal quantities */
5074 @ @<Option variables@>=
5077 @ @<Allocate or initialize ...@>=
5078 mp->max_internal=2*max_given_internal;
5079 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
5080 memset(mp->internal,0,(mp->max_internal+1)* sizeof(scaled));
5081 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
5082 memset(mp->int_name,0,(mp->max_internal+1) * sizeof(char *));
5083 mp->troff_mode=(opt->troff_mode>0 ? true : false);
5085 @ @<Exported function ...@>=
5086 int mp_troff_mode(MP mp);
5089 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5091 @ @<Set initial ...@>=
5092 mp->int_ptr=max_given_internal;
5094 @ The symbolic names for internal quantities are put into \MP's hash table
5095 by using a routine called |primitive|, which will be defined later. Let us
5096 enter them now, so that we don't have to list all those names again
5099 @<Put each of \MP's primitives into the hash table@>=
5100 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5101 @:tracingtitles_}{\&{tracingtitles} primitive@>
5102 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5103 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5104 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5105 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5106 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5107 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5108 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5109 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5110 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5111 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5112 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5113 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5114 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5115 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5116 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5117 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5118 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5119 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5120 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5121 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5122 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5123 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5124 mp_primitive(mp, "year",internal_quantity,mp_year);
5125 @:mp_year_}{\&{year} primitive@>
5126 mp_primitive(mp, "month",internal_quantity,mp_month);
5127 @:mp_month_}{\&{month} primitive@>
5128 mp_primitive(mp, "day",internal_quantity,mp_day);
5129 @:mp_day_}{\&{day} primitive@>
5130 mp_primitive(mp, "time",internal_quantity,mp_time);
5131 @:time_}{\&{time} primitive@>
5132 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5133 @:mp_char_code_}{\&{charcode} primitive@>
5134 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5135 @:mp_char_ext_}{\&{charext} primitive@>
5136 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5137 @:mp_char_wd_}{\&{charwd} primitive@>
5138 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5139 @:mp_char_ht_}{\&{charht} primitive@>
5140 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5141 @:mp_char_dp_}{\&{chardp} primitive@>
5142 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5143 @:mp_char_ic_}{\&{charic} primitive@>
5144 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5145 @:mp_design_size_}{\&{designsize} primitive@>
5146 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5147 @:mp_pausing_}{\&{pausing} primitive@>
5148 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5149 @:mp_showstopping_}{\&{showstopping} primitive@>
5150 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5151 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5152 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5153 @:mp_linejoin_}{\&{linejoin} primitive@>
5154 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5155 @:mp_linecap_}{\&{linecap} primitive@>
5156 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5157 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5158 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5159 @:mp_warning_check_}{\&{warningcheck} primitive@>
5160 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5161 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5162 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5163 @:mp_prologues_}{\&{prologues} primitive@>
5164 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5165 @:mp_true_corners_}{\&{truecorners} primitive@>
5166 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5167 @:mp_procset_}{\&{mpprocset} primitive@>
5168 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5169 @:troffmode_}{\&{troffmode} primitive@>
5170 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5171 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5172 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5173 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5175 @ Colors can be specified in four color models. In the special
5176 case of |no_model|, MetaPost does not output any color operator to
5177 the postscript output.
5179 Note: these values are passed directly on to |with_option|. This only
5180 works because the other possible values passed to |with_option| are
5181 8 and 10 respectively (from |with_pen| and |with_picture|).
5183 There is a first state, that is only used for |gs_colormodel|. It flags
5184 the fact that there has not been any kind of color specification by
5185 the user so far in the game.
5188 enum mp_color_model {
5193 mp_uninitialized_model=9
5197 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5198 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5199 mp->internal[mp_restore_clip_color]=unity;
5201 @ Well, we do have to list the names one more time, for use in symbolic
5204 @<Initialize table...@>=
5205 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5206 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5207 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5208 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5209 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5210 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5211 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5212 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5213 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5214 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5215 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5216 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5217 mp->int_name[mp_year]=xstrdup("year");
5218 mp->int_name[mp_month]=xstrdup("month");
5219 mp->int_name[mp_day]=xstrdup("day");
5220 mp->int_name[mp_time]=xstrdup("time");
5221 mp->int_name[mp_char_code]=xstrdup("charcode");
5222 mp->int_name[mp_char_ext]=xstrdup("charext");
5223 mp->int_name[mp_char_wd]=xstrdup("charwd");
5224 mp->int_name[mp_char_ht]=xstrdup("charht");
5225 mp->int_name[mp_char_dp]=xstrdup("chardp");
5226 mp->int_name[mp_char_ic]=xstrdup("charic");
5227 mp->int_name[mp_design_size]=xstrdup("designsize");
5228 mp->int_name[mp_pausing]=xstrdup("pausing");
5229 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5230 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5231 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5232 mp->int_name[mp_linecap]=xstrdup("linecap");
5233 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5234 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5235 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5236 mp->int_name[mp_prologues]=xstrdup("prologues");
5237 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5238 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5239 mp->int_name[mp_procset]=xstrdup("mpprocset");
5240 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5241 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5243 @ The following procedure, which is called just before \MP\ initializes its
5244 input and output, establishes the initial values of the date and time.
5245 @^system dependencies@>
5247 Note that the values are |scaled| integers. Hence \MP\ can no longer
5248 be used after the year 32767.
5251 static void mp_fix_date_and_time (MP mp) {
5252 time_t aclock = time ((time_t *) 0);
5253 struct tm *tmptr = localtime (&aclock);
5254 mp->internal[mp_time]=
5255 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5256 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5257 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5258 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5262 static void mp_fix_date_and_time (MP mp) ;
5264 @ \MP\ is occasionally supposed to print diagnostic information that
5265 goes only into the transcript file, unless |mp_tracing_online| is positive.
5266 Now that we have defined |mp_tracing_online| we can define
5267 two routines that adjust the destination of print commands:
5270 static void mp_begin_diagnostic (MP mp) ;
5271 static void mp_end_diagnostic (MP mp,boolean blank_line);
5272 static void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
5274 @ @<Basic printing...@>=
5275 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5276 mp->old_setting=mp->selector;
5277 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5279 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5283 void mp_end_diagnostic (MP mp,boolean blank_line) {
5284 /* restore proper conditions after tracing */
5285 mp_print_nl(mp, "");
5286 if ( blank_line ) mp_print_ln(mp);
5287 mp->selector=mp->old_setting;
5293 unsigned int old_setting;
5295 @ We will occasionally use |begin_diagnostic| in connection with line-number
5296 printing, as follows. (The parameter |s| is typically |"Path"| or
5297 |"Cycle spec"|, etc.)
5299 @<Basic printing...@>=
5300 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
5301 mp_begin_diagnostic(mp);
5302 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5303 mp_print(mp, " at line ");
5304 mp_print_int(mp, mp_true_line(mp));
5305 mp_print(mp, t); mp_print_char(mp, xord(':'));
5308 @ The 256 |ASCII_code| characters are grouped into classes by means of
5309 the |char_class| table. Individual class numbers have no semantic
5310 or syntactic significance, except in a few instances defined here.
5311 There's also |max_class|, which can be used as a basis for additional
5312 class numbers in nonstandard extensions of \MP.
5314 @d digit_class 0 /* the class number of \.{0123456789} */
5315 @d period_class 1 /* the class number of `\..' */
5316 @d space_class 2 /* the class number of spaces and nonstandard characters */
5317 @d percent_class 3 /* the class number of `\.\%' */
5318 @d string_class 4 /* the class number of `\."' */
5319 @d right_paren_class 8 /* the class number of `\.)' */
5320 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5321 @d letter_class 9 /* letters and the underline character */
5322 @d left_bracket_class 17 /* `\.[' */
5323 @d right_bracket_class 18 /* `\.]' */
5324 @d invalid_class 20 /* bad character in the input */
5325 @d max_class 20 /* the largest class number */
5328 int char_class[256]; /* the class numbers */
5330 @ If changes are made to accommodate non-ASCII character sets, they should
5331 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5332 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5333 @^system dependencies@>
5335 @<Set initial ...@>=
5336 for (k='0';k<='9';k++)
5337 mp->char_class[k]=digit_class;
5338 mp->char_class['.']=period_class;
5339 mp->char_class[' ']=space_class;
5340 mp->char_class['%']=percent_class;
5341 mp->char_class['"']=string_class;
5342 mp->char_class[',']=5;
5343 mp->char_class[';']=6;
5344 mp->char_class['(']=7;
5345 mp->char_class[')']=right_paren_class;
5346 for (k='A';k<= 'Z';k++ )
5347 mp->char_class[k]=letter_class;
5348 for (k='a';k<='z';k++)
5349 mp->char_class[k]=letter_class;
5350 mp->char_class['_']=letter_class;
5351 mp->char_class['<']=10;
5352 mp->char_class['=']=10;
5353 mp->char_class['>']=10;
5354 mp->char_class[':']=10;
5355 mp->char_class['|']=10;
5356 mp->char_class['`']=11;
5357 mp->char_class['\'']=11;
5358 mp->char_class['+']=12;
5359 mp->char_class['-']=12;
5360 mp->char_class['/']=13;
5361 mp->char_class['*']=13;
5362 mp->char_class['\\']=13;
5363 mp->char_class['!']=14;
5364 mp->char_class['?']=14;
5365 mp->char_class['#']=15;
5366 mp->char_class['&']=15;
5367 mp->char_class['@@']=15;
5368 mp->char_class['$']=15;
5369 mp->char_class['^']=16;
5370 mp->char_class['~']=16;
5371 mp->char_class['[']=left_bracket_class;
5372 mp->char_class[']']=right_bracket_class;
5373 mp->char_class['{']=19;
5374 mp->char_class['}']=19;
5376 mp->char_class[k]=invalid_class;
5377 mp->char_class['\t']=space_class;
5378 mp->char_class['\f']=space_class;
5379 for (k=127;k<=255;k++)
5380 mp->char_class[k]=invalid_class;
5382 @* \[13] The hash table.
5383 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5384 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5385 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5386 table, it is never removed.
5388 The actual sequence of characters forming a symbolic token is
5389 stored in the |str_pool| array together with all the other strings. An
5390 auxiliary array |hash| consists of items with two halfword fields per
5391 word. The first of these, called |mp_next(p)|, points to the next identifier
5392 belonging to the same coalesced list as the identifier corresponding to~|p|;
5393 and the other, called |text(p)|, points to the |str_start| entry for
5394 |p|'s identifier. If position~|p| of the hash table is empty, we have
5395 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5396 hash list, we have |mp_next(p)=0|.
5398 An auxiliary pointer variable called |hash_used| is maintained in such a
5399 way that all locations |p>=hash_used| are nonempty. The global variable
5400 |st_count| tells how many symbolic tokens have been defined, if statistics
5403 The first 256 locations of |hash| are reserved for symbols of length one.
5405 There's a parallel array called |eqtb| that contains the current equivalent
5406 values of each symbolic token. The entries of this array consist of
5407 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5408 piece of information that qualifies the |eq_type|).
5410 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5411 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5412 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5415 #define mp_next(A) mp->hash[(A)].lh /* link for coalesced lists */
5416 #define text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5417 #define hash_base 257 /* hashing actually starts here */
5420 pointer hash_used; /* allocation pointer for |hash| */
5421 integer st_count; /* total number of known identifiers */
5423 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5424 since they are used in error recovery.
5427 #define hash_top (integer)(hash_base+mp->hash_size) /* the first location of the frozen area */
5428 #define frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5429 #define frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5430 #define frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5431 #define frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5432 #define frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5433 #define frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5434 #define frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5435 #define frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5436 #define frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5437 #define frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5438 #define frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5439 #define frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5440 #define frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5441 #define frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5442 #define frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5443 #define hash_end (integer)(hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5447 two_halves *hash; /* the hash table */
5448 two_halves *eqtb; /* the equivalents */
5450 @ @<Allocate or initialize ...@>=
5451 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5452 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5454 @ @<Dealloc variables@>=
5459 mp_next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5460 for (k=2;k<=hash_end;k++) {
5461 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5464 @ @<Initialize table entries...@>=
5465 mp->hash_used=frozen_inaccessible; /* nothing is used */
5467 text(frozen_bad_vardef)=intern("a bad variable");
5468 text(frozen_etex)=intern("etex");
5469 text(frozen_mpx_break)=intern("mpxbreak");
5470 text(frozen_fi)=intern("fi");
5471 text(frozen_end_group)=intern("endgroup");
5472 text(frozen_end_def)=intern("enddef");
5473 text(frozen_end_for)=intern("endfor");
5474 text(frozen_semicolon)=intern(";");
5475 text(frozen_colon)=intern(":");
5476 text(frozen_slash)=intern("/");
5477 text(frozen_left_bracket)=intern("[");
5478 text(frozen_right_delimiter)=intern(")");
5479 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5480 eq_type(frozen_right_delimiter)=right_delimiter;
5482 @ @<Check the ``constant'' values...@>=
5483 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5485 @ Here is the subroutine that searches the hash table for an identifier
5486 that matches a given string of length~|l| appearing in |buffer[j..
5487 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5488 will always be found, and the corresponding hash table address
5492 static pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5493 integer h; /* hash code */
5494 pointer p; /* index in |hash| array */
5495 pointer k; /* index in |buffer| array */
5497 @<Treat special case of length 1 and |break|@>;
5499 @<Compute the hash code |h|@>;
5500 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5502 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5504 if ( mp_next(p)==0 ) {
5505 @<Insert a new symbolic token after |p|, then
5506 make |p| point to it and |break|@>;
5513 @ @<Treat special case of length 1...@>=
5514 p=mp->buffer[j]+1; text(p)=p-1; return p;
5517 @ @<Insert a new symbolic...@>=
5522 mp_overflow(mp, "hash size",(integer)mp->hash_size);
5523 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5524 decr(mp->hash_used);
5525 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5526 mp_next(p)=mp->hash_used;
5530 for (k=j;k<=j+l-1;k++) {
5531 append_char(mp->buffer[k]);
5533 text(p)=mp_make_string(mp);
5534 mp->str_ref[text(p)]=max_str_ref;
5540 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5541 should be a prime number. The theory of hashing tells us to expect fewer
5542 than two table probes, on the average, when the search is successful.
5543 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5544 @^Vitter, Jeffrey Scott@>
5546 @<Compute the hash code |h|@>=
5548 for (k=j+1;k<=j+l-1;k++){
5549 h=h+h+mp->buffer[k];
5550 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5553 @ @<Search |eqtb| for equivalents equal to |p|@>=
5554 for (q=1;q<=hash_end;q++) {
5555 if ( equiv(q)==p ) {
5556 mp_print_nl(mp, "EQUIV(");
5557 mp_print_int(mp, q);
5558 mp_print_char(mp, xord(')'));
5562 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5563 table, together with their command code (which will be the |eq_type|)
5564 and an operand (which will be the |equiv|). The |primitive| procedure
5565 does this, in a way that no \MP\ user can. The global value |cur_sym|
5566 contains the new |eqtb| pointer after |primitive| has acted.
5569 static void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
5570 pool_pointer k; /* index into |str_pool| */
5571 quarterword j; /* index into |buffer| */
5572 quarterword l; /* length of the string */
5575 k=mp->str_start[s]; l=str_stop(s)-k;
5576 /* we will move |s| into the (empty) |buffer| */
5577 for (j=0;j<=l-1;j++) {
5578 mp->buffer[j]=mp->str_pool[k+j];
5580 mp->cur_sym=mp_id_lookup(mp, 0,l);
5581 if ( s>=256 ) { /* we don't want to have the string twice */
5582 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5584 eq_type(mp->cur_sym)=c;
5585 equiv(mp->cur_sym)=o;
5589 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5590 by their |eq_type| alone. These primitives are loaded into the hash table
5593 @<Put each of \MP's primitives into the hash table@>=
5594 mp_primitive(mp, "..",path_join,0);
5595 @:.._}{\.{..} primitive@>
5596 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5597 @:[ }{\.{[} primitive@>
5598 mp_primitive(mp, "]",right_bracket,0);
5599 @:] }{\.{]} primitive@>
5600 mp_primitive(mp, "}",right_brace,0);
5601 @:]]}{\.{\char`\}} primitive@>
5602 mp_primitive(mp, "{",left_brace,0);
5603 @:][}{\.{\char`\{} primitive@>
5604 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5605 @:: }{\.{:} primitive@>
5606 mp_primitive(mp, "::",double_colon,0);
5607 @::: }{\.{::} primitive@>
5608 mp_primitive(mp, "||:",bchar_label,0);
5609 @:::: }{\.{\char'174\char'174:} primitive@>
5610 mp_primitive(mp, ":=",assignment,0);
5611 @::=_}{\.{:=} primitive@>
5612 mp_primitive(mp, ",",comma,0);
5613 @:, }{\., primitive@>
5614 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5615 @:; }{\.; primitive@>
5616 mp_primitive(mp, "\\",relax,0);
5617 @:]]\\}{\.{\char`\\} primitive@>
5619 mp_primitive(mp, "addto",add_to_command,0);
5620 @:add_to_}{\&{addto} primitive@>
5621 mp_primitive(mp, "atleast",at_least,0);
5622 @:at_least_}{\&{atleast} primitive@>
5623 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5624 @:begin_group_}{\&{begingroup} primitive@>
5625 mp_primitive(mp, "controls",controls,0);
5626 @:controls_}{\&{controls} primitive@>
5627 mp_primitive(mp, "curl",curl_command,0);
5628 @:curl_}{\&{curl} primitive@>
5629 mp_primitive(mp, "delimiters",delimiters,0);
5630 @:delimiters_}{\&{delimiters} primitive@>
5631 mp_primitive(mp, "endgroup",end_group,0);
5632 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5633 @:endgroup_}{\&{endgroup} primitive@>
5634 mp_primitive(mp, "everyjob",every_job_command,0);
5635 @:every_job_}{\&{everyjob} primitive@>
5636 mp_primitive(mp, "exitif",exit_test,0);
5637 @:exit_if_}{\&{exitif} primitive@>
5638 mp_primitive(mp, "expandafter",expand_after,0);
5639 @:expand_after_}{\&{expandafter} primitive@>
5640 mp_primitive(mp, "interim",interim_command,0);
5641 @:interim_}{\&{interim} primitive@>
5642 mp_primitive(mp, "let",let_command,0);
5643 @:let_}{\&{let} primitive@>
5644 mp_primitive(mp, "newinternal",new_internal,0);
5645 @:new_internal_}{\&{newinternal} primitive@>
5646 mp_primitive(mp, "of",of_token,0);
5647 @:of_}{\&{of} primitive@>
5648 mp_primitive(mp, "randomseed",mp_random_seed,0);
5649 @:mp_random_seed_}{\&{randomseed} primitive@>
5650 mp_primitive(mp, "save",save_command,0);
5651 @:save_}{\&{save} primitive@>
5652 mp_primitive(mp, "scantokens",scan_tokens,0);
5653 @:scan_tokens_}{\&{scantokens} primitive@>
5654 mp_primitive(mp, "shipout",ship_out_command,0);
5655 @:ship_out_}{\&{shipout} primitive@>
5656 mp_primitive(mp, "skipto",skip_to,0);
5657 @:skip_to_}{\&{skipto} primitive@>
5658 mp_primitive(mp, "special",special_command,0);
5659 @:special}{\&{special} primitive@>
5660 mp_primitive(mp, "fontmapfile",special_command,1);
5661 @:fontmapfile}{\&{fontmapfile} primitive@>
5662 mp_primitive(mp, "fontmapline",special_command,2);
5663 @:fontmapline}{\&{fontmapline} primitive@>
5664 mp_primitive(mp, "step",step_token,0);
5665 @:step_}{\&{step} primitive@>
5666 mp_primitive(mp, "str",str_op,0);
5667 @:str_}{\&{str} primitive@>
5668 mp_primitive(mp, "tension",tension,0);
5669 @:tension_}{\&{tension} primitive@>
5670 mp_primitive(mp, "to",to_token,0);
5671 @:to_}{\&{to} primitive@>
5672 mp_primitive(mp, "until",until_token,0);
5673 @:until_}{\&{until} primitive@>
5674 mp_primitive(mp, "within",within_token,0);
5675 @:within_}{\&{within} primitive@>
5676 mp_primitive(mp, "write",write_command,0);
5677 @:write_}{\&{write} primitive@>
5679 @ Each primitive has a corresponding inverse, so that it is possible to
5680 display the cryptic numeric contents of |eqtb| in symbolic form.
5681 Every call of |primitive| in this program is therefore accompanied by some
5682 straightforward code that forms part of the |print_cmd_mod| routine
5685 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5686 case add_to_command:mp_print(mp, "addto"); break;
5687 case assignment:mp_print(mp, ":="); break;
5688 case at_least:mp_print(mp, "atleast"); break;
5689 case bchar_label:mp_print(mp, "||:"); break;
5690 case begin_group:mp_print(mp, "begingroup"); break;
5691 case colon:mp_print(mp, ":"); break;
5692 case comma:mp_print(mp, ","); break;
5693 case controls:mp_print(mp, "controls"); break;
5694 case curl_command:mp_print(mp, "curl"); break;
5695 case delimiters:mp_print(mp, "delimiters"); break;
5696 case double_colon:mp_print(mp, "::"); break;
5697 case end_group:mp_print(mp, "endgroup"); break;
5698 case every_job_command:mp_print(mp, "everyjob"); break;
5699 case exit_test:mp_print(mp, "exitif"); break;
5700 case expand_after:mp_print(mp, "expandafter"); break;
5701 case interim_command:mp_print(mp, "interim"); break;
5702 case left_brace:mp_print(mp, "{"); break;
5703 case left_bracket:mp_print(mp, "["); break;
5704 case let_command:mp_print(mp, "let"); break;
5705 case new_internal:mp_print(mp, "newinternal"); break;
5706 case of_token:mp_print(mp, "of"); break;
5707 case path_join:mp_print(mp, ".."); break;
5708 case mp_random_seed:mp_print(mp, "randomseed"); break;
5709 case relax:mp_print_char(mp, xord('\\')); break;
5710 case right_brace:mp_print_char(mp, xord('}')); break;
5711 case right_bracket:mp_print_char(mp, xord(']')); break;
5712 case save_command:mp_print(mp, "save"); break;
5713 case scan_tokens:mp_print(mp, "scantokens"); break;
5714 case semicolon:mp_print_char(mp, xord(';')); break;
5715 case ship_out_command:mp_print(mp, "shipout"); break;
5716 case skip_to:mp_print(mp, "skipto"); break;
5717 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5718 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5719 mp_print(mp, "special"); break;
5720 case step_token:mp_print(mp, "step"); break;
5721 case str_op:mp_print(mp, "str"); break;
5722 case tension:mp_print(mp, "tension"); break;
5723 case to_token:mp_print(mp, "to"); break;
5724 case until_token:mp_print(mp, "until"); break;
5725 case within_token:mp_print(mp, "within"); break;
5726 case write_command:mp_print(mp, "write"); break;
5728 @ We will deal with the other primitives later, at some point in the program
5729 where their |eq_type| and |equiv| values are more meaningful. For example,
5730 the primitives for macro definitions will be loaded when we consider the
5731 routines that define macros.
5732 It is easy to find where each particular
5733 primitive was treated by looking in the index at the end; for example, the
5734 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5736 @* \[14] Token lists.
5737 A \MP\ token is either symbolic or numeric or a string, or it denotes
5738 a macro parameter or capsule; so there are five corresponding ways to encode it
5740 internally: (1)~A symbolic token whose hash code is~|p|
5741 is represented by the number |p|, in the |info| field of a single-word
5742 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5743 represented in a two-word node of~|mem|; the |type| field is |known|,
5744 the |name_type| field is |token|, and the |value| field holds~|v|.
5745 The fact that this token appears in a two-word node rather than a
5746 one-word node is, of course, clear from the node address.
5747 (3)~A string token is also represented in a two-word node; the |type|
5748 field is |mp_string_type|, the |name_type| field is |token|, and the
5749 |value| field holds the corresponding |str_number|. (4)~Capsules have
5750 |name_type=capsule|, and their |type| and |value| fields represent
5751 arbitrary values (in ways to be explained later). (5)~Macro parameters
5752 are like symbolic tokens in that they appear in |info| fields of
5753 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5754 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5755 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5756 Actual values of these parameters are kept in a separate stack, as we will
5757 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5758 of course, chosen so that there will be no confusion between symbolic
5759 tokens and parameters of various types.
5762 the `\\{type}' field of a node has nothing to do with ``type'' in a
5763 printer's sense. It's curious that the same word is used in such different ways.
5765 @d mp_type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5766 @d mp_name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5767 @d token_node_size 2 /* the number of words in a large token node */
5768 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5769 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5770 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5771 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5772 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5774 @<Check the ``constant''...@>=
5775 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5777 @ We have set aside a two word node beginning at |null| so that we can have
5778 |value(null)=0|. We will make use of this coincidence later.
5780 @<Initialize table entries...@>=
5781 mp_link(null)=null; value(null)=0;
5783 @ A numeric token is created by the following trivial routine.
5786 static pointer mp_new_num_tok (MP mp,scaled v) {
5787 pointer p; /* the new node */
5788 p=mp_get_node(mp, token_node_size); value(p)=v;
5789 mp_type(p)=mp_known; mp_name_type(p)=mp_token;
5793 @ A token list is a singly linked list of nodes in |mem|, where
5794 each node contains a token and a link. Here's a subroutine that gets rid
5795 of a token list when it is no longer needed.
5797 @c static void mp_flush_token_list (MP mp,pointer p) {
5798 pointer q; /* the node being recycled */
5801 if ( q>=mp->hi_mem_min ) {
5804 switch (mp_type(q)) {
5805 case mp_vacuous: case mp_boolean_type: case mp_known:
5807 case mp_string_type:
5808 delete_str_ref(value(q));
5810 case unknown_types: case mp_pen_type: case mp_path_type:
5811 case mp_picture_type: case mp_pair_type: case mp_color_type:
5812 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5813 case mp_proto_dependent: case mp_independent:
5814 mp_recycle_value(mp,q);
5816 default: mp_confusion(mp, "token");
5817 @:this can't happen token}{\quad token@>
5819 mp_free_node(mp, q,token_node_size);
5824 @ The procedure |show_token_list|, which prints a symbolic form of
5825 the token list that starts at a given node |p|, illustrates these
5826 conventions. The token list being displayed should not begin with a reference
5827 count. However, the procedure is intended to be fairly robust, so that if the
5828 memory links are awry or if |p| is not really a pointer to a token list,
5829 almost nothing catastrophic can happen.
5831 An additional parameter |q| is also given; this parameter is either null
5832 or it points to a node in the token list where a certain magic computation
5833 takes place that will be explained later. (Basically, |q| is non-null when
5834 we are printing the two-line context information at the time of an error
5835 message; |q| marks the place corresponding to where the second line
5838 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5839 of printing exceeds a given limit~|l|; the length of printing upon entry is
5840 assumed to be a given amount called |null_tally|. (Note that
5841 |show_token_list| sometimes uses itself recursively to print
5842 variable names within a capsule.)
5845 Unusual entries are printed in the form of all-caps tokens
5846 preceded by a space, e.g., `\.{\char`\ BAD}'.
5849 static void mp_show_token_list (MP mp, integer p, integer q, integer l,
5850 integer null_tally) ;
5853 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5854 integer null_tally) {
5855 quarterword class,c; /* the |char_class| of previous and new tokens */
5856 integer r,v; /* temporary registers */
5857 class=percent_class;
5858 mp->tally=null_tally;
5859 while ( (p!=null) && (mp->tally<l) ) {
5861 @<Do magic computation@>;
5862 @<Display token |p| and set |c| to its class;
5863 but |return| if there are problems@>;
5864 class=c; p=mp_link(p);
5867 mp_print(mp, " ETC.");
5872 @ @<Display token |p| and set |c| to its class...@>=
5873 c=letter_class; /* the default */
5874 if ( (p<0)||(p>mp->mem_end) ) {
5875 mp_print(mp, " CLOBBERED"); return;
5878 if ( p<mp->hi_mem_min ) {
5879 @<Display two-word token@>;
5882 if ( r>=expr_base ) {
5883 @<Display a parameter token@>;
5887 @<Display a collective subscript@>
5889 mp_print(mp, " IMPOSSIBLE");
5894 if ( (r<0)||(r>mp->max_str_ptr) ) {
5895 mp_print(mp, " NONEXISTENT");
5898 @<Print string |r| as a symbolic token
5899 and set |c| to its class@>;
5905 @ @<Display two-word token@>=
5906 if ( mp_name_type(p)==mp_token ) {
5907 if ( mp_type(p)==mp_known ) {
5908 @<Display a numeric token@>;
5909 } else if ( mp_type(p)!=mp_string_type ) {
5910 mp_print(mp, " BAD");
5913 mp_print_char(mp, xord('"')); mp_print_str(mp, value(p)); mp_print_char(mp, xord('"'));
5916 } else if ((mp_name_type(p)!=mp_capsule)||(mp_type(p)<mp_vacuous)||(mp_type(p)>mp_independent) ) {
5917 mp_print(mp, " BAD");
5919 mp_print_capsule(mp,p); c=right_paren_class;
5922 @ @<Display a numeric token@>=
5923 if ( class==digit_class )
5924 mp_print_char(mp, xord(' '));
5927 if ( class==left_bracket_class )
5928 mp_print_char(mp, xord(' '));
5929 mp_print_char(mp, xord('[')); mp_print_scaled(mp, v); mp_print_char(mp, xord(']'));
5930 c=right_bracket_class;
5932 mp_print_scaled(mp, v); c=digit_class;
5936 @ Strictly speaking, a genuine token will never have |mp_info(p)=0|.
5937 But we will see later (in the |print_variable_name| routine) that
5938 it is convenient to let |mp_info(p)=0| stand for `\.{[]}'.
5940 @<Display a collective subscript@>=
5942 if ( class==left_bracket_class )
5943 mp_print_char(mp, xord(' '));
5944 mp_print(mp, "[]"); c=right_bracket_class;
5947 @ @<Display a parameter token@>=
5949 if ( r<suffix_base ) {
5950 mp_print(mp, "(EXPR"); r=r-(expr_base);
5952 } else if ( r<text_base ) {
5953 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5956 mp_print(mp, "(TEXT"); r=r-(text_base);
5959 mp_print_int(mp, r); mp_print_char(mp, xord(')')); c=right_paren_class;
5963 @ @<Print string |r| as a symbolic token...@>=
5965 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5968 case letter_class:mp_print_char(mp, xord('.')); break;
5969 case isolated_classes: break;
5970 default: mp_print_char(mp, xord(' ')); break;
5973 mp_print_str(mp, r);
5977 static void mp_print_capsule (MP mp, pointer p);
5979 @ @<Declare miscellaneous procedures that were declared |forward|@>=
5980 void mp_print_capsule (MP mp, pointer p) {
5981 mp_print_char(mp, xord('(')); mp_print_exp(mp,p,0); mp_print_char(mp, xord(')'));
5984 @ Macro definitions are kept in \MP's memory in the form of token lists
5985 that have a few extra one-word nodes at the beginning.
5987 The first node contains a reference count that is used to tell when the
5988 list is no longer needed. To emphasize the fact that a reference count is
5989 present, we shall refer to the |info| field of this special node as the
5991 @^reference counts@>
5993 The next node or nodes after the reference count serve to describe the
5994 formal parameters. They consist of zero or more parameter tokens followed
5995 by a code for the type of macro.
5997 @d ref_count mp_info
5998 /* reference count preceding a macro definition or picture header */
5999 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
6000 @d general_macro 0 /* preface to a macro defined with a parameter list */
6001 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
6002 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
6003 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
6004 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
6005 @d of_macro 5 /* preface to a macro with
6006 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
6007 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
6008 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
6011 static void mp_delete_mac_ref (MP mp,pointer p) {
6012 /* |p| points to the reference count of a macro list that is
6013 losing one reference */
6014 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
6015 else decr(ref_count(p));
6018 @ The following subroutine displays a macro, given a pointer to its
6022 static void mp_show_macro (MP mp, pointer p, integer q, integer l) {
6023 pointer r; /* temporary storage */
6024 p=mp_link(p); /* bypass the reference count */
6025 while ( mp_info(p)>text_macro ){
6026 r=mp_link(p); mp_link(p)=null;
6027 mp_show_token_list(mp, p,null,l,0); mp_link(p)=r; p=r;
6028 if ( l>0 ) l=l-mp->tally; else return;
6029 } /* control printing of `\.{ETC.}' */
6032 switch(mp_info(p)) {
6033 case general_macro:mp_print(mp, "->"); break;
6035 case primary_macro: case secondary_macro: case tertiary_macro:
6036 mp_print_char(mp, xord('<'));
6037 mp_print_cmd_mod(mp, param_type,mp_info(p));
6038 mp_print(mp, ">->");
6040 case expr_macro:mp_print(mp, "<expr>->"); break;
6041 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
6042 case suffix_macro:mp_print(mp, "<suffix>->"); break;
6043 case text_macro:mp_print(mp, "<text>->"); break;
6044 } /* there are no other cases */
6045 mp_show_token_list(mp, mp_link(p),q,l-mp->tally,0);
6048 @* \[15] Data structures for variables.
6049 The variables of \MP\ programs can be simple, like `\.x', or they can
6050 combine the structural properties of arrays and records, like `\.{x20a.b}'.
6051 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
6052 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
6053 things are represented inside of the computer.
6055 Each variable value occupies two consecutive words, either in a two-word
6056 node called a value node, or as a two-word subfield of a larger node. One
6057 of those two words is called the |value| field; it is an integer,
6058 containing either a |scaled| numeric value or the representation of some
6059 other type of quantity. (It might also be subdivided into halfwords, in
6060 which case it is referred to by other names instead of |value|.) The other
6061 word is broken into subfields called |type|, |name_type|, and |link|. The
6062 |type| field is a quarterword that specifies the variable's type, and
6063 |name_type| is a quarterword from which \MP\ can reconstruct the
6064 variable's name (sometimes by using the |link| field as well). Thus, only
6065 1.25 words are actually devoted to the value itself; the other
6066 three-quarters of a word are overhead, but they aren't wasted because they
6067 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6069 In this section we shall be concerned only with the structural aspects of
6070 variables, not their values. Later parts of the program will change the
6071 |type| and |value| fields, but we shall treat those fields as black boxes
6072 whose contents should not be touched.
6074 However, if the |type| field is |mp_structured|, there is no |value| field,
6075 and the second word is broken into two pointer fields called |attr_head|
6076 and |subscr_head|. Those fields point to additional nodes that
6077 contain structural information, as we shall see.
6079 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6080 @d attr_head(A) mp_info(subscr_head_loc((A))) /* pointer to attribute info */
6081 @d subscr_head(A) mp_link(subscr_head_loc((A))) /* pointer to subscript info */
6082 @d value_node_size 2 /* the number of words in a value node */
6084 @ An attribute node is three words long. Two of these words contain |type|
6085 and |value| fields as described above, and the third word contains
6086 additional information: There is an |attr_loc| field, which contains the
6087 hash address of the token that names this attribute; and there's also a
6088 |parent| field, which points to the value node of |mp_structured| type at the
6089 next higher level (i.e., at the level to which this attribute is
6090 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6091 |link| field points to the next attribute with the same parent; these are
6092 arranged in increasing order, so that |attr_loc(mp_link(p))>attr_loc(p)|. The
6093 final attribute node links to the constant |end_attr|, whose |attr_loc|
6094 field is greater than any legal hash address. The |attr_head| in the
6095 parent points to a node whose |name_type| is |mp_structured_root|; this
6096 node represents the null attribute, i.e., the variable that is relevant
6097 when no attributes are attached to the parent. The |attr_head| node
6098 has the fields of either
6099 a value node, a subscript node, or an attribute node, depending on what
6100 the parent would be if it were not structured; but the subscript and
6101 attribute fields are ignored, so it effectively contains only the data of
6102 a value node. The |link| field in this special node points to an attribute
6103 node whose |attr_loc| field is zero; the latter node represents a collective
6104 subscript `\.{[]}' attached to the parent, and its |link| field points to
6105 the first non-special attribute node (or to |end_attr| if there are none).
6107 A subscript node likewise occupies three words, with |type| and |value| fields
6108 plus extra information; its |name_type| is |subscr|. In this case the
6109 third word is called the |subscript| field, which is a |scaled| integer.
6110 The |link| field points to the subscript node with the next larger
6111 subscript, if any; otherwise the |link| points to the attribute node
6112 for collective subscripts at this level. We have seen that the latter node
6113 contains an upward pointer, so that the parent can be deduced.
6115 The |name_type| in a parent-less value node is |root|, and the |link|
6116 is the hash address of the token that names this value.
6118 In other words, variables have a hierarchical structure that includes
6119 enough threads running around so that the program is able to move easily
6120 between siblings, parents, and children. An example should be helpful:
6121 (The reader is advised to draw a picture while reading the following
6122 description, since that will help to firm up the ideas.)
6123 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6124 and `\.{x20b}' have been mentioned in a user's program, where
6125 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6126 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6127 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6128 node with |mp_name_type(p)=root| and |mp_link(p)=h(x)|. We have |type(p)=mp_structured|,
6129 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6130 node and |r| to a subscript node. (Are you still following this? Use
6131 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6132 |type(q)| and |value(q)|; furthermore
6133 |mp_name_type(q)=mp_structured_root| and |mp_link(q)=q1|, where |q1| points
6134 to an attribute node representing `\.{x[]}'. Thus |mp_name_type(q1)=attr|,
6135 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6136 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6137 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
6138 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
6139 with no further attributes), |mp_name_type(qq)=structured_root|,
6140 |attr_loc(qq)=0|, |parent(qq)=p|, and
6141 |mp_link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6142 an attribute node representing `\.{x[][]}', which has never yet
6143 occurred; its |type| field is |undefined|, and its |value| field is
6144 undefined. We have |mp_name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6145 |parent(qq1)=q1|, and |mp_link(qq1)=qq2|. Since |qq2| represents
6146 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6147 |parent(qq2)=q1|, |mp_name_type(qq2)=attr|, |mp_link(qq2)=end_attr|.
6148 (Maybe colored lines will help untangle your picture.)
6149 Node |r| is a subscript node with |type| and |value|
6150 representing `\.{x5}'; |mp_name_type(r)=subscr|, |subscript(r)=5.0|,
6151 and |mp_link(r)=r1| is another subscript node. To complete the picture,
6152 see if you can guess what |mp_link(r1)| is; give up? It's~|q1|.
6153 Furthermore |subscript(r1)=20.0|, |mp_name_type(r1)=subscr|,
6154 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6155 and we finish things off with three more nodes
6156 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6157 with a larger sheet of paper.) The value of variable \.{x20b}
6158 appears in node~|qqq2|, as you can well imagine.
6160 If the example in the previous paragraph doesn't make things crystal
6161 clear, a glance at some of the simpler subroutines below will reveal how
6162 things work out in practice.
6164 The only really unusual thing about these conventions is the use of
6165 collective subscript attributes. The idea is to avoid repeating a lot of
6166 type information when many elements of an array are identical macros
6167 (for which distinct values need not be stored) or when they don't have
6168 all of the possible attributes. Branches of the structure below collective
6169 subscript attributes do not carry actual values except for macro identifiers;
6170 branches of the structure below subscript nodes do not carry significant
6171 information in their collective subscript attributes.
6173 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6174 @d attr_loc(A) mp_info(attr_loc_loc((A))) /* hash address of this attribute */
6175 @d parent(A) mp_link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6176 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6177 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6178 @d attr_node_size 3 /* the number of words in an attribute node */
6179 @d subscr_node_size 3 /* the number of words in a subscript node */
6180 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6182 @<Initialize table...@>=
6183 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6185 @ Variables of type \&{pair} will have values that point to four-word
6186 nodes containing two numeric values. The first of these values has
6187 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6188 the |link| in the first points back to the node whose |value| points
6189 to this four-word node.
6191 Variables of type \&{transform} are similar, but in this case their
6192 |value| points to a 12-word node containing six values, identified by
6193 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6194 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6195 Finally, variables of type \&{color} have 3~values in 6~words
6196 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6198 When an entire structured variable is saved, the |root| indication
6199 is temporarily replaced by |saved_root|.
6201 Some variables have no name; they just are used for temporary storage
6202 while expressions are being evaluated. We call them {\sl capsules}.
6204 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6205 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6206 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6207 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6208 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6209 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6210 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6211 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6212 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6213 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6214 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6215 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6216 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6217 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6219 @d pair_node_size 4 /* the number of words in a pair node */
6220 @d transform_node_size 12 /* the number of words in a transform node */
6221 @d color_node_size 6 /* the number of words in a color node */
6222 @d cmykcolor_node_size 8 /* the number of words in a color node */
6225 quarterword big_node_size[mp_pair_type+1];
6226 quarterword sector0[mp_pair_type+1];
6227 quarterword sector_offset[mp_black_part_sector+1];
6229 @ The |sector0| array gives for each big node type, |name_type| values
6230 for its first subfield; the |sector_offset| array gives for each
6231 |name_type| value, the offset from the first subfield in words;
6232 and the |big_node_size| array gives the size in words for each type of
6236 mp->big_node_size[mp_transform_type]=transform_node_size;
6237 mp->big_node_size[mp_pair_type]=pair_node_size;
6238 mp->big_node_size[mp_color_type]=color_node_size;
6239 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6240 mp->sector0[mp_transform_type]=mp_x_part_sector;
6241 mp->sector0[mp_pair_type]=mp_x_part_sector;
6242 mp->sector0[mp_color_type]=mp_red_part_sector;
6243 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6244 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6245 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6247 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6248 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6250 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6251 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6254 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6255 procedure call |init_big_node(p)| will allocate a pair or transform node
6256 for~|p|. The individual parts of such nodes are initially of type
6260 static void mp_init_big_node (MP mp,pointer p) {
6261 pointer q; /* the new node */
6262 quarterword s; /* its size */
6263 s=mp->big_node_size[mp_type(p)]; q=mp_get_node(mp, s);
6266 @<Make variable |q+s| newly independent@>;
6267 mp_name_type(q+s)=halfp(s)+mp->sector0[mp_type(p)];
6270 mp_link(q)=p; value(p)=q;
6273 @ The |id_transform| function creates a capsule for the
6274 identity transformation.
6277 static pointer mp_id_transform (MP mp) {
6278 pointer p,q,r; /* list manipulation registers */
6279 p=mp_get_node(mp, value_node_size); mp_type(p)=mp_transform_type;
6280 mp_name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6281 r=q+transform_node_size;
6284 mp_type(r)=mp_known; value(r)=0;
6286 value(xx_part_loc(q))=unity;
6287 value(yy_part_loc(q))=unity;
6291 @ Tokens are of type |tag_token| when they first appear, but they point
6292 to |null| until they are first used as the root of a variable.
6293 The following subroutine establishes the root node on such grand occasions.
6296 static void mp_new_root (MP mp,pointer x) {
6297 pointer p; /* the new node */
6298 p=mp_get_node(mp, value_node_size); mp_type(p)=undefined; mp_name_type(p)=mp_root;
6299 mp_link(p)=x; equiv(x)=p;
6302 @ These conventions for variable representation are illustrated by the
6303 |print_variable_name| routine, which displays the full name of a
6304 variable given only a pointer to its two-word value packet.
6307 static void mp_print_variable_name (MP mp, pointer p);
6310 void mp_print_variable_name (MP mp, pointer p) {
6311 pointer q; /* a token list that will name the variable's suffix */
6312 pointer r; /* temporary for token list creation */
6313 while ( mp_name_type(p)>=mp_x_part_sector ) {
6314 @<Preface the output with a part specifier; |return| in the
6315 case of a capsule@>;
6318 while ( mp_name_type(p)>mp_saved_root ) {
6319 @<Ascend one level, pushing a token onto list |q|
6320 and replacing |p| by its parent@>;
6322 r=mp_get_avail(mp); mp_info(r)=mp_link(p); mp_link(r)=q;
6323 if ( mp_name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6325 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6326 mp_flush_token_list(mp, r);
6329 @ @<Ascend one level, pushing a token onto list |q|...@>=
6331 if ( mp_name_type(p)==mp_subscr ) {
6332 r=mp_new_num_tok(mp, subscript(p));
6335 } while (mp_name_type(p)!=mp_attr);
6336 } else if ( mp_name_type(p)==mp_structured_root ) {
6337 p=mp_link(p); goto FOUND;
6339 if ( mp_name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6340 @:this can't happen var}{\quad var@>
6341 r=mp_get_avail(mp); mp_info(r)=attr_loc(p);
6348 @ @<Preface the output with a part specifier...@>=
6349 { switch (mp_name_type(p)) {
6350 case mp_x_part_sector: mp_print_char(mp, xord('x')); break;
6351 case mp_y_part_sector: mp_print_char(mp, xord('y')); break;
6352 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6353 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6354 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6355 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6356 case mp_red_part_sector: mp_print(mp, "red"); break;
6357 case mp_green_part_sector: mp_print(mp, "green"); break;
6358 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6359 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6360 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6361 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6362 case mp_black_part_sector: mp_print(mp, "black"); break;
6363 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6365 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6368 } /* there are no other cases */
6369 mp_print(mp, "part ");
6370 p=mp_link(p-mp->sector_offset[mp_name_type(p)]);
6373 @ The |interesting| function returns |true| if a given variable is not
6374 in a capsule, or if the user wants to trace capsules.
6377 static boolean mp_interesting (MP mp,pointer p) {
6378 quarterword t; /* a |name_type| */
6379 if ( mp->internal[mp_tracing_capsules]>0 ) {
6383 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6384 t=mp_name_type(mp_link(p-mp->sector_offset[t]));
6385 return (t!=mp_capsule);
6389 @ Now here is a subroutine that converts an unstructured type into an
6390 equivalent structured type, by inserting a |mp_structured| node that is
6391 capable of growing. This operation is done only when |mp_name_type(p)=root|,
6392 |subscr|, or |attr|.
6394 The procedure returns a pointer to the new node that has taken node~|p|'s
6395 place in the structure. Node~|p| itself does not move, nor are its
6396 |value| or |type| fields changed in any way.
6399 static pointer mp_new_structure (MP mp,pointer p) {
6400 pointer q,r=0; /* list manipulation registers */
6401 switch (mp_name_type(p)) {
6403 q=mp_link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6406 @<Link a new subscript node |r| in place of node |p|@>;
6409 @<Link a new attribute node |r| in place of node |p|@>;
6412 mp_confusion(mp, "struct");
6413 @:this can't happen struct}{\quad struct@>
6416 mp_link(r)=mp_link(p); mp_type(r)=mp_structured; mp_name_type(r)=mp_name_type(p);
6417 attr_head(r)=p; mp_name_type(p)=mp_structured_root;
6418 q=mp_get_node(mp, attr_node_size); mp_link(p)=q; subscr_head(r)=q;
6419 parent(q)=r; mp_type(q)=undefined; mp_name_type(q)=mp_attr; mp_link(q)=end_attr;
6420 attr_loc(q)=collective_subscript;
6424 @ @<Link a new subscript node |r| in place of node |p|@>=
6429 } while (mp_name_type(q)!=mp_attr);
6430 q=parent(q); r=subscr_head_loc(q); /* |mp_link(r)=subscr_head(q)| */
6434 r=mp_get_node(mp, subscr_node_size);
6435 mp_link(q)=r; subscript(r)=subscript(p);
6438 @ If the attribute is |collective_subscript|, there are two pointers to
6439 node~|p|, so we must change both of them.
6441 @<Link a new attribute node |r| in place of node |p|@>=
6443 q=parent(p); r=attr_head(q);
6447 r=mp_get_node(mp, attr_node_size); mp_link(q)=r;
6448 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6449 if ( attr_loc(p)==collective_subscript ) {
6450 q=subscr_head_loc(parent(p));
6451 while ( mp_link(q)!=p ) q=mp_link(q);
6456 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6457 list of suffixes; it returns a pointer to the corresponding two-word
6458 value. For example, if |t| points to token \.x followed by a numeric
6459 token containing the value~7, |find_variable| finds where the value of
6460 \.{x7} is stored in memory. This may seem a simple task, and it
6461 usually is, except when \.{x7} has never been referenced before.
6462 Indeed, \.x may never have even been subscripted before; complexities
6463 arise with respect to updating the collective subscript information.
6465 If a macro type is detected anywhere along path~|t|, or if the first
6466 item on |t| isn't a |tag_token|, the value |null| is returned.
6467 Otherwise |p| will be a non-null pointer to a node such that
6468 |undefined<type(p)<mp_structured|.
6470 @d abort_find { return null; }
6473 static pointer mp_find_variable (MP mp,pointer t) {
6474 pointer p,q,r,s; /* nodes in the ``value'' line */
6475 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6476 integer n; /* subscript or attribute */
6477 memory_word save_word; /* temporary storage for a word of |mem| */
6479 p=mp_info(t); t=mp_link(t);
6480 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6481 if ( equiv(p)==null ) mp_new_root(mp, p);
6484 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6485 if ( t<mp->hi_mem_min ) {
6486 @<Descend one level for the subscript |value(t)|@>
6488 @<Descend one level for the attribute |mp_info(t)|@>;
6492 if ( mp_type(pp)>=mp_structured ) {
6493 if ( mp_type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6495 if ( mp_type(p)==mp_structured ) p=attr_head(p);
6496 if ( mp_type(p)==undefined ) {
6497 if ( mp_type(pp)==undefined ) { mp_type(pp)=mp_numeric_type; value(pp)=null; };
6498 mp_type(p)=mp_type(pp); value(p)=null;
6503 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6504 |pp|~stays in the collective line while |p|~goes through actual subscript
6507 @<Make sure that both nodes |p| and |pp|...@>=
6508 if ( mp_type(pp)!=mp_structured ) {
6509 if ( mp_type(pp)>mp_structured ) abort_find;
6510 ss=mp_new_structure(mp, pp);
6513 }; /* now |type(pp)=mp_structured| */
6514 if ( mp_type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6515 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6517 @ We want this part of the program to be reasonably fast, in case there are
6519 lots of subscripts at the same level of the data structure. Therefore
6520 we store an ``infinite'' value in the word that appears at the end of the
6521 subscript list, even though that word isn't part of a subscript node.
6523 @<Descend one level for the subscript |value(t)|@>=
6526 pp=mp_link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6527 q=mp_link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6528 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |mp_link(s)=subscr_head(p)| */
6531 } while (n>subscript(s));
6532 if ( n==subscript(s) ) {
6535 p=mp_get_node(mp, subscr_node_size); mp_link(r)=p; mp_link(p)=s;
6536 subscript(p)=n; mp_name_type(p)=mp_subscr; mp_type(p)=undefined;
6538 mp->mem[subscript_loc(q)]=save_word;
6541 @ @<Descend one level for the attribute |mp_info(t)|@>=
6546 rr=ss; ss=mp_link(ss);
6547 } while (n>attr_loc(ss));
6548 if ( n<attr_loc(ss) ) {
6549 qq=mp_get_node(mp, attr_node_size); mp_link(rr)=qq; mp_link(qq)=ss;
6550 attr_loc(qq)=n; mp_name_type(qq)=mp_attr; mp_type(qq)=undefined;
6551 parent(qq)=pp; ss=qq;
6556 pp=ss; s=attr_head(p);
6559 } while (n>attr_loc(s));
6560 if ( n==attr_loc(s) ) {
6563 q=mp_get_node(mp, attr_node_size); mp_link(r)=q; mp_link(q)=s;
6564 attr_loc(q)=n; mp_name_type(q)=mp_attr; mp_type(q)=undefined;
6570 @ Variables lose their former values when they appear in a type declaration,
6571 or when they are defined to be macros or \&{let} equal to something else.
6572 A subroutine will be defined later that recycles the storage associated
6573 with any particular |type| or |value|; our goal now is to study a higher
6574 level process called |flush_variable|, which selectively frees parts of a
6577 This routine has some complexity because of examples such as
6578 `\hbox{\tt numeric x[]a[]b}'
6579 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6580 `\hbox{\tt vardef x[]a[]=...}'
6581 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6582 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6583 to handle such examples is to use recursion; so that's what we~do.
6586 Parameter |p| points to the root information of the variable;
6587 parameter |t| points to a list of one-word nodes that represent
6588 suffixes, with |info=collective_subscript| for subscripts.
6591 static void mp_flush_cur_exp (MP mp,scaled v) ;
6594 static void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6595 pointer q,r; /* list manipulation */
6596 halfword n; /* attribute to match */
6598 if ( mp_type(p)!=mp_structured ) return;
6599 n=mp_info(t); t=mp_link(t);
6600 if ( n==collective_subscript ) {
6601 r=subscr_head_loc(p); q=mp_link(r); /* |q=subscr_head(p)| */
6602 while ( mp_name_type(q)==mp_subscr ){
6603 mp_flush_variable(mp, q,t,discard_suffixes);
6605 if ( mp_type(q)==mp_structured ) r=q;
6606 else { mp_link(r)=mp_link(q); mp_free_node(mp, q,subscr_node_size); }
6616 } while (attr_loc(p)<n);
6617 if ( attr_loc(p)!=n ) return;
6619 if ( discard_suffixes ) {
6620 mp_flush_below_variable(mp, p);
6622 if ( mp_type(p)==mp_structured ) p=attr_head(p);
6623 mp_recycle_value(mp, p);
6627 @ The next procedure is simpler; it wipes out everything but |p| itself,
6628 which becomes undefined.
6631 static void mp_flush_below_variable (MP mp, pointer p);
6634 void mp_flush_below_variable (MP mp,pointer p) {
6635 pointer q,r; /* list manipulation registers */
6636 if ( mp_type(p)!=mp_structured ) {
6637 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6640 while ( mp_name_type(q)==mp_subscr ) {
6641 mp_flush_below_variable(mp, q); r=q; q=mp_link(q);
6642 mp_free_node(mp, r,subscr_node_size);
6644 r=attr_head(p); q=mp_link(r); mp_recycle_value(mp, r);
6645 if ( mp_name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6646 else mp_free_node(mp, r,subscr_node_size);
6647 /* we assume that |subscr_node_size=attr_node_size| */
6649 mp_flush_below_variable(mp, q); r=q; q=mp_link(q); mp_free_node(mp, r,attr_node_size);
6650 } while (q!=end_attr);
6651 mp_type(p)=undefined;
6655 @ Just before assigning a new value to a variable, we will recycle the
6656 old value and make the old value undefined. The |und_type| routine
6657 determines what type of undefined value should be given, based on
6658 the current type before recycling.
6661 static quarterword mp_und_type (MP mp,pointer p) {
6662 switch (mp_type(p)) {
6663 case undefined: case mp_vacuous:
6665 case mp_boolean_type: case mp_unknown_boolean:
6666 return mp_unknown_boolean;
6667 case mp_string_type: case mp_unknown_string:
6668 return mp_unknown_string;
6669 case mp_pen_type: case mp_unknown_pen:
6670 return mp_unknown_pen;
6671 case mp_path_type: case mp_unknown_path:
6672 return mp_unknown_path;
6673 case mp_picture_type: case mp_unknown_picture:
6674 return mp_unknown_picture;
6675 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6676 case mp_pair_type: case mp_numeric_type:
6678 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6679 return mp_numeric_type;
6680 } /* there are no other cases */
6684 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6685 of a symbolic token. It must remove any variable structure or macro
6686 definition that is currently attached to that symbol. If the |saving|
6687 parameter is true, a subsidiary structure is saved instead of destroyed.
6690 static void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6691 pointer q; /* |equiv(p)| */
6693 switch (eq_type(p) % outer_tag) {
6695 case secondary_primary_macro:
6696 case tertiary_secondary_macro:
6697 case expression_tertiary_macro:
6698 if ( ! saving ) mp_delete_mac_ref(mp, q);
6703 mp_name_type(q)=mp_saved_root;
6705 mp_flush_below_variable(mp, q);
6706 mp_free_node(mp,q,value_node_size);
6713 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6716 @* \[16] Saving and restoring equivalents.
6717 The nested structure given by \&{begingroup} and \&{endgroup}
6718 allows |eqtb| entries to be saved and restored, so that temporary changes
6719 can be made without difficulty. When the user requests a current value to
6720 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6721 \&{endgroup} ultimately causes the old values to be removed from the save
6722 stack and put back in their former places.
6724 The save stack is a linked list containing three kinds of entries,
6725 distinguished by their |info| fields. If |p| points to a saved item,
6729 |mp_info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6730 such an item to the save stack and each \&{endgroup} cuts back the stack
6731 until the most recent such entry has been removed.
6734 |mp_info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6735 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6739 |mp_info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6740 integer to be restored to internal parameter number~|q|. Such entries
6741 are generated by \&{interim} commands.
6744 The global variable |save_ptr| points to the top item on the save stack.
6746 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6747 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6748 @d save_boundary_item(A) { (A)=mp_get_avail(mp); mp_info((A))=0;
6749 mp_link((A))=mp->save_ptr; mp->save_ptr=(A);
6753 pointer save_ptr; /* the most recently saved item */
6755 @ @<Set init...@>=mp->save_ptr=null;
6757 @ The |save_variable| routine is given a hash address |q|; it salts this
6758 address in the save stack, together with its current equivalent,
6759 then makes token~|q| behave as though it were brand new.
6761 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6762 things from the stack when the program is not inside a group, so there's
6763 no point in wasting the space.
6766 static void mp_save_variable (MP mp,pointer q) {
6767 pointer p; /* temporary register */
6768 if ( mp->save_ptr!=null ){
6769 p=mp_get_node(mp, save_node_size); mp_info(p)=q; mp_link(p)=mp->save_ptr;
6770 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6772 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6775 @ Similarly, |save_internal| is given the location |q| of an internal
6776 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6780 static void mp_save_internal (MP mp,halfword q) {
6781 pointer p; /* new item for the save stack */
6782 if ( mp->save_ptr!=null ){
6783 p=mp_get_node(mp, save_node_size); mp_info(p)=hash_end+q;
6784 mp_link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6788 @ At the end of a group, the |unsave| routine restores all of the saved
6789 equivalents in reverse order. This routine will be called only when there
6790 is at least one boundary item on the save stack.
6793 static void mp_unsave (MP mp) {
6794 pointer q; /* index to saved item */
6795 pointer p; /* temporary register */
6796 while ( mp_info(mp->save_ptr)!=0 ) {
6797 q=mp_info(mp->save_ptr);
6799 if ( mp->internal[mp_tracing_restores]>0 ) {
6800 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6801 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, xord('='));
6802 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, xord('}'));
6803 mp_end_diagnostic(mp, false);
6805 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6807 if ( mp->internal[mp_tracing_restores]>0 ) {
6808 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6809 mp_print_text(q); mp_print_char(mp, xord('}'));
6810 mp_end_diagnostic(mp, false);
6812 mp_clear_symbol(mp, q,false);
6813 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6814 if ( eq_type(q) % outer_tag==tag_token ) {
6816 if ( p!=null ) mp_name_type(p)=mp_root;
6819 p=mp_link(mp->save_ptr);
6820 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6822 p=mp_link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6825 @* \[17] Data structures for paths.
6826 When a \MP\ user specifies a path, \MP\ will create a list of knots
6827 and control points for the associated cubic spline curves. If the
6828 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6829 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6830 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6831 @:Bezier}{B\'ezier, Pierre Etienne@>
6832 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6833 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6836 There is a 8-word node for each knot $z_k$, containing one word of
6837 control information and six words for the |x| and |y| coordinates of
6838 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6839 |mp_left_type| and |mp_right_type| fields, which each occupy a quarter of
6840 the first word in the node; they specify properties of the curve as it
6841 enters and leaves the knot. There's also a halfword |link| field,
6842 which points to the following knot, and a final supplementary word (of
6843 which only a quarter is used).
6845 If the path is a closed contour, knots 0 and |n| are identical;
6846 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6847 is not closed, the |mp_left_type| of knot~0 and the |mp_right_type| of knot~|n|
6848 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6849 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6851 @d mp_left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6852 @d mp_right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6853 @d mp_x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6854 @d mp_y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6855 @d mp_left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6856 @d mp_left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6857 @d mp_right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6858 @d mp_right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6859 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6860 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6861 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6862 @d left_coord(A) mp->mem[(A)+2].sc
6863 /* coordinate of previous control point given |x_loc| or |y_loc| */
6864 @d right_coord(A) mp->mem[(A)+4].sc
6865 /* coordinate of next control point given |x_loc| or |y_loc| */
6866 @d knot_node_size 8 /* number of words in a knot node */
6870 mp_endpoint=0, /* |mp_left_type| at path beginning and |mp_right_type| at path end */
6871 mp_explicit, /* |mp_left_type| or |mp_right_type| when control points are known */
6872 mp_given, /* |mp_left_type| or |mp_right_type| when a direction is given */
6873 mp_curl, /* |mp_left_type| or |mp_right_type| when a curl is desired */
6874 mp_open, /* |mp_left_type| or |mp_right_type| when \MP\ should choose the direction */
6878 @ Before the B\'ezier control points have been calculated, the memory
6879 space they will ultimately occupy is taken up by information that can be
6880 used to compute them. There are four cases:
6883 \textindent{$\bullet$} If |mp_right_type=mp_open|, the curve should leave
6884 the knot in the same direction it entered; \MP\ will figure out a
6888 \textindent{$\bullet$} If |mp_right_type=mp_curl|, the curve should leave the
6889 knot in a direction depending on the angle at which it enters the next
6890 knot and on the curl parameter stored in |right_curl|.
6893 \textindent{$\bullet$} If |mp_right_type=mp_given|, the curve should leave the
6894 knot in a nonzero direction stored as an |angle| in |right_given|.
6897 \textindent{$\bullet$} If |mp_right_type=mp_explicit|, the B\'ezier control
6898 point for leaving this knot has already been computed; it is in the
6899 |mp_right_x| and |mp_right_y| fields.
6902 The rules for |mp_left_type| are similar, but they refer to the curve entering
6903 the knot, and to \\{left} fields instead of \\{right} fields.
6905 Non-|explicit| control points will be chosen based on ``tension'' parameters
6906 in the |left_tension| and |right_tension| fields. The
6907 `\&{atleast}' option is represented by negative tension values.
6908 @:at_least_}{\&{atleast} primitive@>
6910 For example, the \MP\ path specification
6911 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6913 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6915 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6916 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6917 |mp_left_type|&\\{left} info&|mp_x_coord,mp_y_coord|&|mp_right_type|&\\{right} info\cr
6919 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6920 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6921 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6922 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6923 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6924 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6925 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6926 Of course, this example is more complicated than anything a normal user
6929 These types must satisfy certain restrictions because of the form of \MP's
6931 (i)~|open| type never appears in the same node together with |endpoint|,
6933 (ii)~The |mp_right_type| of a node is |explicit| if and only if the
6934 |mp_left_type| of the following node is |explicit|.
6935 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6937 @d left_curl mp_left_x /* curl information when entering this knot */
6938 @d left_given mp_left_x /* given direction when entering this knot */
6939 @d left_tension mp_left_y /* tension information when entering this knot */
6940 @d right_curl mp_right_x /* curl information when leaving this knot */
6941 @d right_given mp_right_x /* given direction when leaving this knot */
6942 @d right_tension mp_right_y /* tension information when leaving this knot */
6944 @ Knots can be user-supplied, or they can be created by program code,
6945 like the |split_cubic| function, or |copy_path|. The distinction is
6946 needed for the cleanup routine that runs after |split_cubic|, because
6947 it should only delete knots it has previously inserted, and never
6948 anything that was user-supplied. In order to be able to differentiate
6949 one knot from another, we will set |originator(p):=mp_metapost_user| when
6950 it appeared in the actual metapost program, and
6951 |originator(p):=mp_program_code| in all other cases.
6953 @d mp_originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6956 enum mp_knot_originator {
6957 mp_program_code=0, /* not created by a user */
6958 mp_metapost_user /* created by a user */
6961 @ Here is a routine that prints a given knot list
6962 in symbolic form. It illustrates the conventions discussed above,
6963 and checks for anomalies that might arise while \MP\ is being debugged.
6966 static void mp_pr_path (MP mp,pointer h);
6969 void mp_pr_path (MP mp,pointer h) {
6970 pointer p,q; /* for list traversal */
6974 if ( (p==null)||(q==null) ) {
6975 mp_print_nl(mp, "???"); return; /* this won't happen */
6978 @<Print information for adjacent knots |p| and |q|@>;
6981 if ( (p!=h)||(mp_left_type(h)!=mp_endpoint) ) {
6982 @<Print two dots, followed by |given| or |curl| if present@>;
6985 if ( mp_left_type(h)!=mp_endpoint )
6986 mp_print(mp, "cycle");
6989 @ @<Print information for adjacent knots...@>=
6990 mp_print_two(mp, mp_x_coord(p),mp_y_coord(p));
6991 switch (mp_right_type(p)) {
6993 if ( mp_left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
6995 if ( (mp_left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
6999 @<Print control points between |p| and |q|, then |goto done1|@>;
7002 @<Print information for a curve that begins |open|@>;
7006 @<Print information for a curve that begins |curl| or |given|@>;
7009 mp_print(mp, "???"); /* can't happen */
7013 if ( mp_left_type(q)<=mp_explicit ) {
7014 mp_print(mp, "..control?"); /* can't happen */
7016 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
7017 @<Print tension between |p| and |q|@>;
7020 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
7021 were |scaled|, the magnitude of a |given| direction vector will be~4096.
7023 @<Print two dots...@>=
7025 mp_print_nl(mp, " ..");
7026 if ( mp_left_type(p)==mp_given ) {
7027 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, xord('{'));
7028 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, xord(','));
7029 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, xord('}'));
7030 } else if ( mp_left_type(p)==mp_curl ){
7031 mp_print(mp, "{curl ");
7032 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, xord('}'));
7036 @ @<Print tension between |p| and |q|@>=
7038 mp_print(mp, "..tension ");
7039 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
7040 mp_print_scaled(mp, abs(right_tension(p)));
7041 if ( right_tension(p)!=left_tension(q) ){
7042 mp_print(mp, " and ");
7043 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
7044 mp_print_scaled(mp, abs(left_tension(q)));
7048 @ @<Print control points between |p| and |q|, then |goto done1|@>=
7050 mp_print(mp, "..controls ");
7051 mp_print_two(mp, mp_right_x(p),mp_right_y(p));
7052 mp_print(mp, " and ");
7053 if ( mp_left_type(q)!=mp_explicit ) {
7054 mp_print(mp, "??"); /* can't happen */
7057 mp_print_two(mp, mp_left_x(q),mp_left_y(q));
7062 @ @<Print information for a curve that begins |open|@>=
7063 if ( (mp_left_type(p)!=mp_explicit)&&(mp_left_type(p)!=mp_open) ) {
7064 mp_print(mp, "{open?}"); /* can't happen */
7068 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7069 \MP's default curl is present.
7071 @<Print information for a curve that begins |curl|...@>=
7073 if ( mp_left_type(p)==mp_open )
7074 mp_print(mp, "??"); /* can't happen */
7076 if ( mp_right_type(p)==mp_curl ) {
7077 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7079 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, xord('{'));
7080 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, xord(','));
7081 mp_print_scaled(mp, mp->n_sin);
7083 mp_print_char(mp, xord('}'));
7086 @ It is convenient to have another version of |pr_path| that prints the path
7087 as a diagnostic message.
7090 static void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) ;
7093 void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
7094 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7097 mp_end_diagnostic(mp, true);
7100 @ If we want to duplicate a knot node, we can say |copy_knot|:
7103 static pointer mp_copy_knot (MP mp,pointer p) {
7104 pointer q; /* the copy */
7105 int k; /* runs through the words of a knot node */
7106 q=mp_get_node(mp, knot_node_size);
7107 for (k=0;k<knot_node_size;k++) {
7108 mp->mem[q+k]=mp->mem[p+k];
7110 mp_originator(q)=mp_originator(p);
7114 @ The |copy_path| routine makes a clone of a given path.
7117 static pointer mp_copy_path (MP mp, pointer p) {
7118 pointer q,pp,qq; /* for list manipulation */
7119 q=mp_copy_knot(mp, p);
7120 qq=q; pp=mp_link(p);
7122 mp_link(qq)=mp_copy_knot(mp, pp);
7131 @ Just before |ship_out|, knot lists are exported for printing.
7133 The |gr_XXXX| macros are defined in |mppsout.h|.
7136 static mp_knot *mp_export_knot (MP mp,pointer p) {
7137 mp_knot *q; /* the copy */
7140 q = xmalloc(1, sizeof (mp_knot));
7141 memset(q,0,sizeof (mp_knot));
7142 gr_left_type(q) = (unsigned short)mp_left_type(p);
7143 gr_right_type(q) = (unsigned short)mp_right_type(p);
7144 gr_x_coord(q) = mp_x_coord(p);
7145 gr_y_coord(q) = mp_y_coord(p);
7146 gr_left_x(q) = mp_left_x(p);
7147 gr_left_y(q) = mp_left_y(p);
7148 gr_right_x(q) = mp_right_x(p);
7149 gr_right_y(q) = mp_right_y(p);
7150 gr_originator(q) = (unsigned char)mp_originator(p);
7154 @ The |export_knot_list| routine therefore also makes a clone
7158 static mp_knot *mp_export_knot_list (MP mp, pointer p) {
7159 mp_knot *q, *qq; /* for list manipulation */
7160 pointer pp; /* for list manipulation */
7163 q=mp_export_knot(mp, p);
7164 qq=q; pp=mp_link(p);
7166 gr_next_knot(qq)=mp_export_knot(mp, pp);
7167 qq=gr_next_knot(qq);
7175 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7176 returns a pointer to the first node of the copy, if the path is a cycle,
7177 but to the final node of a non-cyclic copy. The global
7178 variable |path_tail| will point to the final node of the original path;
7179 this trick makes it easier to implement `\&{doublepath}'.
7181 All node types are assumed to be |endpoint| or |explicit| only.
7184 static pointer mp_htap_ypoc (MP mp,pointer p) {
7185 pointer q,pp,qq,rr; /* for list manipulation */
7186 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7189 mp_right_type(qq)=mp_left_type(pp); mp_left_type(qq)=mp_right_type(pp);
7190 mp_x_coord(qq)=mp_x_coord(pp); mp_y_coord(qq)=mp_y_coord(pp);
7191 mp_right_x(qq)=mp_left_x(pp); mp_right_y(qq)=mp_left_y(pp);
7192 mp_left_x(qq)=mp_right_x(pp); mp_left_y(qq)=mp_right_y(pp);
7193 mp_originator(qq)=mp_originator(pp);
7194 if ( mp_link(pp)==p ) {
7195 mp_link(q)=qq; mp->path_tail=pp; return q;
7197 rr=mp_get_node(mp, knot_node_size); mp_link(rr)=qq; qq=rr; pp=mp_link(pp);
7202 pointer path_tail; /* the node that links to the beginning of a path */
7204 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7205 calling the following subroutine.
7208 static void mp_toss_knot_list (MP mp,pointer p) ;
7211 void mp_toss_knot_list (MP mp,pointer p) {
7212 pointer q; /* the node being freed */
7213 pointer r; /* the next node */
7217 mp_free_node(mp, q,knot_node_size); q=r;
7221 @* \[18] Choosing control points.
7222 Now we must actually delve into one of \MP's more difficult routines,
7223 the |make_choices| procedure that chooses angles and control points for
7224 the splines of a curve when the user has not specified them explicitly.
7225 The parameter to |make_choices| points to a list of knots and
7226 path information, as described above.
7228 A path decomposes into independent segments at ``breakpoint'' knots,
7229 which are knots whose left and right angles are both prespecified in
7230 some way (i.e., their |mp_left_type| and |mp_right_type| aren't both open).
7233 static void mp_make_choices (MP mp,pointer knots) {
7234 pointer h; /* the first breakpoint */
7235 pointer p,q; /* consecutive breakpoints being processed */
7236 @<Other local variables for |make_choices|@>;
7237 check_arith; /* make sure that |arith_error=false| */
7238 if ( mp->internal[mp_tracing_choices]>0 )
7239 mp_print_path(mp, knots,", before choices",true);
7240 @<If consecutive knots are equal, join them explicitly@>;
7241 @<Find the first breakpoint, |h|, on the path;
7242 insert an artificial breakpoint if the path is an unbroken cycle@>;
7245 @<Fill in the control points between |p| and the next breakpoint,
7246 then advance |p| to that breakpoint@>;
7248 if ( mp->internal[mp_tracing_choices]>0 )
7249 mp_print_path(mp, knots,", after choices",true);
7250 if ( mp->arith_error ) {
7251 @<Report an unexpected problem during the choice-making@>;
7255 @ @<Report an unexpected problem during the choice...@>=
7257 print_err("Some number got too big");
7258 @.Some number got too big@>
7259 help2("The path that I just computed is out of range.",
7260 "So it will probably look funny. Proceed, for a laugh.");
7261 mp_put_get_error(mp); mp->arith_error=false;
7264 @ Two knots in a row with the same coordinates will always be joined
7265 by an explicit ``curve'' whose control points are identical with the
7268 @<If consecutive knots are equal, join them explicitly@>=
7272 if ( mp_x_coord(p)==mp_x_coord(q) &&
7273 mp_y_coord(p)==mp_y_coord(q) && mp_right_type(p)>mp_explicit ) {
7274 mp_right_type(p)=mp_explicit;
7275 if ( mp_left_type(p)==mp_open ) {
7276 mp_left_type(p)=mp_curl; left_curl(p)=unity;
7278 mp_left_type(q)=mp_explicit;
7279 if ( mp_right_type(q)==mp_open ) {
7280 mp_right_type(q)=mp_curl; right_curl(q)=unity;
7282 mp_right_x(p)=mp_x_coord(p); mp_left_x(q)=mp_x_coord(p);
7283 mp_right_y(p)=mp_y_coord(p); mp_left_y(q)=mp_y_coord(p);
7288 @ If there are no breakpoints, it is necessary to compute the direction
7289 angles around an entire cycle. In this case the |mp_left_type| of the first
7290 node is temporarily changed to |end_cycle|.
7292 @<Find the first breakpoint, |h|, on the path...@>=
7295 if ( mp_left_type(h)!=mp_open ) break;
7296 if ( mp_right_type(h)!=mp_open ) break;
7299 mp_left_type(h)=mp_end_cycle; break;
7303 @ If |mp_right_type(p)<given| and |q=mp_link(p)|, we must have
7304 |mp_right_type(p)=mp_left_type(q)=mp_explicit| or |endpoint|.
7306 @<Fill in the control points between |p| and the next breakpoint...@>=
7308 if ( mp_right_type(p)>=mp_given ) {
7309 while ( (mp_left_type(q)==mp_open)&&(mp_right_type(q)==mp_open) ) q=mp_link(q);
7310 @<Fill in the control information between
7311 consecutive breakpoints |p| and |q|@>;
7312 } else if ( mp_right_type(p)==mp_endpoint ) {
7313 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7317 @ This step makes it possible to transform an explicitly computed path without
7318 checking the |mp_left_type| and |mp_right_type| fields.
7320 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7322 mp_right_x(p)=mp_x_coord(p); mp_right_y(p)=mp_y_coord(p);
7323 mp_left_x(q)=mp_x_coord(q); mp_left_y(q)=mp_y_coord(q);
7326 @ Before we can go further into the way choices are made, we need to
7327 consider the underlying theory. The basic ideas implemented in |make_choices|
7328 are due to John Hobby, who introduced the notion of ``mock curvature''
7329 @^Hobby, John Douglas@>
7330 at a knot. Angles are chosen so that they preserve mock curvature when
7331 a knot is passed, and this has been found to produce excellent results.
7333 It is convenient to introduce some notations that simplify the necessary
7334 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7335 between knots |k| and |k+1|; and let
7336 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7337 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7338 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7339 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7340 $$\eqalign{z_k^+&=z_k+
7341 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7343 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7344 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7345 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7346 corresponding ``offset angles.'' These angles satisfy the condition
7347 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7348 whenever the curve leaves an intermediate knot~|k| in the direction that
7351 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7352 the curve at its beginning and ending points. This means that
7353 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7354 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7355 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7356 z\k^-,z\k^{\phantom+};t)$
7359 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7360 \qquad{\rm and}\qquad
7361 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7362 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7364 approximation to this true curvature that arises in the limit for
7365 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7366 The standard velocity function satisfies
7367 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7368 hence the mock curvatures are respectively
7369 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7370 \qquad{\rm and}\qquad
7371 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7373 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7374 determines $\phi_k$ when $\theta_k$ is known, so the task of
7375 angle selection is essentially to choose appropriate values for each
7376 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7377 from $(**)$, we obtain a system of linear equations of the form
7378 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7380 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7381 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7382 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7383 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7384 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7385 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7386 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7387 hence they have a unique solution. Moreover, in most cases the tensions
7388 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7389 solution numerically stable, and there is an exponential damping
7390 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7391 a factor of~$O(2^{-j})$.
7393 @ However, we still must consider the angles at the starting and ending
7394 knots of a non-cyclic path. These angles might be given explicitly, or
7395 they might be specified implicitly in terms of an amount of ``curl.''
7397 Let's assume that angles need to be determined for a non-cyclic path
7398 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7399 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7400 have been given for $0<k<n$, and it will be convenient to introduce
7401 equations of the same form for $k=0$ and $k=n$, where
7402 $$A_0=B_0=C_n=D_n=0.$$
7403 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7404 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7405 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7406 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7407 mock curvature at $z_1$; i.e.,
7408 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7409 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7410 This equation simplifies to
7411 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7412 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7413 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7414 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7415 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7416 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7417 hence the linear equations remain nonsingular.
7419 Similar considerations apply at the right end, when the final angle $\phi_n$
7420 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7421 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7423 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7424 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7425 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7427 When |make_choices| chooses angles, it must compute the coefficients of
7428 these linear equations, then solve the equations. To compute the coefficients,
7429 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7430 When the equations are solved, the chosen directions $\theta_k$ are put
7431 back into the form of control points by essentially computing sines and
7434 @ OK, we are ready to make the hard choices of |make_choices|.
7435 Most of the work is relegated to an auxiliary procedure
7436 called |solve_choices|, which has been introduced to keep
7437 |make_choices| from being extremely long.
7439 @<Fill in the control information between...@>=
7440 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7441 set $n$ to the length of the path@>;
7442 @<Remove |open| types at the breakpoints@>;
7443 mp_solve_choices(mp, p,q,n)
7445 @ It's convenient to precompute quantities that will be needed several
7446 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7447 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7448 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7449 and $z\k-z_k$ will be stored in |psi[k]|.
7452 int path_size; /* maximum number of knots between breakpoints of a path */
7455 scaled *delta; /* knot differences */
7456 angle *psi; /* turning angles */
7458 @ @<Dealloc variables@>=
7464 @ @<Other local variables for |make_choices|@>=
7465 int k,n; /* current and final knot numbers */
7466 pointer s,t; /* registers for list traversal */
7467 scaled delx,dely; /* directions where |open| meets |explicit| */
7468 fraction sine,cosine; /* trig functions of various angles */
7470 @ @<Calculate the turning angles...@>=
7473 k=0; s=p; n=mp->path_size;
7476 mp->delta_x[k]=mp_x_coord(t)-mp_x_coord(s);
7477 mp->delta_y[k]=mp_y_coord(t)-mp_y_coord(s);
7478 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7480 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7481 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7482 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7483 mp_take_fraction(mp, mp->delta_y[k],sine),
7484 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7485 mp_take_fraction(mp, mp->delta_x[k],sine));
7488 if ( k==mp->path_size ) {
7489 mp_reallocate_paths(mp, mp->path_size+(mp->path_size/4));
7490 goto RESTART; /* retry, loop size has changed */
7493 } while (!((k>=n)&&(mp_left_type(s)!=mp_end_cycle)));
7494 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7497 @ When we get to this point of the code, |mp_right_type(p)| is either
7498 |given| or |curl| or |open|. If it is |open|, we must have
7499 |mp_left_type(p)=mp_end_cycle| or |mp_left_type(p)=mp_explicit|. In the latter
7500 case, the |open| type is converted to |given|; however, if the
7501 velocity coming into this knot is zero, the |open| type is
7502 converted to a |curl|, since we don't know the incoming direction.
7504 Similarly, |mp_left_type(q)| is either |given| or |curl| or |open| or
7505 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7507 @<Remove |open| types at the breakpoints@>=
7508 if ( mp_left_type(q)==mp_open ) {
7509 delx=mp_right_x(q)-mp_x_coord(q); dely=mp_right_y(q)-mp_y_coord(q);
7510 if ( (delx==0)&&(dely==0) ) {
7511 mp_left_type(q)=mp_curl; left_curl(q)=unity;
7513 mp_left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7516 if ( (mp_right_type(p)==mp_open)&&(mp_left_type(p)==mp_explicit) ) {
7517 delx=mp_x_coord(p)-mp_left_x(p); dely=mp_y_coord(p)-mp_left_y(p);
7518 if ( (delx==0)&&(dely==0) ) {
7519 mp_right_type(p)=mp_curl; right_curl(p)=unity;
7521 mp_right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7525 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7526 and exactly one of the breakpoints involves a curl. The simplest case occurs
7527 when |n=1| and there is a curl at both breakpoints; then we simply draw
7530 But before coding up the simple cases, we might as well face the general case,
7531 since we must deal with it sooner or later, and since the general case
7532 is likely to give some insight into the way simple cases can be handled best.
7534 When there is no cycle, the linear equations to be solved form a tridiagonal
7535 system, and we can apply the standard technique of Gaussian elimination
7536 to convert that system to a sequence of equations of the form
7537 $$\theta_0+u_0\theta_1=v_0,\quad
7538 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7539 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7541 It is possible to do this diagonalization while generating the equations.
7542 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7543 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7545 The procedure is slightly more complex when there is a cycle, but the
7546 basic idea will be nearly the same. In the cyclic case the right-hand
7547 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7548 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7549 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7550 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7551 eliminate the $w$'s from the system, after which the solution can be
7554 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7555 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7556 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7557 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7560 angle *theta; /* values of $\theta_k$ */
7561 fraction *uu; /* values of $u_k$ */
7562 angle *vv; /* values of $v_k$ */
7563 fraction *ww; /* values of $w_k$ */
7565 @ @<Dealloc variables@>=
7572 static void mp_reallocate_paths (MP mp, int l);
7575 void mp_reallocate_paths (MP mp, int l) {
7576 XREALLOC (mp->delta_x, l, scaled);
7577 XREALLOC (mp->delta_y, l, scaled);
7578 XREALLOC (mp->delta, l, scaled);
7579 XREALLOC (mp->psi, l, angle);
7580 XREALLOC (mp->theta, l, angle);
7581 XREALLOC (mp->uu, l, fraction);
7582 XREALLOC (mp->vv, l, angle);
7583 XREALLOC (mp->ww, l, fraction);
7587 @ Our immediate problem is to get the ball rolling by setting up the
7588 first equation or by realizing that no equations are needed, and to fit
7589 this initialization into a framework suitable for the overall computation.
7592 static void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) ;
7595 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7596 int k; /* current knot number */
7597 pointer r,s,t; /* registers for list traversal */
7598 @<Other local variables for |solve_choices|@>;
7603 @<Get the linear equations started; or |return|
7604 with the control points in place, if linear equations
7607 switch (mp_left_type(s)) {
7608 case mp_end_cycle: case mp_open:
7609 @<Set up equation to match mock curvatures
7610 at $z_k$; then |goto found| with $\theta_n$
7611 adjusted to equal $\theta_0$, if a cycle has ended@>;
7614 @<Set up equation for a curl at $\theta_n$
7618 @<Calculate the given value of $\theta_n$
7621 } /* there are no other cases */
7626 @<Finish choosing angles and assigning control points@>;
7629 @ On the first time through the loop, we have |k=0| and |r| is not yet
7630 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7632 @<Get the linear equations started...@>=
7633 switch (mp_right_type(s)) {
7635 if ( mp_left_type(t)==mp_given ) {
7636 @<Reduce to simple case of two givens and |return|@>
7638 @<Set up the equation for a given value of $\theta_0$@>;
7642 if ( mp_left_type(t)==mp_curl ) {
7643 @<Reduce to simple case of straight line and |return|@>
7645 @<Set up the equation for a curl at $\theta_0$@>;
7649 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7650 /* this begins a cycle */
7652 } /* there are no other cases */
7654 @ The general equation that specifies equality of mock curvature at $z_k$ is
7655 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7656 as derived above. We want to combine this with the already-derived equation
7657 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7659 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7661 $$(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}
7662 -A_kw_{k-1}\theta_0$$
7663 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7664 fixed-point arithmetic, avoiding the chance of overflow while retaining
7667 The calculations will be performed in several registers that
7668 provide temporary storage for intermediate quantities.
7670 @<Other local variables for |solve_choices|@>=
7671 fraction aa,bb,cc,ff,acc; /* temporary registers */
7672 scaled dd,ee; /* likewise, but |scaled| */
7673 scaled lt,rt; /* tension values */
7675 @ @<Set up equation to match mock curvatures...@>=
7676 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7677 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7678 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7679 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7680 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7681 @<Calculate the values of $v_k$ and $w_k$@>;
7682 if ( mp_left_type(s)==mp_end_cycle ) {
7683 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7687 @ Since tension values are never less than 3/4, the values |aa| and
7688 |bb| computed here are never more than 4/5.
7690 @<Calculate the values $\\{aa}=...@>=
7691 if ( abs(right_tension(r))==unity) {
7692 aa=fraction_half; dd=2*mp->delta[k];
7694 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7695 dd=mp_take_fraction(mp, mp->delta[k],
7696 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7698 if ( abs(left_tension(t))==unity ){
7699 bb=fraction_half; ee=2*mp->delta[k-1];
7701 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7702 ee=mp_take_fraction(mp, mp->delta[k-1],
7703 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7705 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7707 @ The ratio to be calculated in this step can be written in the form
7708 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7709 \\{cc}\cdot\\{dd},$$
7710 because of the quantities just calculated. The values of |dd| and |ee|
7711 will not be needed after this step has been performed.
7713 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7714 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7715 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7717 ff=mp_make_fraction(mp, lt,rt);
7718 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7719 dd=mp_take_fraction(mp, dd,ff);
7721 ff=mp_make_fraction(mp, rt,lt);
7722 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7723 ee=mp_take_fraction(mp, ee,ff);
7726 ff=mp_make_fraction(mp, ee,ee+dd)
7728 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7729 equation was specified by a curl. In that case we must use a special
7730 method of computation to prevent overflow.
7732 Fortunately, the calculations turn out to be even simpler in this ``hard''
7733 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7734 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7736 @<Calculate the values of $v_k$ and $w_k$@>=
7737 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7738 if ( mp_right_type(r)==mp_curl ) {
7740 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7742 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7743 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7744 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7745 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7746 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7747 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7748 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7751 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7752 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7753 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7754 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7757 The idea in the following code is to observe that
7758 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7759 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7760 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7761 so we can solve for $\theta_n=\theta_0$.
7763 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7765 aa=0; bb=fraction_one; /* we have |k=n| */
7768 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7769 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7770 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7771 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7772 mp->theta[n]=aa; mp->vv[0]=aa;
7773 for (k=1;k<=n-1;k++) {
7774 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7779 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7780 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7782 @<Calculate the given value of $\theta_n$...@>=
7784 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7785 reduce_angle(mp->theta[n]);
7789 @ @<Set up the equation for a given value of $\theta_0$@>=
7791 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7792 reduce_angle(mp->vv[0]);
7793 mp->uu[0]=0; mp->ww[0]=0;
7796 @ @<Set up the equation for a curl at $\theta_0$@>=
7797 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7798 if ( (rt==unity)&&(lt==unity) )
7799 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7801 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7802 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7805 @ @<Set up equation for a curl at $\theta_n$...@>=
7806 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7807 if ( (rt==unity)&&(lt==unity) )
7808 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7810 ff=mp_curl_ratio(mp, cc,lt,rt);
7811 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7812 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7816 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7817 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7818 a somewhat tedious program to calculate
7819 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7820 \alpha^3\gamma+(3-\beta)\beta^2},$$
7821 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7822 is necessary only if the curl and tension are both large.)
7823 The values of $\alpha$ and $\beta$ will be at most~4/3.
7826 static fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7830 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7832 fraction alpha,beta,num,denom,ff; /* registers */
7833 alpha=mp_make_fraction(mp, unity,a_tension);
7834 beta=mp_make_fraction(mp, unity,b_tension);
7835 if ( alpha<=beta ) {
7836 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7837 gamma=mp_take_fraction(mp, gamma,ff);
7838 beta=beta / 010000; /* convert |fraction| to |scaled| */
7839 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7840 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7842 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7843 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7844 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7845 /* $1365\approx 2^{12}/3$ */
7846 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7848 if ( num>=denom+denom+denom+denom ) return fraction_four;
7849 else return mp_make_fraction(mp, num,denom);
7852 @ We're in the home stretch now.
7854 @<Finish choosing angles and assigning control points@>=
7855 for (k=n-1;k>=0;k--) {
7856 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7861 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7862 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7863 mp_set_controls(mp, s,t,k);
7867 @ The |set_controls| routine actually puts the control points into
7868 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7869 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7870 $\cos\phi$ needed in this calculation.
7876 fraction cf; /* sines and cosines */
7879 static void mp_set_controls (MP mp,pointer p, pointer q, integer k);
7882 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7883 fraction rr,ss; /* velocities, divided by thrice the tension */
7884 scaled lt,rt; /* tensions */
7885 fraction sine; /* $\sin(\theta+\phi)$ */
7886 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7887 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7888 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7889 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7890 @<Decrease the velocities,
7891 if necessary, to stay inside the bounding triangle@>;
7893 mp_right_x(p)=mp_x_coord(p)+mp_take_fraction(mp,
7894 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7895 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7896 mp_right_y(p)=mp_y_coord(p)+mp_take_fraction(mp,
7897 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7898 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7899 mp_left_x(q)=mp_x_coord(q)-mp_take_fraction(mp,
7900 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7901 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7902 mp_left_y(q)=mp_y_coord(q)-mp_take_fraction(mp,
7903 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7904 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7905 mp_right_type(p)=mp_explicit; mp_left_type(q)=mp_explicit;
7908 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7909 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7910 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7911 there is no ``bounding triangle.''
7913 @<Decrease the velocities, if necessary...@>=
7914 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7915 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7916 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7918 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7919 if ( right_tension(p)<0 )
7920 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7921 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7922 if ( left_tension(q)<0 )
7923 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7924 ss=mp_make_fraction(mp, abs(mp->st),sine);
7928 @ Only the simple cases remain to be handled.
7930 @<Reduce to simple case of two givens and |return|@>=
7932 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7933 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7934 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7935 mp_set_controls(mp, p,q,0); return;
7938 @ @<Reduce to simple case of straight line and |return|@>=
7940 mp_right_type(p)=mp_explicit; mp_left_type(q)=mp_explicit;
7941 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7943 if ( mp->delta_x[0]>=0 ) mp_right_x(p)=mp_x_coord(p)+((mp->delta_x[0]+1) / 3);
7944 else mp_right_x(p)=mp_x_coord(p)+((mp->delta_x[0]-1) / 3);
7945 if ( mp->delta_y[0]>=0 ) mp_right_y(p)=mp_y_coord(p)+((mp->delta_y[0]+1) / 3);
7946 else mp_right_y(p)=mp_y_coord(p)+((mp->delta_y[0]-1) / 3);
7948 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7949 mp_right_x(p)=mp_x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7950 mp_right_y(p)=mp_y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7953 if ( mp->delta_x[0]>=0 ) mp_left_x(q)=mp_x_coord(q)-((mp->delta_x[0]+1) / 3);
7954 else mp_left_x(q)=mp_x_coord(q)-((mp->delta_x[0]-1) / 3);
7955 if ( mp->delta_y[0]>=0 ) mp_left_y(q)=mp_y_coord(q)-((mp->delta_y[0]+1) / 3);
7956 else mp_left_y(q)=mp_y_coord(q)-((mp->delta_y[0]-1) / 3);
7958 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7959 mp_left_x(q)=mp_x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7960 mp_left_y(q)=mp_y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7965 @* \[19] Measuring paths.
7966 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7967 allow the user to measure the bounding box of anything that can go into a
7968 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7969 by just finding the bounding box of the knots and the control points. We
7970 need a more accurate version of the bounding box, but we can still use the
7971 easy estimate to save time by focusing on the interesting parts of the path.
7973 @ Computing an accurate bounding box involves a theme that will come up again
7974 and again. Given a Bernshte{\u\i}n polynomial
7975 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
7976 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
7977 we can conveniently bisect its range as follows:
7980 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
7983 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
7984 |0<=k<n-j|, for |0<=j<n|.
7988 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
7989 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
7990 This formula gives us the coefficients of polynomials to use over the ranges
7991 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
7993 @ Now here's a subroutine that's handy for all sorts of path computations:
7994 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
7995 returns the unique |fraction| value |t| between 0 and~1 at which
7996 $B(a,b,c;t)$ changes from positive to negative, or returns
7997 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
7998 is already negative at |t=0|), |crossing_point| returns the value zero.
8000 @d no_crossing { return (fraction_one+1); }
8001 @d one_crossing { return fraction_one; }
8002 @d zero_crossing { return 0; }
8003 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
8005 @c static fraction mp_do_crossing_point (integer a, integer b, integer c) {
8006 integer d; /* recursive counter */
8007 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
8008 if ( a<0 ) zero_crossing;
8011 if ( c>0 ) { no_crossing; }
8012 else if ( (a==0)&&(b==0) ) { no_crossing;}
8013 else { one_crossing; }
8015 if ( a==0 ) zero_crossing;
8016 } else if ( a==0 ) {
8017 if ( b<=0 ) zero_crossing;
8019 @<Use bisection to find the crossing point, if one exists@>;
8022 @ The general bisection method is quite simple when $n=2$, hence
8023 |crossing_point| does not take much time. At each stage in the
8024 recursion we have a subinterval defined by |l| and~|j| such that
8025 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
8026 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
8028 It is convenient for purposes of calculation to combine the values
8029 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
8030 of bisection then corresponds simply to doubling $d$ and possibly
8031 adding~1. Furthermore it proves to be convenient to modify
8032 our previous conventions for bisection slightly, maintaining the
8033 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
8034 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
8035 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
8037 The following code maintains the invariant relations
8038 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
8039 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
8040 it has been constructed in such a way that no arithmetic overflow
8041 will occur if the inputs satisfy
8042 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
8044 @<Use bisection to find the crossing point...@>=
8045 d=1; x0=a; x1=a-b; x2=b-c;
8056 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
8060 } while (d<fraction_one);
8061 return (d-fraction_one)
8063 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
8064 a cubic corresponding to the |fraction| value~|t|.
8066 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
8067 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
8069 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
8071 @c static scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
8072 scaled x1,x2,x3; /* intermediate values */
8073 x1=t_of_the_way(knot_coord(p),right_coord(p));
8074 x2=t_of_the_way(right_coord(p),left_coord(q));
8075 x3=t_of_the_way(left_coord(q),knot_coord(q));
8076 x1=t_of_the_way(x1,x2);
8077 x2=t_of_the_way(x2,x3);
8078 return t_of_the_way(x1,x2);
8081 @ The actual bounding box information is stored in global variables.
8082 Since it is convenient to address the $x$ and $y$ information
8083 separately, we define arrays indexed by |x_code..y_code| and use
8084 macros to give them more convenient names.
8088 mp_x_code=0, /* index for |minx| and |maxx| */
8089 mp_y_code /* index for |miny| and |maxy| */
8093 @d mp_minx mp->bbmin[mp_x_code]
8094 @d mp_maxx mp->bbmax[mp_x_code]
8095 @d mp_miny mp->bbmin[mp_y_code]
8096 @d mp_maxy mp->bbmax[mp_y_code]
8099 scaled bbmin[mp_y_code+1];
8100 scaled bbmax[mp_y_code+1];
8101 /* the result of procedures that compute bounding box information */
8103 @ Now we're ready for the key part of the bounding box computation.
8104 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
8105 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
8106 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8108 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8109 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8110 The |c| parameter is |x_code| or |y_code|.
8112 @c static void mp_bound_cubic (MP mp,pointer p, pointer q, quarterword c) {
8113 boolean wavy; /* whether we need to look for extremes */
8114 scaled del1,del2,del3,del,dmax; /* proportional to the control
8115 points of a quadratic derived from a cubic */
8116 fraction t,tt; /* where a quadratic crosses zero */
8117 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8119 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8120 @<Check the control points against the bounding box and set |wavy:=true|
8121 if any of them lie outside@>;
8123 del1=right_coord(p)-knot_coord(p);
8124 del2=left_coord(q)-right_coord(p);
8125 del3=knot_coord(q)-left_coord(q);
8126 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8127 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8129 negate(del1); negate(del2); negate(del3);
8131 t=mp_crossing_point(mp, del1,del2,del3);
8132 if ( t<fraction_one ) {
8133 @<Test the extremes of the cubic against the bounding box@>;
8138 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8139 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8140 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8142 @ @<Check the control points against the bounding box and set...@>=
8144 if ( mp->bbmin[c]<=right_coord(p) )
8145 if ( right_coord(p)<=mp->bbmax[c] )
8146 if ( mp->bbmin[c]<=left_coord(q) )
8147 if ( left_coord(q)<=mp->bbmax[c] )
8150 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8151 section. We just set |del=0| in that case.
8153 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8154 if ( del1!=0 ) del=del1;
8155 else if ( del2!=0 ) del=del2;
8159 if ( abs(del2)>dmax ) dmax=abs(del2);
8160 if ( abs(del3)>dmax ) dmax=abs(del3);
8161 while ( dmax<fraction_half ) {
8162 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8166 @ Since |crossing_point| has tried to choose |t| so that
8167 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8168 slope, the value of |del2| computed below should not be positive.
8169 But rounding error could make it slightly positive in which case we
8170 must cut it to zero to avoid confusion.
8172 @<Test the extremes of the cubic against the bounding box@>=
8174 x=mp_eval_cubic(mp, p,q,t);
8175 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8176 del2=t_of_the_way(del2,del3);
8177 /* now |0,del2,del3| represent the derivative on the remaining interval */
8178 if ( del2>0 ) del2=0;
8179 tt=mp_crossing_point(mp, 0,-del2,-del3);
8180 if ( tt<fraction_one ) {
8181 @<Test the second extreme against the bounding box@>;
8185 @ @<Test the second extreme against the bounding box@>=
8187 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8188 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8191 @ Finding the bounding box of a path is basically a matter of applying
8192 |bound_cubic| twice for each pair of adjacent knots.
8194 @c static void mp_path_bbox (MP mp,pointer h) {
8195 pointer p,q; /* a pair of adjacent knots */
8196 mp_minx=mp_x_coord(h); mp_miny=mp_y_coord(h);
8197 mp_maxx=mp_minx; mp_maxy=mp_miny;
8200 if ( mp_right_type(p)==mp_endpoint ) return;
8202 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8203 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8208 @ Another important way to measure a path is to find its arc length. This
8209 is best done by using the general bisection algorithm to subdivide the path
8210 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8213 Since the arc length is the integral with respect to time of the magnitude of
8214 the velocity, it is natural to use Simpson's rule for the approximation.
8216 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8217 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8218 for the arc length of a path of length~1. For a cubic spline
8219 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8220 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8222 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8224 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8225 is the result of the bisection algorithm.
8227 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8228 This could be done via the theoretical error bound for Simpson's rule,
8230 but this is impractical because it requires an estimate of the fourth
8231 derivative of the quantity being integrated. It is much easier to just perform
8232 a bisection step and see how much the arc length estimate changes. Since the
8233 error for Simpson's rule is proportional to the fourth power of the sample
8234 spacing, the remaining error is typically about $1\over16$ of the amount of
8235 the change. We say ``typically'' because the error has a pseudo-random behavior
8236 that could cause the two estimates to agree when each contain large errors.
8238 To protect against disasters such as undetected cusps, the bisection process
8239 should always continue until all the $dz_i$ vectors belong to a single
8240 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8241 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8242 If such a spline happens to produce an erroneous arc length estimate that
8243 is little changed by bisection, the amount of the error is likely to be fairly
8244 small. We will try to arrange things so that freak accidents of this type do
8245 not destroy the inverse relationship between the \&{arclength} and
8246 \&{arctime} operations.
8247 @:arclength_}{\&{arclength} primitive@>
8248 @:arctime_}{\&{arctime} primitive@>
8250 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8252 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8253 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8254 returns the time when the arc length reaches |a_goal| if there is such a time.
8255 Thus the return value is either an arc length less than |a_goal| or, if the
8256 arc length would be at least |a_goal|, it returns a time value decreased by
8257 |two|. This allows the caller to use the sign of the result to distinguish
8258 between arc lengths and time values. On certain types of overflow, it is
8259 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8260 Otherwise, the result is always less than |a_goal|.
8262 Rather than halving the control point coordinates on each recursive call to
8263 |arc_test|, it is better to keep them proportional to velocity on the original
8264 curve and halve the results instead. This means that recursive calls can
8265 potentially use larger error tolerances in their arc length estimates. How
8266 much larger depends on to what extent the errors behave as though they are
8267 independent of each other. To save computing time, we use optimistic assumptions
8268 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8271 In addition to the tolerance parameter, |arc_test| should also have parameters
8272 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8273 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8274 and they are needed in different instances of |arc_test|.
8277 static scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8278 scaled dx2, scaled dy2, scaled v0, scaled v02,
8279 scaled v2, scaled a_goal, scaled tol) {
8280 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8281 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8283 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8284 scaled arc; /* best arc length estimate before recursion */
8285 @<Other local variables in |arc_test|@>;
8286 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8288 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8289 set |arc_test| and |return|@>;
8290 @<Test if the control points are confined to one quadrant or rotating them
8291 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8292 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8293 if ( arc < a_goal ) {
8296 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8297 that time minus |two|@>;
8300 @<Use one or two recursive calls to compute the |arc_test| function@>;
8304 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8305 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8306 |make_fraction| in this inner loop.
8309 @<Use one or two recursive calls to compute the |arc_test| function@>=
8311 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8312 large as possible@>;
8313 tol = tol + halfp(tol);
8314 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8315 halfp(v02), a_new, tol);
8317 return (-halfp(two-a));
8319 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8320 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8321 halfp(v02), v022, v2, a_new, tol);
8323 return (-halfp(-b) - half_unit);
8325 return (a + half(b-a));
8329 @ @<Other local variables in |arc_test|@>=
8330 scaled a,b; /* results of recursive calls */
8331 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8333 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8334 a_aux = el_gordo - a_goal;
8335 if ( a_goal > a_aux ) {
8336 a_aux = a_goal - a_aux;
8339 a_new = a_goal + a_goal;
8343 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8344 to force the additions and subtractions to be done in an order that avoids
8347 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8350 a_new = a_new + a_aux;
8353 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8354 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8355 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8356 this bound. Note that recursive calls will maintain this invariant.
8358 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8359 dx01 = half(dx0 + dx1);
8360 dx12 = half(dx1 + dx2);
8361 dx02 = half(dx01 + dx12);
8362 dy01 = half(dy0 + dy1);
8363 dy12 = half(dy1 + dy2);
8364 dy02 = half(dy01 + dy12)
8366 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8367 |a_goal=el_gordo| is guaranteed to yield the arc length.
8369 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8370 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8371 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8373 arc1 = v002 + half(halfp(v0+tmp) - v002);
8374 arc = v022 + half(halfp(v2+tmp) - v022);
8375 if ( (arc < el_gordo-arc1) ) {
8378 mp->arith_error = true;
8379 if ( a_goal==el_gordo ) return (el_gordo);
8383 @ @<Other local variables in |arc_test|@>=
8384 scaled tmp, tmp2; /* all purpose temporary registers */
8385 scaled arc1; /* arc length estimate for the first half */
8387 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8388 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8389 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8391 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8392 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8394 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8395 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8397 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8398 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8401 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8403 it is appropriate to use the same approximation to decide when the integral
8404 reaches the intermediate value |a_goal|. At this point
8406 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8407 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8408 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8409 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8410 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8414 $$ {\vb\dot B(t)\vb\over 3} \approx
8415 \cases{B\left(\hbox{|v0|},
8416 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8417 {1\over 2}\hbox{|v02|}; 2t \right)&
8418 if $t\le{1\over 2}$\cr
8419 B\left({1\over 2}\hbox{|v02|},
8420 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8421 \hbox{|v2|}; 2t-1 \right)&
8422 if $t\ge{1\over 2}$.\cr}
8425 We can integrate $\vb\dot B(t)\vb$ by using
8426 $$\int 3B(a,b,c;\tau)\,dt =
8427 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8430 This construction allows us to find the time when the arc length reaches
8431 |a_goal| by solving a cubic equation of the form
8432 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8433 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8434 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8435 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8436 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8437 $\tau$ given $a$, $b$, $c$, and $x$.
8439 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8441 tmp = (v02 + 2) / 4;
8442 if ( a_goal<=arc1 ) {
8445 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8448 return ((half_unit - two) +
8449 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8453 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8454 $$ B(0, a, a+b, a+b+c; t) = x. $$
8455 This routine is based on |crossing_point| but is simplified by the
8456 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8457 If rounding error causes this condition to be violated slightly, we just ignore
8458 it and proceed with binary search. This finds a time when the function value
8459 reaches |x| and the slope is positive.
8462 static scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) ;
8465 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8466 scaled ab, bc, ac; /* bisection results */
8467 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8468 integer xx; /* temporary for updating |x| */
8469 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8470 @:this can't happen rising?}{\quad rising?@>
8473 } else if ( x >= a+b+c ) {
8477 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8481 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8482 xx = x - a - ab - ac;
8483 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8484 else { x = x + xx; a=ac; b=bc; t = t+1; };
8485 } while (t < unity);
8490 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8495 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8497 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8498 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8505 @ It is convenient to have a simpler interface to |arc_test| that requires no
8506 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8507 length less than |fraction_four|.
8509 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8511 @c static scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8512 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8513 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8514 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8515 v0 = mp_pyth_add(mp, dx0,dy0);
8516 v1 = mp_pyth_add(mp, dx1,dy1);
8517 v2 = mp_pyth_add(mp, dx2,dy2);
8518 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8519 mp->arith_error = true;
8520 if ( a_goal==el_gordo ) return el_gordo;
8523 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8524 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8525 v0, v02, v2, a_goal, arc_tol));
8529 @ Now it is easy to find the arc length of an entire path.
8531 @c static scaled mp_get_arc_length (MP mp,pointer h) {
8532 pointer p,q; /* for traversing the path */
8533 scaled a,a_tot; /* current and total arc lengths */
8536 while ( mp_right_type(p)!=mp_endpoint ){
8538 a = mp_do_arc_test(mp, mp_right_x(p)-mp_x_coord(p), mp_right_y(p)-mp_y_coord(p),
8539 mp_left_x(q)-mp_right_x(p), mp_left_y(q)-mp_right_y(p),
8540 mp_x_coord(q)-mp_left_x(q), mp_y_coord(q)-mp_left_y(q), el_gordo);
8541 a_tot = mp_slow_add(mp, a, a_tot);
8542 if ( q==h ) break; else p=q;
8548 @ The inverse operation of finding the time on a path~|h| when the arc length
8549 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8550 is required to handle very large times or negative times on cyclic paths. For
8551 non-cyclic paths, |arc0| values that are negative or too large cause
8552 |get_arc_time| to return 0 or the length of path~|h|.
8554 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8555 time value greater than the length of the path. Since it could be much greater,
8556 we must be prepared to compute the arc length of path~|h| and divide this into
8557 |arc0| to find how many multiples of the length of path~|h| to add.
8559 @c static scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8560 pointer p,q; /* for traversing the path */
8561 scaled t_tot; /* accumulator for the result */
8562 scaled t; /* the result of |do_arc_test| */
8563 scaled arc; /* portion of |arc0| not used up so far */
8564 integer n; /* number of extra times to go around the cycle */
8566 @<Deal with a negative |arc0| value and |return|@>;
8568 if ( arc0==el_gordo ) decr(arc0);
8572 while ( (mp_right_type(p)!=mp_endpoint) && (arc>0) ) {
8574 t = mp_do_arc_test(mp, mp_right_x(p)-mp_x_coord(p), mp_right_y(p)-mp_y_coord(p),
8575 mp_left_x(q)-mp_right_x(p), mp_left_y(q)-mp_right_y(p),
8576 mp_x_coord(q)-mp_left_x(q), mp_y_coord(q)-mp_left_y(q), arc);
8577 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8579 @<Update |t_tot| and |arc| to avoid going around the cyclic
8580 path too many times but set |arith_error:=true| and |goto done| on
8589 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8590 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8591 else { t_tot = t_tot + unity; arc = arc - t; }
8593 @ @<Deal with a negative |arc0| value and |return|@>=
8595 if ( mp_left_type(h)==mp_endpoint ) {
8598 p = mp_htap_ypoc(mp, h);
8599 t_tot = -mp_get_arc_time(mp, p, -arc0);
8600 mp_toss_knot_list(mp, p);
8606 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8608 n = arc / (arc0 - arc);
8609 arc = arc - n*(arc0 - arc);
8610 if ( t_tot > (el_gordo / (n+1)) ) {
8613 t_tot = (n + 1)*t_tot;
8616 @* \[20] Data structures for pens.
8617 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8618 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8619 @:stroke}{\&{stroke} command@>
8620 converted into an area fill as described in the next part of this program.
8621 The mathematics behind this process is based on simple aspects of the theory
8622 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8623 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8624 Foundations of Computer Science {\bf 24} (1983), 100--111].
8626 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8627 @:makepen_}{\&{makepen} primitive@>
8628 This path representation is almost sufficient for our purposes except that
8629 a pen path should always be a convex polygon with the vertices in
8630 counter-clockwise order.
8631 Since we will need to scan pen polygons both forward and backward, a pen
8632 should be represented as a doubly linked ring of knot nodes. There is
8633 room for the extra back pointer because we do not need the
8634 |mp_left_type| or |mp_right_type| fields. In fact, we don't need the |mp_left_x|,
8635 |mp_left_y|, |mp_right_x|, or |mp_right_y| fields either but we leave these alone
8636 so that certain procedures can operate on both pens and paths. In particular,
8637 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8640 /* this replaces the |mp_left_type| and |mp_right_type| fields in a pen knot */
8642 @ The |make_pen| procedure turns a path into a pen by initializing
8643 the |knil| pointers and making sure the knots form a convex polygon.
8644 Thus each cubic in the given path becomes a straight line and the control
8645 points are ignored. If the path is not cyclic, the ends are connected by a
8648 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8651 static pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8652 pointer p,q; /* two consecutive knots */
8659 h=mp_convex_hull(mp, h);
8660 @<Make sure |h| isn't confused with an elliptical pen@>;
8665 @ The only information required about an elliptical pen is the overall
8666 transformation that has been applied to the original \&{pencircle}.
8667 @:pencircle_}{\&{pencircle} primitive@>
8668 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8669 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8670 knot node and transformed as if it were a path.
8672 @d pen_is_elliptical(A) ((A)==mp_link((A)))
8675 static pointer mp_get_pen_circle (MP mp,scaled diam) {
8676 pointer h; /* the knot node to return */
8677 h=mp_get_node(mp, knot_node_size);
8678 mp_link(h)=h; knil(h)=h;
8679 mp_originator(h)=mp_program_code;
8680 mp_x_coord(h)=0; mp_y_coord(h)=0;
8681 mp_left_x(h)=diam; mp_left_y(h)=0;
8682 mp_right_x(h)=0; mp_right_y(h)=diam;
8686 @ If the polygon being returned by |make_pen| has only one vertex, it will
8687 be interpreted as an elliptical pen. This is no problem since a degenerate
8688 polygon can equally well be thought of as a degenerate ellipse. We need only
8689 initialize the |mp_left_x|, |mp_left_y|, |mp_right_x|, and |mp_right_y| fields.
8691 @<Make sure |h| isn't confused with an elliptical pen@>=
8692 if ( pen_is_elliptical( h) ){
8693 mp_left_x(h)=mp_x_coord(h); mp_left_y(h)=mp_y_coord(h);
8694 mp_right_x(h)=mp_x_coord(h); mp_right_y(h)=mp_y_coord(h);
8697 @ Printing a polygonal pen is very much like printing a path
8700 static void mp_pr_pen (MP mp,pointer h) ;
8703 void mp_pr_pen (MP mp,pointer h) {
8704 pointer p,q; /* for list traversal */
8705 if ( pen_is_elliptical(h) ) {
8706 @<Print the elliptical pen |h|@>;
8710 mp_print_two(mp, mp_x_coord(p),mp_y_coord(p));
8711 mp_print_nl(mp, " .. ");
8712 @<Advance |p| making sure the links are OK and |return| if there is
8715 mp_print(mp, "cycle");
8719 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8721 if ( (q==null) || (knil(q)!=p) ) {
8722 mp_print_nl(mp, "???"); return; /* this won't happen */
8727 @ @<Print the elliptical pen |h|@>=
8729 mp_print(mp, "pencircle transformed (");
8730 mp_print_scaled(mp, mp_x_coord(h));
8731 mp_print_char(mp, xord(','));
8732 mp_print_scaled(mp, mp_y_coord(h));
8733 mp_print_char(mp, xord(','));
8734 mp_print_scaled(mp, mp_left_x(h)-mp_x_coord(h));
8735 mp_print_char(mp, xord(','));
8736 mp_print_scaled(mp, mp_right_x(h)-mp_x_coord(h));
8737 mp_print_char(mp, xord(','));
8738 mp_print_scaled(mp, mp_left_y(h)-mp_y_coord(h));
8739 mp_print_char(mp, xord(','));
8740 mp_print_scaled(mp, mp_right_y(h)-mp_y_coord(h));
8741 mp_print_char(mp, xord(')'));
8744 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8748 static void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) ;
8751 void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
8752 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8755 mp_end_diagnostic(mp, true);
8758 @ Making a polygonal pen into a path involves restoring the |mp_left_type| and
8759 |mp_right_type| fields and setting the control points so as to make a polygonal
8763 static void mp_make_path (MP mp,pointer h) {
8764 pointer p; /* for traversing the knot list */
8765 quarterword k; /* a loop counter */
8766 @<Other local variables in |make_path|@>;
8767 if ( pen_is_elliptical(h) ) {
8768 @<Make the elliptical pen |h| into a path@>;
8772 mp_left_type(p)=mp_explicit;
8773 mp_right_type(p)=mp_explicit;
8774 @<copy the coordinates of knot |p| into its control points@>;
8780 @ @<copy the coordinates of knot |p| into its control points@>=
8781 mp_left_x(p)=mp_x_coord(p);
8782 mp_left_y(p)=mp_y_coord(p);
8783 mp_right_x(p)=mp_x_coord(p);
8784 mp_right_y(p)=mp_y_coord(p)
8786 @ We need an eight knot path to get a good approximation to an ellipse.
8788 @<Make the elliptical pen |h| into a path@>=
8790 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8792 for (k=0;k<=7;k++ ) {
8793 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8794 transforming it appropriately@>;
8795 if ( k==7 ) mp_link(p)=h; else mp_link(p)=mp_get_node(mp, knot_node_size);
8800 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8801 center_x=mp_x_coord(h);
8802 center_y=mp_y_coord(h);
8803 width_x=mp_left_x(h)-center_x;
8804 width_y=mp_left_y(h)-center_y;
8805 height_x=mp_right_x(h)-center_x;
8806 height_y=mp_right_y(h)-center_y
8808 @ @<Other local variables in |make_path|@>=
8809 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8810 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8811 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8812 scaled dx,dy; /* the vector from knot |p| to its right control point */
8814 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8816 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8817 find the point $k/8$ of the way around the circle and the direction vector
8820 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8822 mp_x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8823 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8824 mp_y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8825 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8826 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8827 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8828 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8829 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8830 mp_right_x(p)=mp_x_coord(p)+dx;
8831 mp_right_y(p)=mp_y_coord(p)+dy;
8832 mp_left_x(p)=mp_x_coord(p)-dx;
8833 mp_left_y(p)=mp_y_coord(p)-dy;
8834 mp_left_type(p)=mp_explicit;
8835 mp_right_type(p)=mp_explicit;
8836 mp_originator(p)=mp_program_code
8839 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8840 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8842 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8843 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8844 function for $\theta=\phi=22.5^\circ$. This comes out to be
8845 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8846 \approx 0.132608244919772.
8850 mp->half_cos[0]=fraction_half;
8851 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8853 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8854 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8856 for (k=3;k<= 4;k++ ) {
8857 mp->half_cos[k]=-mp->half_cos[4-k];
8858 mp->d_cos[k]=-mp->d_cos[4-k];
8860 for (k=5;k<= 7;k++ ) {
8861 mp->half_cos[k]=mp->half_cos[8-k];
8862 mp->d_cos[k]=mp->d_cos[8-k];
8865 @ The |convex_hull| function forces a pen polygon to be convex when it is
8866 returned by |make_pen| and after any subsequent transformation where rounding
8867 error might allow the convexity to be lost.
8868 The convex hull algorithm used here is described by F.~P. Preparata and
8869 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8872 static pointer mp_convex_hull (MP mp,pointer h);
8875 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8876 pointer l,r; /* the leftmost and rightmost knots */
8877 pointer p,q; /* knots being scanned */
8878 pointer s; /* the starting point for an upcoming scan */
8879 scaled dx,dy; /* a temporary pointer */
8880 if ( pen_is_elliptical(h) ) {
8883 @<Set |l| to the leftmost knot in polygon~|h|@>;
8884 @<Set |r| to the rightmost knot in polygon~|h|@>;
8887 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8888 move them past~|r|@>;
8889 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8890 move them past~|l|@>;
8891 @<Sort the path from |l| to |r| by increasing $x$@>;
8892 @<Sort the path from |r| to |l| by decreasing $x$@>;
8894 if ( l!=mp_link(l) ) {
8895 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8901 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8903 @<Set |l| to the leftmost knot in polygon~|h|@>=
8907 if ( mp_x_coord(p)<=mp_x_coord(l) )
8908 if ( (mp_x_coord(p)<mp_x_coord(l)) || (mp_y_coord(p)<mp_y_coord(l)) )
8913 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8917 if ( mp_x_coord(p)>=mp_x_coord(r) )
8918 if ( (mp_x_coord(p)>mp_x_coord(r)) || (mp_y_coord(p)>mp_y_coord(r)) )
8923 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8924 dx=mp_x_coord(r)-mp_x_coord(l);
8925 dy=mp_y_coord(r)-mp_y_coord(l);
8929 if ( mp_ab_vs_cd(mp, dx,mp_y_coord(p)-mp_y_coord(l),dy,mp_x_coord(p)-mp_x_coord(l))>0 )
8930 mp_move_knot(mp, p, r);
8934 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8938 static void mp_move_knot (MP mp,pointer p, pointer q) ;
8941 void mp_move_knot (MP mp,pointer p, pointer q) {
8942 mp_link(knil(p))=mp_link(p);
8943 knil(mp_link(p))=knil(p);
8945 mp_link(p)=mp_link(q);
8950 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8954 if ( mp_ab_vs_cd(mp, dx,mp_y_coord(p)-mp_y_coord(l),dy,mp_x_coord(p)-mp_x_coord(l))<0 )
8955 mp_move_knot(mp, p,l);
8959 @ The list is likely to be in order already so we just do linear insertions.
8960 Secondary comparisons on $y$ ensure that the sort is consistent with the
8961 choice of |l| and |r|.
8963 @<Sort the path from |l| to |r| by increasing $x$@>=
8967 while ( mp_x_coord(q)>mp_x_coord(p) ) q=knil(q);
8968 while ( mp_x_coord(q)==mp_x_coord(p) ) {
8969 if ( mp_y_coord(q)>mp_y_coord(p) ) q=knil(q); else break;
8971 if ( q==knil(p) ) p=mp_link(p);
8972 else { p=mp_link(p); mp_move_knot(mp, knil(p),q); };
8975 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
8979 while ( mp_x_coord(q)<mp_x_coord(p) ) q=knil(q);
8980 while ( mp_x_coord(q)==mp_x_coord(p) ) {
8981 if ( mp_y_coord(q)<mp_y_coord(p) ) q=knil(q); else break;
8983 if ( q==knil(p) ) p=mp_link(p);
8984 else { p=mp_link(p); mp_move_knot(mp, knil(p),q); };
8987 @ The condition involving |ab_vs_cd| tests if there is not a left turn
8988 at knot |q|. There usually will be a left turn so we streamline the case
8989 where the |then| clause is not executed.
8991 @<Do a Gramm scan and remove vertices where there...@>=
8995 dx=mp_x_coord(q)-mp_x_coord(p);
8996 dy=mp_y_coord(q)-mp_y_coord(p);
9000 if ( mp_ab_vs_cd(mp, dx,mp_y_coord(q)-mp_y_coord(p),dy,mp_x_coord(q)-mp_x_coord(p))<=0 ) {
9001 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
9006 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
9009 mp_free_node(mp, p,knot_node_size);
9010 mp_link(s)=q; knil(q)=s;
9012 else { p=knil(s); q=s; };
9015 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
9016 offset associated with the given direction |(x,y)|. If two different offsets
9017 apply, it chooses one of them.
9020 static void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
9021 pointer p,q; /* consecutive knots */
9023 /* the transformation matrix for an elliptical pen */
9024 fraction xx,yy; /* untransformed offset for an elliptical pen */
9025 fraction d; /* a temporary register */
9026 if ( pen_is_elliptical(h) ) {
9027 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
9032 } while (!(mp_ab_vs_cd(mp, mp_x_coord(q)-mp_x_coord(p),y, mp_y_coord(q)-mp_y_coord(p),x)>=0));
9035 } while (!(mp_ab_vs_cd(mp, mp_x_coord(q)-mp_x_coord(p),y, mp_y_coord(q)-mp_y_coord(p),x)<=0));
9036 mp->cur_x=mp_x_coord(p);
9037 mp->cur_y=mp_y_coord(p);
9043 scaled cur_y; /* all-purpose return value registers */
9045 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
9046 if ( (x==0) && (y==0) ) {
9047 mp->cur_x=mp_x_coord(h); mp->cur_y=mp_y_coord(h);
9049 @<Find the non-constant part of the transformation for |h|@>;
9050 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
9053 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
9054 untransformed version of |(x,y)|@>;
9055 mp->cur_x=mp_x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
9056 mp->cur_y=mp_y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
9059 @ @<Find the non-constant part of the transformation for |h|@>=
9060 wx=mp_left_x(h)-mp_x_coord(h);
9061 wy=mp_left_y(h)-mp_y_coord(h);
9062 hx=mp_right_x(h)-mp_x_coord(h);
9063 hy=mp_right_y(h)-mp_y_coord(h)
9065 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
9066 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
9067 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
9068 d=mp_pyth_add(mp, xx,yy);
9070 xx=half(mp_make_fraction(mp, xx,d));
9071 yy=half(mp_make_fraction(mp, yy,d));
9074 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
9075 But we can handle that case by just calling |find_offset| twice. The answer
9076 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
9079 static void mp_pen_bbox (MP mp,pointer h) {
9080 pointer p; /* for scanning the knot list */
9081 if ( pen_is_elliptical(h) ) {
9082 @<Find the bounding box of an elliptical pen@>;
9084 mp_minx=mp_x_coord(h); mp_maxx=mp_minx;
9085 mp_miny=mp_y_coord(h); mp_maxy=mp_miny;
9088 if ( mp_x_coord(p)<mp_minx ) mp_minx=mp_x_coord(p);
9089 if ( mp_y_coord(p)<mp_miny ) mp_miny=mp_y_coord(p);
9090 if ( mp_x_coord(p)>mp_maxx ) mp_maxx=mp_x_coord(p);
9091 if ( mp_y_coord(p)>mp_maxy ) mp_maxy=mp_y_coord(p);
9097 @ @<Find the bounding box of an elliptical pen@>=
9099 mp_find_offset(mp, 0,fraction_one,h);
9101 mp_minx=2*mp_x_coord(h)-mp->cur_x;
9102 mp_find_offset(mp, -fraction_one,0,h);
9104 mp_miny=2*mp_y_coord(h)-mp->cur_y;
9107 @* \[21] Edge structures.
9108 Now we come to \MP's internal scheme for representing pictures.
9109 The representation is very different from \MF's edge structures
9110 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9111 images. However, the basic idea is somewhat similar in that shapes
9112 are represented via their boundaries.
9114 The main purpose of edge structures is to keep track of graphical objects
9115 until it is time to translate them into \ps. Since \MP\ does not need to
9116 know anything about an edge structure other than how to translate it into
9117 \ps\ and how to find its bounding box, edge structures can be just linked
9118 lists of graphical objects. \MP\ has no easy way to determine whether
9119 two such objects overlap, but it suffices to draw the first one first and
9120 let the second one overwrite it if necessary.
9123 enum mp_graphical_object_code {
9124 @<Graphical object codes@>
9128 @ Let's consider the types of graphical objects one at a time.
9129 First of all, a filled contour is represented by a eight-word node. The first
9130 word contains |type| and |link| fields, and the next six words contain a
9131 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9132 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9133 give the relevant information.
9135 @d mp_path_p(A) mp_link((A)+1)
9136 /* a pointer to the path that needs filling */
9137 @d mp_pen_p(A) mp_info((A)+1)
9138 /* a pointer to the pen to fill or stroke with */
9139 @d mp_color_model(A) mp_type((A)+2) /* the color model */
9140 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9141 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9142 @d obj_grey_loc obj_red_loc /* the location for the color */
9143 @d red_val(A) mp->mem[(A)+3].sc
9144 /* the red component of the color in the range $0\ldots1$ */
9147 @d green_val(A) mp->mem[(A)+4].sc
9148 /* the green component of the color in the range $0\ldots1$ */
9149 @d magenta_val green_val
9150 @d blue_val(A) mp->mem[(A)+5].sc
9151 /* the blue component of the color in the range $0\ldots1$ */
9152 @d yellow_val blue_val
9153 @d black_val(A) mp->mem[(A)+6].sc
9154 /* the blue component of the color in the range $0\ldots1$ */
9155 @d ljoin_val(A) mp_name_type((A)) /* the value of \&{linejoin} */
9156 @:mp_linejoin_}{\&{linejoin} primitive@>
9157 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9158 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9159 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9160 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9161 @d mp_pre_script(A) mp->mem[(A)+8].hh.lh
9162 @d mp_post_script(A) mp->mem[(A)+8].hh.rh
9165 @ @<Graphical object codes@>=
9169 static pointer mp_new_fill_node (MP mp,pointer p) {
9170 /* make a fill node for cyclic path |p| and color black */
9171 pointer t; /* the new node */
9172 t=mp_get_node(mp, fill_node_size);
9173 mp_type(t)=mp_fill_code;
9175 mp_pen_p(t)=null; /* |null| means don't use a pen */
9180 mp_color_model(t)=mp_uninitialized_model;
9181 mp_pre_script(t)=null;
9182 mp_post_script(t)=null;
9183 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9187 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9188 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9189 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9190 else ljoin_val(t)=0;
9191 if ( mp->internal[mp_miterlimit]<unity )
9192 miterlim_val(t)=unity;
9194 miterlim_val(t)=mp->internal[mp_miterlimit]
9196 @ A stroked path is represented by an eight-word node that is like a filled
9197 contour node except that it contains the current \&{linecap} value, a scale
9198 factor for the dash pattern, and a pointer that is non-null if the stroke
9199 is to be dashed. The purpose of the scale factor is to allow a picture to
9200 be transformed without touching the picture that |dash_p| points to.
9202 @d mp_dash_p(A) mp_link((A)+9)
9203 /* a pointer to the edge structure that gives the dash pattern */
9204 @d lcap_val(A) mp_type((A)+9)
9205 /* the value of \&{linecap} */
9206 @:mp_linecap_}{\&{linecap} primitive@>
9207 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9208 @d stroked_node_size 11
9210 @ @<Graphical object codes@>=
9214 static pointer mp_new_stroked_node (MP mp,pointer p) {
9215 /* make a stroked node for path |p| with |mp_pen_p(p)| temporarily |null| */
9216 pointer t; /* the new node */
9217 t=mp_get_node(mp, stroked_node_size);
9218 mp_type(t)=mp_stroked_code;
9219 mp_path_p(t)=p; mp_pen_p(t)=null;
9221 dash_scale(t)=unity;
9226 mp_color_model(t)=mp_uninitialized_model;
9227 mp_pre_script(t)=null;
9228 mp_post_script(t)=null;
9229 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9230 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9231 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9236 @ When a dashed line is computed in a transformed coordinate system, the dash
9237 lengths get scaled like the pen shape and we need to compensate for this. Since
9238 there is no unique scale factor for an arbitrary transformation, we use the
9239 the square root of the determinant. The properties of the determinant make it
9240 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9241 except for the initialization of the scale factor |s|. The factor of 64 is
9242 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9243 to counteract the effect of |take_fraction|.
9246 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9247 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9248 unsigned s; /* amount by which the result of |square_rt| needs to be scaled */
9249 @<Initialize |maxabs|@>;
9251 while ( (maxabs<fraction_one) && (s>1) ){
9252 a+=a; b+=b; c+=c; d+=d;
9253 maxabs+=maxabs; s=(unsigned)(halfp(s));
9255 return (scaled)(s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c))));
9258 static scaled mp_get_pen_scale (MP mp,pointer p) {
9259 return mp_sqrt_det(mp,
9260 mp_left_x(p)-mp_x_coord(p), mp_right_x(p)-mp_x_coord(p),
9261 mp_left_y(p)-mp_y_coord(p), mp_right_y(p)-mp_y_coord(p));
9265 static scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9268 @ @<Initialize |maxabs|@>=
9270 if ( abs(b)>maxabs ) maxabs=abs(b);
9271 if ( abs(c)>maxabs ) maxabs=abs(c);
9272 if ( abs(d)>maxabs ) maxabs=abs(d)
9274 @ When a picture contains text, this is represented by a fourteen-word node
9275 where the color information and |type| and |link| fields are augmented by
9276 additional fields that describe the text and how it is transformed.
9277 The |path_p| and |mp_pen_p| pointers are replaced by a number that identifies
9278 the font and a string number that gives the text to be displayed.
9279 The |width|, |height|, and |depth| fields
9280 give the dimensions of the text at its design size, and the remaining six
9281 words give a transformation to be applied to the text. The |new_text_node|
9282 function initializes everything to default values so that the text comes out
9283 black with its reference point at the origin.
9285 @d mp_text_p(A) mp_link((A)+1) /* a string pointer for the text to display */
9286 @d mp_font_n(A) mp_info((A)+1) /* the font number */
9287 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9288 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9289 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9290 @d text_tx_loc(A) ((A)+11)
9291 /* the first of six locations for transformation parameters */
9292 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9293 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9294 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9295 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9296 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9297 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9298 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9299 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9300 @d text_node_size 17
9302 @ @<Graphical object codes@>=
9306 static pointer mp_new_text_node (MP mp,char *f,str_number s) {
9307 /* make a text node for font |f| and text string |s| */
9308 pointer t; /* the new node */
9309 t=mp_get_node(mp, text_node_size);
9310 mp_type(t)=mp_text_code;
9312 mp_font_n(t)=(halfword)mp_find_font(mp, f); /* this identifies the font */
9317 mp_color_model(t)=mp_uninitialized_model;
9318 mp_pre_script(t)=null;
9319 mp_post_script(t)=null;
9320 tx_val(t)=0; ty_val(t)=0;
9321 txx_val(t)=unity; txy_val(t)=0;
9322 tyx_val(t)=0; tyy_val(t)=unity;
9323 mp_set_text_box(mp, t); /* this finds the bounding box */
9327 @ The last two types of graphical objects that can occur in an edge structure
9328 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9329 @:set_bounds_}{\&{setbounds} primitive@>
9330 to implement because we must keep track of exactly what is being clipped or
9331 bounded when pictures get merged together. For this reason, each clipping or
9332 \&{setbounds} operation is represented by a pair of nodes: first comes a
9333 two-word node whose |path_p| gives the relevant path, then there is the list
9334 of objects to clip or bound followed by a two-word node whose second word is
9337 Using at least two words for each graphical object node allows them all to be
9338 allocated and deallocated similarly with a global array |gr_object_size| to
9339 give the size in words for each object type.
9341 @d start_clip_size 2
9342 @d start_bounds_size 2
9343 @d stop_clip_size 2 /* the second word is not used here */
9344 @d stop_bounds_size 2 /* the second word is not used here */
9346 @d stop_type(A) ((A)+2)
9347 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9348 @d has_color(A) (mp_type((A))<mp_start_clip_code)
9349 /* does a graphical object have color fields? */
9350 @d has_pen(A) (mp_type((A))<mp_text_code)
9351 /* does a graphical object have a |mp_pen_p| field? */
9352 @d is_start_or_stop(A) (mp_type((A))>=mp_start_clip_code)
9353 @d is_stop(A) (mp_type((A))>=mp_stop_clip_code)
9355 @ @<Graphical object codes@>=
9356 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9357 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9358 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9359 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9362 static pointer mp_new_bounds_node (MP mp,pointer p, quarterword c) {
9363 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9364 pointer t; /* the new node */
9365 t=mp_get_node(mp, mp->gr_object_size[c]);
9371 @ We need an array to keep track of the sizes of graphical objects.
9374 quarterword gr_object_size[mp_stop_bounds_code+1];
9377 mp->gr_object_size[mp_fill_code]=fill_node_size;
9378 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9379 mp->gr_object_size[mp_text_code]=text_node_size;
9380 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9381 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9382 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9383 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9385 @ All the essential information in an edge structure is encoded as a linked list
9386 of graphical objects as we have just seen, but it is helpful to add some
9387 redundant information. A single edge structure might be used as a dash pattern
9388 many times, and it would be nice to avoid scanning the same structure
9389 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9390 has a header that gives a list of dashes in a sorted order designed for rapid
9391 translation into \ps.
9393 Each dash is represented by a three-word node containing the initial and final
9394 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9395 the dash node with the next higher $x$-coordinates and the final link points
9396 to a special location called |null_dash|. (There should be no overlap between
9397 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9398 the period of repetition, this needs to be stored in the edge header along
9399 with a pointer to the list of dash nodes.
9401 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9402 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9404 @d dash_list mp_link
9405 /* in an edge header this points to the first dash node */
9406 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9408 @ It is also convenient for an edge header to contain the bounding
9409 box information needed by the \&{llcorner} and \&{urcorner} operators
9410 so that this does not have to be recomputed unnecessarily. This is done by
9411 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9412 how far the bounding box computation has gotten. Thus if the user asks for
9413 the bounding box and then adds some more text to the picture before asking
9414 for more bounding box information, the second computation need only look at
9415 the additional text.
9417 When the bounding box has not been computed, the |bblast| pointer points
9418 to a dummy link at the head of the graphical object list while the |minx_val|
9419 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9420 fields contain |-el_gordo|.
9422 Since the bounding box of pictures containing objects of type
9423 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9424 @:mp_true_corners_}{\&{truecorners} primitive@>
9425 data might not be valid for all values of this parameter. Hence, the |bbtype|
9426 field is needed to keep track of this.
9428 @d minx_val(A) mp->mem[(A)+2].sc
9429 @d miny_val(A) mp->mem[(A)+3].sc
9430 @d maxx_val(A) mp->mem[(A)+4].sc
9431 @d maxy_val(A) mp->mem[(A)+5].sc
9432 @d bblast(A) mp_link((A)+6) /* last item considered in bounding box computation */
9433 @d bbtype(A) mp_info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9434 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9436 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9438 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9440 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9443 static void mp_init_bbox (MP mp,pointer h) {
9444 /* Initialize the bounding box information in edge structure |h| */
9445 bblast(h)=dummy_loc(h);
9446 bbtype(h)=no_bounds;
9447 minx_val(h)=el_gordo;
9448 miny_val(h)=el_gordo;
9449 maxx_val(h)=-el_gordo;
9450 maxy_val(h)=-el_gordo;
9453 @ The only other entries in an edge header are a reference count in the first
9454 word and a pointer to the tail of the object list in the last word.
9456 @d obj_tail(A) mp_info((A)+7) /* points to the last entry in the object list */
9457 @d edge_header_size 8
9460 static void mp_init_edges (MP mp,pointer h) {
9461 /* initialize an edge header to null values */
9462 dash_list(h)=null_dash;
9463 obj_tail(h)=dummy_loc(h);
9464 mp_link(dummy_loc(h))=null;
9466 mp_init_bbox(mp, h);
9469 @ Here is how edge structures are deleted. The process can be recursive because
9470 of the need to dereference edge structures that are used as dash patterns.
9473 @d add_edge_ref(A) incr(ref_count(A))
9474 @d delete_edge_ref(A) {
9475 if ( ref_count((A))==null )
9476 mp_toss_edges(mp, A);
9482 static void mp_flush_dash_list (MP mp,pointer h);
9483 static pointer mp_toss_gr_object (MP mp,pointer p) ;
9484 static void mp_toss_edges (MP mp,pointer h) ;
9486 @ @c void mp_toss_edges (MP mp,pointer h) {
9487 pointer p,q; /* pointers that scan the list being recycled */
9488 pointer r; /* an edge structure that object |p| refers to */
9489 mp_flush_dash_list(mp, h);
9490 q=mp_link(dummy_loc(h));
9491 while ( (q!=null) ) {
9493 r=mp_toss_gr_object(mp, p);
9494 if ( r!=null ) delete_edge_ref(r);
9496 mp_free_node(mp, h,edge_header_size);
9498 void mp_flush_dash_list (MP mp,pointer h) {
9499 pointer p,q; /* pointers that scan the list being recycled */
9501 while ( q!=null_dash ) {
9503 mp_free_node(mp, p,dash_node_size);
9505 dash_list(h)=null_dash;
9507 pointer mp_toss_gr_object (MP mp,pointer p) {
9508 /* returns an edge structure that needs to be dereferenced */
9509 pointer e; /* the edge structure to return */
9511 @<Prepare to recycle graphical object |p|@>;
9512 mp_free_node(mp, p,mp->gr_object_size[mp_type(p)]);
9516 @ @<Prepare to recycle graphical object |p|@>=
9517 switch (mp_type(p)) {
9519 mp_toss_knot_list(mp, mp_path_p(p));
9520 if ( mp_pen_p(p)!=null ) mp_toss_knot_list(mp, mp_pen_p(p));
9521 if ( mp_pre_script(p)!=null ) delete_str_ref(mp_pre_script(p));
9522 if ( mp_post_script(p)!=null ) delete_str_ref(mp_post_script(p));
9524 case mp_stroked_code:
9525 mp_toss_knot_list(mp, mp_path_p(p));
9526 if ( mp_pen_p(p)!=null ) mp_toss_knot_list(mp, mp_pen_p(p));
9527 if ( mp_pre_script(p)!=null ) delete_str_ref(mp_pre_script(p));
9528 if ( mp_post_script(p)!=null ) delete_str_ref(mp_post_script(p));
9532 delete_str_ref(mp_text_p(p));
9533 if ( mp_pre_script(p)!=null ) delete_str_ref(mp_pre_script(p));
9534 if ( mp_post_script(p)!=null ) delete_str_ref(mp_post_script(p));
9536 case mp_start_clip_code:
9537 case mp_start_bounds_code:
9538 mp_toss_knot_list(mp, mp_path_p(p));
9540 case mp_stop_clip_code:
9541 case mp_stop_bounds_code:
9543 } /* there are no other cases */
9545 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9546 to be done before making a significant change to an edge structure. Much of
9547 the work is done in a separate routine |copy_objects| that copies a list of
9548 graphical objects into a new edge header.
9551 static pointer mp_private_edges (MP mp,pointer h) {
9552 /* make a private copy of the edge structure headed by |h| */
9553 pointer hh; /* the edge header for the new copy */
9554 pointer p,pp; /* pointers for copying the dash list */
9555 if ( ref_count(h)==null ) {
9559 hh=mp_copy_objects(mp, mp_link(dummy_loc(h)),null);
9560 @<Copy the dash list from |h| to |hh|@>;
9561 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9562 point into the new object list@>;
9567 @ Here we use the fact that |dash_list(hh)=mp_link(hh)|.
9568 @^data structure assumptions@>
9570 @<Copy the dash list from |h| to |hh|@>=
9571 pp=hh; p=dash_list(h);
9572 while ( (p!=null_dash) ) {
9573 mp_link(pp)=mp_get_node(mp, dash_node_size);
9575 start_x(pp)=start_x(p);
9576 stop_x(pp)=stop_x(p);
9579 mp_link(pp)=null_dash;
9580 dash_y(hh)=dash_y(h)
9583 @ |h| is an edge structure
9586 static mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
9589 scaled scf; /* scale factor */
9593 if (h==null || dash_list(h)==null_dash)
9596 scf=mp_get_pen_scale(mp, mp_pen_p(q));
9598 if (*w==0) scf = dash_scale(q); else return NULL;
9600 scf=mp_make_scaled(mp, *w,scf);
9601 scf=mp_take_scaled(mp, scf,dash_scale(q));
9604 d = xmalloc(1,sizeof(mp_dash_object));
9605 start_x(null_dash)=start_x(p)+dash_y(h);
9606 while (p != null_dash) {
9607 dashes = xrealloc(dashes, (num_dashes+2), sizeof(scaled));
9608 dashes[(num_dashes-1)] =
9609 mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
9610 dashes[(num_dashes)] =
9611 mp_take_scaled(mp,(start_x(mp_link(p))-stop_x(p)),scf);
9612 dashes[(num_dashes+1)] = -1; /* terminus */
9617 d->offset = mp_take_scaled(mp,mp_dash_offset(mp, h),scf);
9623 @ @<Copy the bounding box information from |h| to |hh|...@>=
9624 minx_val(hh)=minx_val(h);
9625 miny_val(hh)=miny_val(h);
9626 maxx_val(hh)=maxx_val(h);
9627 maxy_val(hh)=maxy_val(h);
9628 bbtype(hh)=bbtype(h);
9629 p=dummy_loc(h); pp=dummy_loc(hh);
9630 while ((p!=bblast(h)) ) {
9631 if ( p==null ) mp_confusion(mp, "bblast");
9632 @:this can't happen bblast}{\quad bblast@>
9633 p=mp_link(p); pp=mp_link(pp);
9637 @ Here is the promised routine for copying graphical objects into a new edge
9638 structure. It starts copying at object~|p| and stops just before object~|q|.
9639 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9640 structure requires further initialization by |init_bbox|.
9643 static pointer mp_copy_objects (MP mp, pointer p, pointer q);
9646 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9647 pointer hh; /* the new edge header */
9648 pointer pp; /* the last newly copied object */
9649 quarterword k; /* temporary register */
9650 hh=mp_get_node(mp, edge_header_size);
9651 dash_list(hh)=null_dash;
9655 @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9662 @ @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9663 { k=mp->gr_object_size[mp_type(p)];
9664 mp_link(pp)=mp_get_node(mp, k);
9666 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9667 @<Fix anything in graphical object |pp| that should differ from the
9668 corresponding field in |p|@>;
9672 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9673 switch (mp_type(p)) {
9674 case mp_start_clip_code:
9675 case mp_start_bounds_code:
9676 mp_path_p(pp)=mp_copy_path(mp, mp_path_p(p));
9679 mp_path_p(pp)=mp_copy_path(mp, mp_path_p(p));
9680 if ( mp_pre_script(p)!=null ) add_str_ref(mp_pre_script(p));
9681 if ( mp_post_script(p)!=null ) add_str_ref(mp_post_script(p));
9682 if ( mp_pen_p(p)!=null ) mp_pen_p(pp)=copy_pen(mp_pen_p(p));
9684 case mp_stroked_code:
9685 if ( mp_pre_script(p)!=null ) add_str_ref(mp_pre_script(p));
9686 if ( mp_post_script(p)!=null ) add_str_ref(mp_post_script(p));
9687 mp_path_p(pp)=mp_copy_path(mp, mp_path_p(p));
9688 mp_pen_p(pp)=copy_pen(mp_pen_p(p));
9689 if ( mp_dash_p(p)!=null ) add_edge_ref(mp_dash_p(pp));
9692 if ( mp_pre_script(p)!=null ) add_str_ref(mp_pre_script(p));
9693 if ( mp_post_script(p)!=null ) add_str_ref(mp_post_script(p));
9694 add_str_ref(mp_text_p(pp));
9696 case mp_stop_clip_code:
9697 case mp_stop_bounds_code:
9699 } /* there are no other cases */
9701 @ Here is one way to find an acceptable value for the second argument to
9702 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9703 skips past one picture component, where a ``picture component'' is a single
9704 graphical object, or a start bounds or start clip object and everything up
9705 through the matching stop bounds or stop clip object. The macro version avoids
9706 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9707 unless |p| points to a stop bounds or stop clip node, in which case it executes
9710 @d skip_component(A)
9711 if ( ! is_start_or_stop((A)) ) (A)=mp_link((A));
9712 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9716 static pointer mp_skip_1component (MP mp,pointer p) {
9717 integer lev; /* current nesting level */
9720 if ( is_start_or_stop(p) ) {
9721 if ( is_stop(p) ) decr(lev); else incr(lev);
9728 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9731 static void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) ;
9734 void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
9735 pointer p; /* a graphical object to be printed */
9736 pointer hh,pp; /* temporary pointers */
9737 scaled scf; /* a scale factor for the dash pattern */
9738 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9739 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9741 while ( mp_link(p)!=null ) {
9744 switch (mp_type(p)) {
9745 @<Cases for printing graphical object node |p|@>;
9747 mp_print(mp, "[unknown object type!]");
9751 mp_print_nl(mp, "End edges");
9752 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9754 mp_end_diagnostic(mp, true);
9757 @ @<Cases for printing graphical object node |p|@>=
9759 mp_print(mp, "Filled contour ");
9760 mp_print_obj_color(mp, p);
9761 mp_print_char(mp, xord(':')); mp_print_ln(mp);
9762 mp_pr_path(mp, mp_path_p(p)); mp_print_ln(mp);
9763 if ( (mp_pen_p(p)!=null) ) {
9764 @<Print join type for graphical object |p|@>;
9765 mp_print(mp, " with pen"); mp_print_ln(mp);
9766 mp_pr_pen(mp, mp_pen_p(p));
9770 @ @<Print join type for graphical object |p|@>=
9771 switch (ljoin_val(p)) {
9773 mp_print(mp, "mitered joins limited ");
9774 mp_print_scaled(mp, miterlim_val(p));
9777 mp_print(mp, "round joins");
9780 mp_print(mp, "beveled joins");
9783 mp_print(mp, "?? joins");
9788 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9790 @<Print join and cap types for stroked node |p|@>=
9791 switch (lcap_val(p)) {
9792 case 0:mp_print(mp, "butt"); break;
9793 case 1:mp_print(mp, "round"); break;
9794 case 2:mp_print(mp, "square"); break;
9795 default: mp_print(mp, "??"); break;
9798 mp_print(mp, " ends, ");
9799 @<Print join type for graphical object |p|@>
9801 @ Here is a routine that prints the color of a graphical object if it isn't
9802 black (the default color).
9805 static void mp_print_obj_color (MP mp,pointer p) ;
9808 void mp_print_obj_color (MP mp,pointer p) {
9809 if ( mp_color_model(p)==mp_grey_model ) {
9810 if ( grey_val(p)>0 ) {
9811 mp_print(mp, "greyed ");
9812 mp_print_compact_node(mp, obj_grey_loc(p),1);
9814 } else if ( mp_color_model(p)==mp_cmyk_model ) {
9815 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9816 (yellow_val(p)>0) || (black_val(p)>0) ) {
9817 mp_print(mp, "processcolored ");
9818 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9820 } else if ( mp_color_model(p)==mp_rgb_model ) {
9821 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9822 mp_print(mp, "colored ");
9823 mp_print_compact_node(mp, obj_red_loc(p),3);
9828 @ We also need a procedure for printing consecutive scaled values as if they
9829 were a known big node.
9832 static void mp_print_compact_node (MP mp,pointer p, quarterword k) ;
9835 void mp_print_compact_node (MP mp,pointer p, quarterword k) {
9836 pointer q; /* last location to print */
9838 mp_print_char(mp, xord('('));
9840 mp_print_scaled(mp, mp->mem[p].sc);
9841 if ( p<q ) mp_print_char(mp, xord(','));
9844 mp_print_char(mp, xord(')'));
9847 @ @<Cases for printing graphical object node |p|@>=
9848 case mp_stroked_code:
9849 mp_print(mp, "Filled pen stroke ");
9850 mp_print_obj_color(mp, p);
9851 mp_print_char(mp, xord(':')); mp_print_ln(mp);
9852 mp_pr_path(mp, mp_path_p(p));
9853 if ( mp_dash_p(p)!=null ) {
9854 mp_print_nl(mp, "dashed (");
9855 @<Finish printing the dash pattern that |p| refers to@>;
9858 @<Print join and cap types for stroked node |p|@>;
9859 mp_print(mp, " with pen"); mp_print_ln(mp);
9860 if ( mp_pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9862 else mp_pr_pen(mp, mp_pen_p(p));
9865 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9866 when it is not known to define a suitable dash pattern. This is disallowed
9867 here because the |mp_dash_p| field should never point to such an edge header.
9868 Note that memory is allocated for |start_x(null_dash)| and we are free to
9869 give it any convenient value.
9871 @<Finish printing the dash pattern that |p| refers to@>=
9872 ok_to_dash=pen_is_elliptical(mp_pen_p(p));
9873 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9876 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9877 mp_print(mp, " ??");
9878 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9879 while ( pp!=null_dash ) {
9880 mp_print(mp, "on ");
9881 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9882 mp_print(mp, " off ");
9883 mp_print_scaled(mp, mp_take_scaled(mp, start_x(mp_link(pp))-stop_x(pp),scf));
9885 if ( pp!=null_dash ) mp_print_char(mp, xord(' '));
9887 mp_print(mp, ") shifted ");
9888 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9889 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9893 static scaled mp_dash_offset (MP mp,pointer h) ;
9896 scaled mp_dash_offset (MP mp,pointer h) {
9897 scaled x; /* the answer */
9898 if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
9899 @:this can't happen dash0}{\quad dash0@>
9900 if ( dash_y(h)==0 ) {
9903 x=-(start_x(dash_list(h)) % dash_y(h));
9904 if ( x<0 ) x=x+dash_y(h);
9909 @ @<Cases for printing graphical object node |p|@>=
9911 mp_print_char(mp, xord('"')); mp_print_str(mp,mp_text_p(p));
9912 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[mp_font_n(p)]);
9913 mp_print_char(mp, xord('"')); mp_print_ln(mp);
9914 mp_print_obj_color(mp, p);
9915 mp_print(mp, "transformed ");
9916 mp_print_compact_node(mp, text_tx_loc(p),6);
9919 @ @<Cases for printing graphical object node |p|@>=
9920 case mp_start_clip_code:
9921 mp_print(mp, "clipping path:");
9923 mp_pr_path(mp, mp_path_p(p));
9925 case mp_stop_clip_code:
9926 mp_print(mp, "stop clipping");
9929 @ @<Cases for printing graphical object node |p|@>=
9930 case mp_start_bounds_code:
9931 mp_print(mp, "setbounds path:");
9933 mp_pr_path(mp, mp_path_p(p));
9935 case mp_stop_bounds_code:
9936 mp_print(mp, "end of setbounds");
9939 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9940 subroutine that scans an edge structure and tries to interpret it as a dash
9941 pattern. This can only be done when there are no filled regions or clipping
9942 paths and all the pen strokes have the same color. The first step is to let
9943 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9944 project all the pen stroke paths onto the line $y=y_0$ and require that there
9945 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9946 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9947 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9950 static pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9951 pointer p; /* this scans the stroked nodes in the object list */
9952 pointer p0; /* if not |null| this points to the first stroked node */
9953 pointer pp,qq,rr; /* pointers into |mp_path_p(p)| */
9954 pointer d,dd; /* pointers used to create the dash list */
9956 @<Other local variables in |make_dashes|@>;
9957 y0=0; /* the initial $y$ coordinate */
9958 if ( dash_list(h)!=null_dash )
9961 p=mp_link(dummy_loc(h));
9963 if ( mp_type(p)!=mp_stroked_code ) {
9964 @<Compain that the edge structure contains a node of the wrong type
9965 and |goto not_found|@>;
9968 if ( p0==null ){ p0=p; y0=mp_y_coord(pp); };
9969 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9970 or |goto not_found| if there is an error@>;
9971 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9974 if ( dash_list(h)==null_dash )
9975 goto NOT_FOUND; /* No error message */
9976 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9977 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
9980 @<Flush the dash list, recycle |h| and return |null|@>;
9983 @ @<Compain that the edge structure contains a node of the wrong type...@>=
9985 print_err("Picture is too complicated to use as a dash pattern");
9986 help3("When you say `dashed p', picture p should not contain any",
9987 "text, filled regions, or clipping paths. This time it did",
9988 "so I'll just make it a solid line instead.");
9989 mp_put_get_error(mp);
9993 @ A similar error occurs when monotonicity fails.
9996 static void mp_x_retrace_error (MP mp) ;
9999 void mp_x_retrace_error (MP mp) {
10000 print_err("Picture is too complicated to use as a dash pattern");
10001 help3("When you say `dashed p', every path in p should be monotone",
10002 "in x and there must be no overlapping. This failed",
10003 "so I'll just make it a solid line instead.");
10004 mp_put_get_error(mp);
10007 @ We stash |p| in |mp_info(d)| if |mp_dash_p(p)<>0| so that subsequent processing can
10008 handle the case where the pen stroke |p| is itself dashed.
10010 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
10011 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
10014 if ( mp_link(pp)!=pp ) {
10016 qq=rr; rr=mp_link(rr);
10017 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
10018 if there is a problem@>;
10019 } while (mp_right_type(rr)!=mp_endpoint);
10021 d=mp_get_node(mp, dash_node_size);
10022 if ( mp_dash_p(p)==0 ) mp_info(d)=0; else mp_info(d)=p;
10023 if ( mp_x_coord(pp)<mp_x_coord(rr) ) {
10024 start_x(d)=mp_x_coord(pp);
10025 stop_x(d)=mp_x_coord(rr);
10027 start_x(d)=mp_x_coord(rr);
10028 stop_x(d)=mp_x_coord(pp);
10031 @ We also need to check for the case where the segment from |qq| to |rr| is
10032 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
10034 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
10039 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
10040 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
10041 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
10042 mp_x_retrace_error(mp); goto NOT_FOUND;
10046 if ( (mp_x_coord(pp)>x0) || (x0>x3) ) {
10047 if ( (mp_x_coord(pp)<x0) || (x0<x3) ) {
10048 mp_x_retrace_error(mp); goto NOT_FOUND;
10052 @ @<Other local variables in |make_dashes|@>=
10053 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
10055 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
10056 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
10057 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
10058 print_err("Picture is too complicated to use as a dash pattern");
10059 help3("When you say `dashed p', everything in picture p should",
10060 "be the same color. I can\'t handle your color changes",
10061 "so I'll just make it a solid line instead.");
10062 mp_put_get_error(mp);
10066 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
10067 start_x(null_dash)=stop_x(d);
10068 dd=h; /* this makes |mp_link(dd)=dash_list(h)| */
10069 while ( start_x(mp_link(dd))<stop_x(d) )
10072 if ( (stop_x(dd)>start_x(d)) )
10073 { mp_x_retrace_error(mp); goto NOT_FOUND; };
10075 mp_link(d)=mp_link(dd);
10078 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
10080 while ( (mp_link(d)!=null_dash) )
10083 dash_y(h)=stop_x(d)-start_x(dd);
10084 if ( abs(y0)>dash_y(h) ) {
10086 } else if ( d!=dd ) {
10087 dash_list(h)=mp_link(dd);
10088 stop_x(d)=stop_x(dd)+dash_y(h);
10089 mp_free_node(mp, dd,dash_node_size);
10092 @ We get here when the argument is a null picture or when there is an error.
10093 Recovering from an error involves making |dash_list(h)| empty to indicate
10094 that |h| is not known to be a valid dash pattern. We also dereference |h|
10095 since it is not being used for the return value.
10097 @<Flush the dash list, recycle |h| and return |null|@>=
10098 mp_flush_dash_list(mp, h);
10099 delete_edge_ref(h);
10102 @ Having carefully saved the dashed stroked nodes in the
10103 corresponding dash nodes, we must be prepared to break up these dashes into
10106 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
10107 d=h; /* now |mp_link(d)=dash_list(h)| */
10108 while ( mp_link(d)!=null_dash ) {
10109 ds=mp_info(mp_link(d));
10114 hsf=dash_scale(ds);
10115 if ( (hh==null) ) mp_confusion(mp, "dash1");
10116 @:this can't happen dash0}{\quad dash1@>
10117 if ( dash_y(hh)==0 ) {
10120 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
10121 @:this can't happen dash0}{\quad dash1@>
10122 @<Replace |mp_link(d)| by a dashed version as determined by edge header
10123 |hh| and scale factor |ds|@>;
10128 @ @<Other local variables in |make_dashes|@>=
10129 pointer dln; /* |mp_link(d)| */
10130 pointer hh; /* an edge header that tells how to break up |dln| */
10131 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
10132 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
10133 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
10135 @ @<Replace |mp_link(d)| by a dashed version as determined by edge header...@>=
10138 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
10139 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
10140 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
10141 +mp_take_scaled(mp, hsf,dash_y(hh));
10142 stop_x(null_dash)=start_x(null_dash);
10143 @<Advance |dd| until finding the first dash that overlaps |dln| when
10144 offset by |xoff|@>;
10145 while ( start_x(dln)<=stop_x(dln) ) {
10146 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
10147 @<Insert a dash between |d| and |dln| for the overlap with the offset version
10150 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10152 mp_link(d)=mp_link(dln);
10153 mp_free_node(mp, dln,dash_node_size)
10155 @ The name of this module is a bit of a lie because we just find the
10156 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
10157 overlap possible. It could be that the unoffset version of dash |dln| falls
10158 in the gap between |dd| and its predecessor.
10160 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
10161 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
10165 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
10166 if ( dd==null_dash ) {
10168 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10171 @ At this point we already know that
10172 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10174 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10175 if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
10176 mp_link(d)=mp_get_node(mp, dash_node_size);
10179 if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
10180 start_x(d)=start_x(dln);
10182 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10183 if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
10184 stop_x(d)=stop_x(dln);
10186 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10189 @ The next major task is to update the bounding box information in an edge
10190 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10191 header's bounding box to accommodate the box computed by |path_bbox| or
10192 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10195 @c static void mp_adjust_bbox (MP mp,pointer h) {
10196 if ( mp_minx<minx_val(h) ) minx_val(h)=mp_minx;
10197 if ( mp_miny<miny_val(h) ) miny_val(h)=mp_miny;
10198 if ( mp_maxx>maxx_val(h) ) maxx_val(h)=mp_maxx;
10199 if ( mp_maxy>maxy_val(h) ) maxy_val(h)=mp_maxy;
10202 @ Here is a special routine for updating the bounding box information in
10203 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10204 that is to be stroked with the pen~|pp|.
10206 @c static void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10207 pointer q; /* a knot node adjacent to knot |p| */
10208 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10209 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10210 scaled z; /* a coordinate being tested against the bounding box */
10211 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10212 integer i; /* a loop counter */
10213 if ( mp_right_type(p)!=mp_endpoint ) {
10216 @<Make |(dx,dy)| the final direction for the path segment from
10217 |q| to~|p|; set~|d|@>;
10218 d=mp_pyth_add(mp, dx,dy);
10220 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10221 for (i=1;i<= 2;i++) {
10222 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10223 update the bounding box to accommodate it@>;
10227 if ( mp_right_type(p)==mp_endpoint ) {
10230 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10236 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10237 if ( q==mp_link(p) ) {
10238 dx=mp_x_coord(p)-mp_right_x(p);
10239 dy=mp_y_coord(p)-mp_right_y(p);
10240 if ( (dx==0)&&(dy==0) ) {
10241 dx=mp_x_coord(p)-mp_left_x(q);
10242 dy=mp_y_coord(p)-mp_left_y(q);
10245 dx=mp_x_coord(p)-mp_left_x(p);
10246 dy=mp_y_coord(p)-mp_left_y(p);
10247 if ( (dx==0)&&(dy==0) ) {
10248 dx=mp_x_coord(p)-mp_right_x(q);
10249 dy=mp_y_coord(p)-mp_right_y(q);
10252 dx=mp_x_coord(p)-mp_x_coord(q);
10253 dy=mp_y_coord(p)-mp_y_coord(q)
10255 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10256 dx=mp_make_fraction(mp, dx,d);
10257 dy=mp_make_fraction(mp, dy,d);
10258 mp_find_offset(mp, -dy,dx,pp);
10259 xx=mp->cur_x; yy=mp->cur_y
10261 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10262 mp_find_offset(mp, dx,dy,pp);
10263 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10264 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10265 mp_confusion(mp, "box_ends");
10266 @:this can't happen box ends}{\quad\\{box\_ends}@>
10267 z=mp_x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10268 if ( z<minx_val(h) ) minx_val(h)=z;
10269 if ( z>maxx_val(h) ) maxx_val(h)=z;
10270 z=mp_y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10271 if ( z<miny_val(h) ) miny_val(h)=z;
10272 if ( z>maxy_val(h) ) maxy_val(h)=z
10274 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10278 } while (mp_right_type(p)!=mp_endpoint)
10280 @ The major difficulty in finding the bounding box of an edge structure is the
10281 effect of clipping paths. We treat them conservatively by only clipping to the
10282 clipping path's bounding box, but this still
10283 requires recursive calls to |set_bbox| in order to find the bounding box of
10285 the objects to be clipped. Such calls are distinguished by the fact that the
10286 boolean parameter |top_level| is false.
10289 void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10290 pointer p; /* a graphical object being considered */
10291 scaled sminx,sminy,smaxx,smaxy;
10292 /* for saving the bounding box during recursive calls */
10293 scaled x0,x1,y0,y1; /* temporary registers */
10294 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10295 @<Wipe out any existing bounding box information if |bbtype(h)| is
10296 incompatible with |internal[mp_true_corners]|@>;
10297 while ( mp_link(bblast(h))!=null ) {
10298 p=mp_link(bblast(h));
10300 switch (mp_type(p)) {
10301 case mp_stop_clip_code:
10302 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10303 @:this can't happen bbox}{\quad bbox@>
10305 @<Other cases for updating the bounding box based on the type of object |p|@>;
10306 } /* all cases are enumerated above */
10308 if ( ! top_level ) mp_confusion(mp, "bbox");
10311 @ @<Declarations@>=
10312 static void mp_set_bbox (MP mp,pointer h, boolean top_level);
10314 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10315 switch (bbtype(h)) {
10319 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10322 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10324 } /* there are no other cases */
10326 @ @<Other cases for updating the bounding box...@>=
10328 mp_path_bbox(mp, mp_path_p(p));
10329 if ( mp_pen_p(p)!=null ) {
10330 x0=mp_minx; y0=mp_miny;
10331 x1=mp_maxx; y1=mp_maxy;
10332 mp_pen_bbox(mp, mp_pen_p(p));
10333 mp_minx=mp_minx+x0;
10334 mp_miny=mp_miny+y0;
10335 mp_maxx=mp_maxx+x1;
10336 mp_maxy=mp_maxy+y1;
10338 mp_adjust_bbox(mp, h);
10341 @ @<Other cases for updating the bounding box...@>=
10342 case mp_start_bounds_code:
10343 if ( mp->internal[mp_true_corners]>0 ) {
10344 bbtype(h)=bounds_unset;
10346 bbtype(h)=bounds_set;
10347 mp_path_bbox(mp, mp_path_p(p));
10348 mp_adjust_bbox(mp, h);
10349 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10353 case mp_stop_bounds_code:
10354 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10355 @:this can't happen bbox2}{\quad bbox2@>
10358 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10361 if ( mp_link(p)==null ) mp_confusion(mp, "bbox2");
10362 @:this can't happen bbox2}{\quad bbox2@>
10364 if ( mp_type(p)==mp_start_bounds_code ) incr(lev);
10365 else if ( mp_type(p)==mp_stop_bounds_code ) decr(lev);
10369 @ It saves a lot of grief here to be slightly conservative and not account for
10370 omitted parts of dashed lines. We also don't worry about the material omitted
10371 when using butt end caps. The basic computation is for round end caps and
10372 |box_ends| augments it for square end caps.
10374 @<Other cases for updating the bounding box...@>=
10375 case mp_stroked_code:
10376 mp_path_bbox(mp, mp_path_p(p));
10377 x0=mp_minx; y0=mp_miny;
10378 x1=mp_maxx; y1=mp_maxy;
10379 mp_pen_bbox(mp, mp_pen_p(p));
10380 mp_minx=mp_minx+x0;
10381 mp_miny=mp_miny+y0;
10382 mp_maxx=mp_maxx+x1;
10383 mp_maxy=mp_maxy+y1;
10384 mp_adjust_bbox(mp, h);
10385 if ( (mp_left_type(mp_path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10386 mp_box_ends(mp, mp_path_p(p), mp_pen_p(p), h);
10389 @ The height width and depth information stored in a text node determines a
10390 rectangle that needs to be transformed according to the transformation
10391 parameters stored in the text node.
10393 @<Other cases for updating the bounding box...@>=
10395 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10396 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10397 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10400 if ( y0<y1 ) { mp_minx=mp_minx+y0; mp_maxx=mp_maxx+y1; }
10401 else { mp_minx=mp_minx+y1; mp_maxx=mp_maxx+y0; }
10402 if ( x1<0 ) mp_minx=mp_minx+x1; else mp_maxx=mp_maxx+x1;
10403 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10404 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10405 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10408 if ( y0<y1 ) { mp_miny=mp_miny+y0; mp_maxy=mp_maxy+y1; }
10409 else { mp_miny=mp_miny+y1; mp_maxy=mp_maxy+y0; }
10410 if ( x1<0 ) mp_miny=mp_miny+x1; else mp_maxy=mp_maxy+x1;
10411 mp_adjust_bbox(mp, h);
10414 @ This case involves a recursive call that advances |bblast(h)| to the node of
10415 type |mp_stop_clip_code| that matches |p|.
10417 @<Other cases for updating the bounding box...@>=
10418 case mp_start_clip_code:
10419 mp_path_bbox(mp, mp_path_p(p));
10420 x0=mp_minx; y0=mp_miny;
10421 x1=mp_maxx; y1=mp_maxy;
10422 sminx=minx_val(h); sminy=miny_val(h);
10423 smaxx=maxx_val(h); smaxy=maxy_val(h);
10424 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10425 starting at |mp_link(p)|@>;
10426 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10428 mp_minx=sminx; mp_miny=sminy;
10429 mp_maxx=smaxx; mp_maxy=smaxy;
10430 mp_adjust_bbox(mp, h);
10433 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10434 minx_val(h)=el_gordo;
10435 miny_val(h)=el_gordo;
10436 maxx_val(h)=-el_gordo;
10437 maxy_val(h)=-el_gordo;
10438 mp_set_bbox(mp, h,false)
10440 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10441 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10442 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10443 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10444 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10446 @* \[22] Finding an envelope.
10447 When \MP\ has a path and a polygonal pen, it needs to express the desired
10448 shape in terms of things \ps\ can understand. The present task is to compute
10449 a new path that describes the region to be filled. It is convenient to
10450 define this as a two step process where the first step is determining what
10451 offset to use for each segment of the path.
10453 @ Given a pointer |c| to a cyclic path,
10454 and a pointer~|h| to the first knot of a pen polygon,
10455 the |offset_prep| routine changes the path into cubics that are
10456 associated with particular pen offsets. Thus if the cubic between |p|
10457 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10458 has offset |l| then |mp_info(q)=zero_off+l-k|. (The constant |zero_off| is added
10459 to because |l-k| could be negative.)
10461 After overwriting the type information with offset differences, we no longer
10462 have a true path so we refer to the knot list returned by |offset_prep| as an
10465 Since an envelope spec only determines relative changes in pen offsets,
10466 |offset_prep| sets a global variable |spec_offset| to the relative change from
10467 |h| to the first offset.
10469 @d zero_off 16384 /* added to offset changes to make them positive */
10472 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10475 static pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10476 halfword n; /* the number of vertices in the pen polygon */
10477 pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
10478 integer k_needed; /* amount to be added to |mp_info(p)| when it is computed */
10479 pointer w0; /* a pointer to pen offset to use just before |p| */
10480 scaled dxin,dyin; /* the direction into knot |p| */
10481 integer turn_amt; /* change in pen offsets for the current cubic */
10482 @<Other local variables for |offset_prep|@>;
10484 @<Initialize the pen size~|n|@>;
10485 @<Initialize the incoming direction and pen offset at |c|@>;
10486 p=c; c0=c; k_needed=0;
10489 @<Split the cubic between |p| and |q|, if necessary, into cubics
10490 associated with single offsets, after which |q| should
10491 point to the end of the final such cubic@>;
10493 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10494 might have been introduced by the splitting process@>;
10496 @<Fix the offset change in |mp_info(c)| and set |c| to the return value of
10501 @ We shall want to keep track of where certain knots on the cyclic path
10502 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10503 knot nodes because some nodes are deleted while removing dead cubics. Thus
10504 |offset_prep| updates the following pointers
10508 pointer spec_p2; /* pointers to distinguished knots */
10511 mp->spec_p1=null; mp->spec_p2=null;
10513 @ @<Initialize the pen size~|n|@>=
10520 @ Since the true incoming direction isn't known yet, we just pick a direction
10521 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10524 @<Initialize the incoming direction and pen offset at |c|@>=
10525 dxin=mp_x_coord(mp_link(h))-mp_x_coord(knil(h));
10526 dyin=mp_y_coord(mp_link(h))-mp_y_coord(knil(h));
10527 if ( (dxin==0)&&(dyin==0) ) {
10528 dxin=mp_y_coord(knil(h))-mp_y_coord(h);
10529 dyin=mp_x_coord(h)-mp_x_coord(knil(h));
10533 @ We must be careful not to remove the only cubic in a cycle.
10535 But we must also be careful for another reason. If the user-supplied
10536 path starts with a set of degenerate cubics, the target node |q| can
10537 be collapsed to the initial node |p| which might be the same as the
10538 initial node |c| of the curve. This would cause the |offset_prep| routine
10539 to bail out too early, causing distress later on. (See for example
10540 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10543 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10547 if ( mp_x_coord(p)==mp_right_x(p) && mp_y_coord(p)==mp_right_y(p) &&
10548 mp_x_coord(p)==mp_left_x(r) && mp_y_coord(p)==mp_left_y(r) &&
10549 mp_x_coord(p)==mp_x_coord(r) && mp_y_coord(p)==mp_y_coord(r) &&
10551 @<Remove the cubic following |p| and update the data structures
10552 to merge |r| into |p|@>;
10556 /* Check if we removed too much */
10557 if ((q!=q0)&&(q!=c||c==c0))
10560 @ @<Remove the cubic following |p| and update the data structures...@>=
10561 { k_needed=mp_info(p)-zero_off;
10565 mp_info(p)=k_needed+mp_info(r);
10568 if ( r==c ) { mp_info(p)=mp_info(c); c=p; };
10569 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10570 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10571 r=p; mp_remove_cubic(mp, p);
10574 @ Not setting the |info| field of the newly created knot allows the splitting
10575 routine to work for paths.
10578 static void mp_split_cubic (MP mp,pointer p, fraction t) ;
10581 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10582 scaled v; /* an intermediate value */
10583 pointer q,r; /* for list manipulation */
10584 q=mp_link(p); r=mp_get_node(mp, knot_node_size); mp_link(p)=r; mp_link(r)=q;
10585 mp_originator(r)=mp_program_code;
10586 mp_left_type(r)=mp_explicit; mp_right_type(r)=mp_explicit;
10587 v=t_of_the_way(mp_right_x(p),mp_left_x(q));
10588 mp_right_x(p)=t_of_the_way(mp_x_coord(p),mp_right_x(p));
10589 mp_left_x(q)=t_of_the_way(mp_left_x(q),mp_x_coord(q));
10590 mp_left_x(r)=t_of_the_way(mp_right_x(p),v);
10591 mp_right_x(r)=t_of_the_way(v,mp_left_x(q));
10592 mp_x_coord(r)=t_of_the_way(mp_left_x(r),mp_right_x(r));
10593 v=t_of_the_way(mp_right_y(p),mp_left_y(q));
10594 mp_right_y(p)=t_of_the_way(mp_y_coord(p),mp_right_y(p));
10595 mp_left_y(q)=t_of_the_way(mp_left_y(q),mp_y_coord(q));
10596 mp_left_y(r)=t_of_the_way(mp_right_y(p),v);
10597 mp_right_y(r)=t_of_the_way(v,mp_left_y(q));
10598 mp_y_coord(r)=t_of_the_way(mp_left_y(r),mp_right_y(r));
10601 @ This does not set |mp_info(p)| or |mp_right_type(p)|.
10604 static void mp_remove_cubic (MP mp,pointer p) ;
10607 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10608 pointer q; /* the node that disappears */
10609 q=mp_link(p); mp_link(p)=mp_link(q);
10610 mp_right_x(p)=mp_right_x(q); mp_right_y(p)=mp_right_y(q);
10611 mp_free_node(mp, q,knot_node_size);
10614 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10615 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10616 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10617 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10618 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10619 When listed by increasing $k$, these directions occur in counter-clockwise
10620 order so that $d_k\preceq d\k$ for all~$k$.
10621 The goal of |offset_prep| is to find an offset index~|k| to associate with
10622 each cubic, such that the direction $d(t)$ of the cubic satisfies
10623 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10624 We may have to split a cubic into many pieces before each
10625 piece corresponds to a unique offset.
10627 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10628 mp_info(p)=zero_off+k_needed;
10630 @<Prepare for derivative computations;
10631 |goto not_found| if the current cubic is dead@>;
10632 @<Find the initial direction |(dx,dy)|@>;
10633 @<Update |mp_info(p)| and find the offset $w_k$ such that
10634 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10635 the direction change at |p|@>;
10636 @<Find the final direction |(dxin,dyin)|@>;
10637 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10638 @<Complete the offset splitting process@>;
10639 w0=mp_pen_walk(mp, w0,turn_amt)
10641 @ @<Declarations@>=
10642 static pointer mp_pen_walk (MP mp,pointer w, integer k) ;
10645 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10646 /* walk |k| steps around a pen from |w| */
10647 while ( k>0 ) { w=mp_link(w); decr(k); };
10648 while ( k<0 ) { w=knil(w); incr(k); };
10652 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10653 calculated from the quadratic polynomials
10654 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10655 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10656 Since we may be calculating directions from several cubics
10657 split from the current one, it is desirable to do these calculations
10658 without losing too much precision. ``Scaled up'' values of the
10659 derivatives, which will be less tainted by accumulated errors than
10660 derivatives found from the cubics themselves, are maintained in
10661 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10662 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10663 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)$.
10665 @<Other local variables for |offset_prep|@>=
10666 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10667 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10668 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10669 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10670 integer max_coef; /* used while scaling */
10671 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10672 fraction t; /* where the derivative passes through zero */
10673 fraction s; /* a temporary value */
10675 @ @<Prepare for derivative computations...@>=
10676 x0=mp_right_x(p)-mp_x_coord(p);
10677 x2=mp_x_coord(q)-mp_left_x(q);
10678 x1=mp_left_x(q)-mp_right_x(p);
10679 y0=mp_right_y(p)-mp_y_coord(p); y2=mp_y_coord(q)-mp_left_y(q);
10680 y1=mp_left_y(q)-mp_right_y(p);
10682 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10683 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10684 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10685 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10686 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10687 if ( max_coef==0 ) goto NOT_FOUND;
10688 while ( max_coef<fraction_half ) {
10690 double(x0); double(x1); double(x2);
10691 double(y0); double(y1); double(y2);
10694 @ Let us first solve a special case of the problem: Suppose we
10695 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10696 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10697 $d(0)\succ d_{k-1}$.
10698 Then, in a sense, we're halfway done, since one of the two relations
10699 in $(*)$ is satisfied, and the other couldn't be satisfied for
10700 any other value of~|k|.
10702 Actually, the conditions can be relaxed somewhat since a relation such as
10703 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10704 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10705 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10706 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10707 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10708 counterclockwise direction.
10710 The |fin_offset_prep| subroutine solves the stated subproblem.
10711 It has a parameter called |rise| that is |1| in
10712 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10713 the derivative of the cubic following |p|.
10714 The |w| parameter should point to offset~$w_k$ and |mp_info(p)| should already
10715 be set properly. The |turn_amt| parameter gives the absolute value of the
10716 overall net change in pen offsets.
10719 static void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10720 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10721 integer rise, integer turn_amt) ;
10724 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10725 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10726 integer rise, integer turn_amt) {
10727 pointer ww; /* for list manipulation */
10728 scaled du,dv; /* for slope calculation */
10729 integer t0,t1,t2; /* test coefficients */
10730 fraction t; /* place where the derivative passes a critical slope */
10731 fraction s; /* slope or reciprocal slope */
10732 integer v; /* intermediate value for updating |x0..y2| */
10733 pointer q; /* original |mp_link(p)| */
10736 if ( rise>0 ) ww=mp_link(w); /* a pointer to $w\k$ */
10737 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10738 @<Compute test coefficients |(t0,t1,t2)|
10739 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10740 t=mp_crossing_point(mp, t0,t1,t2);
10741 if ( t>=fraction_one ) {
10742 if ( turn_amt>0 ) t=fraction_one; else return;
10744 @<Split the cubic at $t$,
10745 and split off another cubic if the derivative crosses back@>;
10750 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10751 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10752 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10755 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10756 du=mp_x_coord(ww)-mp_x_coord(w); dv=mp_y_coord(ww)-mp_y_coord(w);
10757 if ( abs(du)>=abs(dv) ) {
10758 s=mp_make_fraction(mp, dv,du);
10759 t0=mp_take_fraction(mp, x0,s)-y0;
10760 t1=mp_take_fraction(mp, x1,s)-y1;
10761 t2=mp_take_fraction(mp, x2,s)-y2;
10762 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10764 s=mp_make_fraction(mp, du,dv);
10765 t0=x0-mp_take_fraction(mp, y0,s);
10766 t1=x1-mp_take_fraction(mp, y1,s);
10767 t2=x2-mp_take_fraction(mp, y2,s);
10768 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10770 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10772 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10773 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
10774 respectively, yielding another solution of $(*)$.
10776 @<Split the cubic at $t$, and split off another...@>=
10778 mp_split_cubic(mp, p,t); p=mp_link(p); mp_info(p)=zero_off+rise;
10780 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10781 x0=t_of_the_way(v,x1);
10782 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10783 y0=t_of_the_way(v,y1);
10784 if ( turn_amt<0 ) {
10785 t1=t_of_the_way(t1,t2);
10786 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10787 t=mp_crossing_point(mp, 0,-t1,-t2);
10788 if ( t>fraction_one ) t=fraction_one;
10790 if ( (t==fraction_one)&&(mp_link(p)!=q) ) {
10791 mp_info(mp_link(p))=mp_info(mp_link(p))-rise;
10793 mp_split_cubic(mp, p,t); mp_info(mp_link(p))=zero_off-rise;
10794 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10795 x2=t_of_the_way(x1,v);
10796 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10797 y2=t_of_the_way(y1,v);
10802 @ Now we must consider the general problem of |offset_prep|, when
10803 nothing is known about a given cubic. We start by finding its
10804 direction in the vicinity of |t=0|.
10806 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10807 has not yet introduced any more numerical errors. Thus we can compute
10808 the true initial direction for the given cubic, even if it is almost
10811 @<Find the initial direction |(dx,dy)|@>=
10813 if ( dx==0 && dy==0 ) {
10815 if ( dx==0 && dy==0 ) {
10819 if ( p==c ) { dx0=dx; dy0=dy; }
10821 @ @<Find the final direction |(dxin,dyin)|@>=
10823 if ( dxin==0 && dyin==0 ) {
10825 if ( dxin==0 && dyin==0 ) {
10830 @ The next step is to bracket the initial direction between consecutive
10831 edges of the pen polygon. We must be careful to turn clockwise only if
10832 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10833 counter-clockwise in order to make \&{doublepath} envelopes come out
10834 @:double_path_}{\&{doublepath} primitive@>
10835 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10837 @<Update |mp_info(p)| and find the offset $w_k$ such that...@>=
10838 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10839 w=mp_pen_walk(mp, w0, turn_amt);
10841 mp_info(p)=mp_info(p)+turn_amt
10843 @ Decide how many pen offsets to go away from |w| in order to find the offset
10844 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10845 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10846 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10848 If the pen polygon has only two edges, they could both be parallel
10849 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10850 such edge in order to avoid an infinite loop.
10853 static integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10854 scaled dy, boolean ccw);
10857 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10858 scaled dy, boolean ccw) {
10859 pointer ww; /* a neighbor of knot~|w| */
10860 integer s; /* turn amount so far */
10861 integer t; /* |ab_vs_cd| result */
10866 t=mp_ab_vs_cd(mp, dy,(mp_x_coord(ww)-mp_x_coord(w)),
10867 dx,(mp_y_coord(ww)-mp_y_coord(w)));
10870 w=ww; ww=mp_link(ww);
10874 while ( mp_ab_vs_cd(mp, dy,(mp_x_coord(w)-mp_x_coord(ww)),
10875 dx,(mp_y_coord(w)-mp_y_coord(ww))) < 0) {
10883 @ When we're all done, the final offset is |w0| and the final curve direction
10884 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10885 can correct |mp_info(c)| which was erroneously based on an incoming offset
10888 @d fix_by(A) mp_info(c)=mp_info(c)+(A)
10890 @<Fix the offset change in |mp_info(c)| and set |c| to the return value of...@>=
10891 mp->spec_offset=mp_info(c)-zero_off;
10892 if ( mp_link(c)==c ) {
10893 mp_info(c)=zero_off+n;
10896 while ( w0!=h ) { fix_by(1); w0=mp_link(w0); };
10897 while ( mp_info(c)<=zero_off-n ) fix_by(n);
10898 while ( mp_info(c)>zero_off ) fix_by(-n);
10899 if ( (mp_info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10902 @ Finally we want to reduce the general problem to situations that
10903 |fin_offset_prep| can handle. We split the cubic into at most three parts
10904 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10906 @<Complete the offset splitting process@>=
10908 @<Compute test coeff...@>;
10909 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10910 |t:=fraction_one+1|@>;
10911 if ( t>fraction_one ) {
10912 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10914 mp_split_cubic(mp, p,t); r=mp_link(p);
10915 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10916 x2a=t_of_the_way(x1a,x1);
10917 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10918 y2a=t_of_the_way(y1a,y1);
10919 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10920 mp_info(r)=zero_off-1;
10921 if ( turn_amt>=0 ) {
10922 t1=t_of_the_way(t1,t2);
10924 t=mp_crossing_point(mp, 0,-t1,-t2);
10925 if ( t>fraction_one ) t=fraction_one;
10926 @<Split off another rising cubic for |fin_offset_prep|@>;
10927 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10929 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10933 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10934 mp_split_cubic(mp, r,t); mp_info(mp_link(r))=zero_off+1;
10935 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10936 x0a=t_of_the_way(x1,x1a);
10937 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10938 y0a=t_of_the_way(y1,y1a);
10939 mp_fin_offset_prep(mp, mp_link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10942 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10943 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10944 need to decide whether the directions are parallel or antiparallel. We
10945 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10946 should be avoided when the value of |turn_amt| already determines the
10947 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10948 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10949 crossing and the first crossing cannot be antiparallel.
10951 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10952 t=mp_crossing_point(mp, t0,t1,t2);
10953 if ( turn_amt>=0 ) {
10957 u0=t_of_the_way(x0,x1);
10958 u1=t_of_the_way(x1,x2);
10959 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10960 v0=t_of_the_way(y0,y1);
10961 v1=t_of_the_way(y1,y2);
10962 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10963 if ( ss<0 ) t=fraction_one+1;
10965 } else if ( t>fraction_one ) {
10969 @ @<Other local variables for |offset_prep|@>=
10970 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10971 integer ss = 0; /* the part of the dot product computed so far */
10972 int d_sign; /* sign of overall change in direction for this cubic */
10974 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10975 problem to decide which way it loops around but that's OK as long we're
10976 consistent. To make \&{doublepath} envelopes work properly, reversing
10977 the path should always change the sign of |turn_amt|.
10979 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10980 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10982 @<Check rotation direction based on node position@>
10986 if ( dy>0 ) d_sign=1; else d_sign=-1;
10988 if ( dx>0 ) d_sign=1; else d_sign=-1;
10991 @<Make |ss| negative if and only if the total change in direction is
10992 more than $180^\circ$@>;
10993 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10994 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
10996 @ We check rotation direction by looking at the vector connecting the current
10997 node with the next. If its angle with incoming and outgoing tangents has the
10998 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
10999 Otherwise we proceed to the cusp code.
11001 @<Check rotation direction based on node position@>=
11002 u0=mp_x_coord(q)-mp_x_coord(p);
11003 u1=mp_y_coord(q)-mp_y_coord(p);
11004 d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
11005 mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
11007 @ In order to be invariant under path reversal, the result of this computation
11008 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
11009 then swapped with |(x2,y2)|. We make use of the identities
11010 |take_fraction(-a,-b)=take_fraction(a,b)| and
11011 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
11013 @<Make |ss| negative if and only if the total change in direction is...@>=
11014 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
11015 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
11016 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
11018 t=mp_crossing_point(mp, t0,t1,-t0);
11019 u0=t_of_the_way(x0,x1);
11020 u1=t_of_the_way(x1,x2);
11021 v0=t_of_the_way(y0,y1);
11022 v1=t_of_the_way(y1,y2);
11024 t=mp_crossing_point(mp, -t0,t1,t0);
11025 u0=t_of_the_way(x2,x1);
11026 u1=t_of_the_way(x1,x0);
11027 v0=t_of_the_way(y2,y1);
11028 v1=t_of_the_way(y1,y0);
11030 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
11031 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
11033 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
11034 that the |cur_pen| has not been walked around to the first offset.
11037 static void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
11038 pointer p,q; /* list traversal */
11039 pointer w; /* the current pen offset */
11040 mp_print_diagnostic(mp, "Envelope spec",s,true);
11041 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
11043 mp_print_two(mp, mp_x_coord(cur_spec),mp_y_coord(cur_spec));
11044 mp_print(mp, " % beginning with offset ");
11045 mp_print_two(mp, mp_x_coord(w),mp_y_coord(w));
11049 @<Print the cubic between |p| and |q|@>;
11051 if ((p==cur_spec) || (mp_info(p)!=zero_off))
11054 if ( mp_info(p)!=zero_off ) {
11055 @<Update |w| as indicated by |mp_info(p)| and print an explanation@>;
11057 } while (p!=cur_spec);
11058 mp_print_nl(mp, " & cycle");
11059 mp_end_diagnostic(mp, true);
11062 @ @<Update |w| as indicated by |mp_info(p)| and print an explanation@>=
11064 w=mp_pen_walk(mp, w, (mp_info(p)-zero_off));
11065 mp_print(mp, " % ");
11066 if ( mp_info(p)>zero_off ) mp_print(mp, "counter");
11067 mp_print(mp, "clockwise to offset ");
11068 mp_print_two(mp, mp_x_coord(w),mp_y_coord(w));
11071 @ @<Print the cubic between |p| and |q|@>=
11073 mp_print_nl(mp, " ..controls ");
11074 mp_print_two(mp, mp_right_x(p),mp_right_y(p));
11075 mp_print(mp, " and ");
11076 mp_print_two(mp, mp_left_x(q),mp_left_y(q));
11077 mp_print_nl(mp, " ..");
11078 mp_print_two(mp, mp_x_coord(q),mp_y_coord(q));
11081 @ Once we have an envelope spec, the remaining task to construct the actual
11082 envelope by offsetting each cubic as determined by the |info| fields in
11083 the knots. First we use |offset_prep| to convert the |c| into an envelope
11084 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
11087 The |ljoin| and |miterlim| parameters control the treatment of points where the
11088 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
11089 The endpoints are easily located because |c| is given in undoubled form
11090 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
11091 track of the endpoints and treat them like very sharp corners.
11092 Butt end caps are treated like beveled joins; round end caps are treated like
11093 round joins; and square end caps are achieved by setting |join_type:=3|.
11095 None of these parameters apply to inside joins where the convolution tracing
11096 has retrograde lines. In such cases we use a simple connect-the-endpoints
11097 approach that is achieved by setting |join_type:=2|.
11100 static pointer mp_make_envelope (MP mp,pointer c, pointer h, quarterword ljoin,
11101 quarterword lcap, scaled miterlim) {
11102 pointer p,q,r,q0; /* for manipulating the path */
11103 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
11104 pointer w,w0; /* the pen knot for the current offset */
11105 scaled qx,qy; /* unshifted coordinates of |q| */
11106 halfword k,k0; /* controls pen edge insertion */
11107 @<Other local variables for |make_envelope|@>;
11108 dxin=0; dyin=0; dxout=0; dyout=0;
11109 mp->spec_p1=null; mp->spec_p2=null;
11110 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
11111 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
11112 the initial offset@>;
11116 q=mp_link(p); q0=q;
11117 qx=mp_x_coord(q); qy=mp_y_coord(q);
11120 if ( k!=zero_off ) {
11121 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
11123 @<Add offset |w| to the cubic from |p| to |q|@>;
11124 while ( k!=zero_off ) {
11125 @<Step |w| and move |k| one step closer to |zero_off|@>;
11126 if ( (join_type==1)||(k==zero_off) )
11127 q=mp_insert_knot(mp, q,qx+mp_x_coord(w),qy+mp_y_coord(w));
11129 if ( q!=mp_link(p) ) {
11130 @<Set |p=mp_link(p)| and add knots between |p| and |q| as
11131 required by |join_type|@>;
11138 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
11139 c=mp_offset_prep(mp, c,h);
11140 if ( mp->internal[mp_tracing_specs]>0 )
11141 mp_print_spec(mp, c,h,"");
11142 h=mp_pen_walk(mp, h,mp->spec_offset)
11144 @ Mitered and squared-off joins depend on path directions that are difficult to
11145 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
11146 have degenerate cubics only if the entire cycle collapses to a single
11147 degenerate cubic. Setting |join_type:=2| in this case makes the computed
11148 envelope degenerate as well.
11150 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
11151 if ( k<zero_off ) {
11154 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
11155 else if ( lcap==2 ) join_type=3;
11156 else join_type=2-lcap;
11157 if ( (join_type==0)||(join_type==3) ) {
11158 @<Set the incoming and outgoing directions at |q|; in case of
11159 degeneracy set |join_type:=2|@>;
11160 if ( join_type==0 ) {
11161 @<If |miterlim| is less than the secant of half the angle at |q|
11162 then set |join_type:=2|@>;
11167 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
11169 tmp=mp_take_fraction(mp, miterlim,fraction_half+
11170 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
11172 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
11175 @ @<Other local variables for |make_envelope|@>=
11176 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
11177 scaled tmp; /* a temporary value */
11179 @ The coordinates of |p| have already been shifted unless |p| is the first
11180 knot in which case they get shifted at the very end.
11182 @<Add offset |w| to the cubic from |p| to |q|@>=
11183 mp_right_x(p)=mp_right_x(p)+mp_x_coord(w);
11184 mp_right_y(p)=mp_right_y(p)+mp_y_coord(w);
11185 mp_left_x(q)=mp_left_x(q)+mp_x_coord(w);
11186 mp_left_y(q)=mp_left_y(q)+mp_y_coord(w);
11187 mp_x_coord(q)=mp_x_coord(q)+mp_x_coord(w);
11188 mp_y_coord(q)=mp_y_coord(q)+mp_y_coord(w);
11189 mp_left_type(q)=mp_explicit;
11190 mp_right_type(q)=mp_explicit
11192 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
11193 if ( k>zero_off ){ w=mp_link(w); decr(k); }
11194 else { w=knil(w); incr(k); }
11196 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
11197 the |mp_right_x| and |mp_right_y| fields of |r| are set from |q|. This is done in
11198 case the cubic containing these control points is ``yet to be examined.''
11201 static pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y);
11204 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
11205 /* returns the inserted knot */
11206 pointer r; /* the new knot */
11207 r=mp_get_node(mp, knot_node_size);
11208 mp_link(r)=mp_link(q); mp_link(q)=r;
11209 mp_right_x(r)=mp_right_x(q);
11210 mp_right_y(r)=mp_right_y(q);
11213 mp_right_x(q)=mp_x_coord(q);
11214 mp_right_y(q)=mp_y_coord(q);
11215 mp_left_x(r)=mp_x_coord(r);
11216 mp_left_y(r)=mp_y_coord(r);
11217 mp_left_type(r)=mp_explicit;
11218 mp_right_type(r)=mp_explicit;
11219 mp_originator(r)=mp_program_code;
11223 @ After setting |p:=mp_link(p)|, either |join_type=1| or |q=mp_link(p)|.
11225 @<Set |p=mp_link(p)| and add knots between |p| and |q| as...@>=
11228 if ( (join_type==0)||(join_type==3) ) {
11229 if ( join_type==0 ) {
11230 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11232 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11236 mp_right_x(r)=mp_x_coord(r);
11237 mp_right_y(r)=mp_y_coord(r);
11242 @ For very small angles, adding a knot is unnecessary and would cause numerical
11243 problems, so we just set |r:=null| in that case.
11245 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11247 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11248 if ( abs(det)<26844 ) {
11249 r=null; /* sine $<10^{-4}$ */
11251 tmp=mp_take_fraction(mp, mp_x_coord(q)-mp_x_coord(p),dyout)-
11252 mp_take_fraction(mp, mp_y_coord(q)-mp_y_coord(p),dxout);
11253 tmp=mp_make_fraction(mp, tmp,det);
11254 r=mp_insert_knot(mp, p,mp_x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11255 mp_y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11259 @ @<Other local variables for |make_envelope|@>=
11260 fraction det; /* a determinant used for mitered join calculations */
11262 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11264 ht_x=mp_y_coord(w)-mp_y_coord(w0);
11265 ht_y=mp_x_coord(w0)-mp_x_coord(w);
11266 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11267 ht_x+=ht_x; ht_y+=ht_y;
11269 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11270 product with |(ht_x,ht_y)|@>;
11271 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11272 mp_take_fraction(mp, dyin,ht_y));
11273 r=mp_insert_knot(mp, p,mp_x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11274 mp_y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11275 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11276 mp_take_fraction(mp, dyout,ht_y));
11277 r=mp_insert_knot(mp, r,mp_x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11278 mp_y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11281 @ @<Other local variables for |make_envelope|@>=
11282 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11283 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11284 halfword kk; /* keeps track of the pen vertices being scanned */
11285 pointer ww; /* the pen vertex being tested */
11287 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11288 from zero to |max_ht|.
11290 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11295 @<Step |ww| and move |kk| one step closer to |k0|@>;
11296 if ( kk==k0 ) break;
11297 tmp=mp_take_fraction(mp, (mp_x_coord(ww)-mp_x_coord(w0)),ht_x)+
11298 mp_take_fraction(mp, (mp_y_coord(ww)-mp_y_coord(w0)),ht_y);
11299 if ( tmp>max_ht ) max_ht=tmp;
11303 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11304 if ( kk>k0 ) { ww=mp_link(ww); decr(kk); }
11305 else { ww=knil(ww); incr(kk); }
11307 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11308 if ( mp_left_type(c)==mp_endpoint ) {
11309 mp->spec_p1=mp_htap_ypoc(mp, c);
11310 mp->spec_p2=mp->path_tail;
11311 mp_originator(mp->spec_p1)=mp_program_code;
11312 mp_link(mp->spec_p2)=mp_link(mp->spec_p1);
11313 mp_link(mp->spec_p1)=c;
11314 mp_remove_cubic(mp, mp->spec_p1);
11316 if ( c!=mp_link(c) ) {
11317 mp_originator(mp->spec_p2)=mp_program_code;
11318 mp_remove_cubic(mp, mp->spec_p2);
11320 @<Make |c| look like a cycle of length one@>;
11324 @ @<Make |c| look like a cycle of length one@>=
11326 mp_left_type(c)=mp_explicit; mp_right_type(c)=mp_explicit;
11327 mp_left_x(c)=mp_x_coord(c); mp_left_y(c)=mp_y_coord(c);
11328 mp_right_x(c)=mp_x_coord(c); mp_right_y(c)=mp_y_coord(c);
11331 @ In degenerate situations we might have to look at the knot preceding~|q|.
11332 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11334 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11335 dxin=mp_x_coord(q)-mp_left_x(q);
11336 dyin=mp_y_coord(q)-mp_left_y(q);
11337 if ( (dxin==0)&&(dyin==0) ) {
11338 dxin=mp_x_coord(q)-mp_right_x(p);
11339 dyin=mp_y_coord(q)-mp_right_y(p);
11340 if ( (dxin==0)&&(dyin==0) ) {
11341 dxin=mp_x_coord(q)-mp_x_coord(p);
11342 dyin=mp_y_coord(q)-mp_y_coord(p);
11343 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11344 dxin=dxin+mp_x_coord(w);
11345 dyin=dyin+mp_y_coord(w);
11349 tmp=mp_pyth_add(mp, dxin,dyin);
11353 dxin=mp_make_fraction(mp, dxin,tmp);
11354 dyin=mp_make_fraction(mp, dyin,tmp);
11355 @<Set the outgoing direction at |q|@>;
11358 @ If |q=c| then the coordinates of |r| and the control points between |q|
11359 and~|r| have already been offset by |h|.
11361 @<Set the outgoing direction at |q|@>=
11362 dxout=mp_right_x(q)-mp_x_coord(q);
11363 dyout=mp_right_y(q)-mp_y_coord(q);
11364 if ( (dxout==0)&&(dyout==0) ) {
11366 dxout=mp_left_x(r)-mp_x_coord(q);
11367 dyout=mp_left_y(r)-mp_y_coord(q);
11368 if ( (dxout==0)&&(dyout==0) ) {
11369 dxout=mp_x_coord(r)-mp_x_coord(q);
11370 dyout=mp_y_coord(r)-mp_y_coord(q);
11374 dxout=dxout-mp_x_coord(h);
11375 dyout=dyout-mp_y_coord(h);
11377 tmp=mp_pyth_add(mp, dxout,dyout);
11378 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11379 @:this can't happen degerate spec}{\quad degenerate spec@>
11380 dxout=mp_make_fraction(mp, dxout,tmp);
11381 dyout=mp_make_fraction(mp, dyout,tmp)
11383 @* \[23] Direction and intersection times.
11384 A path of length $n$ is defined parametrically by functions $x(t)$ and
11385 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11386 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11387 we shall consider operations that determine special times associated with
11388 given paths: the first time that a path travels in a given direction, and
11389 a pair of times at which two paths cross each other.
11391 @ Let's start with the easier task. The function |find_direction_time| is
11392 given a direction |(x,y)| and a path starting at~|h|. If the path never
11393 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11394 it will be nonnegative.
11396 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11397 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11398 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11399 assumed to match any given direction at time~|t|.
11401 The routine solves this problem in nondegenerate cases by rotating the path
11402 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11403 to find when a given path first travels ``due east.''
11406 static scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11407 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11408 pointer p,q; /* for list traversal */
11409 scaled n; /* the direction time at knot |p| */
11410 scaled tt; /* the direction time within a cubic */
11411 @<Other local variables for |find_direction_time|@>;
11412 @<Normalize the given direction for better accuracy;
11413 but |return| with zero result if it's zero@>;
11416 if ( mp_right_type(p)==mp_endpoint ) break;
11418 @<Rotate the cubic between |p| and |q|; then
11419 |goto found| if the rotated cubic travels due east at some time |tt|;
11420 but |break| if an entire cyclic path has been traversed@>;
11428 @ @<Normalize the given direction for better accuracy...@>=
11429 if ( abs(x)<abs(y) ) {
11430 x=mp_make_fraction(mp, x,abs(y));
11431 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11432 } else if ( x==0 ) {
11435 y=mp_make_fraction(mp, y,abs(x));
11436 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11439 @ Since we're interested in the tangent directions, we work with the
11440 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
11441 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11442 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11443 in order to achieve better accuracy.
11445 The given path may turn abruptly at a knot, and it might pass the critical
11446 tangent direction at such a time. Therefore we remember the direction |phi|
11447 in which the previous rotated cubic was traveling. (The value of |phi| will be
11448 undefined on the first cubic, i.e., when |n=0|.)
11450 @<Rotate the cubic between |p| and |q|; then...@>=
11452 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11453 points of the rotated derivatives@>;
11454 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11456 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11459 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11460 @<Exit to |found| if the curve whose derivatives are specified by
11461 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11463 @ @<Other local variables for |find_direction_time|@>=
11464 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11465 angle theta,phi; /* angles of exit and entry at a knot */
11466 fraction t; /* temp storage */
11468 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11469 x1=mp_right_x(p)-mp_x_coord(p); x2=mp_left_x(q)-mp_right_x(p);
11470 x3=mp_x_coord(q)-mp_left_x(q);
11471 y1=mp_right_y(p)-mp_y_coord(p); y2=mp_left_y(q)-mp_right_y(p);
11472 y3=mp_y_coord(q)-mp_left_y(q);
11474 if ( abs(x2)>max ) max=abs(x2);
11475 if ( abs(x3)>max ) max=abs(x3);
11476 if ( abs(y1)>max ) max=abs(y1);
11477 if ( abs(y2)>max ) max=abs(y2);
11478 if ( abs(y3)>max ) max=abs(y3);
11479 if ( max==0 ) goto FOUND;
11480 while ( max<fraction_half ){
11481 max+=max; x1+=x1; x2+=x2; x3+=x3;
11482 y1+=y1; y2+=y2; y3+=y3;
11484 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11485 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11486 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11487 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11488 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11489 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11491 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11492 theta=mp_n_arg(mp, x1,y1);
11493 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11494 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11496 @ In this step we want to use the |crossing_point| routine to find the
11497 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11498 Several complications arise: If the quadratic equation has a double root,
11499 the curve never crosses zero, and |crossing_point| will find nothing;
11500 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11501 equation has simple roots, or only one root, we may have to negate it
11502 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11503 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11506 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11507 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11508 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11509 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11510 either |goto found| or |goto done|@>;
11513 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11514 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11516 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11517 $B(x_1,x_2,x_3;t)\ge0$@>;
11520 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11521 two roots, because we know that it isn't identically zero.
11523 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11524 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11525 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11526 subject to rounding errors. Yet this code optimistically tries to
11527 do the right thing.
11529 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11531 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11532 t=mp_crossing_point(mp, y1,y2,y3);
11533 if ( t>fraction_one ) goto DONE;
11534 y2=t_of_the_way(y2,y3);
11535 x1=t_of_the_way(x1,x2);
11536 x2=t_of_the_way(x2,x3);
11537 x1=t_of_the_way(x1,x2);
11538 if ( x1>=0 ) we_found_it;
11540 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11541 if ( t>fraction_one ) goto DONE;
11542 x1=t_of_the_way(x1,x2);
11543 x2=t_of_the_way(x2,x3);
11544 if ( t_of_the_way(x1,x2)>=0 ) {
11545 t=t_of_the_way(tt,fraction_one); we_found_it;
11548 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11549 either |goto found| or |goto done|@>=
11551 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11552 t=mp_make_fraction(mp, y1,y1-y2);
11553 x1=t_of_the_way(x1,x2);
11554 x2=t_of_the_way(x2,x3);
11555 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11556 } else if ( y3==0 ) {
11558 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11559 } else if ( x3>=0 ) {
11560 tt=unity; goto FOUND;
11566 @ At this point we know that the derivative of |y(t)| is identically zero,
11567 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11570 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11572 t=mp_crossing_point(mp, -x1,-x2,-x3);
11573 if ( t<=fraction_one ) we_found_it;
11574 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11575 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11579 @ The intersection of two cubics can be found by an interesting variant
11580 of the general bisection scheme described in the introduction to
11582 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)$,
11583 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11584 if an intersection exists. First we find the smallest rectangle that
11585 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11586 the smallest rectangle that encloses
11587 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11588 But if the rectangles do overlap, we bisect the intervals, getting
11589 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11590 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11591 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11592 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11593 levels of bisection we will have determined the intersection times $t_1$
11594 and~$t_2$ to $l$~bits of accuracy.
11596 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11597 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11598 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11599 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11600 to determine when the enclosing rectangles overlap. Here's why:
11601 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11602 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11603 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11604 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11605 overlap if and only if $u\submin\L x\submax$ and
11606 $x\submin\L u\submax$. Letting
11607 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11608 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11609 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11611 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11612 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11613 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11614 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11615 because of the overlap condition; i.e., we know that $X\submin$,
11616 $X\submax$, and their relatives are bounded, hence $X\submax-
11617 U\submin$ and $X\submin-U\submax$ are bounded.
11619 @ Incidentally, if the given cubics intersect more than once, the process
11620 just sketched will not necessarily find the lexicographically smallest pair
11621 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11622 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11623 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11624 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11625 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11626 Shuffled order agrees with lexicographic order if all pairs of solutions
11627 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11628 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11629 and the bisection algorithm would be substantially less efficient if it were
11630 constrained by lexicographic order.
11632 For example, suppose that an overlap has been found for $l=3$ and
11633 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11634 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11635 Then there is probably an intersection in one of the subintervals
11636 $(.1011,.011x)$; but lexicographic order would require us to explore
11637 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11638 want to store all of the subdivision data for the second path, so the
11639 subdivisions would have to be regenerated many times. Such inefficiencies
11640 would be associated with every `1' in the binary representation of~$t_1$.
11642 @ The subdivision process introduces rounding errors, hence we need to
11643 make a more liberal test for overlap. It is not hard to show that the
11644 computed values of $U_i$ differ from the truth by at most~$l$, on
11645 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11646 If $\beta$ is an upper bound on the absolute error in the computed
11647 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11648 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11649 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11651 More accuracy is obtained if we try the algorithm first with |tol=0|;
11652 the more liberal tolerance is used only if an exact approach fails.
11653 It is convenient to do this double-take by letting `3' in the preceding
11654 paragraph be a parameter, which is first 0, then 3.
11657 unsigned int tol_step; /* either 0 or 3, usually */
11659 @ We shall use an explicit stack to implement the recursive bisection
11660 method described above. The |bisect_stack| array will contain numerous 5-word
11661 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11662 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11664 The following macros define the allocation of stack positions to
11665 the quantities needed for bisection-intersection.
11667 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11668 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11669 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11670 @d stack_min(A) mp->bisect_stack[(A)+3]
11671 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11672 @d stack_max(A) mp->bisect_stack[(A)+4]
11673 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11674 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11676 @d u_packet(A) ((A)-5)
11677 @d v_packet(A) ((A)-10)
11678 @d x_packet(A) ((A)-15)
11679 @d y_packet(A) ((A)-20)
11680 @d l_packets (mp->bisect_ptr-int_packets)
11681 @d r_packets mp->bisect_ptr
11682 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11683 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11684 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11685 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11686 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11687 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11688 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11689 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11691 @d u1l stack_1(ul_packet) /* $U'_1$ */
11692 @d u2l stack_2(ul_packet) /* $U'_2$ */
11693 @d u3l stack_3(ul_packet) /* $U'_3$ */
11694 @d v1l stack_1(vl_packet) /* $V'_1$ */
11695 @d v2l stack_2(vl_packet) /* $V'_2$ */
11696 @d v3l stack_3(vl_packet) /* $V'_3$ */
11697 @d x1l stack_1(xl_packet) /* $X'_1$ */
11698 @d x2l stack_2(xl_packet) /* $X'_2$ */
11699 @d x3l stack_3(xl_packet) /* $X'_3$ */
11700 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11701 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11702 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11703 @d u1r stack_1(ur_packet) /* $U''_1$ */
11704 @d u2r stack_2(ur_packet) /* $U''_2$ */
11705 @d u3r stack_3(ur_packet) /* $U''_3$ */
11706 @d v1r stack_1(vr_packet) /* $V''_1$ */
11707 @d v2r stack_2(vr_packet) /* $V''_2$ */
11708 @d v3r stack_3(vr_packet) /* $V''_3$ */
11709 @d x1r stack_1(xr_packet) /* $X''_1$ */
11710 @d x2r stack_2(xr_packet) /* $X''_2$ */
11711 @d x3r stack_3(xr_packet) /* $X''_3$ */
11712 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11713 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11714 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11716 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11717 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11718 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11719 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11720 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11721 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11724 integer *bisect_stack;
11725 integer bisect_ptr;
11727 @ @<Allocate or initialize ...@>=
11728 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11730 @ @<Dealloc variables@>=
11731 xfree(mp->bisect_stack);
11733 @ @<Check the ``constant''...@>=
11734 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11736 @ Computation of the min and max is a tedious but fairly fast sequence of
11737 instructions; exactly four comparisons are made in each branch.
11740 if ( stack_1((A))<0 ) {
11741 if ( stack_3((A))>=0 ) {
11742 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11743 else stack_min((A))=stack_1((A));
11744 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11745 if ( stack_max((A))<0 ) stack_max((A))=0;
11747 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11748 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11749 stack_max((A))=stack_1((A))+stack_2((A));
11750 if ( stack_max((A))<0 ) stack_max((A))=0;
11752 } else if ( stack_3((A))<=0 ) {
11753 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11754 else stack_max((A))=stack_1((A));
11755 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11756 if ( stack_min((A))>0 ) stack_min((A))=0;
11758 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11759 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11760 stack_min((A))=stack_1((A))+stack_2((A));
11761 if ( stack_min((A))>0 ) stack_min((A))=0;
11764 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11765 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11766 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11767 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11768 plus the |scaled| values of $t_1$ and~$t_2$.
11770 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11771 finds no intersection. The routine gives up and gives an approximate answer
11772 if it has backtracked
11773 more than 5000 times (otherwise there are cases where several minutes
11774 of fruitless computation would be possible).
11776 @d max_patience 5000
11779 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11780 integer time_to_go; /* this many backtracks before giving up */
11781 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11783 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11784 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,mp_link(p))|
11785 and |(pp,mp_link(pp))|, respectively.
11788 static void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11789 pointer q,qq; /* |mp_link(p)|, |mp_link(pp)| */
11790 mp->time_to_go=max_patience; mp->max_t=2;
11791 @<Initialize for intersections at level zero@>;
11794 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11795 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11796 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11797 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11799 if ( mp->cur_t>=mp->max_t ){
11800 if ( mp->max_t==two ) { /* we've done 17 bisections */
11801 mp->cur_t=halfp(mp->cur_t+1);
11802 mp->cur_tt=halfp(mp->cur_tt+1);
11805 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11807 @<Subdivide for a new level of intersection@>;
11810 if ( mp->time_to_go>0 ) {
11811 decr(mp->time_to_go);
11813 while ( mp->appr_t<unity ) {
11814 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11816 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11818 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11822 @ The following variables are global, although they are used only by
11823 |cubic_intersection|, because it is necessary on some machines to
11824 split |cubic_intersection| up into two procedures.
11827 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11828 integer tol; /* bound on the uncertainty in the overlap test */
11830 integer xy; /* pointers to the current packets of interest */
11831 integer three_l; /* |tol_step| times the bisection level */
11832 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11834 @ We shall assume that the coordinates are sufficiently non-extreme that
11835 integer overflow will not occur.
11836 @^overflow in arithmetic@>
11838 @<Initialize for intersections at level zero@>=
11839 q=mp_link(p); qq=mp_link(pp); mp->bisect_ptr=int_packets;
11840 u1r=mp_right_x(p)-mp_x_coord(p); u2r=mp_left_x(q)-mp_right_x(p);
11841 u3r=mp_x_coord(q)-mp_left_x(q); set_min_max(ur_packet);
11842 v1r=mp_right_y(p)-mp_y_coord(p); v2r=mp_left_y(q)-mp_right_y(p);
11843 v3r=mp_y_coord(q)-mp_left_y(q); set_min_max(vr_packet);
11844 x1r=mp_right_x(pp)-mp_x_coord(pp); x2r=mp_left_x(qq)-mp_right_x(pp);
11845 x3r=mp_x_coord(qq)-mp_left_x(qq); set_min_max(xr_packet);
11846 y1r=mp_right_y(pp)-mp_y_coord(pp); y2r=mp_left_y(qq)-mp_right_y(pp);
11847 y3r=mp_y_coord(qq)-mp_left_y(qq); set_min_max(yr_packet);
11848 mp->delx=mp_x_coord(p)-mp_x_coord(pp); mp->dely=mp_y_coord(p)-mp_y_coord(pp);
11849 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11850 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11852 @ @<Subdivide for a new level of intersection@>=
11853 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11854 stack_uv=mp->uv; stack_xy=mp->xy;
11855 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11856 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11857 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11858 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11859 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11860 u3l=half(u2l+u2r); u1r=u3l;
11861 set_min_max(ul_packet); set_min_max(ur_packet);
11862 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11863 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11864 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11865 v3l=half(v2l+v2r); v1r=v3l;
11866 set_min_max(vl_packet); set_min_max(vr_packet);
11867 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11868 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11869 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11870 x3l=half(x2l+x2r); x1r=x3l;
11871 set_min_max(xl_packet); set_min_max(xr_packet);
11872 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11873 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11874 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11875 y3l=half(y2l+y2r); y1r=y3l;
11876 set_min_max(yl_packet); set_min_max(yr_packet);
11877 mp->uv=l_packets; mp->xy=l_packets;
11878 mp->delx+=mp->delx; mp->dely+=mp->dely;
11879 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11880 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11882 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11884 if ( odd(mp->cur_tt) ) {
11885 if ( odd(mp->cur_t) ) {
11886 @<Descend to the previous level and |goto not_found|@>;
11889 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11890 +stack_3(u_packet(mp->uv));
11891 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11892 +stack_3(v_packet(mp->uv));
11893 mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
11894 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11895 /* switch from |r_packets| to |l_packets| */
11896 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11897 +stack_3(x_packet(mp->xy));
11898 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11899 +stack_3(y_packet(mp->xy));
11902 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11903 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11904 -stack_3(x_packet(mp->xy));
11905 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11906 -stack_3(y_packet(mp->xy));
11907 mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
11910 @ @<Descend to the previous level...@>=
11912 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11913 if ( mp->cur_t==0 ) return;
11914 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11915 mp->three_l=mp->three_l-mp->tol_step;
11916 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11917 mp->uv=stack_uv; mp->xy=stack_xy;
11921 @ The |path_intersection| procedure is much simpler.
11922 It invokes |cubic_intersection| in lexicographic order until finding a
11923 pair of cubics that intersect. The final intersection times are placed in
11924 |cur_t| and~|cur_tt|.
11927 static void mp_path_intersection (MP mp,pointer h, pointer hh) {
11928 pointer p,pp; /* link registers that traverse the given paths */
11929 integer n,nn; /* integer parts of intersection times, minus |unity| */
11930 @<Change one-point paths into dead cycles@>;
11935 if ( mp_right_type(p)!=mp_endpoint ) {
11938 if ( mp_right_type(pp)!=mp_endpoint ) {
11939 mp_cubic_intersection(mp, p,pp);
11940 if ( mp->cur_t>0 ) {
11941 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11945 nn=nn+unity; pp=mp_link(pp);
11948 n=n+unity; p=mp_link(p);
11950 mp->tol_step=mp->tol_step+3;
11951 } while (mp->tol_step<=3);
11952 mp->cur_t=-unity; mp->cur_tt=-unity;
11955 @ @<Change one-point paths...@>=
11956 if ( mp_right_type(h)==mp_endpoint ) {
11957 mp_right_x(h)=mp_x_coord(h); mp_left_x(h)=mp_x_coord(h);
11958 mp_right_y(h)=mp_y_coord(h); mp_left_y(h)=mp_y_coord(h); mp_right_type(h)=mp_explicit;
11960 if ( mp_right_type(hh)==mp_endpoint ) {
11961 mp_right_x(hh)=mp_x_coord(hh); mp_left_x(hh)=mp_x_coord(hh);
11962 mp_right_y(hh)=mp_y_coord(hh); mp_left_y(hh)=mp_y_coord(hh); mp_right_type(hh)=mp_explicit;
11965 @* \[24] Dynamic linear equations.
11966 \MP\ users define variables implicitly by stating equations that should be
11967 satisfied; the computer is supposed to be smart enough to solve those equations.
11968 And indeed, the computer tries valiantly to do so, by distinguishing five
11969 different types of numeric values:
11972 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11973 of the variable whose address is~|p|.
11976 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11977 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11978 as a |scaled| number plus a sum of independent variables with |fraction|
11982 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11983 number'' reflecting the time this variable was first used in an equation;
11984 also |0<=m<64|, and each dependent variable
11985 that refers to this one is actually referring to the future value of
11986 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11987 scaling are sometimes needed to keep the coefficients in dependency lists
11988 from getting too large. The value of~|m| will always be even.)
11991 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11992 equation before, but it has been explicitly declared to be numeric.
11995 |type(p)=undefined| means that variable |p| hasn't appeared before.
11997 \smallskip\noindent
11998 We have actually discussed these five types in the reverse order of their
11999 history during a computation: Once |known|, a variable never again
12000 becomes |dependent|; once |dependent|, it almost never again becomes
12001 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
12002 and once |mp_numeric_type|, it never again becomes |undefined| (except
12003 of course when the user specifically decides to scrap the old value
12004 and start again). A backward step may, however, take place: Sometimes
12005 a |dependent| variable becomes |mp_independent| again, when one of the
12006 independent variables it depends on is reverting to |undefined|.
12009 The next patch detects overflow of independent-variable serial
12010 numbers. Diagnosed and patched by Thorsten Dahlheimer.
12012 @d s_scale 64 /* the serial numbers are multiplied by this factor */
12013 @d new_indep(A) /* create a new independent variable */
12014 { if ( mp->serial_no>el_gordo-s_scale )
12015 mp_fatal_error(mp, "variable instance identifiers exhausted");
12016 mp_type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
12017 value((A))=mp->serial_no;
12021 integer serial_no; /* the most recent serial number, times |s_scale| */
12023 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
12025 @ But how are dependency lists represented? It's simple: The linear combination
12026 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
12027 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
12028 @t$\alpha_1$@>| (which is a |fraction|); |mp_info(q)| points to the location
12029 of $\alpha_1$; and |mp_link(p)| points to the dependency list
12030 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
12031 then |value(q)=@t$\beta$@>| (which is |scaled|) and |mp_info(q)=null|.
12032 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
12033 they appear in decreasing order of their |value| fields (i.e., of
12034 their serial numbers). \ (It is convenient to use decreasing order,
12035 since |value(null)=0|. If the independent variables were not sorted by
12036 serial number but by some other criterion, such as their location in |mem|,
12037 the equation-solving mechanism would be too system-dependent, because
12038 the ordering can affect the computed results.)
12040 The |link| field in the node that contains the constant term $\beta$ is
12041 called the {\sl final link\/} of the dependency list. \MP\ maintains
12042 a doubly-linked master list of all dependency lists, in terms of a permanently
12044 in |mem| called |dep_head|. If there are no dependencies, we have
12045 |mp_link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
12046 otherwise |mp_link(dep_head)| points to the first dependent variable, say~|p|,
12047 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
12048 points to its dependency list. If the final link of that dependency list
12049 occurs in location~|q|, then |mp_link(q)| points to the next dependent
12050 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
12052 @d dep_list(A) mp_link(value_loc((A)))
12053 /* half of the |value| field in a |dependent| variable */
12054 @d prev_dep(A) mp_info(value_loc((A)))
12055 /* the other half; makes a doubly linked list */
12056 @d dep_node_size 2 /* the number of words per dependency node */
12058 @<Initialize table entries...@>= mp->serial_no=0;
12059 mp_link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
12060 mp_info(dep_head)=null; dep_list(dep_head)=null;
12062 @ Actually the description above contains a little white lie. There's
12063 another kind of variable called |mp_proto_dependent|, which is
12064 just like a |dependent| one except that the $\alpha$ coefficients
12065 in its dependency list are |scaled| instead of being fractions.
12066 Proto-dependency lists are mixed with dependency lists in the
12067 nodes reachable from |dep_head|.
12069 @ Here is a procedure that prints a dependency list in symbolic form.
12070 The second parameter should be either |dependent| or |mp_proto_dependent|,
12071 to indicate the scaling of the coefficients.
12074 static void mp_print_dependency (MP mp,pointer p, quarterword t);
12077 void mp_print_dependency (MP mp,pointer p, quarterword t) {
12078 integer v; /* a coefficient */
12079 pointer pp,q; /* for list manipulation */
12082 v=abs(value(p)); q=mp_info(p);
12083 if ( q==null ) { /* the constant term */
12084 if ( (v!=0)||(p==pp) ) {
12085 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, xord('+'));
12086 mp_print_scaled(mp, value(p));
12090 @<Print the coefficient, unless it's $\pm1.0$@>;
12091 if ( mp_type(q)!=mp_independent ) mp_confusion(mp, "dep");
12092 @:this can't happen dep}{\quad dep@>
12093 mp_print_variable_name(mp, q); v=value(q) % s_scale;
12094 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
12099 @ @<Print the coefficient, unless it's $\pm1.0$@>=
12100 if ( value(p)<0 ) mp_print_char(mp, xord('-'));
12101 else if ( p!=pp ) mp_print_char(mp, xord('+'));
12102 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
12103 if ( v!=unity ) mp_print_scaled(mp, v)
12105 @ The maximum absolute value of a coefficient in a given dependency list
12106 is returned by the following simple function.
12109 static fraction mp_max_coef (MP mp,pointer p) {
12110 fraction x; /* the maximum so far */
12112 while ( mp_info(p)!=null ) {
12113 if ( abs(value(p))>x ) x=abs(value(p));
12119 @ One of the main operations needed on dependency lists is to add a multiple
12120 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
12121 to dependency lists and |f| is a fraction.
12123 If the coefficient of any independent variable becomes |coef_bound| or
12124 more, in absolute value, this procedure changes the type of that variable
12125 to `|independent_needing_fix|', and sets the global variable |fix_needed|
12126 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
12127 $\mu^2+\mu<8$; this means that the numbers we deal with won't
12128 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
12129 2.3723$, the safer value 7/3 is taken as the threshold.)
12131 The changes mentioned in the preceding paragraph are actually done only if
12132 the global variable |watch_coefs| is |true|. But it usually is; in fact,
12133 it is |false| only when \MP\ is making a dependency list that will soon
12134 be equated to zero.
12136 Several procedures that act on dependency lists, including |p_plus_fq|,
12137 set the global variable |dep_final| to the final (constant term) node of
12138 the dependency list that they produce.
12140 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
12141 @d independent_needing_fix 0
12144 boolean fix_needed; /* does at least one |independent| variable need scaling? */
12145 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
12146 pointer dep_final; /* location of the constant term and final link */
12149 mp->fix_needed=false; mp->watch_coefs=true;
12151 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
12152 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
12153 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
12154 should be |mp_proto_dependent| if |q| is a proto-dependency list.
12156 List |q| is unchanged by the operation; but list |p| is totally destroyed.
12158 The final link of the dependency list or proto-dependency list returned
12159 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
12160 constant term of the result will be located in the same |mem| location
12161 as the original constant term of~|p|.
12163 Coefficients of the result are assumed to be zero if they are less than
12164 a certain threshold. This compensates for inevitable rounding errors,
12165 and tends to make more variables `|known|'. The threshold is approximately
12166 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
12167 proto-dependencies.
12169 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
12170 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
12171 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
12172 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
12175 static pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12176 pointer q, quarterword t, quarterword tt) ;
12179 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12180 pointer q, quarterword t, quarterword tt) {
12181 pointer pp,qq; /* |mp_info(p)| and |mp_info(q)|, respectively */
12182 pointer r,s; /* for list manipulation */
12183 integer threshold; /* defines a neighborhood of zero */
12184 integer v; /* temporary register */
12185 if ( t==mp_dependent ) threshold=fraction_threshold;
12186 else threshold=scaled_threshold;
12187 r=temp_head; pp=mp_info(p); qq=mp_info(q);
12193 @<Contribute a term from |p|, plus |f| times the
12194 corresponding term from |q|@>
12196 } else if ( value(pp)<value(qq) ) {
12197 @<Contribute a term from |q|, multiplied by~|f|@>
12199 mp_link(r)=p; r=p; p=mp_link(p); pp=mp_info(p);
12202 if ( t==mp_dependent )
12203 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
12205 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
12206 mp_link(r)=p; mp->dep_final=p;
12207 return mp_link(temp_head);
12210 @ @<Contribute a term from |p|, plus |f|...@>=
12212 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
12213 else v=value(p)+mp_take_scaled(mp, f,value(q));
12214 value(p)=v; s=p; p=mp_link(p);
12215 if ( abs(v)<threshold ) {
12216 mp_free_node(mp, s,dep_node_size);
12218 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12219 mp_type(qq)=independent_needing_fix; mp->fix_needed=true;
12223 pp=mp_info(p); q=mp_link(q); qq=mp_info(q);
12226 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12228 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12229 else v=mp_take_scaled(mp, f,value(q));
12230 if ( abs(v)>halfp(threshold) ) {
12231 s=mp_get_node(mp, dep_node_size); mp_info(s)=qq; value(s)=v;
12232 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12233 mp_type(qq)=independent_needing_fix; mp->fix_needed=true;
12237 q=mp_link(q); qq=mp_info(q);
12240 @ It is convenient to have another subroutine for the special case
12241 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12242 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12245 static pointer mp_p_plus_q (MP mp,pointer p, pointer q, quarterword t) {
12246 pointer pp,qq; /* |mp_info(p)| and |mp_info(q)|, respectively */
12247 pointer r,s; /* for list manipulation */
12248 integer threshold; /* defines a neighborhood of zero */
12249 integer v; /* temporary register */
12250 if ( t==mp_dependent ) threshold=fraction_threshold;
12251 else threshold=scaled_threshold;
12252 r=temp_head; pp=mp_info(p); qq=mp_info(q);
12258 @<Contribute a term from |p|, plus the
12259 corresponding term from |q|@>
12262 if ( value(pp)<value(qq) ) {
12263 s=mp_get_node(mp, dep_node_size); mp_info(s)=qq; value(s)=value(q);
12264 q=mp_link(q); qq=mp_info(q); mp_link(r)=s; r=s;
12266 mp_link(r)=p; r=p; p=mp_link(p); pp=mp_info(p);
12270 value(p)=mp_slow_add(mp, value(p),value(q));
12271 mp_link(r)=p; mp->dep_final=p;
12272 return mp_link(temp_head);
12275 @ @<Contribute a term from |p|, plus the...@>=
12277 v=value(p)+value(q);
12278 value(p)=v; s=p; p=mp_link(p); pp=mp_info(p);
12279 if ( abs(v)<threshold ) {
12280 mp_free_node(mp, s,dep_node_size);
12282 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12283 mp_type(qq)=independent_needing_fix; mp->fix_needed=true;
12287 q=mp_link(q); qq=mp_info(q);
12290 @ A somewhat simpler routine will multiply a dependency list
12291 by a given constant~|v|. The constant is either a |fraction| less than
12292 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12293 convert a dependency list to a proto-dependency list.
12294 Parameters |t0| and |t1| are the list types before and after;
12295 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12296 and |v_is_scaled=true|.
12299 static pointer mp_p_times_v (MP mp,pointer p, integer v, quarterword t0,
12300 quarterword t1, boolean v_is_scaled) {
12301 pointer r,s; /* for list manipulation */
12302 integer w; /* tentative coefficient */
12304 boolean scaling_down;
12305 if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
12306 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12307 else threshold=half_scaled_threshold;
12309 while ( mp_info(p)!=null ) {
12310 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12311 else w=mp_take_scaled(mp, v,value(p));
12312 if ( abs(w)<=threshold ) {
12313 s=mp_link(p); mp_free_node(mp, p,dep_node_size); p=s;
12315 if ( abs(w)>=coef_bound ) {
12316 mp->fix_needed=true; mp_type(mp_info(p))=independent_needing_fix;
12318 mp_link(r)=p; r=p; value(p)=w; p=mp_link(p);
12322 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12323 else value(p)=mp_take_fraction(mp, value(p),v);
12324 return mp_link(temp_head);
12327 @ Similarly, we sometimes need to divide a dependency list
12328 by a given |scaled| constant.
12331 static pointer mp_p_over_v (MP mp,pointer p, scaled v, quarterword
12332 t0, quarterword t1) ;
12335 pointer mp_p_over_v (MP mp,pointer p, scaled v, quarterword
12336 t0, quarterword t1) {
12337 pointer r,s; /* for list manipulation */
12338 integer w; /* tentative coefficient */
12340 boolean scaling_down;
12341 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12342 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12343 else threshold=half_scaled_threshold;
12345 while ( mp_info( p)!=null ) {
12346 if ( scaling_down ) {
12347 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12348 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12350 w=mp_make_scaled(mp, value(p),v);
12352 if ( abs(w)<=threshold ) {
12353 s=mp_link(p); mp_free_node(mp, p,dep_node_size); p=s;
12355 if ( abs(w)>=coef_bound ) {
12356 mp->fix_needed=true; mp_type(mp_info(p))=independent_needing_fix;
12358 mp_link(r)=p; r=p; value(p)=w; p=mp_link(p);
12361 mp_link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12362 return mp_link(temp_head);
12365 @ Here's another utility routine for dependency lists. When an independent
12366 variable becomes dependent, we want to remove it from all existing
12367 dependencies. The |p_with_x_becoming_q| function computes the
12368 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12370 This procedure has basically the same calling conventions as |p_plus_fq|:
12371 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12372 final link are inherited from~|p|; and the fourth parameter tells whether
12373 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12374 is not altered if |x| does not occur in list~|p|.
12377 static pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12378 pointer x, pointer q, quarterword t) {
12379 pointer r,s; /* for list manipulation */
12380 integer v; /* coefficient of |x| */
12381 integer sx; /* serial number of |x| */
12382 s=p; r=temp_head; sx=value(x);
12383 while ( value(mp_info(s))>sx ) { r=s; s=mp_link(s); };
12384 if ( mp_info(s)!=x ) {
12387 mp_link(temp_head)=p; mp_link(r)=mp_link(s); v=value(s);
12388 mp_free_node(mp, s,dep_node_size);
12389 return mp_p_plus_fq(mp, mp_link(temp_head),v,q,t,mp_dependent);
12393 @ Here's a simple procedure that reports an error when a variable
12394 has just received a known value that's out of the required range.
12397 static void mp_val_too_big (MP mp,scaled x) ;
12399 @ @c void mp_val_too_big (MP mp,scaled x) {
12400 if ( mp->internal[mp_warning_check]>0 ) {
12401 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, xord(')'));
12402 @.Value is too large@>
12403 help4("The equation I just processed has given some variable",
12404 "a value of 4096 or more. Continue and I'll try to cope",
12405 "with that big value; but it might be dangerous.",
12406 "(Set warningcheck:=0 to suppress this message.)");
12411 @ When a dependent variable becomes known, the following routine
12412 removes its dependency list. Here |p| points to the variable, and
12413 |q| points to the dependency list (which is one node long).
12416 static void mp_make_known (MP mp,pointer p, pointer q) ;
12418 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12419 int t; /* the previous type */
12420 prev_dep(mp_link(q))=prev_dep(p);
12421 mp_link(prev_dep(p))=mp_link(q); t=mp_type(p);
12422 mp_type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12423 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12424 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12425 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12426 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12427 mp_print_variable_name(mp, p);
12428 mp_print_char(mp, xord('=')); mp_print_scaled(mp, value(p));
12429 mp_end_diagnostic(mp, false);
12431 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12432 mp->cur_type=mp_known; mp->cur_exp=value(p);
12433 mp_free_node(mp, p,value_node_size);
12437 @ The |fix_dependencies| routine is called into action when |fix_needed|
12438 has been triggered. The program keeps a list~|s| of independent variables
12439 whose coefficients must be divided by~4.
12441 In unusual cases, this fixup process might reduce one or more coefficients
12442 to zero, so that a variable will become known more or less by default.
12445 static void mp_fix_dependencies (MP mp);
12448 static void mp_fix_dependencies (MP mp) {
12449 pointer p,q,r,s,t; /* list manipulation registers */
12450 pointer x; /* an independent variable */
12451 r=mp_link(dep_head); s=null;
12452 while ( r!=dep_head ){
12454 @<Run through the dependency list for variable |t|, fixing
12455 all nodes, and ending with final link~|q|@>;
12457 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12459 while ( s!=null ) {
12460 p=mp_link(s); x=mp_info(s); free_avail(s); s=p;
12461 mp_type(x)=mp_independent; value(x)=value(x)+2;
12463 mp->fix_needed=false;
12466 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12468 @<Run through the dependency list for variable |t|...@>=
12469 r=value_loc(t); /* |mp_link(r)=dep_list(t)| */
12471 q=mp_link(r); x=mp_info(q);
12472 if ( x==null ) break;
12473 if ( mp_type(x)<=independent_being_fixed ) {
12474 if ( mp_type(x)<independent_being_fixed ) {
12475 p=mp_get_avail(mp); mp_link(p)=s; s=p;
12476 mp_info(s)=x; mp_type(x)=independent_being_fixed;
12478 value(q)=value(q) / 4;
12479 if ( value(q)==0 ) {
12480 mp_link(r)=mp_link(q); mp_free_node(mp, q,dep_node_size); q=r;
12487 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12488 linking it into the list of all known dependencies. We assume that
12489 |dep_final| points to the final node of list~|p|.
12492 static void mp_new_dep (MP mp,pointer q, pointer p) {
12493 pointer r; /* what used to be the first dependency */
12494 dep_list(q)=p; prev_dep(q)=dep_head;
12495 r=mp_link(dep_head); mp_link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12496 mp_link(dep_head)=q;
12499 @ Here is one of the ways a dependency list gets started.
12500 The |const_dependency| routine produces a list that has nothing but
12503 @c static pointer mp_const_dependency (MP mp, scaled v) {
12504 mp->dep_final=mp_get_node(mp, dep_node_size);
12505 value(mp->dep_final)=v; mp_info(mp->dep_final)=null;
12506 return mp->dep_final;
12509 @ And here's a more interesting way to start a dependency list from scratch:
12510 The parameter to |single_dependency| is the location of an
12511 independent variable~|x|, and the result is the simple dependency list
12514 In the unlikely event that the given independent variable has been doubled so
12515 often that we can't refer to it with a nonzero coefficient,
12516 |single_dependency| returns the simple list `0'. This case can be
12517 recognized by testing that the returned list pointer is equal to
12521 static pointer mp_single_dependency (MP mp,pointer p) {
12522 pointer q; /* the new dependency list */
12523 integer m; /* the number of doublings */
12524 m=value(p) % s_scale;
12526 return mp_const_dependency(mp, 0);
12528 q=mp_get_node(mp, dep_node_size);
12529 value(q)=(integer)two_to_the(28-m); mp_info(q)=p;
12530 mp_link(q)=mp_const_dependency(mp, 0);
12535 @ We sometimes need to make an exact copy of a dependency list.
12538 static pointer mp_copy_dep_list (MP mp,pointer p) {
12539 pointer q; /* the new dependency list */
12540 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12542 mp_info(mp->dep_final)=mp_info(p); value(mp->dep_final)=value(p);
12543 if ( mp_info(mp->dep_final)==null ) break;
12544 mp_link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12545 mp->dep_final=mp_link(mp->dep_final); p=mp_link(p);
12550 @ But how do variables normally become known? Ah, now we get to the heart of the
12551 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12552 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12553 appears. It equates this list to zero, by choosing an independent variable
12554 with the largest coefficient and making it dependent on the others. The
12555 newly dependent variable is eliminated from all current dependencies,
12556 thereby possibly making other dependent variables known.
12558 The given list |p| is, of course, totally destroyed by all this processing.
12561 static void mp_linear_eq (MP mp, pointer p, quarterword t) {
12562 pointer q,r,s; /* for link manipulation */
12563 pointer x; /* the variable that loses its independence */
12564 integer n; /* the number of times |x| had been halved */
12565 integer v; /* the coefficient of |x| in list |p| */
12566 pointer prev_r; /* lags one step behind |r| */
12567 pointer final_node; /* the constant term of the new dependency list */
12568 integer w; /* a tentative coefficient */
12569 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12570 x=mp_info(q); n=value(x) % s_scale;
12571 @<Divide list |p| by |-v|, removing node |q|@>;
12572 if ( mp->internal[mp_tracing_equations]>0 ) {
12573 @<Display the new dependency@>;
12575 @<Simplify all existing dependencies by substituting for |x|@>;
12576 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12577 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12580 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12581 q=p; r=mp_link(p); v=value(q);
12582 while ( mp_info(r)!=null ) {
12583 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12587 @ Here we want to change the coefficients from |scaled| to |fraction|,
12588 except in the constant term. In the common case of a trivial equation
12589 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12591 @<Divide list |p| by |-v|, removing node |q|@>=
12592 s=temp_head; mp_link(s)=p; r=p;
12595 mp_link(s)=mp_link(r); mp_free_node(mp, r,dep_node_size);
12597 w=mp_make_fraction(mp, value(r),v);
12598 if ( abs(w)<=half_fraction_threshold ) {
12599 mp_link(s)=mp_link(r); mp_free_node(mp, r,dep_node_size);
12605 } while (mp_info(r)!=null);
12606 if ( t==mp_proto_dependent ) {
12607 value(r)=-mp_make_scaled(mp, value(r),v);
12608 } else if ( v!=-fraction_one ) {
12609 value(r)=-mp_make_fraction(mp, value(r),v);
12611 final_node=r; p=mp_link(temp_head)
12613 @ @<Display the new dependency@>=
12614 if ( mp_interesting(mp, x) ) {
12615 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12616 mp_print_variable_name(mp, x);
12617 @:]]]\#\#_}{\.{\#\#}@>
12619 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12620 mp_print_char(mp, xord('=')); mp_print_dependency(mp, p,mp_dependent);
12621 mp_end_diagnostic(mp, false);
12624 @ @<Simplify all existing dependencies by substituting for |x|@>=
12625 prev_r=dep_head; r=mp_link(dep_head);
12626 while ( r!=dep_head ) {
12627 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,mp_type(r));
12628 if ( mp_info(q)==null ) {
12629 mp_make_known(mp, r,q);
12632 do { q=mp_link(q); } while (mp_info(q)!=null);
12638 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12639 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12640 if ( mp_info(p)==null ) {
12641 mp_type(x)=mp_known;
12643 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12644 mp_free_node(mp, p,dep_node_size);
12645 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12646 mp->cur_exp=value(x); mp->cur_type=mp_known;
12647 mp_free_node(mp, x,value_node_size);
12650 mp_type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12651 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12654 @ @<Divide list |p| by $2^n$@>=
12656 s=temp_head; mp_link(temp_head)=p; r=p;
12659 else w=value(r) / two_to_the(n);
12660 if ( (abs(w)<=half_fraction_threshold)&&(mp_info(r)!=null) ) {
12661 mp_link(s)=mp_link(r);
12662 mp_free_node(mp, r,dep_node_size);
12667 } while (mp_info(s)!=null);
12668 p=mp_link(temp_head);
12671 @ The |check_mem| procedure, which is used only when \MP\ is being
12672 debugged, makes sure that the current dependency lists are well formed.
12674 @<Check the list of linear dependencies@>=
12675 q=dep_head; p=mp_link(q);
12676 while ( p!=dep_head ) {
12677 if ( prev_dep(p)!=q ) {
12678 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12683 r=mp_info(p); q=p; p=mp_link(q);
12684 if ( r==null ) break;
12685 if ( value(mp_info(p))>=value(r) ) {
12686 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12687 @.Out of order...@>
12692 @* \[25] Dynamic nonlinear equations.
12693 Variables of numeric type are maintained by the general scheme of
12694 independent, dependent, and known values that we have just studied;
12695 and the components of pair and transform variables are handled in the
12696 same way. But \MP\ also has five other types of values: \&{boolean},
12697 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12699 Equations are allowed between nonlinear quantities, but only in a
12700 simple form. Two variables that haven't yet been assigned values are
12701 either equal to each other, or they're not.
12703 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12704 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12705 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12706 |null| (which means that no other variables are equivalent to this one), or
12707 it points to another variable of the same undefined type. The pointers in the
12708 latter case form a cycle of nodes, which we shall call a ``ring.''
12709 Rings of undefined variables may include capsules, which arise as
12710 intermediate results within expressions or as \&{expr} parameters to macros.
12712 When one member of a ring receives a value, the same value is given to
12713 all the other members. In the case of paths and pictures, this implies
12714 making separate copies of a potentially large data structure; users should
12715 restrain their enthusiasm for such generality, unless they have lots and
12716 lots of memory space.
12718 @ The following procedure is called when a capsule node is being
12719 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12722 static pointer mp_new_ring_entry (MP mp,pointer p) {
12723 pointer q; /* the new capsule node */
12724 q=mp_get_node(mp, value_node_size); mp_name_type(q)=mp_capsule;
12725 mp_type(q)=mp_type(p);
12726 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12731 @ Conversely, we might delete a capsule or a variable before it becomes known.
12732 The following procedure simply detaches a quantity from its ring,
12733 without recycling the storage.
12736 static void mp_ring_delete (MP mp,pointer p);
12739 void mp_ring_delete (MP mp,pointer p) {
12742 if ( q!=null ) if ( q!=p ){
12743 while ( value(q)!=p ) q=value(q);
12748 @ Eventually there might be an equation that assigns values to all of the
12749 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12750 propagation of values.
12752 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12753 value, it will soon be recycled.
12756 static void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12757 quarterword t; /* the type of ring |p| */
12758 pointer q,r; /* link manipulation registers */
12759 t=mp_type(p)-unknown_tag; q=value(p);
12760 if ( flush_p ) mp_type(p)=mp_vacuous; else p=q;
12762 r=value(q); mp_type(q)=t;
12764 case mp_boolean_type: value(q)=v; break;
12765 case mp_string_type: value(q)=v; add_str_ref(v); break;
12766 case mp_pen_type: value(q)=copy_pen(v); break;
12767 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12768 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12769 } /* there ain't no more cases */
12774 @ If two members of rings are equated, and if they have the same type,
12775 the |ring_merge| procedure is called on to make them equivalent.
12778 static void mp_ring_merge (MP mp,pointer p, pointer q) {
12779 pointer r; /* traverses one list */
12783 @<Exclaim about a redundant equation@>;
12788 r=value(p); value(p)=value(q); value(q)=r;
12791 @ @<Exclaim about a redundant equation@>=
12793 print_err("Redundant equation");
12794 @.Redundant equation@>
12795 help2("I already knew that this equation was true.",
12796 "But perhaps no harm has been done; let's continue.");
12797 mp_put_get_error(mp);
12800 @* \[26] Introduction to the syntactic routines.
12801 Let's pause a moment now and try to look at the Big Picture.
12802 The \MP\ program consists of three main parts: syntactic routines,
12803 semantic routines, and output routines. The chief purpose of the
12804 syntactic routines is to deliver the user's input to the semantic routines,
12805 while parsing expressions and locating operators and operands. The
12806 semantic routines act as an interpreter responding to these operators,
12807 which may be regarded as commands. And the output routines are
12808 periodically called on to produce compact font descriptions that can be
12809 used for typesetting or for making interim proof drawings. We have
12810 discussed the basic data structures and many of the details of semantic
12811 operations, so we are good and ready to plunge into the part of \MP\ that
12812 actually controls the activities.
12814 Our current goal is to come to grips with the |get_next| procedure,
12815 which is the keystone of \MP's input mechanism. Each call of |get_next|
12816 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12817 representing the next input token.
12818 $$\vbox{\halign{#\hfil\cr
12819 \hbox{|cur_cmd| denotes a command code from the long list of codes
12821 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12822 \hbox{|cur_sym| is the hash address of the symbolic token that was
12824 \hbox{\qquad or zero in the case of a numeric or string
12825 or capsule token.}\cr}}$$
12826 Underlying this external behavior of |get_next| is all the machinery
12827 necessary to convert from character files to tokens. At a given time we
12828 may be only partially finished with the reading of several files (for
12829 which \&{input} was specified), and partially finished with the expansion
12830 of some user-defined macros and/or some macro parameters, and partially
12831 finished reading some text that the user has inserted online,
12832 and so on. When reading a character file, the characters must be
12833 converted to tokens; comments and blank spaces must
12834 be removed, numeric and string tokens must be evaluated.
12836 To handle these situations, which might all be present simultaneously,
12837 \MP\ uses various stacks that hold information about the incomplete
12838 activities, and there is a finite state control for each level of the
12839 input mechanism. These stacks record the current state of an implicitly
12840 recursive process, but the |get_next| procedure is not recursive.
12843 integer cur_cmd; /* current command set by |get_next| */
12844 integer cur_mod; /* operand of current command */
12845 halfword cur_sym; /* hash address of current symbol */
12847 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12848 command code and its modifier.
12849 It consists of a rather tedious sequence of print
12850 commands, and most of it is essentially an inverse to the |primitive|
12851 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12852 all of this procedure appears elsewhere in the program, together with the
12853 corresponding |primitive| calls.
12856 static void mp_print_cmd_mod (MP mp,integer c, integer m) ;
12859 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12861 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12862 default: mp_print(mp, "[unknown command code!]"); break;
12866 @ Here is a procedure that displays a given command in braces, in the
12867 user's transcript file.
12869 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12872 static void mp_show_cmd_mod (MP mp,integer c, integer m) {
12873 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12874 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, xord('}'));
12875 mp_end_diagnostic(mp, false);
12878 @* \[27] Input stacks and states.
12879 The state of \MP's input mechanism appears in the input stack, whose
12880 entries are records with five fields, called |index|, |start|, |loc|,
12881 |limit|, and |name|. The top element of this stack is maintained in a
12882 global variable for which no subscripting needs to be done; the other
12883 elements of the stack appear in an array. Hence the stack is declared thus:
12887 quarterword index_field;
12888 halfword start_field, loc_field, limit_field, name_field;
12892 in_state_record *input_stack;
12893 integer input_ptr; /* first unused location of |input_stack| */
12894 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12895 in_state_record cur_input; /* the ``top'' input state */
12896 int stack_size; /* maximum number of simultaneous input sources */
12898 @ @<Allocate or initialize ...@>=
12899 mp->stack_size = 300;
12900 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12902 @ @<Dealloc variables@>=
12903 xfree(mp->input_stack);
12905 @ We've already defined the special variable |loc==cur_input.loc_field|
12906 in our discussion of basic input-output routines. The other components of
12907 |cur_input| are defined in the same way:
12909 @d iindex mp->cur_input.index_field /* reference for buffer information */
12910 @d start mp->cur_input.start_field /* starting position in |buffer| */
12911 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12912 @d name mp->cur_input.name_field /* name of the current file */
12914 @ Let's look more closely now at the five control variables
12915 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12916 assuming that \MP\ is reading a line of characters that have been input
12917 from some file or from the user's terminal. There is an array called
12918 |buffer| that acts as a stack of all lines of characters that are
12919 currently being read from files, including all lines on subsidiary
12920 levels of the input stack that are not yet completed. \MP\ will return to
12921 the other lines when it is finished with the present input file.
12923 (Incidentally, on a machine with byte-oriented addressing, it would be
12924 appropriate to combine |buffer| with the |str_pool| array,
12925 letting the buffer entries grow downward from the top of the string pool
12926 and checking that these two tables don't bump into each other.)
12928 The line we are currently working on begins in position |start| of the
12929 buffer; the next character we are about to read is |buffer[loc]|; and
12930 |limit| is the location of the last character present. We always have
12931 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12932 that the end of a line is easily sensed.
12934 The |name| variable is a string number that designates the name of
12935 the current file, if we are reading an ordinary text file. Special codes
12936 |is_term..max_spec_src| indicate other sources of input text.
12938 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12939 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12940 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12941 @d max_spec_src is_scantok
12943 @ Additional information about the current line is available via the
12944 |index| variable, which counts how many lines of characters are present
12945 in the buffer below the current level. We have |index=0| when reading
12946 from the terminal and prompting the user for each line; then if the user types,
12947 e.g., `\.{input figs}', we will have |index=1| while reading
12948 the file \.{figs.mp}. However, it does not follow that |index| is the
12949 same as the input stack pointer, since many of the levels on the input
12950 stack may come from token lists and some |index| values may correspond
12951 to \.{MPX} files that are not currently on the stack.
12953 The global variable |in_open| is equal to the highest |index| value counting
12954 \.{MPX} files but excluding token-list input levels. Thus, the number of
12955 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12956 when we are not reading a token list.
12958 If we are not currently reading from the terminal,
12959 we are reading from the file variable |input_file[index]|. We use
12960 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12961 and |cur_file| as an abbreviation for |input_file[index]|.
12963 When \MP\ is not reading from the terminal, the global variable |line| contains
12964 the line number in the current file, for use in error messages. More precisely,
12965 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12966 the line number for each file in the |input_file| array.
12968 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12969 array so that the name doesn't get lost when the file is temporarily removed
12970 from the input stack.
12971 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12972 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12973 Since this is not an \.{MPX} file, we have
12974 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12975 This |name| field is set to |finished| when |input_file[k]| is completely
12978 If more information about the input state is needed, it can be
12979 included in small arrays like those shown here. For example,
12980 the current page or segment number in the input file might be put
12981 into a variable |page|, that is really a macro for the current entry
12982 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12983 by analogy with |line_stack|.
12984 @^system dependencies@>
12986 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12987 @d cur_file mp->input_file[iindex] /* the current |void *| variable */
12988 @d line mp->line_stack[iindex] /* current line number in the current source file */
12989 @d in_name mp->iname_stack[iindex] /* a string used to construct \.{MPX} file names */
12990 @d in_area mp->iarea_stack[iindex] /* another string for naming \.{MPX} files */
12991 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12992 @d mpx_reading (mp->mpx_name[iindex]>absent)
12993 /* when reading a file, is it an \.{MPX} file? */
12995 /* |name_field| value when the corresponding \.{MPX} file is finished */
12998 integer in_open; /* the number of lines in the buffer, less one */
12999 unsigned int open_parens; /* the number of open text files */
13000 void * *input_file ;
13001 integer *line_stack ; /* the line number for each file */
13002 char * *iname_stack; /* used for naming \.{MPX} files */
13003 char * *iarea_stack; /* used for naming \.{MPX} files */
13004 halfword*mpx_name ;
13006 @ @<Allocate or ...@>=
13007 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
13008 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
13009 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
13010 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
13011 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
13014 for (k=0;k<=mp->max_in_open;k++) {
13015 mp->iname_stack[k] =NULL;
13016 mp->iarea_stack[k] =NULL;
13020 @ @<Dealloc variables@>=
13023 for (l=0;l<=mp->max_in_open;l++) {
13024 xfree(mp->iname_stack[l]);
13025 xfree(mp->iarea_stack[l]);
13028 xfree(mp->input_file);
13029 xfree(mp->line_stack);
13030 xfree(mp->iname_stack);
13031 xfree(mp->iarea_stack);
13032 xfree(mp->mpx_name);
13035 @ However, all this discussion about input state really applies only to the
13036 case that we are inputting from a file. There is another important case,
13037 namely when we are currently getting input from a token list. In this case
13038 |iindex>max_in_open|, and the conventions about the other state variables
13041 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
13042 the node that will be read next. If |loc=null|, the token list has been
13045 \yskip\hang|start| points to the first node of the token list; this node
13046 may or may not contain a reference count, depending on the type of token
13049 \yskip\hang|token_type|, which takes the place of |iindex| in the
13050 discussion above, is a code number that explains what kind of token list
13053 \yskip\hang|name| points to the |eqtb| address of the control sequence
13054 being expanded, if the current token list is a macro not defined by
13055 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
13056 can be deduced by looking at their first two parameters.
13058 \yskip\hang|param_start|, which takes the place of |limit|, tells where
13059 the parameters of the current macro or loop text begin in the |param_stack|.
13061 \yskip\noindent The |token_type| can take several values, depending on
13062 where the current token list came from:
13065 \indent|forever_text|, if the token list being scanned is the body of
13066 a \&{forever} loop;
13068 \indent|loop_text|, if the token list being scanned is the body of
13069 a \&{for} or \&{forsuffixes} loop;
13071 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
13073 \indent|backed_up|, if the token list being scanned has been inserted as
13074 `to be read again'.
13076 \indent|inserted|, if the token list being scanned has been inserted as
13077 part of error recovery;
13079 \indent|macro|, if the expansion of a user-defined symbolic token is being
13083 The token list begins with a reference count if and only if |token_type=
13085 @^reference counts@>
13087 @d token_type iindex /* type of current token list */
13088 @d token_state (iindex>(int)mp->max_in_open) /* are we scanning a token list? */
13089 @d file_state (iindex<=(int)mp->max_in_open) /* are we scanning a file line? */
13090 @d param_start limit /* base of macro parameters in |param_stack| */
13091 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
13092 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
13093 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
13094 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
13095 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
13096 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
13098 @ The |param_stack| is an auxiliary array used to hold pointers to the token
13099 lists for parameters at the current level and subsidiary levels of input.
13100 This stack grows at a different rate from the others.
13103 pointer *param_stack; /* token list pointers for parameters */
13104 integer param_ptr; /* first unused entry in |param_stack| */
13105 integer max_param_stack; /* largest value of |param_ptr| */
13107 @ @<Allocate or initialize ...@>=
13108 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
13110 @ @<Dealloc variables@>=
13111 xfree(mp->param_stack);
13113 @ Notice that the |line| isn't valid when |token_state| is true because it
13114 depends on |iindex|. If we really need to know the line number for the
13115 topmost file in the iindex stack we use the following function. If a page
13116 number or other information is needed, this routine should be modified to
13117 compute it as well.
13118 @^system dependencies@>
13121 static integer mp_true_line (MP mp) ;
13124 integer mp_true_line (MP mp) {
13125 int k; /* an index into the input stack */
13126 if ( file_state && (name>max_spec_src) ) {
13131 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
13132 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
13135 return (k>0 ? mp->line_stack[(k-1)] : 0 );
13139 @ Thus, the ``current input state'' can be very complicated indeed; there
13140 can be many levels and each level can arise in a variety of ways. The
13141 |show_context| procedure, which is used by \MP's error-reporting routine to
13142 print out the current input state on all levels down to the most recent
13143 line of characters from an input file, illustrates most of these conventions.
13144 The global variable |file_ptr| contains the lowest level that was
13145 displayed by this procedure.
13148 integer file_ptr; /* shallowest level shown by |show_context| */
13150 @ The status at each level is indicated by printing two lines, where the first
13151 line indicates what was read so far and the second line shows what remains
13152 to be read. The context is cropped, if necessary, so that the first line
13153 contains at most |half_error_line| characters, and the second contains
13154 at most |error_line|. Non-current input levels whose |token_type| is
13155 `|backed_up|' are shown only if they have not been fully read.
13157 @c void mp_show_context (MP mp) { /* prints where the scanner is */
13158 unsigned old_setting; /* saved |selector| setting */
13159 @<Local variables for formatting calculations@>
13160 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
13161 /* store current state */
13163 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
13164 @<Display the current context@>;
13166 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
13167 decr(mp->file_ptr);
13169 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
13172 @ @<Display the current context@>=
13173 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
13174 (token_type!=backed_up) || (loc!=null) ) {
13175 /* we omit backed-up token lists that have already been read */
13176 mp->tally=0; /* get ready to count characters */
13177 old_setting=mp->selector;
13178 if ( file_state ) {
13179 @<Print location of current line@>;
13180 @<Pseudoprint the line@>;
13182 @<Print type of token list@>;
13183 @<Pseudoprint the token list@>;
13185 mp->selector=old_setting; /* stop pseudoprinting */
13186 @<Print two lines using the tricky pseudoprinted information@>;
13189 @ This routine should be changed, if necessary, to give the best possible
13190 indication of where the current line resides in the input file.
13191 For example, on some systems it is best to print both a page and line number.
13192 @^system dependencies@>
13194 @<Print location of current line@>=
13195 if ( name>max_spec_src ) {
13196 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
13197 } else if ( terminal_input ) {
13198 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
13199 else mp_print_nl(mp, "<insert>");
13200 } else if ( name==is_scantok ) {
13201 mp_print_nl(mp, "<scantokens>");
13203 mp_print_nl(mp, "<read>");
13205 mp_print_char(mp, xord(' '))
13207 @ Can't use case statement here because the |token_type| is not
13208 a constant expression.
13210 @<Print type of token list@>=
13212 if(token_type==forever_text) {
13213 mp_print_nl(mp, "<forever> ");
13214 } else if (token_type==loop_text) {
13215 @<Print the current loop value@>;
13216 } else if (token_type==parameter) {
13217 mp_print_nl(mp, "<argument> ");
13218 } else if (token_type==backed_up) {
13219 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
13220 else mp_print_nl(mp, "<to be read again> ");
13221 } else if (token_type==inserted) {
13222 mp_print_nl(mp, "<inserted text> ");
13223 } else if (token_type==macro) {
13225 if ( name!=null ) mp_print_text(name);
13226 else @<Print the name of a \&{vardef}'d macro@>;
13227 mp_print(mp, "->");
13229 mp_print_nl(mp, "?");/* this should never happen */
13234 @ The parameter that corresponds to a loop text is either a token list
13235 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13236 We'll discuss capsules later; for now, all we need to know is that
13237 the |link| field in a capsule parameter is |void| and that
13238 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13240 @<Print the current loop value@>=
13241 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13243 if ( mp_link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13244 else mp_show_token_list(mp, p,null,20,mp->tally);
13246 mp_print(mp, ")> ");
13249 @ The first two parameters of a macro defined by \&{vardef} will be token
13250 lists representing the macro's prefix and ``at point.'' By putting these
13251 together, we get the macro's full name.
13253 @<Print the name of a \&{vardef}'d macro@>=
13254 { p=mp->param_stack[param_start];
13256 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13259 while ( mp_link(q)!=null ) q=mp_link(q);
13260 mp_link(q)=mp->param_stack[param_start+1];
13261 mp_show_token_list(mp, p,null,20,mp->tally);
13266 @ Now it is necessary to explain a little trick. We don't want to store a long
13267 string that corresponds to a token list, because that string might take up
13268 lots of memory; and we are printing during a time when an error message is
13269 being given, so we dare not do anything that might overflow one of \MP's
13270 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13271 that stores characters into a buffer of length |error_line|, where character
13272 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13273 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13274 |tally:=0| and |trick_count:=1000000|; then when we reach the
13275 point where transition from line 1 to line 2 should occur, we
13276 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13277 tally+1+error_line-half_error_line)|. At the end of the
13278 pseudoprinting, the values of |first_count|, |tally|, and
13279 |trick_count| give us all the information we need to print the two lines,
13280 and all of the necessary text is in |trick_buf|.
13282 Namely, let |l| be the length of the descriptive information that appears
13283 on the first line. The length of the context information gathered for that
13284 line is |k=first_count|, and the length of the context information
13285 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13286 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13287 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13288 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13289 and print `\.{...}' followed by
13290 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13291 where subscripts of |trick_buf| are circular modulo |error_line|. The
13292 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13293 unless |n+m>error_line|; in the latter case, further cropping is done.
13294 This is easier to program than to explain.
13296 @<Local variables for formatting...@>=
13297 int i; /* index into |buffer| */
13298 integer l; /* length of descriptive information on line 1 */
13299 integer m; /* context information gathered for line 2 */
13300 int n; /* length of line 1 */
13301 integer p; /* starting or ending place in |trick_buf| */
13302 integer q; /* temporary index */
13304 @ The following code tells the print routines to gather
13305 the desired information.
13307 @d begin_pseudoprint {
13308 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13309 mp->trick_count=1000000;
13311 @d set_trick_count {
13312 mp->first_count=mp->tally;
13313 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13314 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13317 @ And the following code uses the information after it has been gathered.
13319 @<Print two lines using the tricky pseudoprinted information@>=
13320 if ( mp->trick_count==1000000 ) set_trick_count;
13321 /* |set_trick_count| must be performed */
13322 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13323 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13324 if ( l+mp->first_count<=mp->half_error_line ) {
13325 p=0; n=l+mp->first_count;
13327 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13328 n=mp->half_error_line;
13330 for (q=p;q<=mp->first_count-1;q++) {
13331 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13334 for (q=1;q<=n;q++) {
13335 mp_print_char(mp, xord(' ')); /* print |n| spaces to begin line~2 */
13337 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13338 else p=mp->first_count+(mp->error_line-n-3);
13339 for (q=mp->first_count;q<=p-1;q++) {
13340 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13342 if ( m+n>mp->error_line ) mp_print(mp, "...")
13344 @ But the trick is distracting us from our current goal, which is to
13345 understand the input state. So let's concentrate on the data structures that
13346 are being pseudoprinted as we finish up the |show_context| procedure.
13348 @<Pseudoprint the line@>=
13351 for (i=start;i<=limit-1;i++) {
13352 if ( i==loc ) set_trick_count;
13353 mp_print_str(mp, mp->buffer[i]);
13357 @ @<Pseudoprint the token list@>=
13359 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13360 else mp_show_macro(mp, start,loc,100000)
13362 @ Here is the missing piece of |show_token_list| that is activated when the
13363 token beginning line~2 is about to be shown:
13365 @<Do magic computation@>=set_trick_count
13367 @* \[28] Maintaining the input stacks.
13368 The following subroutines change the input status in commonly needed ways.
13370 First comes |push_input|, which stores the current state and creates a
13371 new level (having, initially, the same properties as the old).
13373 @d push_input { /* enter a new input level, save the old */
13374 if ( mp->input_ptr>mp->max_in_stack ) {
13375 mp->max_in_stack=mp->input_ptr;
13376 if ( mp->input_ptr==mp->stack_size ) {
13377 int l = (mp->stack_size+(mp->stack_size/4));
13378 XREALLOC(mp->input_stack, l, in_state_record);
13379 mp->stack_size = l;
13382 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13383 incr(mp->input_ptr);
13386 @ And of course what goes up must come down.
13388 @d pop_input { /* leave an input level, re-enter the old */
13389 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13392 @ Here is a procedure that starts a new level of token-list input, given
13393 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13394 set |name|, reset~|loc|, and increase the macro's reference count.
13396 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13399 static void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13400 push_input; start=p; token_type=t;
13401 param_start=mp->param_ptr; loc=p;
13404 @ When a token list has been fully scanned, the following computations
13405 should be done as we leave that level of input.
13409 static void mp_end_token_list (MP mp) { /* leave a token-list input level */
13410 pointer p; /* temporary register */
13411 if ( token_type>=backed_up ) { /* token list to be deleted */
13412 if ( token_type<=inserted ) {
13413 mp_flush_token_list(mp, start); goto DONE;
13415 mp_delete_mac_ref(mp, start); /* update reference count */
13418 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13419 decr(mp->param_ptr);
13420 p=mp->param_stack[mp->param_ptr];
13422 if ( mp_link(p)==mp_void ) { /* it's an \&{expr} parameter */
13423 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13425 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13430 pop_input; check_interrupt;
13433 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13434 token by the |cur_tok| routine.
13437 @c @<Declare the procedure called |make_exp_copy|@>
13438 static pointer mp_cur_tok (MP mp) {
13439 pointer p; /* a new token node */
13440 quarterword save_type; /* |cur_type| to be restored */
13441 integer save_exp; /* |cur_exp| to be restored */
13442 if ( mp->cur_sym==0 ) {
13443 if ( mp->cur_cmd==capsule_token ) {
13444 save_type=mp->cur_type; save_exp=mp->cur_exp;
13445 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); mp_link(p)=null;
13446 mp->cur_type=save_type; mp->cur_exp=save_exp;
13448 p=mp_get_node(mp, token_node_size);
13449 value(p)=mp->cur_mod; mp_name_type(p)=mp_token;
13450 if ( mp->cur_cmd==numeric_token ) mp_type(p)=mp_known;
13451 else mp_type(p)=mp_string_type;
13454 fast_get_avail(p); mp_info(p)=mp->cur_sym;
13459 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13460 seen. The |back_input| procedure takes care of this by putting the token
13461 just scanned back into the input stream, ready to be read again.
13462 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13465 static void mp_back_input (MP mp);
13467 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13468 pointer p; /* a token list of length one */
13470 while ( token_state &&(loc==null) )
13471 mp_end_token_list(mp); /* conserve stack space */
13475 @ The |back_error| routine is used when we want to restore or replace an
13476 offending token just before issuing an error message. We disable interrupts
13477 during the call of |back_input| so that the help message won't be lost.
13479 @ @c static void mp_back_error (MP mp) { /* back up one token and call |error| */
13480 mp->OK_to_interrupt=false;
13482 mp->OK_to_interrupt=true; mp_error(mp);
13484 static void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13485 mp->OK_to_interrupt=false;
13486 mp_back_input(mp); token_type=inserted;
13487 mp->OK_to_interrupt=true; mp_error(mp);
13490 @ The |begin_file_reading| procedure starts a new level of input for lines
13491 of characters to be read from a file, or as an insertion from the
13492 terminal. It does not take care of opening the file, nor does it set |loc|
13493 or |limit| or |line|.
13494 @^system dependencies@>
13496 @c void mp_begin_file_reading (MP mp) {
13497 if ( mp->in_open==mp->max_in_open )
13498 mp_overflow(mp, "text input levels",mp->max_in_open);
13499 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13500 if ( mp->first==mp->buf_size )
13501 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4)));
13502 incr(mp->in_open); push_input; iindex=mp->in_open;
13503 mp->mpx_name[iindex]=absent;
13504 start=(halfword)mp->first;
13505 name=is_term; /* |terminal_input| is now |true| */
13508 @ Conversely, the variables must be downdated when such a level of input
13509 is finished. Any associated \.{MPX} file must also be closed and popped
13510 off the file stack.
13512 @c static void mp_end_file_reading (MP mp) {
13513 if ( mp->in_open>iindex ) {
13514 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13515 mp_confusion(mp, "endinput");
13516 @:this can't happen endinput}{\quad endinput@>
13518 (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13519 delete_str_ref(mp->mpx_name[mp->in_open]);
13523 mp->first=(size_t)start;
13524 if ( iindex!=mp->in_open ) mp_confusion(mp, "endinput");
13525 if ( name>max_spec_src ) {
13526 (mp->close_file)(mp,cur_file);
13527 delete_str_ref(name);
13531 pop_input; decr(mp->in_open);
13534 @ Here is a function that tries to resume input from an \.{MPX} file already
13535 associated with the current input file. It returns |false| if this doesn't
13538 @c static boolean mp_begin_mpx_reading (MP mp) {
13539 if ( mp->in_open!=iindex+1 ) {
13542 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13543 @:this can't happen mpx}{\quad mpx@>
13544 if ( mp->first==mp->buf_size )
13545 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4)));
13546 push_input; iindex=mp->in_open;
13547 start=(halfword)mp->first;
13548 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13549 @<Put an empty line in the input buffer@>;
13554 @ This procedure temporarily stops reading an \.{MPX} file.
13556 @c static void mp_end_mpx_reading (MP mp) {
13557 if ( mp->in_open!=iindex ) mp_confusion(mp, "mpx");
13558 @:this can't happen mpx}{\quad mpx@>
13560 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13562 mp->first=(size_t)start;
13566 @ Here we enforce a restriction that simplifies the input stacks considerably.
13567 This should not inconvenience the user because \.{MPX} files are generated
13568 by an auxiliary program called \.{DVItoMP}.
13570 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13572 print_err("`mpxbreak' must be at the end of a line");
13573 help4("This file contains picture expressions for btex...etex",
13574 "blocks. Such files are normally generated automatically",
13575 "but this one seems to be messed up. I'm going to ignore",
13576 "the rest of this line.");
13580 @ In order to keep the stack from overflowing during a long sequence of
13581 inserted `\.{show}' commands, the following routine removes completed
13582 error-inserted lines from memory.
13584 @c void mp_clear_for_error_prompt (MP mp) {
13585 while ( file_state && terminal_input &&
13586 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13587 mp_print_ln(mp); clear_terminal;
13590 @ To get \MP's whole input mechanism going, we perform the following
13593 @<Initialize the input routines@>=
13594 { mp->input_ptr=0; mp->max_in_stack=0;
13595 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13596 mp->param_ptr=0; mp->max_param_stack=0;
13598 start=1; iindex=0; line=0; name=is_term;
13599 mp->mpx_name[0]=absent;
13600 mp->force_eof=false;
13601 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13602 limit=(halfword)mp->last; mp->first=mp->last+1;
13603 /* |init_terminal| has set |loc| and |last| */
13606 @* \[29] Getting the next token.
13607 The heart of \MP's input mechanism is the |get_next| procedure, which
13608 we shall develop in the next few sections of the program. Perhaps we
13609 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13610 eyes and mouth, reading the source files and gobbling them up. And it also
13611 helps \MP\ to regurgitate stored token lists that are to be processed again.
13613 The main duty of |get_next| is to input one token and to set |cur_cmd|
13614 and |cur_mod| to that token's command code and modifier. Furthermore, if
13615 the input token is a symbolic token, that token's |hash| address
13616 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13618 Underlying this simple description is a certain amount of complexity
13619 because of all the cases that need to be handled.
13620 However, the inner loop of |get_next| is reasonably short and fast.
13622 @ Before getting into |get_next|, we need to consider a mechanism by which
13623 \MP\ helps keep errors from propagating too far. Whenever the program goes
13624 into a mode where it keeps calling |get_next| repeatedly until a certain
13625 condition is met, it sets |scanner_status| to some value other than |normal|.
13626 Then if an input file ends, or if an `\&{outer}' symbol appears,
13627 an appropriate error recovery will be possible.
13629 The global variable |warning_info| helps in this error recovery by providing
13630 additional information. For example, |warning_info| might indicate the
13631 name of a macro whose replacement text is being scanned.
13633 @d normal 0 /* |scanner_status| at ``quiet times'' */
13634 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13635 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13636 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13637 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13638 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13639 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13640 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13643 integer scanner_status; /* are we scanning at high speed? */
13644 integer warning_info; /* if so, what else do we need to know,
13645 in case an error occurs? */
13647 @ @<Initialize the input routines@>=
13648 mp->scanner_status=normal;
13650 @ The following subroutine
13651 is called when an `\&{outer}' symbolic token has been scanned or
13652 when the end of a file has been reached. These two cases are distinguished
13653 by |cur_sym|, which is zero at the end of a file.
13656 static boolean mp_check_outer_validity (MP mp) {
13657 pointer p; /* points to inserted token list */
13658 if ( mp->scanner_status==normal ) {
13660 } else if ( mp->scanner_status==tex_flushing ) {
13661 @<Check if the file has ended while flushing \TeX\ material and set the
13662 result value for |check_outer_validity|@>;
13664 mp->deletions_allowed=false;
13665 @<Back up an outer symbolic token so that it can be reread@>;
13666 if ( mp->scanner_status>skipping ) {
13667 @<Tell the user what has run away and try to recover@>;
13669 print_err("Incomplete if; all text was ignored after line ");
13670 @.Incomplete if...@>
13671 mp_print_int(mp, mp->warning_info);
13672 help3("A forbidden `outer' token occurred in skipped text.",
13673 "This kind of error happens when you say `if...' and forget",
13674 "the matching `fi'. I've inserted a `fi'; this might work.");
13675 if ( mp->cur_sym==0 )
13676 mp->help_line[2]="The file ended while I was skipping conditional text.";
13677 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13679 mp->deletions_allowed=true;
13684 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13685 if ( mp->cur_sym!=0 ) {
13688 mp->deletions_allowed=false;
13689 print_err("TeX mode didn't end; all text was ignored after line ");
13690 mp_print_int(mp, mp->warning_info);
13691 help2("The file ended while I was looking for the `etex' to",
13692 "finish this TeX material. I've inserted `etex' now.");
13693 mp->cur_sym = frozen_etex;
13695 mp->deletions_allowed=true;
13699 @ @<Back up an outer symbolic token so that it can be reread@>=
13700 if ( mp->cur_sym!=0 ) {
13701 p=mp_get_avail(mp); mp_info(p)=mp->cur_sym;
13702 back_list(p); /* prepare to read the symbolic token again */
13705 @ @<Tell the user what has run away...@>=
13707 mp_runaway(mp); /* print the definition-so-far */
13708 if ( mp->cur_sym==0 ) {
13709 print_err("File ended");
13710 @.File ended while scanning...@>
13712 print_err("Forbidden token found");
13713 @.Forbidden token found...@>
13715 mp_print(mp, " while scanning ");
13716 help4("I suspect you have forgotten an `enddef',",
13717 "causing me to read past where you wanted me to stop.",
13718 "I'll try to recover; but if the error is serious,",
13719 "you'd better type `E' or `X' now and fix your file.");
13720 switch (mp->scanner_status) {
13721 @<Complete the error message,
13722 and set |cur_sym| to a token that might help recover from the error@>
13723 } /* there are no other cases */
13727 @ As we consider various kinds of errors, it is also appropriate to
13728 change the first line of the help message just given; |help_line[3]|
13729 points to the string that might be changed.
13731 @<Complete the error message,...@>=
13733 mp_print(mp, "to the end of the statement");
13734 mp->help_line[3]="A previous error seems to have propagated,";
13735 mp->cur_sym=frozen_semicolon;
13738 mp_print(mp, "a text argument");
13739 mp->help_line[3]="It seems that a right delimiter was left out,";
13740 if ( mp->warning_info==0 ) {
13741 mp->cur_sym=frozen_end_group;
13743 mp->cur_sym=frozen_right_delimiter;
13744 equiv(frozen_right_delimiter)=mp->warning_info;
13749 mp_print(mp, "the definition of ");
13750 if ( mp->scanner_status==op_defining )
13751 mp_print_text(mp->warning_info);
13753 mp_print_variable_name(mp, mp->warning_info);
13754 mp->cur_sym=frozen_end_def;
13756 case loop_defining:
13757 mp_print(mp, "the text of a ");
13758 mp_print_text(mp->warning_info);
13759 mp_print(mp, " loop");
13760 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13761 mp->cur_sym=frozen_end_for;
13764 @ The |runaway| procedure displays the first part of the text that occurred
13765 when \MP\ began its special |scanner_status|, if that text has been saved.
13768 static void mp_runaway (MP mp) ;
13771 void mp_runaway (MP mp) {
13772 if ( mp->scanner_status>flushing ) {
13773 mp_print_nl(mp, "Runaway ");
13774 switch (mp->scanner_status) {
13775 case absorbing: mp_print(mp, "text?"); break;
13777 case op_defining: mp_print(mp,"definition?"); break;
13778 case loop_defining: mp_print(mp, "loop?"); break;
13779 } /* there are no other cases */
13781 mp_show_token_list(mp, mp_link(hold_head),null,mp->error_line-10,0);
13785 @ We need to mention a procedure that may be called by |get_next|.
13788 static void mp_firm_up_the_line (MP mp);
13790 @ And now we're ready to take the plunge into |get_next| itself.
13791 Note that the behavior depends on the |scanner_status| because percent signs
13792 and double quotes need to be passed over when skipping TeX material.
13795 void mp_get_next (MP mp) {
13796 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13798 /*restart*/ /* go here to get the next input token */
13799 /*exit*/ /* go here when the next input token has been got */
13800 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13801 /*found*/ /* go here when the end of a symbolic token has been found */
13802 /*switch*/ /* go here to branch on the class of an input character */
13803 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13804 /* go here at crucial stages when scanning a number */
13805 int k; /* an index into |buffer| */
13806 ASCII_code c; /* the current character in the buffer */
13807 int class; /* its class number */
13808 integer n,f; /* registers for decimal-to-binary conversion */
13811 if ( file_state ) {
13812 @<Input from external file; |goto restart| if no input found,
13813 or |return| if a non-symbolic token is found@>;
13815 @<Input from token list; |goto restart| if end of list or
13816 if a parameter needs to be expanded,
13817 or |return| if a non-symbolic token is found@>;
13820 @<Finish getting the symbolic token in |cur_sym|;
13821 |goto restart| if it is illegal@>;
13824 @ When a symbolic token is declared to be `\&{outer}', its command code
13825 is increased by |outer_tag|.
13828 @<Finish getting the symbolic token in |cur_sym|...@>=
13829 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13830 if ( mp->cur_cmd>=outer_tag ) {
13831 if ( mp_check_outer_validity(mp) )
13832 mp->cur_cmd=mp->cur_cmd-outer_tag;
13837 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13838 to have a special test for end-of-line.
13841 @<Input from external file;...@>=
13844 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13846 case digit_class: goto START_NUMERIC_TOKEN; break;
13848 class=mp->char_class[mp->buffer[loc]];
13849 if ( class>period_class ) {
13851 } else if ( class<period_class ) { /* |class=digit_class| */
13852 n=0; goto START_DECIMAL_TOKEN;
13856 case space_class: goto SWITCH; break;
13857 case percent_class:
13858 if ( mp->scanner_status==tex_flushing ) {
13859 if ( loc<limit ) goto SWITCH;
13861 @<Move to next line of file, or |goto restart| if there is no next line@>;
13866 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13867 else @<Get a string token and |return|@>;
13869 case isolated_classes:
13870 k=loc-1; goto FOUND; break;
13871 case invalid_class:
13872 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13873 else @<Decry the invalid character and |goto restart|@>;
13875 default: break; /* letters, etc. */
13878 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13880 START_NUMERIC_TOKEN:
13881 @<Get the integer part |n| of a numeric token;
13882 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13883 START_DECIMAL_TOKEN:
13884 @<Get the fraction part |f| of a numeric token@>;
13886 @<Pack the numeric and fraction parts of a numeric token
13889 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13892 @ We go to |restart| instead of to |SWITCH|, because we might enter
13893 |token_state| after the error has been dealt with
13894 (cf.\ |clear_for_error_prompt|).
13896 @<Decry the invalid...@>=
13898 print_err("Text line contains an invalid character");
13899 @.Text line contains...@>
13900 help2("A funny symbol that I can\'t read has just been input.",
13901 "Continue, and I'll forget that it ever happened.");
13902 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13906 @ @<Get a string token and |return|@>=
13908 if ( mp->buffer[loc]=='"' ) {
13909 mp->cur_mod=null_str;
13911 k=loc; mp->buffer[limit+1]=xord('"');
13914 } while (mp->buffer[loc]!='"');
13916 @<Decry the missing string delimiter and |goto restart|@>;
13919 mp->cur_mod=mp->buffer[k];
13923 append_char(mp->buffer[k]); incr(k);
13925 mp->cur_mod=mp_make_string(mp);
13928 incr(loc); mp->cur_cmd=string_token;
13932 @ We go to |restart| after this error message, not to |SWITCH|,
13933 because the |clear_for_error_prompt| routine might have reinstated
13934 |token_state| after |error| has finished.
13936 @<Decry the missing string delimiter and |goto restart|@>=
13938 loc=limit; /* the next character to be read on this line will be |"%"| */
13939 print_err("Incomplete string token has been flushed");
13940 @.Incomplete string token...@>
13941 help3("Strings should finish on the same line as they began.",
13942 "I've deleted the partial string; you might want to",
13943 "insert another by typing, e.g., `I\"new string\"'.");
13944 mp->deletions_allowed=false; mp_error(mp);
13945 mp->deletions_allowed=true;
13949 @ @<Get the integer part |n| of a numeric token...@>=
13951 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13952 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13955 if ( mp->buffer[loc]=='.' )
13956 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13959 goto FIN_NUMERIC_TOKEN;
13962 @ @<Get the fraction part |f| of a numeric token@>=
13965 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13966 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13969 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13970 f=mp_round_decimals(mp, k);
13975 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13977 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13978 } else if ( mp->scanner_status!=tex_flushing ) {
13979 print_err("Enormous number has been reduced");
13980 @.Enormous number...@>
13981 help2("I can\'t handle numbers bigger than 32767.99998;",
13982 "so I've changed your constant to that maximum amount.");
13983 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13984 mp->cur_mod=el_gordo;
13986 mp->cur_cmd=numeric_token; return
13988 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13990 mp->cur_mod=n*unity+f;
13991 if ( mp->cur_mod>=fraction_one ) {
13992 if ( (mp->internal[mp_warning_check]>0) &&
13993 (mp->scanner_status!=tex_flushing) ) {
13994 print_err("Number is too large (");
13995 mp_print_scaled(mp, mp->cur_mod);
13996 mp_print_char(mp, xord(')'));
13997 help3("It is at least 4096. Continue and I'll try to cope",
13998 "with that big value; but it might be dangerous.",
13999 "(Set warningcheck:=0 to suppress this message.)");
14005 @ Let's consider now what happens when |get_next| is looking at a token list.
14008 @<Input from token list;...@>=
14009 if ( loc>=mp->hi_mem_min ) { /* one-word token */
14010 mp->cur_sym=mp_info(loc); loc=mp_link(loc); /* move to next */
14011 if ( mp->cur_sym>=expr_base ) {
14012 if ( mp->cur_sym>=suffix_base ) {
14013 @<Insert a suffix or text parameter and |goto restart|@>;
14015 mp->cur_cmd=capsule_token;
14016 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
14017 mp->cur_sym=0; return;
14020 } else if ( loc>null ) {
14021 @<Get a stored numeric or string or capsule token and |return|@>
14022 } else { /* we are done with this token list */
14023 mp_end_token_list(mp); goto RESTART; /* resume previous level */
14026 @ @<Insert a suffix or text parameter...@>=
14028 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
14029 /* |param_size=text_base-suffix_base| */
14030 mp_begin_token_list(mp,
14031 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
14036 @ @<Get a stored numeric or string or capsule token...@>=
14038 if ( mp_name_type(loc)==mp_token ) {
14039 mp->cur_mod=value(loc);
14040 if ( mp_type(loc)==mp_known ) {
14041 mp->cur_cmd=numeric_token;
14043 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
14046 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
14048 loc=mp_link(loc); return;
14051 @ All of the easy branches of |get_next| have now been taken care of.
14052 There is one more branch.
14054 @<Move to next line of file, or |goto restart|...@>=
14055 if ( name>max_spec_src) {
14056 @<Read next line of file into |buffer|, or
14057 |goto restart| if the file has ended@>;
14059 if ( mp->input_ptr>0 ) {
14060 /* text was inserted during error recovery or by \&{scantokens} */
14061 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
14063 if (mp->job_name == NULL && ( mp->selector<log_only || mp->selector>=write_file))
14064 mp_open_log_file(mp);
14065 if ( mp->interaction>mp_nonstop_mode ) {
14066 if ( limit==start ) /* previous line was empty */
14067 mp_print_nl(mp, "(Please type a command or say `end')");
14069 mp_print_ln(mp); mp->first=(size_t)start;
14070 prompt_input("*"); /* input on-line into |buffer| */
14072 limit=(halfword)mp->last; mp->buffer[limit]=xord('%');
14073 mp->first=(size_t)(limit+1); loc=start;
14075 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
14077 /* nonstop mode, which is intended for overnight batch processing,
14078 never waits for on-line input */
14082 @ The global variable |force_eof| is normally |false|; it is set |true|
14083 by an \&{endinput} command.
14086 boolean force_eof; /* should the next \&{input} be aborted early? */
14088 @ We must decrement |loc| in order to leave the buffer in a valid state
14089 when an error condition causes us to |goto restart| without calling
14090 |end_file_reading|.
14092 @<Read next line of file into |buffer|, or
14093 |goto restart| if the file has ended@>=
14095 incr(line); mp->first=(size_t)start;
14096 if ( ! mp->force_eof ) {
14097 if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
14098 mp_firm_up_the_line(mp); /* this sets |limit| */
14100 mp->force_eof=true;
14102 if ( mp->force_eof ) {
14103 mp->force_eof=false;
14105 if ( mpx_reading ) {
14106 @<Complain that the \.{MPX} file ended unexpectly; then set
14107 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
14109 mp_print_char(mp, xord(')')); decr(mp->open_parens);
14110 update_terminal; /* show user that file has been read */
14111 mp_end_file_reading(mp); /* resume previous level */
14112 if ( mp_check_outer_validity(mp) ) goto RESTART;
14116 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start; /* ready to read */
14119 @ We should never actually come to the end of an \.{MPX} file because such
14120 files should have an \&{mpxbreak} after the translation of the last
14121 \&{btex}$\,\ldots\,$\&{etex} block.
14123 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
14125 mp->mpx_name[iindex]=mpx_finished;
14126 print_err("mpx file ended unexpectedly");
14127 help4("The file had too few picture expressions for btex...etex",
14128 "blocks. Such files are normally generated automatically",
14129 "but this one got messed up. You might want to insert a",
14130 "picture expression now.");
14131 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
14132 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
14135 @ Sometimes we want to make it look as though we have just read a blank line
14136 without really doing so.
14138 @<Put an empty line in the input buffer@>=
14139 mp->last=mp->first; limit=(halfword)mp->last;
14140 /* simulate |input_ln| and |firm_up_the_line| */
14141 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start
14143 @ If the user has set the |mp_pausing| parameter to some positive value,
14144 and if nonstop mode has not been selected, each line of input is displayed
14145 on the terminal and the transcript file, followed by `\.{=>}'.
14146 \MP\ waits for a response. If the response is null (i.e., if nothing is
14147 typed except perhaps a few blank spaces), the original
14148 line is accepted as it stands; otherwise the line typed is
14149 used instead of the line in the file.
14151 @c void mp_firm_up_the_line (MP mp) {
14152 size_t k; /* an index into |buffer| */
14153 limit=(halfword)mp->last;
14154 if ((!mp->noninteractive)
14155 && (mp->internal[mp_pausing]>0 )
14156 && (mp->interaction>mp_nonstop_mode )) {
14157 wake_up_terminal; mp_print_ln(mp);
14158 if ( start<limit ) {
14159 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
14160 mp_print_str(mp, mp->buffer[k]);
14163 mp->first=(size_t)limit; prompt_input("=>"); /* wait for user response */
14165 if ( mp->last>mp->first ) {
14166 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
14167 mp->buffer[k+start-mp->first]=mp->buffer[k];
14169 limit=(halfword)(start+mp->last-mp->first);
14174 @* \[30] Dealing with \TeX\ material.
14175 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
14176 features need to be implemented at a low level in the scanning process
14177 so that \MP\ can stay in synch with the a preprocessor that treats
14178 blocks of \TeX\ material as they occur in the input file without trying
14179 to expand \MP\ macros. Thus we need a special version of |get_next|
14180 that does not expand macros and such but does handle \&{btex},
14181 \&{verbatimtex}, etc.
14183 The special version of |get_next| is called |get_t_next|. It works by flushing
14184 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
14185 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
14186 \&{btex}, and switching back when it sees \&{mpxbreak}.
14192 mp_primitive(mp, "btex",start_tex,btex_code);
14193 @:btex_}{\&{btex} primitive@>
14194 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
14195 @:verbatimtex_}{\&{verbatimtex} primitive@>
14196 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
14197 @:etex_}{\&{etex} primitive@>
14198 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
14199 @:mpx_break_}{\&{mpxbreak} primitive@>
14201 @ @<Cases of |print_cmd...@>=
14202 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
14203 else mp_print(mp, "verbatimtex"); break;
14204 case etex_marker: mp_print(mp, "etex"); break;
14205 case mpx_break: mp_print(mp, "mpxbreak"); break;
14207 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
14208 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
14211 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
14214 static void mp_start_mpx_input (MP mp);
14217 static void mp_t_next (MP mp) {
14218 int old_status; /* saves the |scanner_status| */
14219 integer old_info; /* saves the |warning_info| */
14220 while ( mp->cur_cmd<=max_pre_command ) {
14221 if ( mp->cur_cmd==mpx_break ) {
14222 if ( ! file_state || (mp->mpx_name[iindex]==absent) ) {
14223 @<Complain about a misplaced \&{mpxbreak}@>;
14225 mp_end_mpx_reading(mp);
14228 } else if ( mp->cur_cmd==start_tex ) {
14229 if ( token_state || (name<=max_spec_src) ) {
14230 @<Complain that we are not reading a file@>;
14231 } else if ( mpx_reading ) {
14232 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
14233 } else if ( (mp->cur_mod!=verbatim_code)&&
14234 (mp->mpx_name[iindex]!=mpx_finished) ) {
14235 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
14240 @<Complain about a misplaced \&{etex}@>;
14242 goto COMMON_ENDING;
14244 @<Flush the \TeX\ material@>;
14250 @ We could be in the middle of an operation such as skipping false conditional
14251 text when \TeX\ material is encountered, so we must be careful to save the
14254 @<Flush the \TeX\ material@>=
14255 old_status=mp->scanner_status;
14256 old_info=mp->warning_info;
14257 mp->scanner_status=tex_flushing;
14258 mp->warning_info=line;
14259 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14260 mp->scanner_status=old_status;
14261 mp->warning_info=old_info
14263 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14264 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14265 help4("This file contains picture expressions for btex...etex",
14266 "blocks. Such files are normally generated automatically",
14267 "but this one seems to be messed up. I'll just keep going",
14268 "and hope for the best.");
14272 @ @<Complain that we are not reading a file@>=
14273 { print_err("You can only use `btex' or `verbatimtex' in a file");
14274 help3("I'll have to ignore this preprocessor command because it",
14275 "only works when there is a file to preprocess. You might",
14276 "want to delete everything up to the next `etex`.");
14280 @ @<Complain about a misplaced \&{mpxbreak}@>=
14281 { print_err("Misplaced mpxbreak");
14282 help2("I'll ignore this preprocessor command because it",
14283 "doesn't belong here");
14287 @ @<Complain about a misplaced \&{etex}@>=
14288 { print_err("Extra etex will be ignored");
14289 help1("There is no btex or verbatimtex for this to match");
14293 @* \[31] Scanning macro definitions.
14294 \MP\ has a variety of ways to tuck tokens away into token lists for later
14295 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14296 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14297 All such operations are handled by the routines in this part of the program.
14299 The modifier part of each command code is zero for the ``ending delimiters''
14300 like \&{enddef} and \&{endfor}.
14302 @d start_def 1 /* command modifier for \&{def} */
14303 @d var_def 2 /* command modifier for \&{vardef} */
14304 @d end_def 0 /* command modifier for \&{enddef} */
14305 @d start_forever 1 /* command modifier for \&{forever} */
14306 @d end_for 0 /* command modifier for \&{endfor} */
14309 mp_primitive(mp, "def",macro_def,start_def);
14310 @:def_}{\&{def} primitive@>
14311 mp_primitive(mp, "vardef",macro_def,var_def);
14312 @:var_def_}{\&{vardef} primitive@>
14313 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14314 @:primary_def_}{\&{primarydef} primitive@>
14315 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14316 @:secondary_def_}{\&{secondarydef} primitive@>
14317 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14318 @:tertiary_def_}{\&{tertiarydef} primitive@>
14319 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14320 @:end_def_}{\&{enddef} primitive@>
14322 mp_primitive(mp, "for",iteration,expr_base);
14323 @:for_}{\&{for} primitive@>
14324 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14325 @:for_suffixes_}{\&{forsuffixes} primitive@>
14326 mp_primitive(mp, "forever",iteration,start_forever);
14327 @:forever_}{\&{forever} primitive@>
14328 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14329 @:end_for_}{\&{endfor} primitive@>
14331 @ @<Cases of |print_cmd...@>=
14333 if ( m<=var_def ) {
14334 if ( m==start_def ) mp_print(mp, "def");
14335 else if ( m<start_def ) mp_print(mp, "enddef");
14336 else mp_print(mp, "vardef");
14337 } else if ( m==secondary_primary_macro ) {
14338 mp_print(mp, "primarydef");
14339 } else if ( m==tertiary_secondary_macro ) {
14340 mp_print(mp, "secondarydef");
14342 mp_print(mp, "tertiarydef");
14346 if ( m<=start_forever ) {
14347 if ( m==start_forever ) mp_print(mp, "forever");
14348 else mp_print(mp, "endfor");
14349 } else if ( m==expr_base ) {
14350 mp_print(mp, "for");
14352 mp_print(mp, "forsuffixes");
14356 @ Different macro-absorbing operations have different syntaxes, but they
14357 also have a lot in common. There is a list of special symbols that are to
14358 be replaced by parameter tokens; there is a special command code that
14359 ends the definition; the quotation conventions are identical. Therefore
14360 it makes sense to have most of the work done by a single subroutine. That
14361 subroutine is called |scan_toks|.
14363 The first parameter to |scan_toks| is the command code that will
14364 terminate scanning (either |macro_def| or |iteration|).
14366 The second parameter, |subst_list|, points to a (possibly empty) list
14367 of two-word nodes whose |info| and |value| fields specify symbol tokens
14368 before and after replacement. The list will be returned to free storage
14371 The third parameter is simply appended to the token list that is built.
14372 And the final parameter tells how many of the special operations
14373 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14374 When such parameters are present, they are called \.{(SUFFIX0)},
14375 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14377 @c static pointer mp_scan_toks (MP mp,command_code terminator, pointer
14378 subst_list, pointer tail_end, quarterword suffix_count) {
14379 pointer p; /* tail of the token list being built */
14380 pointer q; /* temporary for link management */
14381 integer balance; /* left delimiters minus right delimiters */
14382 p=hold_head; balance=1; mp_link(hold_head)=null;
14385 if ( mp->cur_sym>0 ) {
14386 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14387 if ( mp->cur_cmd==terminator ) {
14388 @<Adjust the balance; |break| if it's zero@>;
14389 } else if ( mp->cur_cmd==macro_special ) {
14390 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14393 mp_link(p)=mp_cur_tok(mp); p=mp_link(p);
14395 mp_link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14396 return mp_link(hold_head);
14399 @ @<Substitute for |cur_sym|...@>=
14402 while ( q!=null ) {
14403 if ( mp_info(q)==mp->cur_sym ) {
14404 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14410 @ @<Adjust the balance; |break| if it's zero@>=
14411 if ( mp->cur_mod>0 ) {
14419 @ Four commands are intended to be used only within macro texts: \&{quote},
14420 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14421 code called |macro_special|.
14423 @d quote 0 /* |macro_special| modifier for \&{quote} */
14424 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14425 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14426 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14429 mp_primitive(mp, "quote",macro_special,quote);
14430 @:quote_}{\&{quote} primitive@>
14431 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14432 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14433 mp_primitive(mp, "@@",macro_special,macro_at);
14434 @:]]]\AT!_}{\.{\AT!} primitive@>
14435 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14436 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14438 @ @<Cases of |print_cmd...@>=
14439 case macro_special:
14441 case macro_prefix: mp_print(mp, "#@@"); break;
14442 case macro_at: mp_print_char(mp, xord('@@')); break;
14443 case macro_suffix: mp_print(mp, "@@#"); break;
14444 default: mp_print(mp, "quote"); break;
14448 @ @<Handle quoted...@>=
14450 if ( mp->cur_mod==quote ) { get_t_next; }
14451 else if ( mp->cur_mod<=suffix_count )
14452 mp->cur_sym=suffix_base-1+mp->cur_mod;
14455 @ Here is a routine that's used whenever a token will be redefined. If
14456 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14457 substituted; the latter is redefinable but essentially impossible to use,
14458 hence \MP's tables won't get fouled up.
14460 @c static void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14463 if ( (mp->cur_sym==0)||(mp->cur_sym>(integer)frozen_inaccessible) ) {
14464 print_err("Missing symbolic token inserted");
14465 @.Missing symbolic token...@>
14466 help3("Sorry: You can\'t redefine a number, string, or expr.",
14467 "I've inserted an inaccessible symbol so that your",
14468 "definition will be completed without mixing me up too badly.");
14469 if ( mp->cur_sym>0 )
14470 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14471 else if ( mp->cur_cmd==string_token )
14472 delete_str_ref(mp->cur_mod);
14473 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14477 @ Before we actually redefine a symbolic token, we need to clear away its
14478 former value, if it was a variable. The following stronger version of
14479 |get_symbol| does that.
14481 @c static void mp_get_clear_symbol (MP mp) {
14482 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14485 @ Here's another little subroutine; it checks that an equals sign
14486 or assignment sign comes along at the proper place in a macro definition.
14488 @c static void mp_check_equals (MP mp) {
14489 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14490 mp_missing_err(mp, "=");
14492 help5("The next thing in this `def' should have been `=',",
14493 "because I've already looked at the definition heading.",
14494 "But don't worry; I'll pretend that an equals sign",
14495 "was present. Everything from here to `enddef'",
14496 "will be the replacement text of this macro.");
14501 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14502 handled now that we have |scan_toks|. In this case there are
14503 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14504 |expr_base| and |expr_base+1|).
14506 @c static void mp_make_op_def (MP mp) {
14507 command_code m; /* the type of definition */
14508 pointer p,q,r; /* for list manipulation */
14510 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14511 mp_info(q)=mp->cur_sym; value(q)=expr_base;
14512 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14513 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14514 mp_info(p)=mp->cur_sym; value(p)=expr_base+1; mp_link(p)=q;
14515 get_t_next; mp_check_equals(mp);
14516 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14517 r=mp_get_avail(mp); mp_link(q)=r; mp_info(r)=general_macro;
14518 mp_link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14519 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14520 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14523 @ Parameters to macros are introduced by the keywords \&{expr},
14524 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14527 mp_primitive(mp, "expr",param_type,expr_base);
14528 @:expr_}{\&{expr} primitive@>
14529 mp_primitive(mp, "suffix",param_type,suffix_base);
14530 @:suffix_}{\&{suffix} primitive@>
14531 mp_primitive(mp, "text",param_type,text_base);
14532 @:text_}{\&{text} primitive@>
14533 mp_primitive(mp, "primary",param_type,primary_macro);
14534 @:primary_}{\&{primary} primitive@>
14535 mp_primitive(mp, "secondary",param_type,secondary_macro);
14536 @:secondary_}{\&{secondary} primitive@>
14537 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14538 @:tertiary_}{\&{tertiary} primitive@>
14540 @ @<Cases of |print_cmd...@>=
14542 if ( m>=expr_base ) {
14543 if ( m==expr_base ) mp_print(mp, "expr");
14544 else if ( m==suffix_base ) mp_print(mp, "suffix");
14545 else mp_print(mp, "text");
14546 } else if ( m<secondary_macro ) {
14547 mp_print(mp, "primary");
14548 } else if ( m==secondary_macro ) {
14549 mp_print(mp, "secondary");
14551 mp_print(mp, "tertiary");
14555 @ Let's turn next to the more complex processing associated with \&{def}
14556 and \&{vardef}. When the following procedure is called, |cur_mod|
14557 should be either |start_def| or |var_def|.
14560 static void mp_scan_def (MP mp) {
14561 int m; /* the type of definition */
14562 int n; /* the number of special suffix parameters */
14563 int k; /* the total number of parameters */
14564 int c; /* the kind of macro we're defining */
14565 pointer r; /* parameter-substitution list */
14566 pointer q; /* tail of the macro token list */
14567 pointer p; /* temporary storage */
14568 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14569 pointer l_delim,r_delim; /* matching delimiters */
14570 m=mp->cur_mod; c=general_macro; mp_link(hold_head)=null;
14571 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14572 @<Scan the token or variable to be defined;
14573 set |n|, |scanner_status|, and |warning_info|@>;
14575 if ( mp->cur_cmd==left_delimiter ) {
14576 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14578 if ( mp->cur_cmd==param_type ) {
14579 @<Absorb undelimited parameters, putting them into list |r|@>;
14581 mp_check_equals(mp);
14582 p=mp_get_avail(mp); mp_info(p)=c; mp_link(q)=p;
14583 @<Attach the replacement text to the tail of node |p|@>;
14584 mp->scanner_status=normal; mp_get_x_next(mp);
14587 @ We don't put `|frozen_end_group|' into the replacement text of
14588 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14590 @<Attach the replacement text to the tail of node |p|@>=
14591 if ( m==start_def ) {
14592 mp_link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14594 q=mp_get_avail(mp); mp_info(q)=mp->bg_loc; mp_link(p)=q;
14595 p=mp_get_avail(mp); mp_info(p)=mp->eg_loc;
14596 mp_link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14598 if ( mp->warning_info==bad_vardef )
14599 mp_flush_token_list(mp, value(bad_vardef))
14603 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14605 @ @<Scan the token or variable to be defined;...@>=
14606 if ( m==start_def ) {
14607 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14608 mp->scanner_status=op_defining; n=0;
14609 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14611 p=mp_scan_declared_variable(mp);
14612 mp_flush_variable(mp, equiv(mp_info(p)),mp_link(p),true);
14613 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14614 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14615 mp->scanner_status=var_defining; n=2;
14616 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14619 mp_type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14620 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14622 @ @<Change to `\.{a bad variable}'@>=
14624 print_err("This variable already starts with a macro");
14625 @.This variable already...@>
14626 help2("After `vardef a' you can\'t say `vardef a.b'.",
14627 "So I'll have to discard this definition.");
14628 mp_error(mp); mp->warning_info=bad_vardef;
14631 @ @<Initialize table entries...@>=
14632 mp_name_type(bad_vardef)=mp_root; mp_link(bad_vardef)=frozen_bad_vardef;
14633 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14635 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14637 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14638 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14641 print_err("Missing parameter type; `expr' will be assumed");
14642 @.Missing parameter type@>
14643 help1("You should've had `expr' or `suffix' or `text' here.");
14644 mp_back_error(mp); base=expr_base;
14646 @<Absorb parameter tokens for type |base|@>;
14647 mp_check_delimiter(mp, l_delim,r_delim);
14649 } while (mp->cur_cmd==left_delimiter)
14651 @ @<Absorb parameter tokens for type |base|@>=
14653 mp_link(q)=mp_get_avail(mp); q=mp_link(q); mp_info(q)=base+k;
14654 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14655 value(p)=base+k; mp_info(p)=mp->cur_sym;
14656 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14657 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14658 incr(k); mp_link(p)=r; r=p; get_t_next;
14659 } while (mp->cur_cmd==comma)
14661 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14663 p=mp_get_node(mp, token_node_size);
14664 if ( mp->cur_mod<expr_base ) {
14665 c=mp->cur_mod; value(p)=expr_base+k;
14667 value(p)=mp->cur_mod+k;
14668 if ( mp->cur_mod==expr_base ) c=expr_macro;
14669 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14672 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14673 incr(k); mp_get_symbol(mp); mp_info(p)=mp->cur_sym; mp_link(p)=r; r=p; get_t_next;
14674 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14675 c=of_macro; p=mp_get_node(mp, token_node_size);
14676 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14677 value(p)=expr_base+k; mp_get_symbol(mp); mp_info(p)=mp->cur_sym;
14678 mp_link(p)=r; r=p; get_t_next;
14682 @* \[32] Expanding the next token.
14683 Only a few command codes |<min_command| can possibly be returned by
14684 |get_t_next|; in increasing order, they are
14685 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14686 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14688 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14689 like |get_t_next| except that it keeps getting more tokens until
14690 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14691 macros and removes conditionals or iterations or input instructions that
14694 It follows that |get_x_next| might invoke itself recursively. In fact,
14695 there is massive recursion, since macro expansion can involve the
14696 scanning of arbitrarily complex expressions, which in turn involve
14697 macro expansion and conditionals, etc.
14700 Therefore it's necessary to declare a whole bunch of |forward|
14701 procedures at this point, and to insert some other procedures
14702 that will be invoked by |get_x_next|.
14705 static void mp_scan_primary (MP mp);
14706 static void mp_scan_secondary (MP mp);
14707 static void mp_scan_tertiary (MP mp);
14708 static void mp_scan_expression (MP mp);
14709 static void mp_scan_suffix (MP mp);
14710 static void mp_get_boolean (MP mp);
14711 static void mp_pass_text (MP mp);
14712 static void mp_conditional (MP mp);
14713 static void mp_start_input (MP mp);
14714 static void mp_begin_iteration (MP mp);
14715 static void mp_resume_iteration (MP mp);
14716 static void mp_stop_iteration (MP mp);
14718 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14719 when it has to do exotic expansion commands.
14722 static void mp_expand (MP mp) {
14723 pointer p; /* for list manipulation */
14724 size_t k; /* something that we hope is |<=buf_size| */
14725 pool_pointer j; /* index into |str_pool| */
14726 if ( mp->internal[mp_tracing_commands]>unity )
14727 if ( mp->cur_cmd!=defined_macro )
14729 switch (mp->cur_cmd) {
14731 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14734 @<Terminate the current conditional and skip to \&{fi}@>;
14737 @<Initiate or terminate input from a file@>;
14740 if ( mp->cur_mod==end_for ) {
14741 @<Scold the user for having an extra \&{endfor}@>;
14743 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14750 @<Exit a loop if the proper time has come@>;
14755 @<Expand the token after the next token@>;
14758 @<Put a string into the input buffer@>;
14760 case defined_macro:
14761 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14763 }; /* there are no other cases */
14766 @ @<Scold the user...@>=
14768 print_err("Extra `endfor'");
14770 help2("I'm not currently working on a for loop,",
14771 "so I had better not try to end anything.");
14775 @ The processing of \&{input} involves the |start_input| subroutine,
14776 which will be declared later; the processing of \&{endinput} is trivial.
14779 mp_primitive(mp, "input",input,0);
14780 @:input_}{\&{input} primitive@>
14781 mp_primitive(mp, "endinput",input,1);
14782 @:end_input_}{\&{endinput} primitive@>
14784 @ @<Cases of |print_cmd_mod|...@>=
14786 if ( m==0 ) mp_print(mp, "input");
14787 else mp_print(mp, "endinput");
14790 @ @<Initiate or terminate input...@>=
14791 if ( mp->cur_mod>0 ) mp->force_eof=true;
14792 else mp_start_input(mp)
14794 @ We'll discuss the complicated parts of loop operations later. For now
14795 it suffices to know that there's a global variable called |loop_ptr|
14796 that will be |null| if no loop is in progress.
14799 { while ( token_state &&(loc==null) )
14800 mp_end_token_list(mp); /* conserve stack space */
14801 if ( mp->loop_ptr==null ) {
14802 print_err("Lost loop");
14804 help2("I'm confused; after exiting from a loop, I still seem",
14805 "to want to repeat it. I'll try to forget the problem.");
14808 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14812 @ @<Exit a loop if the proper time has come@>=
14813 { mp_get_boolean(mp);
14814 if ( mp->internal[mp_tracing_commands]>unity )
14815 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14816 if ( mp->cur_exp==true_code ) {
14817 if ( mp->loop_ptr==null ) {
14818 print_err("No loop is in progress");
14819 @.No loop is in progress@>
14820 help1("Why say `exitif' when there's nothing to exit from?");
14821 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14823 @<Exit prematurely from an iteration@>;
14825 } else if ( mp->cur_cmd!=semicolon ) {
14826 mp_missing_err(mp, ";");
14828 help2("After `exitif <boolean exp>' I expect to see a semicolon.",
14829 "I shall pretend that one was there."); mp_back_error(mp);
14833 @ Here we use the fact that |forever_text| is the only |token_type| that
14834 is less than |loop_text|.
14836 @<Exit prematurely...@>=
14839 if ( file_state ) {
14840 mp_end_file_reading(mp);
14842 if ( token_type<=loop_text ) p=start;
14843 mp_end_token_list(mp);
14846 if ( p!=mp_info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14848 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14851 @ @<Expand the token after the next token@>=
14853 p=mp_cur_tok(mp); get_t_next;
14854 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14855 else mp_back_input(mp);
14859 @ @<Put a string into the input buffer@>=
14860 { mp_get_x_next(mp); mp_scan_primary(mp);
14861 if ( mp->cur_type!=mp_string_type ) {
14862 mp_disp_err(mp, null,"Not a string");
14864 help2("I'm going to flush this expression, since",
14865 "scantokens should be followed by a known string.");
14866 mp_put_get_flush_error(mp, 0);
14869 if ( length(mp->cur_exp)>0 )
14870 @<Pretend we're reading a new one-line file@>;
14874 @ @<Pretend we're reading a new one-line file@>=
14875 { mp_begin_file_reading(mp); name=is_scantok;
14876 k=mp->first+length(mp->cur_exp);
14877 if ( k>=mp->max_buf_stack ) {
14878 while ( k>=mp->buf_size ) {
14879 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4)));
14881 mp->max_buf_stack=k+1;
14883 j=mp->str_start[mp->cur_exp]; limit=(halfword)k;
14884 while ( mp->first<(size_t)limit ) {
14885 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14887 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start;
14888 mp_flush_cur_exp(mp, 0);
14891 @ Here finally is |get_x_next|.
14893 The expression scanning routines to be considered later
14894 communicate via the global quantities |cur_type| and |cur_exp|;
14895 we must be very careful to save and restore these quantities while
14896 macros are being expanded.
14900 static void mp_get_x_next (MP mp);
14902 @ @c void mp_get_x_next (MP mp) {
14903 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14905 if ( mp->cur_cmd<min_command ) {
14906 save_exp=mp_stash_cur_exp(mp);
14908 if ( mp->cur_cmd==defined_macro )
14909 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14913 } while (mp->cur_cmd<min_command);
14914 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14918 @ Now let's consider the |macro_call| procedure, which is used to start up
14919 all user-defined macros. Since the arguments to a macro might be expressions,
14920 |macro_call| is recursive.
14923 The first parameter to |macro_call| points to the reference count of the
14924 token list that defines the macro. The second parameter contains any
14925 arguments that have already been parsed (see below). The third parameter
14926 points to the symbolic token that names the macro. If the third parameter
14927 is |null|, the macro was defined by \&{vardef}, so its name can be
14928 reconstructed from the prefix and ``at'' arguments found within the
14931 What is this second parameter? It's simply a linked list of one-word items,
14932 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14933 no arguments have been scanned yet; otherwise |mp_info(arg_list)| points to
14934 the first scanned argument, and |mp_link(arg_list)| points to the list of
14935 further arguments (if any).
14937 Arguments of type \&{expr} are so-called capsules, which we will
14938 discuss later when we concentrate on expressions; they can be
14939 recognized easily because their |link| field is |void|. Arguments of type
14940 \&{suffix} and \&{text} are token lists without reference counts.
14942 @ After argument scanning is complete, the arguments are moved to the
14943 |param_stack|. (They can't be put on that stack any sooner, because
14944 the stack is growing and shrinking in unpredictable ways as more arguments
14945 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14946 the replacement text of the macro is placed at the top of the \MP's
14947 input stack, so that |get_t_next| will proceed to read it next.
14950 static void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14951 pointer macro_name) ;
14954 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14955 pointer macro_name) {
14956 /* invokes a user-defined control sequence */
14957 pointer r; /* current node in the macro's token list */
14958 pointer p,q; /* for list manipulation */
14959 integer n; /* the number of arguments */
14960 pointer tail = 0; /* tail of the argument list */
14961 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14962 r=mp_link(def_ref); add_mac_ref(def_ref);
14963 if ( arg_list==null ) {
14966 @<Determine the number |n| of arguments already supplied,
14967 and set |tail| to the tail of |arg_list|@>;
14969 if ( mp->internal[mp_tracing_macros]>0 ) {
14970 @<Show the text of the macro being expanded, and the existing arguments@>;
14972 @<Scan the remaining arguments, if any; set |r| to the first token
14973 of the replacement text@>;
14974 @<Feed the arguments and replacement text to the scanner@>;
14977 @ @<Show the text of the macro...@>=
14978 mp_begin_diagnostic(mp); mp_print_ln(mp);
14979 mp_print_macro_name(mp, arg_list,macro_name);
14980 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14981 mp_show_macro(mp, def_ref,null,100000);
14982 if ( arg_list!=null ) {
14986 mp_print_arg(mp, q,n,0);
14987 incr(n); p=mp_link(p);
14990 mp_end_diagnostic(mp, false)
14993 @ @<Declarations@>=
14994 static void mp_print_macro_name (MP mp,pointer a, pointer n);
14997 void mp_print_macro_name (MP mp,pointer a, pointer n) {
14998 pointer p,q; /* they traverse the first part of |a| */
15004 mp_print_text(mp_info(mp_info(mp_link(a))));
15007 while ( mp_link(q)!=null ) q=mp_link(q);
15008 mp_link(q)=mp_info(mp_link(a));
15009 mp_show_token_list(mp, p,null,1000,0);
15015 @ @<Declarations@>=
15016 static void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
15019 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
15020 if ( mp_link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
15021 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
15022 else mp_print_nl(mp, "(TEXT");
15023 mp_print_int(mp, n); mp_print(mp, ")<-");
15024 if ( mp_link(q)==mp_void ) mp_print_exp(mp, q,1);
15025 else mp_show_token_list(mp, q,null,1000,0);
15028 @ @<Determine the number |n| of arguments already supplied...@>=
15030 n=1; tail=arg_list;
15031 while ( mp_link(tail)!=null ) {
15032 incr(n); tail=mp_link(tail);
15036 @ @<Scan the remaining arguments, if any; set |r|...@>=
15037 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
15038 while ( mp_info(r)>=expr_base ) {
15039 @<Scan the delimited argument represented by |mp_info(r)|@>;
15042 if ( mp->cur_cmd==comma ) {
15043 print_err("Too many arguments to ");
15044 @.Too many arguments...@>
15045 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, xord(';'));
15046 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
15048 mp_print(mp, "' has been inserted");
15049 help3("I'm going to assume that the comma I just read was a",
15050 "right delimiter, and then I'll begin expanding the macro.",
15051 "You might want to delete some tokens before continuing.");
15054 if ( mp_info(r)!=general_macro ) {
15055 @<Scan undelimited argument(s)@>;
15059 @ At this point, the reader will find it advisable to review the explanation
15060 of token list format that was presented earlier, paying special attention to
15061 the conventions that apply only at the beginning of a macro's token list.
15063 On the other hand, the reader will have to take the expression-parsing
15064 aspects of the following program on faith; we will explain |cur_type|
15065 and |cur_exp| later. (Several things in this program depend on each other,
15066 and it's necessary to jump into the circle somewhere.)
15068 @<Scan the delimited argument represented by |mp_info(r)|@>=
15069 if ( mp->cur_cmd!=comma ) {
15071 if ( mp->cur_cmd!=left_delimiter ) {
15072 print_err("Missing argument to ");
15073 @.Missing argument...@>
15074 mp_print_macro_name(mp, arg_list,macro_name);
15075 help3("That macro has more parameters than you thought.",
15076 "I'll continue by pretending that each missing argument",
15077 "is either zero or null.");
15078 if ( mp_info(r)>=suffix_base ) {
15079 mp->cur_exp=null; mp->cur_type=mp_token_list;
15081 mp->cur_exp=0; mp->cur_type=mp_known;
15083 mp_back_error(mp); mp->cur_cmd=right_delimiter;
15086 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
15088 @<Scan the argument represented by |mp_info(r)|@>;
15089 if ( mp->cur_cmd!=comma )
15090 @<Check that the proper right delimiter was present@>;
15092 @<Append the current expression to |arg_list|@>
15094 @ @<Check that the proper right delim...@>=
15095 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15096 if ( mp_info(mp_link(r))>=expr_base ) {
15097 mp_missing_err(mp, ",");
15099 help3("I've finished reading a macro argument and am about to",
15100 "read another; the arguments weren't delimited correctly.",
15101 "You might want to delete some tokens before continuing.");
15102 mp_back_error(mp); mp->cur_cmd=comma;
15104 mp_missing_err(mp, str(text(r_delim)));
15106 help2("I've gotten to the end of the macro parameter list.",
15107 "You might want to delete some tokens before continuing.");
15112 @ A \&{suffix} or \&{text} parameter will have been scanned as
15113 a token list pointed to by |cur_exp|, in which case we will have
15114 |cur_type=token_list|.
15116 @<Append the current expression to |arg_list|@>=
15118 p=mp_get_avail(mp);
15119 if ( mp->cur_type==mp_token_list ) mp_info(p)=mp->cur_exp;
15120 else mp_info(p)=mp_stash_cur_exp(mp);
15121 if ( mp->internal[mp_tracing_macros]>0 ) {
15122 mp_begin_diagnostic(mp); mp_print_arg(mp, mp_info(p),n,mp_info(r));
15123 mp_end_diagnostic(mp, false);
15125 if ( arg_list==null ) arg_list=p;
15126 else mp_link(tail)=p;
15130 @ @<Scan the argument represented by |mp_info(r)|@>=
15131 if ( mp_info(r)>=text_base ) {
15132 mp_scan_text_arg(mp, l_delim,r_delim);
15135 if ( mp_info(r)>=suffix_base ) mp_scan_suffix(mp);
15136 else mp_scan_expression(mp);
15139 @ The parameters to |scan_text_arg| are either a pair of delimiters
15140 or zero; the latter case is for undelimited text arguments, which
15141 end with the first semicolon or \&{endgroup} or \&{end} that is not
15142 contained in a group.
15145 static void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
15148 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
15149 integer balance; /* excess of |l_delim| over |r_delim| */
15150 pointer p; /* list tail */
15151 mp->warning_info=l_delim; mp->scanner_status=absorbing;
15152 p=hold_head; balance=1; mp_link(hold_head)=null;
15155 if ( l_delim==0 ) {
15156 @<Adjust the balance for an undelimited argument; |break| if done@>;
15158 @<Adjust the balance for a delimited argument; |break| if done@>;
15160 mp_link(p)=mp_cur_tok(mp); p=mp_link(p);
15162 mp->cur_exp=mp_link(hold_head); mp->cur_type=mp_token_list;
15163 mp->scanner_status=normal;
15166 @ @<Adjust the balance for a delimited argument...@>=
15167 if ( mp->cur_cmd==right_delimiter ) {
15168 if ( mp->cur_mod==l_delim ) {
15170 if ( balance==0 ) break;
15172 } else if ( mp->cur_cmd==left_delimiter ) {
15173 if ( mp->cur_mod==r_delim ) incr(balance);
15176 @ @<Adjust the balance for an undelimited...@>=
15177 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
15178 if ( balance==1 ) { break; }
15179 else { if ( mp->cur_cmd==end_group ) decr(balance); }
15180 } else if ( mp->cur_cmd==begin_group ) {
15184 @ @<Scan undelimited argument(s)@>=
15186 if ( mp_info(r)<text_macro ) {
15188 if ( mp_info(r)!=suffix_macro ) {
15189 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
15192 switch (mp_info(r)) {
15193 case primary_macro:mp_scan_primary(mp); break;
15194 case secondary_macro:mp_scan_secondary(mp); break;
15195 case tertiary_macro:mp_scan_tertiary(mp); break;
15196 case expr_macro:mp_scan_expression(mp); break;
15198 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
15201 @<Scan a suffix with optional delimiters@>;
15203 case text_macro:mp_scan_text_arg(mp, 0,0); break;
15204 } /* there are no other cases */
15206 @<Append the current expression to |arg_list|@>;
15209 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
15211 mp_scan_expression(mp); p=mp_get_avail(mp); mp_info(p)=mp_stash_cur_exp(mp);
15212 if ( mp->internal[mp_tracing_macros]>0 ) {
15213 mp_begin_diagnostic(mp); mp_print_arg(mp, mp_info(p),n,0);
15214 mp_end_diagnostic(mp, false);
15216 if ( arg_list==null ) arg_list=p; else mp_link(tail)=p;
15218 if ( mp->cur_cmd!=of_token ) {
15219 mp_missing_err(mp, "of"); mp_print(mp, " for ");
15221 mp_print_macro_name(mp, arg_list,macro_name);
15222 help1("I've got the first argument; will look now for the other.");
15225 mp_get_x_next(mp); mp_scan_primary(mp);
15228 @ @<Scan a suffix with optional delimiters@>=
15230 if ( mp->cur_cmd!=left_delimiter ) {
15233 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
15235 mp_scan_suffix(mp);
15236 if ( l_delim!=null ) {
15237 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15238 mp_missing_err(mp, str(text(r_delim)));
15240 help2("I've gotten to the end of the macro parameter list.",
15241 "You might want to delete some tokens before continuing.");
15248 @ Before we put a new token list on the input stack, it is wise to clean off
15249 all token lists that have recently been depleted. Then a user macro that ends
15250 with a call to itself will not require unbounded stack space.
15252 @<Feed the arguments and replacement text to the scanner@>=
15253 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15254 if ( mp->param_ptr+n>mp->max_param_stack ) {
15255 mp->max_param_stack=mp->param_ptr+n;
15256 if ( mp->max_param_stack>mp->param_size )
15257 mp_overflow(mp, "parameter stack size",mp->param_size);
15258 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15260 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15264 mp->param_stack[mp->param_ptr]=mp_info(p); incr(mp->param_ptr); p=mp_link(p);
15266 mp_flush_list(mp, arg_list);
15269 @ It's sometimes necessary to put a single argument onto |param_stack|.
15270 The |stack_argument| subroutine does this.
15273 static void mp_stack_argument (MP mp,pointer p) {
15274 if ( mp->param_ptr==mp->max_param_stack ) {
15275 incr(mp->max_param_stack);
15276 if ( mp->max_param_stack>mp->param_size )
15277 mp_overflow(mp, "parameter stack size",mp->param_size);
15278 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15280 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15283 @* \[33] Conditional processing.
15284 Let's consider now the way \&{if} commands are handled.
15286 Conditions can be inside conditions, and this nesting has a stack
15287 that is independent of other stacks.
15288 Four global variables represent the top of the condition stack:
15289 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15290 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15291 the largest code of a |fi_or_else| command that is syntactically legal;
15292 and |if_line| is the line number at which the current conditional began.
15294 If no conditions are currently in progress, the condition stack has the
15295 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15296 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15297 |link| fields of the first word contain |if_limit|, |cur_if|, and
15298 |cond_ptr| at the next level, and the second word contains the
15299 corresponding |if_line|.
15301 @d if_node_size 2 /* number of words in stack entry for conditionals */
15302 @d if_line_field(A) mp->mem[(A)+1].cint
15303 @d if_code 1 /* code for \&{if} being evaluated */
15304 @d fi_code 2 /* code for \&{fi} */
15305 @d else_code 3 /* code for \&{else} */
15306 @d else_if_code 4 /* code for \&{elseif} */
15309 pointer cond_ptr; /* top of the condition stack */
15310 integer if_limit; /* upper bound on |fi_or_else| codes */
15311 quarterword cur_if; /* type of conditional being worked on */
15312 integer if_line; /* line where that conditional began */
15315 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15318 mp_primitive(mp, "if",if_test,if_code);
15319 @:if_}{\&{if} primitive@>
15320 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15321 @:fi_}{\&{fi} primitive@>
15322 mp_primitive(mp, "else",fi_or_else,else_code);
15323 @:else_}{\&{else} primitive@>
15324 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15325 @:else_if_}{\&{elseif} primitive@>
15327 @ @<Cases of |print_cmd_mod|...@>=
15331 case if_code:mp_print(mp, "if"); break;
15332 case fi_code:mp_print(mp, "fi"); break;
15333 case else_code:mp_print(mp, "else"); break;
15334 default: mp_print(mp, "elseif"); break;
15338 @ Here is a procedure that ignores text until coming to an \&{elseif},
15339 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15340 nesting. After it has acted, |cur_mod| will indicate the token that
15343 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15344 makes the skipping process a bit simpler.
15347 void mp_pass_text (MP mp) {
15349 mp->scanner_status=skipping;
15350 mp->warning_info=mp_true_line(mp);
15353 if ( mp->cur_cmd<=fi_or_else ) {
15354 if ( mp->cur_cmd<fi_or_else ) {
15358 if ( mp->cur_mod==fi_code ) decr(l);
15361 @<Decrease the string reference count,
15362 if the current token is a string@>;
15365 mp->scanner_status=normal;
15368 @ @<Decrease the string reference count...@>=
15369 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15371 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15372 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15373 condition has been evaluated, a colon will be inserted.
15374 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15376 @<Push the condition stack@>=
15377 { p=mp_get_node(mp, if_node_size); mp_link(p)=mp->cond_ptr; mp_type(p)=mp->if_limit;
15378 mp_name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15379 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15380 mp->cur_if=if_code;
15383 @ @<Pop the condition stack@>=
15384 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15385 mp->cur_if=mp_name_type(p); mp->if_limit=mp_type(p); mp->cond_ptr=mp_link(p);
15386 mp_free_node(mp, p,if_node_size);
15389 @ Here's a procedure that changes the |if_limit| code corresponding to
15390 a given value of |cond_ptr|.
15393 static void mp_change_if_limit (MP mp,quarterword l, pointer p) {
15395 if ( p==mp->cond_ptr ) {
15396 mp->if_limit=l; /* that's the easy case */
15400 if ( q==null ) mp_confusion(mp, "if");
15401 @:this can't happen if}{\quad if@>
15402 if ( mp_link(q)==p ) {
15403 mp_type(q)=l; return;
15410 @ The user is supposed to put colons into the proper parts of conditional
15411 statements. Therefore, \MP\ has to check for their presence.
15414 static void mp_check_colon (MP mp) {
15415 if ( mp->cur_cmd!=colon ) {
15416 mp_missing_err(mp, ":");
15418 help2("There should've been a colon after the condition.",
15419 "I shall pretend that one was there.");
15424 @ A condition is started when the |get_x_next| procedure encounters
15425 an |if_test| command; in that case |get_x_next| calls |conditional|,
15426 which is a recursive procedure.
15430 void mp_conditional (MP mp) {
15431 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15432 int new_if_limit; /* future value of |if_limit| */
15433 pointer p; /* temporary register */
15434 @<Push the condition stack@>;
15435 save_cond_ptr=mp->cond_ptr;
15437 mp_get_boolean(mp); new_if_limit=else_if_code;
15438 if ( mp->internal[mp_tracing_commands]>unity ) {
15439 @<Display the boolean value of |cur_exp|@>;
15442 mp_check_colon(mp);
15443 if ( mp->cur_exp==true_code ) {
15444 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15445 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15447 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15449 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15450 if ( mp->cur_mod==fi_code ) {
15451 @<Pop the condition stack@>
15452 } else if ( mp->cur_mod==else_if_code ) {
15455 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15460 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15461 \&{else}: \\{bar} \&{fi}', the first \&{else}
15462 that we come to after learning that the \&{if} is false is not the
15463 \&{else} we're looking for. Hence the following curious logic is needed.
15465 @<Skip to \&{elseif}...@>=
15468 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15469 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15473 @ @<Display the boolean value...@>=
15474 { mp_begin_diagnostic(mp);
15475 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15476 else mp_print(mp, "{false}");
15477 mp_end_diagnostic(mp, false);
15480 @ The processing of conditionals is complete except for the following
15481 code, which is actually part of |get_x_next|. It comes into play when
15482 \&{elseif}, \&{else}, or \&{fi} is scanned.
15484 @<Terminate the current conditional and skip to \&{fi}@>=
15485 if ( mp->cur_mod>mp->if_limit ) {
15486 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15487 mp_missing_err(mp, ":");
15489 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15491 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15495 help1("I'm ignoring this; it doesn't match any if.");
15499 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15500 @<Pop the condition stack@>;
15503 @* \[34] Iterations.
15504 To bring our treatment of |get_x_next| to a close, we need to consider what
15505 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15507 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15508 that are currently active. If |loop_ptr=null|, no loops are in progress;
15509 otherwise |mp_info(loop_ptr)| points to the iterative text of the current
15510 (innermost) loop, and |mp_link(loop_ptr)| points to the data for any other
15511 loops that enclose the current one.
15513 A loop-control node also has two other fields, called |loop_type| and
15514 |loop_list|, whose contents depend on the type of loop:
15516 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15517 points to a list of one-word nodes whose |info| fields point to the
15518 remaining argument values of a suffix list and expression list.
15520 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15523 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15524 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15525 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15528 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15529 header and |loop_list(loop_ptr)| points into the graphical object list for
15532 \yskip\noindent In the case of a progression node, the first word is not used
15533 because the link field of words in the dynamic memory area cannot be arbitrary.
15535 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15536 @d loop_type(A) mp_info(loop_list_loc((A))) /* the type of \&{for} loop */
15537 @d loop_list(A) mp_link(loop_list_loc((A))) /* the remaining list elements */
15538 @d loop_node_size 2 /* the number of words in a loop control node */
15539 @d progression_node_size 4 /* the number of words in a progression node */
15540 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15541 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15542 @d progression_flag (null+2)
15543 /* |loop_type| value when |loop_list| points to a progression node */
15546 pointer loop_ptr; /* top of the loop-control-node stack */
15551 @ If the expressions that define an arithmetic progression in
15552 a \&{for} loop don't have known numeric values, the |bad_for|
15553 subroutine screams at the user.
15556 static void mp_bad_for (MP mp, const char * s) {
15557 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15558 @.Improper...replaced by 0@>
15559 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15560 help4("When you say `for x=a step b until c',",
15561 "the initial value `a' and the step size `b'",
15562 "and the final value `c' must have known numeric values.",
15563 "I'm zeroing this one. Proceed, with fingers crossed.");
15564 mp_put_get_flush_error(mp, 0);
15567 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15568 has just been scanned. (This code requires slight familiarity with
15569 expression-parsing routines that we have not yet discussed; but it seems
15570 to belong in the present part of the program, even though the original author
15571 didn't write it until later. The reader may wish to come back to it.)
15573 @c void mp_begin_iteration (MP mp) {
15574 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15575 halfword n; /* hash address of the current symbol */
15576 pointer s; /* the new loop-control node */
15577 pointer p; /* substitution list for |scan_toks| */
15578 pointer q; /* link manipulation register */
15579 pointer pp; /* a new progression node */
15580 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15581 if ( m==start_forever ){
15582 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15584 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15585 mp_info(p)=mp->cur_sym; value(p)=m;
15587 if ( mp->cur_cmd==within_token ) {
15588 @<Set up a picture iteration@>;
15590 @<Check for the |"="| or |":="| in a loop header@>;
15591 @<Scan the values to be used in the loop@>;
15594 @<Check for the presence of a colon@>;
15595 @<Scan the loop text and put it on the loop control stack@>;
15596 mp_resume_iteration(mp);
15599 @ @<Check for the |"="| or |":="| in a loop header@>=
15600 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15601 mp_missing_err(mp, "=");
15603 help3("The next thing in this loop should have been `=' or `:='.",
15604 "But don't worry; I'll pretend that an equals sign",
15605 "was present, and I'll look for the values next.");
15609 @ @<Check for the presence of a colon@>=
15610 if ( mp->cur_cmd!=colon ) {
15611 mp_missing_err(mp, ":");
15613 help3("The next thing in this loop should have been a `:'.",
15614 "So I'll pretend that a colon was present;",
15615 "everything from here to `endfor' will be iterated.");
15619 @ We append a special |frozen_repeat_loop| token in place of the
15620 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15621 at the proper time to cause the loop to be repeated.
15623 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15624 he will be foiled by the |get_symbol| routine, which keeps frozen
15625 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15626 token, so it won't be lost accidentally.)
15628 @ @<Scan the loop text...@>=
15629 q=mp_get_avail(mp); mp_info(q)=frozen_repeat_loop;
15630 mp->scanner_status=loop_defining; mp->warning_info=n;
15631 mp_info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15632 mp_link(s)=mp->loop_ptr; mp->loop_ptr=s
15634 @ @<Initialize table...@>=
15635 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15636 text(frozen_repeat_loop)=intern(" ENDFOR");
15638 @ The loop text is inserted into \MP's scanning apparatus by the
15639 |resume_iteration| routine.
15641 @c void mp_resume_iteration (MP mp) {
15642 pointer p,q; /* link registers */
15643 p=loop_type(mp->loop_ptr);
15644 if ( p==progression_flag ) {
15645 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15646 mp->cur_exp=value(p);
15647 if ( @<The arithmetic progression has ended@> ) {
15648 mp_stop_iteration(mp);
15651 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15652 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15653 } else if ( p==null ) {
15654 p=loop_list(mp->loop_ptr);
15656 mp_stop_iteration(mp);
15659 loop_list(mp->loop_ptr)=mp_link(p); q=mp_info(p); free_avail(p);
15660 } else if ( p==mp_void ) {
15661 mp_begin_token_list(mp, mp_info(mp->loop_ptr),forever_text); return;
15663 @<Make |q| a capsule containing the next picture component from
15664 |loop_list(loop_ptr)| or |goto not_found|@>;
15666 mp_begin_token_list(mp, mp_info(mp->loop_ptr),loop_text);
15667 mp_stack_argument(mp, q);
15668 if ( mp->internal[mp_tracing_commands]>unity ) {
15669 @<Trace the start of a loop@>;
15673 mp_stop_iteration(mp);
15676 @ @<The arithmetic progression has ended@>=
15677 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15678 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15680 @ @<Trace the start of a loop@>=
15682 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15684 if ( (q!=null)&&(mp_link(q)==mp_void) ) mp_print_exp(mp, q,1);
15685 else mp_show_token_list(mp, q,null,50,0);
15686 mp_print_char(mp, xord('}')); mp_end_diagnostic(mp, false);
15689 @ @<Make |q| a capsule containing the next picture component from...@>=
15690 { q=loop_list(mp->loop_ptr);
15691 if ( q==null ) goto NOT_FOUND;
15692 skip_component(q) goto NOT_FOUND;
15693 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15694 mp_init_bbox(mp, mp->cur_exp);
15695 mp->cur_type=mp_picture_type;
15696 loop_list(mp->loop_ptr)=q;
15697 q=mp_stash_cur_exp(mp);
15700 @ A level of loop control disappears when |resume_iteration| has decided
15701 not to resume, or when an \&{exitif} construction has removed the loop text
15702 from the input stack.
15704 @c void mp_stop_iteration (MP mp) {
15705 pointer p,q; /* the usual */
15706 p=loop_type(mp->loop_ptr);
15707 if ( p==progression_flag ) {
15708 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15709 } else if ( p==null ){
15710 q=loop_list(mp->loop_ptr);
15711 while ( q!=null ) {
15714 if ( mp_link(p)==mp_void ) { /* it's an \&{expr} parameter */
15715 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15717 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15720 p=q; q=mp_link(q); free_avail(p);
15722 } else if ( p>progression_flag ) {
15723 delete_edge_ref(p);
15725 p=mp->loop_ptr; mp->loop_ptr=mp_link(p); mp_flush_token_list(mp, mp_info(p));
15726 mp_free_node(mp, p,loop_node_size);
15729 @ Now that we know all about loop control, we can finish up
15730 the missing portion of |begin_iteration| and we'll be done.
15732 The following code is performed after the `\.=' has been scanned in
15733 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15734 (if |m=suffix_base|).
15736 @<Scan the values to be used in the loop@>=
15737 loop_type(s)=null; q=loop_list_loc(s); mp_link(q)=null; /* |mp_link(q)=loop_list(s)| */
15740 if ( m!=expr_base ) {
15741 mp_scan_suffix(mp);
15743 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15745 mp_scan_expression(mp);
15746 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15747 @<Prepare for step-until construction and |break|@>;
15749 mp->cur_exp=mp_stash_cur_exp(mp);
15751 mp_link(q)=mp_get_avail(mp); q=mp_link(q);
15752 mp_info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15755 } while (mp->cur_cmd==comma)
15757 @ @<Prepare for step-until construction and |break|@>=
15759 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15760 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15761 mp_get_x_next(mp); mp_scan_expression(mp);
15762 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15763 step_size(pp)=mp->cur_exp;
15764 if ( mp->cur_cmd!=until_token ) {
15765 mp_missing_err(mp, "until");
15766 @.Missing `until'@>
15767 help2("I assume you meant to say `until' after `step'.",
15768 "So I'll look for the final value and colon next.");
15771 mp_get_x_next(mp); mp_scan_expression(mp);
15772 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15773 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15774 loop_type(s)=progression_flag;
15778 @ The last case is when we have just seen ``\&{within}'', and we need to
15779 parse a picture expression and prepare to iterate over it.
15781 @<Set up a picture iteration@>=
15782 { mp_get_x_next(mp);
15783 mp_scan_expression(mp);
15784 @<Make sure the current expression is a known picture@>;
15785 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15786 q=mp_link(dummy_loc(mp->cur_exp));
15788 if ( is_start_or_stop(q) )
15789 if ( mp_skip_1component(mp, q)==null ) q=mp_link(q);
15793 @ @<Make sure the current expression is a known picture@>=
15794 if ( mp->cur_type!=mp_picture_type ) {
15795 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15796 help1("When you say `for x in p', p must be a known picture.");
15797 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15798 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15801 @* \[35] File names.
15802 It's time now to fret about file names. Besides the fact that different
15803 operating systems treat files in different ways, we must cope with the
15804 fact that completely different naming conventions are used by different
15805 groups of people. The following programs show what is required for one
15806 particular operating system; similar routines for other systems are not
15807 difficult to devise.
15808 @^system dependencies@>
15810 \MP\ assumes that a file name has three parts: the name proper; its
15811 ``extension''; and a ``file area'' where it is found in an external file
15812 system. The extension of an input file is assumed to be
15813 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15814 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15815 metric files that describe characters in any fonts created by \MP; it is
15816 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15817 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15818 The file area can be arbitrary on input files, but files are usually
15819 output to the user's current area. If an input file cannot be
15820 found on the specified area, \MP\ will look for it on a special system
15821 area; this special area is intended for commonly used input files.
15823 Simple uses of \MP\ refer only to file names that have no explicit
15824 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15825 instead of `\.{input} \.{cmr10.new}'. Simple file
15826 names are best, because they make the \MP\ source files portable;
15827 whenever a file name consists entirely of letters and digits, it should be
15828 treated in the same way by all implementations of \MP. However, users
15829 need the ability to refer to other files in their environment, especially
15830 when responding to error messages concerning unopenable files; therefore
15831 we want to let them use the syntax that appears in their favorite
15834 @ \MP\ uses the same conventions that have proved to be satisfactory for
15835 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15836 @^system dependencies@>
15837 the system-independent parts of \MP\ are expressed in terms
15838 of three system-dependent
15839 procedures called |begin_name|, |more_name|, and |end_name|. In
15840 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15841 the system-independent driver program does the operations
15842 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
15844 These three procedures communicate with each other via global variables.
15845 Afterwards the file name will appear in the string pool as three strings
15846 called |cur_name|\penalty10000\hskip-.05em,
15847 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15848 |""|), unless they were explicitly specified by the user.
15850 Actually the situation is slightly more complicated, because \MP\ needs
15851 to know when the file name ends. The |more_name| routine is a function
15852 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15853 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15854 returns |false|; or, it returns |true| and $c_n$ is the last character
15855 on the current input line. In other words,
15856 |more_name| is supposed to return |true| unless it is sure that the
15857 file name has been completely scanned; and |end_name| is supposed to be able
15858 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15859 whether $|more_name|(c_n)$ returned |true| or |false|.
15862 char * cur_name; /* name of file just scanned */
15863 char * cur_area; /* file area just scanned, or \.{""} */
15864 char * cur_ext; /* file extension just scanned, or \.{""} */
15866 @ It is easier to maintain reference counts if we assign initial values.
15869 mp->cur_name=xstrdup("");
15870 mp->cur_area=xstrdup("");
15871 mp->cur_ext=xstrdup("");
15873 @ @<Dealloc variables@>=
15874 xfree(mp->cur_area);
15875 xfree(mp->cur_name);
15876 xfree(mp->cur_ext);
15878 @ The file names we shall deal with for illustrative purposes have the
15879 following structure: If the name contains `\.>' or `\.:', the file area
15880 consists of all characters up to and including the final such character;
15881 otherwise the file area is null. If the remaining file name contains
15882 `\..', the file extension consists of all such characters from the first
15883 remaining `\..' to the end, otherwise the file extension is null.
15884 @^system dependencies@>
15886 We can scan such file names easily by using two global variables that keep track
15887 of the occurrences of area and extension delimiters. Note that these variables
15888 cannot be of type |pool_pointer| because a string pool compaction could occur
15889 while scanning a file name.
15892 integer area_delimiter;
15893 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15894 integer ext_delimiter; /* the relevant `\..', if any */
15896 @ Here now is the first of the system-dependent routines for file name scanning.
15897 @^system dependencies@>
15899 The file name length is limited to |file_name_size|. That is good, because
15900 in the current configuration we cannot call |mp_do_compaction| while a name
15901 is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct
15902 offsets into |mp->str_pool|. I am not in a great hurry to fix this, because
15903 calling |str_room()| just once is more efficient anyway. TODO.
15906 static void mp_begin_name (MP mp);
15907 static boolean mp_more_name (MP mp, ASCII_code c);
15908 static void mp_end_name (MP mp);
15911 void mp_begin_name (MP mp) {
15912 xfree(mp->cur_name);
15913 xfree(mp->cur_area);
15914 xfree(mp->cur_ext);
15915 mp->area_delimiter=-1;
15916 mp->ext_delimiter=-1;
15917 str_room(file_name_size);
15920 @ And here's the second.
15921 @^system dependencies@>
15924 boolean mp_more_name (MP mp, ASCII_code c) {
15928 if ( (c=='>')||(c==':') ) {
15929 mp->area_delimiter=mp->pool_ptr;
15930 mp->ext_delimiter=-1;
15931 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15932 mp->ext_delimiter=mp->pool_ptr;
15934 append_char(c); /* contribute |c| to the current string */
15940 @^system dependencies@>
15942 @d copy_pool_segment(A,B,C) {
15943 A = xmalloc(C+1,sizeof(char));
15944 strncpy(A,(char *)(mp->str_pool+B),C);
15948 void mp_end_name (MP mp) {
15949 pool_pointer s; /* length of area, name, and extension */
15952 s = mp->str_start[mp->str_ptr];
15953 if ( mp->area_delimiter<0 ) {
15954 mp->cur_area=xstrdup("");
15956 len = (unsigned)(mp->area_delimiter-s);
15957 copy_pool_segment(mp->cur_area,s,len);
15960 if ( mp->ext_delimiter<0 ) {
15961 mp->cur_ext=xstrdup("");
15962 len = (unsigned)(mp->pool_ptr-s);
15964 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(size_t)(mp->pool_ptr-mp->ext_delimiter));
15965 len = (unsigned)(mp->ext_delimiter-s);
15967 copy_pool_segment(mp->cur_name,s,len);
15968 mp->pool_ptr=s; /* don't need this partial string */
15971 @ Conversely, here is a routine that takes three strings and prints a file
15972 name that might have produced them. (The routine is system dependent, because
15973 some operating systems put the file area last instead of first.)
15974 @^system dependencies@>
15976 @<Basic printing...@>=
15977 static void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15978 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15981 @ Another system-dependent routine is needed to convert three internal
15983 to the |name_of_file| value that is used to open files. The present code
15984 allows both lowercase and uppercase letters in the file name.
15985 @^system dependencies@>
15987 @d append_to_name(A) { c=xord((int)(A));
15988 if ( k<file_name_size ) {
15989 mp->name_of_file[k]=(char)xchr(c);
15995 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
15996 integer k; /* number of positions filled in |name_of_file| */
15997 ASCII_code c; /* character being packed */
15998 const char *j; /* a character index */
16002 for (j=a;*j!='\0';j++) { append_to_name(*j); }
16004 for (j=n;*j!='\0';j++) { append_to_name(*j); }
16006 for (j=e;*j!='\0';j++) { append_to_name(*j); }
16008 mp->name_of_file[k]=0;
16012 @ @<Internal library declarations@>=
16013 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
16015 @ @<Option variables@>=
16016 char *mem_name; /* for commandline */
16018 @ @<Find constant sizes@>=
16019 mp->mem_name = xstrdup(opt->mem_name);
16020 if (mp->mem_name) {
16021 size_t l = strlen(mp->mem_name);
16023 char *test = strstr(mp->mem_name,".mem");
16024 if (test == mp->mem_name+l-4) {
16031 @ @<Dealloc variables@>=
16032 xfree(mp->mem_name);
16034 @ This part of the program becomes active when a ``virgin'' \MP\ is
16035 trying to get going, just after the preliminary initialization, or
16036 when the user is substituting another mem file by typing `\.\&' after
16037 the initial `\.{**}' prompt. The buffer contains the first line of
16038 input in |buffer[loc..(last-1)]|, where |loc<last| and |buffer[loc]<>""|.
16041 static boolean mp_open_mem_name (MP mp) ;
16042 static boolean mp_open_mem_file (MP mp) ;
16045 boolean mp_open_mem_name (MP mp) {
16046 if (mp->mem_name!=NULL) {
16047 size_t l = strlen(mp->mem_name);
16048 char *s = xstrdup (mp->mem_name);
16050 char *test = strstr(s,".mem");
16051 if (test == NULL || test != s+l-4) {
16052 s = xrealloc (s, l+5, 1);
16053 strcat (s, ".mem");
16056 s = xrealloc (s, l+5, 1);
16057 strcat (s, ".mem");
16059 mp->mem_file = (mp->open_file)(mp,s, "r", mp_filetype_memfile);
16061 if ( mp->mem_file ) return true;
16065 boolean mp_open_mem_file (MP mp) {
16066 if (mp->mem_file != NULL)
16068 if (mp_open_mem_name(mp))
16070 if (mp_xstrcmp(mp->mem_name, "plain")) {
16072 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
16073 @.Sorry, I can't find...@>
16075 /* now pull out all the stops: try for the system \.{plain} file */
16076 xfree(mp->mem_name);
16077 mp->mem_name = xstrdup("plain");
16078 if (mp_open_mem_name(mp))
16082 wterm_ln("I can\'t find the PLAIN mem file!");
16083 @.I can't find PLAIN...@>
16088 @ Operating systems often make it possible to determine the exact name (and
16089 possible version number) of a file that has been opened. The following routine,
16090 which simply makes a \MP\ string from the value of |name_of_file|, should
16091 ideally be changed to deduce the full name of file~|f|, which is the file
16092 most recently opened, if it is possible to do this.
16093 @^system dependencies@>
16096 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
16097 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
16098 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
16101 static str_number mp_make_name_string (MP mp) {
16102 int k; /* index into |name_of_file| */
16103 str_room(mp->name_length);
16104 for (k=0;k<mp->name_length;k++) {
16105 append_char(xord((int)mp->name_of_file[k]));
16107 return mp_make_string(mp);
16110 @ Now let's consider the ``driver''
16111 routines by which \MP\ deals with file names
16112 in a system-independent manner. First comes a procedure that looks for a
16113 file name in the input by taking the information from the input buffer.
16114 (We can't use |get_next|, because the conversion to tokens would
16115 destroy necessary information.)
16117 This procedure doesn't allow semicolons or percent signs to be part of
16118 file names, because of other conventions of \MP.
16119 {\sl The {\logos METAFONT\/}book} doesn't
16120 use semicolons or percents immediately after file names, but some users
16121 no doubt will find it natural to do so; therefore system-dependent
16122 changes to allow such characters in file names should probably
16123 be made with reluctance, and only when an entire file name that
16124 includes special characters is ``quoted'' somehow.
16125 @^system dependencies@>
16128 static void mp_scan_file_name (MP mp) {
16130 while ( mp->buffer[loc]==' ' ) incr(loc);
16132 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
16133 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
16139 @ Here is another version that takes its input from a string.
16141 @<Declare subroutines for parsing file names@>=
16142 void mp_str_scan_file (MP mp, str_number s) ;
16145 void mp_str_scan_file (MP mp, str_number s) {
16146 pool_pointer p,q; /* current position and stopping point */
16148 p=mp->str_start[s]; q=str_stop(s);
16150 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
16156 @ And one that reads from a |char*|.
16158 @<Declare subroutines for parsing file names@>=
16159 extern void mp_ptr_scan_file (MP mp, char *s);
16162 void mp_ptr_scan_file (MP mp, char *s) {
16163 char *p, *q; /* current position and stopping point */
16165 p=s; q=p+strlen(s);
16167 if ( ! mp_more_name(mp, xord((int)(*p)))) break;
16174 @ The global variable |job_name| contains the file name that was first
16175 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
16176 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
16179 boolean log_opened; /* has the transcript file been opened? */
16180 char *log_name; /* full name of the log file */
16182 @ @<Option variables@>=
16183 char *job_name; /* principal file name */
16185 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
16186 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
16187 except of course for a short time just after |job_name| has become nonzero.
16189 @<Allocate or ...@>=
16190 mp->job_name=mp_xstrdup(mp, opt->job_name);
16191 if (opt->noninteractive && opt->ini_version) {
16192 if (mp->job_name == NULL)
16193 mp->job_name=mp_xstrdup(mp,mp->mem_name);
16194 if (mp->job_name != NULL) {
16195 size_t l = strlen(mp->job_name);
16197 char *test = strstr(mp->job_name,".mem");
16198 if (test == mp->job_name+l-4)
16203 mp->log_opened=false;
16205 @ @<Dealloc variables@>=
16206 xfree(mp->job_name);
16208 @ Here is a routine that manufactures the output file names, assuming that
16209 |job_name<>0|. It ignores and changes the current settings of |cur_area|
16212 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
16214 @<Internal library ...@>=
16215 void mp_pack_job_name (MP mp, const char *s) ;
16218 void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
16219 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
16220 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16221 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
16225 @ If some trouble arises when \MP\ tries to open a file, the following
16226 routine calls upon the user to supply another file name. Parameter~|s|
16227 is used in the error message to identify the type of file; parameter~|e|
16228 is the default extension if none is given. Upon exit from the routine,
16229 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16230 ready for another attempt at file opening.
16232 @<Internal library ...@>=
16233 void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
16235 @ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
16236 size_t k; /* index into |buffer| */
16237 char * saved_cur_name;
16238 if ( mp->interaction==mp_scroll_mode )
16240 if (strcmp(s,"input file name")==0) {
16241 print_err("I can\'t find file `");
16242 @.I can't find file x@>
16244 print_err("I can\'t write on file `");
16245 @.I can't write on file x@>
16247 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16248 mp_print(mp, "'.");
16249 if (strcmp(e,"")==0)
16250 mp_show_context(mp);
16251 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16253 if (mp->noninteractive || mp->interaction<mp_scroll_mode )
16254 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16255 @.job aborted, file error...@>
16256 saved_cur_name = xstrdup(mp->cur_name);
16257 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16258 if (strcmp(mp->cur_ext,"")==0)
16259 mp->cur_ext=xstrdup(e);
16260 if (strlen(mp->cur_name)==0) {
16261 mp->cur_name=saved_cur_name;
16263 xfree(saved_cur_name);
16268 @ @<Scan file name in the buffer@>=
16270 mp_begin_name(mp); k=mp->first;
16271 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16273 if ( k==mp->last ) break;
16274 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16280 @ The |open_log_file| routine is used to open the transcript file and to help
16281 it catch up to what has previously been printed on the terminal.
16283 @c void mp_open_log_file (MP mp) {
16284 unsigned old_setting; /* previous |selector| setting */
16285 int k; /* index into |months| and |buffer| */
16286 int l; /* end of first input line */
16287 integer m; /* the current month */
16288 const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16289 /* abbreviations of month names */
16290 old_setting=mp->selector;
16291 if ( mp->job_name==NULL ) {
16292 mp->job_name=xstrdup("mpout");
16294 mp_pack_job_name(mp,".log");
16295 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16296 @<Try to get a different log file name@>;
16298 mp->log_name=xstrdup(mp->name_of_file);
16299 mp->selector=log_only; mp->log_opened=true;
16300 @<Print the banner line, including the date and time@>;
16301 mp->input_stack[mp->input_ptr]=mp->cur_input;
16302 /* make sure bottom level is in memory */
16303 if (!mp->noninteractive) {
16304 mp_print_nl(mp, "**");
16306 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16307 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16308 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16310 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16313 @ @<Dealloc variables@>=
16314 xfree(mp->log_name);
16316 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16317 unable to print error messages or even to |show_context|.
16318 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16319 routine will not be invoked because |log_opened| will be false.
16321 The normal idea of |mp_batch_mode| is that nothing at all should be written
16322 on the terminal. However, in the unusual case that
16323 no log file could be opened, we make an exception and allow
16324 an explanatory message to be seen.
16326 Incidentally, the program always refers to the log file as a `\.{transcript
16327 file}', because some systems cannot use the extension `\.{.log}' for
16330 @<Try to get a different log file name@>=
16332 mp->selector=term_only;
16333 mp_prompt_file_name(mp, "transcript file name",".log");
16336 @ @<Print the banner...@>=
16339 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16340 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16341 mp_print_char(mp, xord(' '));
16342 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16343 for (k=3*m-3;k<3*m;k++) { wlog_chr((unsigned char)months[k]); }
16344 mp_print_char(mp, xord(' '));
16345 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16346 mp_print_char(mp, xord(' '));
16347 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16348 mp_print_dd(mp, m / 60); mp_print_char(mp, xord(':')); mp_print_dd(mp, m % 60);
16351 @ The |try_extension| function tries to open an input file determined by
16352 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16353 can't find the file in |cur_area| or the appropriate system area.
16356 static boolean mp_try_extension (MP mp, const char *ext) {
16357 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16358 in_name=xstrdup(mp->cur_name);
16359 in_area=xstrdup(mp->cur_area);
16360 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16363 mp_pack_file_name(mp, mp->cur_name,NULL,ext);
16364 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16368 @ Let's turn now to the procedure that is used to initiate file reading
16369 when an `\.{input}' command is being processed.
16371 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16372 char *fname = NULL;
16373 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16375 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16376 if ( strlen(mp->cur_ext)==0 ) {
16377 if ( mp_try_extension(mp, ".mp") ) break;
16378 else if ( mp_try_extension(mp, "") ) break;
16379 else if ( mp_try_extension(mp, ".mf") ) break;
16380 /* |else do_nothing; | */
16381 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16384 mp_end_file_reading(mp); /* remove the level that didn't work */
16385 mp_prompt_file_name(mp, "input file name","");
16387 name=mp_a_make_name_string(mp, cur_file);
16388 fname = xstrdup(mp->name_of_file);
16389 if ( mp->job_name==NULL ) {
16390 mp->job_name=xstrdup(mp->cur_name);
16391 mp_open_log_file(mp);
16392 } /* |open_log_file| doesn't |show_context|, so |limit|
16393 and |loc| needn't be set to meaningful values yet */
16394 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16395 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, xord(' '));
16396 mp_print_char(mp, xord('(')); incr(mp->open_parens); mp_print(mp, fname);
16399 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16400 @<Read the first line of the new file@>;
16403 @ This code should be omitted if |a_make_name_string| returns something other
16404 than just a copy of its argument and the full file name is needed for opening
16405 \.{MPX} files or implementing the switch-to-editor option.
16406 @^system dependencies@>
16408 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16409 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16411 @ If the file is empty, it is considered to contain a single blank line,
16412 so there is no need to test the return value.
16414 @<Read the first line...@>=
16417 (void)mp_input_ln(mp, cur_file );
16418 mp_firm_up_the_line(mp);
16419 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start;
16422 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16423 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16424 if ( token_state ) {
16425 print_err("File names can't appear within macros");
16426 @.File names can't...@>
16427 help3("Sorry...I've converted what follows to tokens,",
16428 "possibly garbaging the name you gave.",
16429 "Please delete the tokens and insert the name again.");
16432 if ( file_state ) {
16433 mp_scan_file_name(mp);
16435 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16436 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16437 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16440 @ The following simple routine starts reading the \.{MPX} file associated
16441 with the current input file.
16443 @c void mp_start_mpx_input (MP mp) {
16444 char *origname = NULL; /* a copy of nameoffile */
16445 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16446 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16447 |goto not_found| if there is a problem@>;
16448 mp_begin_file_reading(mp);
16449 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16450 mp_end_file_reading(mp);
16453 name=mp_a_make_name_string(mp, cur_file);
16454 mp->mpx_name[iindex]=name; add_str_ref(name);
16455 @<Read the first line of the new file@>;
16459 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16463 @ This should ideally be changed to do whatever is necessary to create the
16464 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16465 of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
16466 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16467 completely different typesetting program if suitable postprocessor is
16468 available to perform the function of \.{DVItoMP}.)
16469 @^system dependencies@>
16471 @ @<Exported types@>=
16472 typedef int (*mp_makempx_cmd)(MP mp, char *origname, char *mtxname);
16474 @ @<Option variables@>=
16475 mp_makempx_cmd run_make_mpx;
16477 @ @<Allocate or initialize ...@>=
16478 set_callback_option(run_make_mpx);
16480 @ @<Declarations@>=
16481 static int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16483 @ The default does nothing.
16485 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16492 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16493 |goto not_found| if there is a problem@>=
16494 origname = mp_xstrdup(mp,mp->name_of_file);
16495 *(origname+strlen(origname)-1)=0; /* drop the x */
16496 if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
16499 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16500 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16501 mp_print_nl(mp, ">> ");
16502 mp_print(mp, origname);
16503 mp_print_nl(mp, ">> ");
16504 mp_print(mp, mp->name_of_file);
16505 mp_print_nl(mp, "! Unable to make mpx file");
16506 help4("The two files given above are one of your source files",
16507 "and an auxiliary file I need to read to find out what your",
16508 "btex..etex blocks mean. If you don't know why I had trouble,",
16509 "try running it manually through MPtoTeX, TeX, and DVItoMP");
16512 @ The last file-opening commands are for files accessed via the \&{readfrom}
16513 @:read_from_}{\&{readfrom} primitive@>
16514 operator and the \&{write} command. Such files are stored in separate arrays.
16515 @:write_}{\&{write} primitive@>
16517 @<Types in the outer block@>=
16518 typedef unsigned int readf_index; /* |0..max_read_files| */
16519 typedef unsigned int write_index; /* |0..max_write_files| */
16522 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16523 void ** rd_file; /* \&{readfrom} files */
16524 char ** rd_fname; /* corresponding file name or 0 if file not open */
16525 readf_index read_files; /* number of valid entries in the above arrays */
16526 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16527 void ** wr_file; /* \&{write} files */
16528 char ** wr_fname; /* corresponding file name or 0 if file not open */
16529 write_index write_files; /* number of valid entries in the above arrays */
16531 @ @<Allocate or initialize ...@>=
16532 mp->max_read_files=8;
16533 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
16534 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16535 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16536 mp->max_write_files=8;
16537 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
16538 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16539 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16542 @ This routine starts reading the file named by string~|s| without setting
16543 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16544 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16547 static boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16548 mp_ptr_scan_file(mp, s);
16550 mp_begin_file_reading(mp);
16551 if ( ! mp_a_open_in(mp, &mp->rd_file[n], (int)(mp_filetype_text+n)) )
16553 if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
16554 (mp->close_file)(mp,mp->rd_file[n]);
16557 mp->rd_fname[n]=xstrdup(s);
16560 mp_end_file_reading(mp);
16564 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16567 static void mp_open_write_file (MP mp, char *s, readf_index n) ;
16569 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16570 mp_ptr_scan_file(mp, s);
16572 while ( ! mp_a_open_out(mp, &mp->wr_file[n], (int)(mp_filetype_text+n)) )
16573 mp_prompt_file_name(mp, "file name for write output","");
16574 mp->wr_fname[n]=xstrdup(s);
16578 @* \[36] Introduction to the parsing routines.
16579 We come now to the central nervous system that sparks many of \MP's activities.
16580 By evaluating expressions, from their primary constituents to ever larger
16581 subexpressions, \MP\ builds the structures that ultimately define complete
16582 pictures or fonts of type.
16584 Four mutually recursive subroutines are involved in this process: We call them
16585 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16586 and |scan_expression|.}$$
16588 Each of them is parameterless and begins with the first token to be scanned
16589 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16590 the value of the primary or secondary or tertiary or expression that was
16591 found will appear in the global variables |cur_type| and |cur_exp|. The
16592 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16595 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16596 backup mechanisms have been added in order to provide reasonable error
16600 quarterword cur_type; /* the type of the expression just found */
16601 integer cur_exp; /* the value of the expression just found */
16606 @ Many different kinds of expressions are possible, so it is wise to have
16607 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16610 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16611 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16612 construction in which there was no expression before the \&{endgroup}.
16613 In this case |cur_exp| has some irrelevant value.
16616 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16620 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16622 a ring of equivalent booleans whose value has not yet been defined.
16625 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16626 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16627 includes this particular reference.
16630 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16632 a ring of equivalent strings whose value has not yet been defined.
16635 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16636 else points to any of the nodes in this pen. The pen may be polygonal or
16640 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16642 a ring of equivalent pens whose value has not yet been defined.
16645 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16646 a path; nobody else points to this particular path. The control points of
16647 the path will have been chosen.
16650 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16652 a ring of equivalent paths whose value has not yet been defined.
16655 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16656 There may be other pointers to this particular set of edges. The header node
16657 contains a reference count that includes this particular reference.
16660 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16662 a ring of equivalent pictures whose value has not yet been defined.
16665 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16666 capsule node. The |value| part of this capsule
16667 points to a transform node that contains six numeric values,
16668 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16671 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16672 capsule node. The |value| part of this capsule
16673 points to a color node that contains three numeric values,
16674 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16677 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16678 capsule node. The |value| part of this capsule
16679 points to a color node that contains four numeric values,
16680 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16683 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16684 node whose type is |mp_pair_type|. The |value| part of this capsule
16685 points to a pair node that contains two numeric values,
16686 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16689 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16692 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16693 is |dependent|. The |dep_list| field in this capsule points to the associated
16697 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16698 capsule node. The |dep_list| field in this capsule
16699 points to the associated dependency list.
16702 |cur_type=independent| means that |cur_exp| points to a capsule node
16703 whose type is |independent|. This somewhat unusual case can arise, for
16704 example, in the expression
16705 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16708 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16711 \smallskip\noindent
16712 The possible settings of |cur_type| have been listed here in increasing
16713 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16714 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16715 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16718 @ Capsules are two-word nodes that have a similar meaning
16719 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
16720 and their |type| field is one of the possibilities for |cur_type| listed above.
16721 Also |link<=void| in capsules that aren't part of a token list.
16723 The |value| field of a capsule is, in most cases, the value that
16724 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16725 However, when |cur_exp| would point to a capsule,
16726 no extra layer of indirection is present; the |value|
16727 field is what would have been called |value(cur_exp)| if it had not been
16728 encapsulated. Furthermore, if the type is |dependent| or
16729 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16730 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16731 always part of the general |dep_list| structure.
16733 The |get_x_next| routine is careful not to change the values of |cur_type|
16734 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16735 call a macro, which might parse an expression, which might execute lots of
16736 commands in a group; hence it's possible that |cur_type| might change
16737 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16738 |known| or |independent|, during the time |get_x_next| is called. The
16739 programs below are careful to stash sensitive intermediate results in
16740 capsules, so that \MP's generality doesn't cause trouble.
16742 Here's a procedure that illustrates these conventions. It takes
16743 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16744 and stashes them away in a
16745 capsule. It is not used when |cur_type=mp_token_list|.
16746 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16747 copy path lists or to update reference counts, etc.
16749 The special link |mp_void| is put on the capsule returned by
16750 |stash_cur_exp|, because this procedure is used to store macro parameters
16751 that must be easily distinguishable from token lists.
16753 @<Declare the stashing/unstashing routines@>=
16754 static pointer mp_stash_cur_exp (MP mp) {
16755 pointer p; /* the capsule that will be returned */
16756 switch (mp->cur_type) {
16757 case unknown_types:
16758 case mp_transform_type:
16759 case mp_color_type:
16762 case mp_proto_dependent:
16763 case mp_independent:
16764 case mp_cmykcolor_type:
16768 p=mp_get_node(mp, value_node_size); mp_name_type(p)=mp_capsule;
16769 mp_type(p)=mp->cur_type; value(p)=mp->cur_exp;
16772 mp->cur_type=mp_vacuous; mp_link(p)=mp_void;
16776 @ The inverse of |stash_cur_exp| is the following procedure, which
16777 deletes an unnecessary capsule and puts its contents into |cur_type|
16780 The program steps of \MP\ can be divided into two categories: those in
16781 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16782 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16783 information or not. It's important not to ignore them when they're alive,
16784 and it's important not to pay attention to them when they're dead.
16786 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16787 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16788 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16789 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16790 only when they are alive or dormant.
16792 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16793 are alive or dormant. The \\{unstash} procedure assumes that they are
16794 dead or dormant; it resuscitates them.
16796 @<Declare the stashing/unstashing...@>=
16797 static void mp_unstash_cur_exp (MP mp,pointer p) ;
16800 void mp_unstash_cur_exp (MP mp,pointer p) {
16801 mp->cur_type=mp_type(p);
16802 switch (mp->cur_type) {
16803 case unknown_types:
16804 case mp_transform_type:
16805 case mp_color_type:
16808 case mp_proto_dependent:
16809 case mp_independent:
16810 case mp_cmykcolor_type:
16814 mp->cur_exp=value(p);
16815 mp_free_node(mp, p,value_node_size);
16820 @ The following procedure prints the values of expressions in an
16821 abbreviated format. If its first parameter |p| is null, the value of
16822 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16823 containing the desired value. The second parameter controls the amount of
16824 output. If it is~0, dependency lists will be abbreviated to
16825 `\.{linearform}' unless they consist of a single term. If it is greater
16826 than~1, complicated structures (pens, pictures, and paths) will be displayed
16831 @<Declare the procedure called |print_dp|@>
16832 @<Declare the stashing/unstashing routines@>
16833 static void mp_print_exp (MP mp,pointer p, quarterword verbosity) ;
16836 void mp_print_exp (MP mp,pointer p, quarterword verbosity) {
16837 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16838 quarterword t; /* the type of the expression */
16839 pointer q; /* a big node being displayed */
16840 integer v=0; /* the value of the expression */
16842 restore_cur_exp=false;
16844 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16847 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16848 @<Print an abbreviated value of |v| with format depending on |t|@>;
16849 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16852 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16854 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16855 case mp_boolean_type:
16856 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16858 case unknown_types: case mp_numeric_type:
16859 @<Display a variable that's been declared but not defined@>;
16861 case mp_string_type:
16862 mp_print_char(mp, xord('"')); mp_print_str(mp, v); mp_print_char(mp, xord('"'));
16864 case mp_pen_type: case mp_path_type: case mp_picture_type:
16865 @<Display a complex type@>;
16867 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16868 if ( v==null ) mp_print_type(mp, t);
16869 else @<Display a big node@>;
16871 case mp_known:mp_print_scaled(mp, v); break;
16872 case mp_dependent: case mp_proto_dependent:
16873 mp_print_dp(mp, t,v,verbosity);
16875 case mp_independent:mp_print_variable_name(mp, p); break;
16876 default: mp_confusion(mp, "exp"); break;
16877 @:this can't happen exp}{\quad exp@>
16880 @ @<Display a big node@>=
16882 mp_print_char(mp, xord('(')); q=v+mp->big_node_size[t];
16884 if ( mp_type(v)==mp_known ) mp_print_scaled(mp, value(v));
16885 else if ( mp_type(v)==mp_independent ) mp_print_variable_name(mp, v);
16886 else mp_print_dp(mp, mp_type(v),dep_list(v),verbosity);
16888 if ( v!=q ) mp_print_char(mp, xord(','));
16890 mp_print_char(mp, xord(')'));
16893 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16894 in the log file only, unless the user has given a positive value to
16897 @<Display a complex type@>=
16898 if ( verbosity<=1 ) {
16899 mp_print_type(mp, t);
16901 if ( mp->selector==term_and_log )
16902 if ( mp->internal[mp_tracing_online]<=0 ) {
16903 mp->selector=term_only;
16904 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16905 mp->selector=term_and_log;
16908 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16909 case mp_path_type:mp_print_path(mp, v,"",false); break;
16910 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16911 } /* there are no other cases */
16914 @ @<Declare the procedure called |print_dp|@>=
16915 static void mp_print_dp (MP mp, quarterword t, pointer p,
16916 quarterword verbosity) {
16917 pointer q; /* the node following |p| */
16919 if ( (mp_info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16920 else mp_print(mp, "linearform");
16923 @ The displayed name of a variable in a ring will not be a capsule unless
16924 the ring consists entirely of capsules.
16926 @<Display a variable that's been declared but not defined@>=
16927 { mp_print_type(mp, t);
16929 { mp_print_char(mp, xord(' '));
16930 while ( (mp_name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16931 mp_print_variable_name(mp, v);
16935 @ When errors are detected during parsing, it is often helpful to
16936 display an expression just above the error message, using |exp_err|
16937 or |disp_err| instead of |print_err|.
16939 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16942 static void mp_disp_err (MP mp,pointer p, const char *s) ;
16945 void mp_disp_err (MP mp,pointer p, const char *s) {
16946 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16947 mp_print_nl(mp, ">> ");
16949 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16951 mp_print_nl(mp, "! "); mp_print(mp, s);
16956 @ If |cur_type| and |cur_exp| contain relevant information that should
16957 be recycled, we will use the following procedure, which changes |cur_type|
16958 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16959 and |cur_exp| as either alive or dormant after this has been done,
16960 because |cur_exp| will not contain a pointer value.
16963 static void mp_flush_cur_exp (MP mp,scaled v) {
16964 switch (mp->cur_type) {
16965 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16966 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16967 mp_recycle_value(mp, mp->cur_exp);
16968 mp_free_node(mp, mp->cur_exp,value_node_size);
16970 case mp_string_type:
16971 delete_str_ref(mp->cur_exp); break;
16972 case mp_pen_type: case mp_path_type:
16973 mp_toss_knot_list(mp, mp->cur_exp); break;
16974 case mp_picture_type:
16975 delete_edge_ref(mp->cur_exp); break;
16979 mp->cur_type=mp_known; mp->cur_exp=v;
16982 @ There's a much more general procedure that is capable of releasing
16983 the storage associated with any two-word value packet.
16986 static void mp_recycle_value (MP mp,pointer p) ;
16989 static void mp_recycle_value (MP mp,pointer p) {
16990 quarterword t; /* a type code */
16991 integer vv; /* another value */
16992 pointer q,r,s,pp; /* link manipulation registers */
16993 integer v=0; /* a value */
16995 if ( t<mp_dependent ) v=value(p);
16997 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
16998 case mp_numeric_type:
17000 case unknown_types:
17001 mp_ring_delete(mp, p); break;
17002 case mp_string_type:
17003 delete_str_ref(v); break;
17004 case mp_path_type: case mp_pen_type:
17005 mp_toss_knot_list(mp, v); break;
17006 case mp_picture_type:
17007 delete_edge_ref(v); break;
17008 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
17009 case mp_transform_type:
17010 @<Recycle a big node@>; break;
17011 case mp_dependent: case mp_proto_dependent:
17012 @<Recycle a dependency list@>; break;
17013 case mp_independent:
17014 @<Recycle an independent variable@>; break;
17015 case mp_token_list: case mp_structured:
17016 mp_confusion(mp, "recycle"); break;
17017 @:this can't happen recycle}{\quad recycle@>
17018 case mp_unsuffixed_macro: case mp_suffixed_macro:
17019 mp_delete_mac_ref(mp, value(p)); break;
17020 } /* there are no other cases */
17021 mp_type(p)=undefined;
17024 @ @<Recycle a big node@>=
17026 q=v+mp->big_node_size[t];
17028 q=q-2; mp_recycle_value(mp, q);
17030 mp_free_node(mp, v,mp->big_node_size[t]);
17033 @ @<Recycle a dependency list@>=
17036 while ( mp_info(q)!=null ) q=mp_link(q);
17037 mp_link(prev_dep(p))=mp_link(q);
17038 prev_dep(mp_link(q))=prev_dep(p);
17039 mp_link(q)=null; mp_flush_node_list(mp, dep_list(p));
17042 @ When an independent variable disappears, it simply fades away, unless
17043 something depends on it. In the latter case, a dependent variable whose
17044 coefficient of dependence is maximal will take its place.
17045 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
17046 as part of his Ph.D. thesis (Stanford University, December 1982).
17047 @^Zabala Salelles, Ignacio Andr\'es@>
17049 For example, suppose that variable $x$ is being recycled, and that the
17050 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
17051 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
17052 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
17053 we will print `\.{\#\#\# -2x=-y+a}'.
17055 There's a slight complication, however: An independent variable $x$
17056 can occur both in dependency lists and in proto-dependency lists.
17057 This makes it necessary to be careful when deciding which coefficient
17060 Furthermore, this complication is not so slight when
17061 a proto-dependent variable is chosen to become independent. For example,
17062 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
17063 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
17064 large coefficient `50'.
17066 In order to deal with these complications without wasting too much time,
17067 we shall link together the occurrences of~$x$ among all the linear
17068 dependencies, maintaining separate lists for the dependent and
17069 proto-dependent cases.
17071 @<Recycle an independent variable@>=
17073 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
17074 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
17075 q=mp_link(dep_head);
17076 while ( q!=dep_head ) {
17077 s=value_loc(q); /* now |mp_link(s)=dep_list(q)| */
17080 if ( mp_info(r)==null ) break;
17081 if ( mp_info(r)!=p ) {
17084 t=mp_type(q); mp_link(s)=mp_link(r); mp_info(r)=q;
17085 if ( abs(value(r))>mp->max_c[t] ) {
17086 @<Record a new maximum coefficient of type |t|@>;
17088 mp_link(r)=mp->max_link[t]; mp->max_link[t]=r;
17094 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
17095 @<Choose a dependent variable to take the place of the disappearing
17096 independent variable, and change all remaining dependencies
17101 @ The code for independency removal makes use of three two-word arrays.
17104 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
17105 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
17106 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
17108 @ @<Record a new maximum coefficient...@>=
17110 if ( mp->max_c[t]>0 ) {
17111 mp_link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17113 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
17116 @ @<Choose a dependent...@>=
17118 if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
17121 t=mp_proto_dependent;
17122 @<Determine the dependency list |s| to substitute for the independent
17124 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
17125 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
17126 mp_link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17128 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
17129 else { @<Substitute new proto-dependencies in place of |p|@>;}
17130 mp_flush_node_list(mp, s);
17131 if ( mp->fix_needed ) mp_fix_dependencies(mp);
17135 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
17136 and |mp_info(s)| points to the dependent variable~|pp| of type~|t| from
17137 whose dependency list we have removed node~|s|. We must reinsert
17138 node~|s| into the dependency list, with coefficient $-1.0$, and with
17139 |pp| as the new independent variable. Since |pp| will have a larger serial
17140 number than any other variable, we can put node |s| at the head of the
17143 @<Determine the dep...@>=
17144 s=mp->max_ptr[t]; pp=mp_info(s); v=value(s);
17145 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
17146 r=dep_list(pp); mp_link(s)=r;
17147 while ( mp_info(r)!=null ) r=mp_link(r);
17148 q=mp_link(r); mp_link(r)=null;
17149 prev_dep(q)=prev_dep(pp); mp_link(prev_dep(pp))=q;
17151 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
17152 if ( mp->internal[mp_tracing_equations]>0 ) {
17153 @<Show the transformed dependency@>;
17156 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
17157 by the dependency list~|s|.
17159 @<Show the transformed...@>=
17160 if ( mp_interesting(mp, p) ) {
17161 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
17162 @:]]]\#\#\#_}{\.{\#\#\#}@>
17163 if ( v>0 ) mp_print_char(mp, xord('-'));
17164 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
17165 else vv=mp->max_c[mp_proto_dependent];
17166 if ( vv!=unity ) mp_print_scaled(mp, vv);
17167 mp_print_variable_name(mp, p);
17168 while ( value(p) % s_scale>0 ) {
17169 mp_print(mp, "*4"); value(p)=value(p)-2;
17171 if ( t==mp_dependent ) mp_print_char(mp, xord('=')); else mp_print(mp, " = ");
17172 mp_print_dependency(mp, s,t);
17173 mp_end_diagnostic(mp, false);
17176 @ Finally, there are dependent and proto-dependent variables whose
17177 dependency lists must be brought up to date.
17179 @<Substitute new dependencies...@>=
17180 for (t=mp_dependent;t<=mp_proto_dependent;t++){
17182 while ( r!=null ) {
17184 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17185 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
17186 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
17187 q=r; r=mp_link(r); mp_free_node(mp, q,dep_node_size);
17191 @ @<Substitute new proto...@>=
17192 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
17194 while ( r!=null ) {
17196 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
17197 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
17198 mp->cur_type=mp_proto_dependent;
17199 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
17200 mp_dependent,mp_proto_dependent);
17201 mp_type(q)=mp_proto_dependent;
17202 value(r)=mp_round_fraction(mp, value(r));
17204 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17205 mp_make_scaled(mp, value(r),-v),s,
17206 mp_proto_dependent,mp_proto_dependent);
17207 if ( dep_list(q)==mp->dep_final )
17208 mp_make_known(mp, q,mp->dep_final);
17209 q=r; r=mp_link(r); mp_free_node(mp, q,dep_node_size);
17213 @ Here are some routines that provide handy combinations of actions
17214 that are often needed during error recovery. For example,
17215 `|flush_error|' flushes the current expression, replaces it by
17216 a given value, and calls |error|.
17218 Errors often are detected after an extra token has already been scanned.
17219 The `\\{put\_get}' routines put that token back before calling |error|;
17220 then they get it back again. (Or perhaps they get another token, if
17221 the user has changed things.)
17224 static void mp_flush_error (MP mp,scaled v);
17225 static void mp_put_get_error (MP mp);
17226 static void mp_put_get_flush_error (MP mp,scaled v) ;
17229 void mp_flush_error (MP mp,scaled v) {
17230 mp_error(mp); mp_flush_cur_exp(mp, v);
17232 void mp_put_get_error (MP mp) {
17233 mp_back_error(mp); mp_get_x_next(mp);
17235 void mp_put_get_flush_error (MP mp,scaled v) {
17236 mp_put_get_error(mp);
17237 mp_flush_cur_exp(mp, v);
17240 @ A global variable |var_flag| is set to a special command code
17241 just before \MP\ calls |scan_expression|, if the expression should be
17242 treated as a variable when this command code immediately follows. For
17243 example, |var_flag| is set to |assignment| at the beginning of a
17244 statement, because we want to know the {\sl location\/} of a variable at
17245 the left of `\.{:=}', not the {\sl value\/} of that variable.
17247 The |scan_expression| subroutine calls |scan_tertiary|,
17248 which calls |scan_secondary|, which calls |scan_primary|, which sets
17249 |var_flag:=0|. In this way each of the scanning routines ``knows''
17250 when it has been called with a special |var_flag|, but |var_flag| is
17253 A variable preceding a command that equals |var_flag| is converted to a
17254 token list rather than a value. Furthermore, an `\.{=}' sign following an
17255 expression with |var_flag=assignment| is not considered to be a relation
17256 that produces boolean expressions.
17260 int var_flag; /* command that wants a variable */
17265 @* \[37] Parsing primary expressions.
17266 The first parsing routine, |scan_primary|, is also the most complicated one,
17267 since it involves so many different cases. But each case---with one
17268 exception---is fairly simple by itself.
17270 When |scan_primary| begins, the first token of the primary to be scanned
17271 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17272 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17273 earlier. If |cur_cmd| is not between |min_primary_command| and
17274 |max_primary_command|, inclusive, a syntax error will be signaled.
17276 @<Declare the basic parsing subroutines@>=
17277 void mp_scan_primary (MP mp) {
17278 pointer p,q,r; /* for list manipulation */
17279 quarterword c; /* a primitive operation code */
17280 int my_var_flag; /* initial value of |my_var_flag| */
17281 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17282 @<Other local variables for |scan_primary|@>;
17283 my_var_flag=mp->var_flag; mp->var_flag=0;
17286 @<Supply diagnostic information, if requested@>;
17287 switch (mp->cur_cmd) {
17288 case left_delimiter:
17289 @<Scan a delimited primary@>; break;
17291 @<Scan a grouped primary@>; break;
17293 @<Scan a string constant@>; break;
17294 case numeric_token:
17295 @<Scan a primary that starts with a numeric token@>; break;
17297 @<Scan a nullary operation@>; break;
17298 case unary: case type_name: case cycle: case plus_or_minus:
17299 @<Scan a unary operation@>; break;
17300 case primary_binary:
17301 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17303 @<Convert a suffix to a string@>; break;
17304 case internal_quantity:
17305 @<Scan an internal numeric quantity@>; break;
17306 case capsule_token:
17307 mp_make_exp_copy(mp, mp->cur_mod); break;
17309 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17311 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17312 @.A primary expression...@>
17314 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17316 if ( mp->cur_cmd==left_bracket ) {
17317 if ( mp->cur_type>=mp_known ) {
17318 @<Scan a mediation construction@>;
17325 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17328 static void mp_bad_exp (MP mp, const char * s) {
17330 print_err(s); mp_print(mp, " expression can't begin with `");
17331 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17332 mp_print_char(mp, xord('\''));
17333 help4("I'm afraid I need some sort of value in order to continue,",
17334 "so I've tentatively inserted `0'. You may want to",
17335 "delete this zero and insert something else;",
17336 "see Chapter 27 of The METAFONTbook for an example.");
17337 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17338 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17339 mp->cur_mod=0; mp_ins_error(mp);
17340 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17341 mp->var_flag=save_flag;
17344 @ @<Supply diagnostic information, if requested@>=
17346 if ( mp->panicking ) mp_check_mem(mp, false);
17348 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17349 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17352 @ @<Scan a delimited primary@>=
17354 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17355 mp_get_x_next(mp); mp_scan_expression(mp);
17356 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17357 @<Scan the rest of a delimited set of numerics@>;
17359 mp_check_delimiter(mp, l_delim,r_delim);
17363 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17364 within a ``big node.''
17367 static void mp_stash_in (MP mp,pointer p) {
17368 pointer q; /* temporary register */
17369 mp_type(p)=mp->cur_type;
17370 if ( mp->cur_type==mp_known ) {
17371 value(p)=mp->cur_exp;
17373 if ( mp->cur_type==mp_independent ) {
17374 @<Stash an independent |cur_exp| into a big node@>;
17376 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17377 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17378 mp_link(prev_dep(p))=p;
17380 mp_free_node(mp, mp->cur_exp,value_node_size);
17382 mp->cur_type=mp_vacuous;
17385 @ In rare cases the current expression can become |independent|. There
17386 may be many dependency lists pointing to such an independent capsule,
17387 so we can't simply move it into place within a big node. Instead,
17388 we copy it, then recycle it.
17390 @ @<Stash an independent |cur_exp|...@>=
17392 q=mp_single_dependency(mp, mp->cur_exp);
17393 if ( q==mp->dep_final ){
17394 mp_type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17396 mp_type(p)=mp_dependent; mp_new_dep(mp, p,q);
17398 mp_recycle_value(mp, mp->cur_exp);
17401 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17402 are synonymous with |x_part_loc| and |y_part_loc|.
17404 @<Scan the rest of a delimited set of numerics@>=
17406 p=mp_stash_cur_exp(mp);
17407 mp_get_x_next(mp); mp_scan_expression(mp);
17408 @<Make sure the second part of a pair or color has a numeric type@>;
17409 q=mp_get_node(mp, value_node_size); mp_name_type(q)=mp_capsule;
17410 if ( mp->cur_cmd==comma ) mp_type(q)=mp_color_type;
17411 else mp_type(q)=mp_pair_type;
17412 mp_init_big_node(mp, q); r=value(q);
17413 mp_stash_in(mp, y_part_loc(r));
17414 mp_unstash_cur_exp(mp, p);
17415 mp_stash_in(mp, x_part_loc(r));
17416 if ( mp->cur_cmd==comma ) {
17417 @<Scan the last of a triplet of numerics@>;
17419 if ( mp->cur_cmd==comma ) {
17420 mp_type(q)=mp_cmykcolor_type;
17421 mp_init_big_node(mp, q); t=value(q);
17422 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17423 value(cyan_part_loc(t))=value(red_part_loc(r));
17424 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17425 value(magenta_part_loc(t))=value(green_part_loc(r));
17426 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17427 value(yellow_part_loc(t))=value(blue_part_loc(r));
17428 mp_recycle_value(mp, r);
17430 @<Scan the last of a quartet of numerics@>;
17432 mp_check_delimiter(mp, l_delim,r_delim);
17433 mp->cur_type=mp_type(q);
17437 @ @<Make sure the second part of a pair or color has a numeric type@>=
17438 if ( mp->cur_type<mp_known ) {
17439 exp_err("Nonnumeric ypart has been replaced by 0");
17440 @.Nonnumeric...replaced by 0@>
17441 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';",
17442 "but after finding a nice `a' I found a `b' that isn't",
17443 "of numeric type. So I've changed that part to zero.",
17444 "(The b that I didn't like appears above the error message.)");
17445 mp_put_get_flush_error(mp, 0);
17448 @ @<Scan the last of a triplet of numerics@>=
17450 mp_get_x_next(mp); mp_scan_expression(mp);
17451 if ( mp->cur_type<mp_known ) {
17452 exp_err("Nonnumeric third part has been replaced by 0");
17453 @.Nonnumeric...replaced by 0@>
17454 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'",
17455 "isn't of numeric type. So I've changed that part to zero.",
17456 "(The c that I didn't like appears above the error message.)");
17457 mp_put_get_flush_error(mp, 0);
17459 mp_stash_in(mp, blue_part_loc(r));
17462 @ @<Scan the last of a quartet of numerics@>=
17464 mp_get_x_next(mp); mp_scan_expression(mp);
17465 if ( mp->cur_type<mp_known ) {
17466 exp_err("Nonnumeric blackpart has been replaced by 0");
17467 @.Nonnumeric...replaced by 0@>
17468 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't",
17469 "of numeric type. So I've changed that part to zero.",
17470 "(The k that I didn't like appears above the error message.)");
17471 mp_put_get_flush_error(mp, 0);
17473 mp_stash_in(mp, black_part_loc(r));
17476 @ The local variable |group_line| keeps track of the line
17477 where a \&{begingroup} command occurred; this will be useful
17478 in an error message if the group doesn't actually end.
17480 @<Other local variables for |scan_primary|@>=
17481 integer group_line; /* where a group began */
17483 @ @<Scan a grouped primary@>=
17485 group_line=mp_true_line(mp);
17486 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17487 save_boundary_item(p);
17489 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17490 } while (mp->cur_cmd==semicolon);
17491 if ( mp->cur_cmd!=end_group ) {
17492 print_err("A group begun on line ");
17493 @.A group...never ended@>
17494 mp_print_int(mp, group_line);
17495 mp_print(mp, " never ended");
17496 help2("I saw a `begingroup' back there that hasn't been matched",
17497 "by `endgroup'. So I've inserted `endgroup' now.");
17498 mp_back_error(mp); mp->cur_cmd=end_group;
17501 /* this might change |cur_type|, if independent variables are recycled */
17502 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17505 @ @<Scan a string constant@>=
17507 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17510 @ Later we'll come to procedures that perform actual operations like
17511 addition, square root, and so on; our purpose now is to do the parsing.
17512 But we might as well mention those future procedures now, so that the
17513 suspense won't be too bad:
17516 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17517 `\&{true}' or `\&{pencircle}');
17520 |do_unary(c)| applies a primitive operation to the current expression;
17523 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17524 and the current expression.
17526 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17528 @ @<Scan a unary operation@>=
17530 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17531 mp_do_unary(mp, c); goto DONE;
17534 @ A numeric token might be a primary by itself, or it might be the
17535 numerator of a fraction composed solely of numeric tokens, or it might
17536 multiply the primary that follows (provided that the primary doesn't begin
17537 with a plus sign or a minus sign). The code here uses the facts that
17538 |max_primary_command=plus_or_minus| and
17539 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17540 than unity, we try to retain higher precision when we use it in scalar
17543 @<Other local variables for |scan_primary|@>=
17544 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17546 @ @<Scan a primary that starts with a numeric token@>=
17548 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17549 if ( mp->cur_cmd!=slash ) {
17553 if ( mp->cur_cmd!=numeric_token ) {
17555 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17558 num=mp->cur_exp; denom=mp->cur_mod;
17559 if ( denom==0 ) { @<Protest division by zero@>; }
17560 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17561 check_arith; mp_get_x_next(mp);
17563 if ( mp->cur_cmd>=min_primary_command ) {
17564 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17565 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17566 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17567 mp_do_binary(mp, p,times);
17569 mp_frac_mult(mp, num,denom);
17570 mp_free_node(mp, p,value_node_size);
17577 @ @<Protest division...@>=
17579 print_err("Division by zero");
17580 @.Division by zero@>
17581 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17584 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17586 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17587 if ( mp->cur_cmd!=of_token ) {
17588 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17589 mp_print_cmd_mod(mp, primary_binary,c);
17591 help1("I've got the first argument; will look now for the other.");
17594 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17595 mp_do_binary(mp, p,c); goto DONE;
17598 @ @<Convert a suffix to a string@>=
17600 mp_get_x_next(mp); mp_scan_suffix(mp);
17601 mp->old_setting=mp->selector; mp->selector=new_string;
17602 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17603 mp_flush_token_list(mp, mp->cur_exp);
17604 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17605 mp->cur_type=mp_string_type;
17609 @ If an internal quantity appears all by itself on the left of an
17610 assignment, we return a token list of length one, containing the address
17611 of the internal quantity plus |hash_end|. (This accords with the conventions
17612 of the save stack, as described earlier.)
17614 @<Scan an internal...@>=
17617 if ( my_var_flag==assignment ) {
17619 if ( mp->cur_cmd==assignment ) {
17620 mp->cur_exp=mp_get_avail(mp);
17621 mp_info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17626 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17629 @ The most difficult part of |scan_primary| has been saved for last, since
17630 it was necessary to build up some confidence first. We can now face the task
17631 of scanning a variable.
17633 As we scan a variable, we build a token list containing the relevant
17634 names and subscript values, simultaneously following along in the
17635 ``collective'' structure to see if we are actually dealing with a macro
17636 instead of a value.
17638 The local variables |pre_head| and |post_head| will point to the beginning
17639 of the prefix and suffix lists; |tail| will point to the end of the list
17640 that is currently growing.
17642 Another local variable, |tt|, contains partial information about the
17643 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17644 relation |tt=mp_type(q)| will always hold. If |tt=undefined|, the routine
17645 doesn't bother to update its information about type. And if
17646 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17648 @ @<Other local variables for |scan_primary|@>=
17649 pointer pre_head,post_head,tail;
17650 /* prefix and suffix list variables */
17651 quarterword tt; /* approximation to the type of the variable-so-far */
17652 pointer t; /* a token */
17653 pointer macro_ref = 0; /* reference count for a suffixed macro */
17655 @ @<Scan a variable primary...@>=
17657 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17659 t=mp_cur_tok(mp); mp_link(tail)=t;
17660 if ( tt!=undefined ) {
17661 @<Find the approximate type |tt| and corresponding~|q|@>;
17662 if ( tt>=mp_unsuffixed_macro ) {
17663 @<Either begin an unsuffixed macro call or
17664 prepare for a suffixed one@>;
17667 mp_get_x_next(mp); tail=t;
17668 if ( mp->cur_cmd==left_bracket ) {
17669 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17671 if ( mp->cur_cmd>max_suffix_token ) break;
17672 if ( mp->cur_cmd<min_suffix_token ) break;
17673 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17674 @<Handle unusual cases that masquerade as variables, and |goto restart|
17675 or |goto done| if appropriate;
17676 otherwise make a copy of the variable and |goto done|@>;
17679 @ @<Either begin an unsuffixed macro call or...@>=
17681 mp_link(tail)=null;
17682 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17683 post_head=mp_get_avail(mp); tail=post_head; mp_link(tail)=t;
17684 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17686 @<Set up unsuffixed macro call and |goto restart|@>;
17690 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17692 mp_get_x_next(mp); mp_scan_expression(mp);
17693 if ( mp->cur_cmd!=right_bracket ) {
17694 @<Put the left bracket and the expression back to be rescanned@>;
17696 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17697 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17701 @ The left bracket that we thought was introducing a subscript might have
17702 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17703 So we don't issue an error message at this point; but we do want to back up
17704 so as to avoid any embarrassment about our incorrect assumption.
17706 @<Put the left bracket and the expression back to be rescanned@>=
17708 mp_back_input(mp); /* that was the token following the current expression */
17709 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17710 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17713 @ Here's a routine that puts the current expression back to be read again.
17716 static void mp_back_expr (MP mp) {
17717 pointer p; /* capsule token */
17718 p=mp_stash_cur_exp(mp); mp_link(p)=null; back_list(p);
17721 @ Unknown subscripts lead to the following error message.
17724 static void mp_bad_subscript (MP mp) {
17725 exp_err("Improper subscript has been replaced by zero");
17726 @.Improper subscript...@>
17727 help3("A bracketed subscript must have a known numeric value;",
17728 "unfortunately, what I found was the value that appears just",
17729 "above this error message. So I'll try a zero subscript.");
17730 mp_flush_error(mp, 0);
17733 @ Every time we call |get_x_next|, there's a chance that the variable we've
17734 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17735 into the variable structure; we need to start searching from the root each time.
17737 @<Find the approximate type |tt| and corresponding~|q|@>=
17740 p=mp_link(pre_head); q=mp_info(p); tt=undefined;
17741 if ( eq_type(q) % outer_tag==tag_token ) {
17743 if ( q==null ) goto DONE2;
17747 tt=mp_type(q); goto DONE2;
17749 if ( mp_type(q)!=mp_structured ) goto DONE2;
17750 q=mp_link(attr_head(q)); /* the |collective_subscript| attribute */
17751 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17752 do { q=mp_link(q); } while (! (attr_loc(q)>=mp_info(p)));
17753 if ( attr_loc(q)>mp_info(p) ) goto DONE2;
17761 @ How do things stand now? Well, we have scanned an entire variable name,
17762 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17763 |cur_sym| represent the token that follows. If |post_head=null|, a
17764 token list for this variable name starts at |mp_link(pre_head)|, with all
17765 subscripts evaluated. But if |post_head<>null|, the variable turned out
17766 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17767 |post_head| is the head of a token list containing both `\.{\AT!}' and
17770 Our immediate problem is to see if this variable still exists. (Variable
17771 structures can change drastically whenever we call |get_x_next|; users
17772 aren't supposed to do this, but the fact that it is possible means that
17773 we must be cautious.)
17775 The following procedure prints an error message when a variable
17776 unexpectedly disappears. Its help message isn't quite right for
17777 our present purposes, but we'll be able to fix that up.
17780 static void mp_obliterated (MP mp,pointer q) {
17781 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17782 mp_print(mp, " has been obliterated");
17783 @.Variable...obliterated@>
17784 help5("It seems you did a nasty thing---probably by accident,",
17785 "but nevertheless you nearly hornswoggled me...",
17786 "While I was evaluating the right-hand side of this",
17787 "command, something happened, and the left-hand side",
17788 "is no longer a variable! So I won't change anything.");
17791 @ If the variable does exist, we also need to check
17792 for a few other special cases before deciding that a plain old ordinary
17793 variable has, indeed, been scanned.
17795 @<Handle unusual cases that masquerade as variables...@>=
17796 if ( post_head!=null ) {
17797 @<Set up suffixed macro call and |goto restart|@>;
17799 q=mp_link(pre_head); free_avail(pre_head);
17800 if ( mp->cur_cmd==my_var_flag ) {
17801 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17803 p=mp_find_variable(mp, q);
17805 mp_make_exp_copy(mp, p);
17807 mp_obliterated(mp, q);
17808 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17809 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17810 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17811 mp_put_get_flush_error(mp, 0);
17813 mp_flush_node_list(mp, q);
17816 @ The only complication associated with macro calling is that the prefix
17817 and ``at'' parameters must be packaged in an appropriate list of lists.
17819 @<Set up unsuffixed macro call and |goto restart|@>=
17821 p=mp_get_avail(mp); mp_info(pre_head)=mp_link(pre_head); mp_link(pre_head)=p;
17822 mp_info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17827 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17828 we don't care, because we have reserved a pointer (|macro_ref|) to its
17831 @<Set up suffixed macro call and |goto restart|@>=
17833 mp_back_input(mp); p=mp_get_avail(mp); q=mp_link(post_head);
17834 mp_info(pre_head)=mp_link(pre_head); mp_link(pre_head)=post_head;
17835 mp_info(post_head)=q; mp_link(post_head)=p; mp_info(p)=mp_link(q); mp_link(q)=null;
17836 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17837 mp_get_x_next(mp); goto RESTART;
17840 @ Our remaining job is simply to make a copy of the value that has been
17841 found. Some cases are harder than others, but complexity arises solely
17842 because of the multiplicity of possible cases.
17844 @<Declare the procedure called |make_exp_copy|@>=
17845 @<Declare subroutines needed by |make_exp_copy|@>
17846 static void mp_make_exp_copy (MP mp,pointer p) {
17847 pointer q,r,t; /* registers for list manipulation */
17849 mp->cur_type=mp_type(p);
17850 switch (mp->cur_type) {
17851 case mp_vacuous: case mp_boolean_type: case mp_known:
17852 mp->cur_exp=value(p); break;
17853 case unknown_types:
17854 mp->cur_exp=mp_new_ring_entry(mp, p);
17856 case mp_string_type:
17857 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17859 case mp_picture_type:
17860 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17863 mp->cur_exp=copy_pen(value(p));
17866 mp->cur_exp=mp_copy_path(mp, value(p));
17868 case mp_transform_type: case mp_color_type:
17869 case mp_cmykcolor_type: case mp_pair_type:
17870 @<Copy the big node |p|@>;
17872 case mp_dependent: case mp_proto_dependent:
17873 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17875 case mp_numeric_type:
17876 new_indep(p); goto RESTART;
17878 case mp_independent:
17879 q=mp_single_dependency(mp, p);
17880 if ( q==mp->dep_final ){
17881 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
17883 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17887 mp_confusion(mp, "copy");
17888 @:this can't happen copy}{\quad copy@>
17893 @ The |encapsulate| subroutine assumes that |dep_final| is the
17894 tail of dependency list~|p|.
17896 @<Declare subroutines needed by |make_exp_copy|@>=
17897 static void mp_encapsulate (MP mp,pointer p) {
17898 mp->cur_exp=mp_get_node(mp, value_node_size); mp_type(mp->cur_exp)=mp->cur_type;
17899 mp_name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17902 @ The most tedious case arises when the user refers to a
17903 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17904 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17907 @<Copy the big node |p|@>=
17909 if ( value(p)==null )
17910 mp_init_big_node(mp, p);
17911 t=mp_get_node(mp, value_node_size); mp_name_type(t)=mp_capsule; mp_type(t)=mp->cur_type;
17912 mp_init_big_node(mp, t);
17913 q=value(p)+mp->big_node_size[mp->cur_type];
17914 r=value(t)+mp->big_node_size[mp->cur_type];
17916 q=q-2; r=r-2; mp_install(mp, r,q);
17917 } while (q!=value(p));
17921 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17922 a big node that will be part of a capsule.
17924 @<Declare subroutines needed by |make_exp_copy|@>=
17925 static void mp_install (MP mp,pointer r, pointer q) {
17926 pointer p; /* temporary register */
17927 if ( mp_type(q)==mp_known ){
17928 value(r)=value(q); mp_type(r)=mp_known;
17929 } else if ( mp_type(q)==mp_independent ) {
17930 p=mp_single_dependency(mp, q);
17931 if ( p==mp->dep_final ) {
17932 mp_type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
17934 mp_type(r)=mp_dependent; mp_new_dep(mp, r,p);
17937 mp_type(r)=mp_type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17941 @ Expressions of the form `\.{a[b,c]}' are converted into
17942 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17943 provided that \.a is numeric.
17945 @<Scan a mediation...@>=
17947 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17948 if ( mp->cur_cmd!=comma ) {
17949 @<Put the left bracket and the expression back...@>;
17950 mp_unstash_cur_exp(mp, p);
17952 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17953 if ( mp->cur_cmd!=right_bracket ) {
17954 mp_missing_err(mp, "]");
17956 help3("I've scanned an expression of the form `a[b,c',",
17957 "so a right bracket should have come next.",
17958 "I shall pretend that one was there.");
17961 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17962 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17963 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17967 @ Here is a comparatively simple routine that is used to scan the
17968 \&{suffix} parameters of a macro.
17970 @<Declare the basic parsing subroutines@>=
17971 static void mp_scan_suffix (MP mp) {
17972 pointer h,t; /* head and tail of the list being built */
17973 pointer p; /* temporary register */
17974 h=mp_get_avail(mp); t=h;
17976 if ( mp->cur_cmd==left_bracket ) {
17977 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17979 if ( mp->cur_cmd==numeric_token ) {
17980 p=mp_new_num_tok(mp, mp->cur_mod);
17981 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17982 p=mp_get_avail(mp); mp_info(p)=mp->cur_sym;
17986 mp_link(t)=p; t=p; mp_get_x_next(mp);
17988 mp->cur_exp=mp_link(h); free_avail(h); mp->cur_type=mp_token_list;
17991 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17993 mp_get_x_next(mp); mp_scan_expression(mp);
17994 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17995 if ( mp->cur_cmd!=right_bracket ) {
17996 mp_missing_err(mp, "]");
17998 help3("I've seen a `[' and a subscript value, in a suffix,",
17999 "so a right bracket should have come next.",
18000 "I shall pretend that one was there.");
18003 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
18006 @* \[38] Parsing secondary and higher expressions.
18008 After the intricacies of |scan_primary|\kern-1pt,
18009 the |scan_secondary| routine is
18010 refreshingly simple. It's not trivial, but the operations are relatively
18011 straightforward; the main difficulty is, again, that expressions and data
18012 structures might change drastically every time we call |get_x_next|, so a
18013 cautious approach is mandatory. For example, a macro defined by
18014 \&{primarydef} might have disappeared by the time its second argument has
18015 been scanned; we solve this by increasing the reference count of its token
18016 list, so that the macro can be called even after it has been clobbered.
18018 @<Declare the basic parsing subroutines@>=
18019 static void mp_scan_secondary (MP mp) {
18020 pointer p; /* for list manipulation */
18021 halfword c,d; /* operation codes or modifiers */
18022 pointer mac_name; /* token defined with \&{primarydef} */
18024 if ((mp->cur_cmd<min_primary_command)||
18025 (mp->cur_cmd>max_primary_command) )
18026 mp_bad_exp(mp, "A secondary");
18027 @.A secondary expression...@>
18028 mp_scan_primary(mp);
18030 if ( mp->cur_cmd<=max_secondary_command &&
18031 mp->cur_cmd>=min_secondary_command ) {
18032 p=mp_stash_cur_exp(mp);
18033 c=mp->cur_mod; d=mp->cur_cmd;
18034 if ( d==secondary_primary_macro ) {
18035 mac_name=mp->cur_sym;
18039 mp_scan_primary(mp);
18040 if ( d!=secondary_primary_macro ) {
18041 mp_do_binary(mp, p,c);
18044 mp_binary_mac(mp, p,c,mac_name);
18045 decr(ref_count(c));
18053 @ The following procedure calls a macro that has two parameters,
18057 static void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
18058 pointer q,r; /* nodes in the parameter list */
18059 q=mp_get_avail(mp); r=mp_get_avail(mp); mp_link(q)=r;
18060 mp_info(q)=p; mp_info(r)=mp_stash_cur_exp(mp);
18061 mp_macro_call(mp, c,q,n);
18064 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
18066 @<Declare the basic parsing subroutines@>=
18067 static void mp_scan_tertiary (MP mp) {
18068 pointer p; /* for list manipulation */
18069 halfword c,d; /* operation codes or modifiers */
18070 pointer mac_name; /* token defined with \&{secondarydef} */
18072 if ((mp->cur_cmd<min_primary_command)||
18073 (mp->cur_cmd>max_primary_command) )
18074 mp_bad_exp(mp, "A tertiary");
18075 @.A tertiary expression...@>
18076 mp_scan_secondary(mp);
18078 if ( mp->cur_cmd<=max_tertiary_command ) {
18079 if ( mp->cur_cmd>=min_tertiary_command ) {
18080 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18081 if ( d==tertiary_secondary_macro ) {
18082 mac_name=mp->cur_sym; add_mac_ref(c);
18084 mp_get_x_next(mp); mp_scan_secondary(mp);
18085 if ( d!=tertiary_secondary_macro ) {
18086 mp_do_binary(mp, p,c);
18088 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18089 decr(ref_count(c)); mp_get_x_next(mp);
18097 @ Finally we reach the deepest level in our quartet of parsing routines.
18098 This one is much like the others; but it has an extra complication from
18099 paths, which materialize here.
18101 @d continue_path 25 /* a label inside of |scan_expression| */
18102 @d finish_path 26 /* another */
18104 @<Declare the basic parsing subroutines@>=
18105 static void mp_scan_expression (MP mp) {
18106 pointer p,q,r,pp,qq; /* for list manipulation */
18107 halfword c,d; /* operation codes or modifiers */
18108 int my_var_flag; /* initial value of |var_flag| */
18109 pointer mac_name; /* token defined with \&{tertiarydef} */
18110 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
18111 scaled x,y; /* explicit coordinates or tension at a path join */
18112 int t; /* knot type following a path join */
18114 my_var_flag=mp->var_flag; mac_name=null;
18116 if ((mp->cur_cmd<min_primary_command)||
18117 (mp->cur_cmd>max_primary_command) )
18118 mp_bad_exp(mp, "An");
18119 @.An expression...@>
18120 mp_scan_tertiary(mp);
18122 if ( mp->cur_cmd<=max_expression_command )
18123 if ( mp->cur_cmd>=min_expression_command ) {
18124 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
18125 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18126 if ( d==expression_tertiary_macro ) {
18127 mac_name=mp->cur_sym; add_mac_ref(c);
18129 if ( (d<ampersand)||((d==ampersand)&&
18130 ((mp_type(p)==mp_pair_type)||(mp_type(p)==mp_path_type))) ) {
18131 @<Scan a path construction operation;
18132 but |return| if |p| has the wrong type@>;
18134 mp_get_x_next(mp); mp_scan_tertiary(mp);
18135 if ( d!=expression_tertiary_macro ) {
18136 mp_do_binary(mp, p,c);
18138 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18139 decr(ref_count(c)); mp_get_x_next(mp);
18148 @ The reader should review the data structure conventions for paths before
18149 hoping to understand the next part of this code.
18151 @<Scan a path construction operation...@>=
18154 @<Convert the left operand, |p|, into a partial path ending at~|q|;
18155 but |return| if |p| doesn't have a suitable type@>;
18157 @<Determine the path join parameters;
18158 but |goto finish_path| if there's only a direction specifier@>;
18159 if ( mp->cur_cmd==cycle ) {
18160 @<Get ready to close a cycle@>;
18162 mp_scan_tertiary(mp);
18163 @<Convert the right operand, |cur_exp|,
18164 into a partial path from |pp| to~|qq|@>;
18166 @<Join the partial paths and reset |p| and |q| to the head and tail
18168 if ( mp->cur_cmd>=min_expression_command )
18169 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
18171 @<Choose control points for the path and put the result into |cur_exp|@>;
18174 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
18176 mp_unstash_cur_exp(mp, p);
18177 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
18178 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
18181 while ( mp_link(q)!=p ) q=mp_link(q);
18182 if ( mp_left_type(p)!=mp_endpoint ) { /* open up a cycle */
18183 r=mp_copy_knot(mp, p); mp_link(q)=r; q=r;
18185 mp_left_type(p)=mp_open; mp_right_type(q)=mp_open;
18188 @ A pair of numeric values is changed into a knot node for a one-point path
18189 when \MP\ discovers that the pair is part of a path.
18192 static pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
18193 pointer q; /* the new node */
18194 q=mp_get_node(mp, knot_node_size); mp_left_type(q)=mp_endpoint;
18195 mp_right_type(q)=mp_endpoint; mp_originator(q)=mp_metapost_user; mp_link(q)=q;
18196 mp_known_pair(mp); mp_x_coord(q)=mp->cur_x; mp_y_coord(q)=mp->cur_y;
18200 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
18201 of the current expression, assuming that the current expression is a
18202 pair of known numerics. Unknown components are zeroed, and the
18203 current expression is flushed.
18206 static void mp_known_pair (MP mp);
18209 void mp_known_pair (MP mp) {
18210 pointer p; /* the pair node */
18211 if ( mp->cur_type!=mp_pair_type ) {
18212 exp_err("Undefined coordinates have been replaced by (0,0)");
18213 @.Undefined coordinates...@>
18214 help5("I need x and y numbers for this part of the path.",
18215 "The value I found (see above) was no good;",
18216 "so I'll try to keep going by using zero instead.",
18217 "(Chapter 27 of The METAFONTbook explains that",
18218 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18219 "you might want to type `I ??" "?' now.)");
18220 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
18222 p=value(mp->cur_exp);
18223 @<Make sure that both |x| and |y| parts of |p| are known;
18224 copy them into |cur_x| and |cur_y|@>;
18225 mp_flush_cur_exp(mp, 0);
18229 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
18230 if ( mp_type(x_part_loc(p))==mp_known ) {
18231 mp->cur_x=value(x_part_loc(p));
18233 mp_disp_err(mp, x_part_loc(p),
18234 "Undefined x coordinate has been replaced by 0");
18235 @.Undefined coordinates...@>
18236 help5("I need a `known' x value for this part of the path.",
18237 "The value I found (see above) was no good;",
18238 "so I'll try to keep going by using zero instead.",
18239 "(Chapter 27 of The METAFONTbook explains that",
18240 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18241 "you might want to type `I ??" "?' now.)");
18242 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18244 if ( mp_type(y_part_loc(p))==mp_known ) {
18245 mp->cur_y=value(y_part_loc(p));
18247 mp_disp_err(mp, y_part_loc(p),
18248 "Undefined y coordinate has been replaced by 0");
18249 help5("I need a `known' y value for this part of the path.",
18250 "The value I found (see above) was no good;",
18251 "so I'll try to keep going by using zero instead.",
18252 "(Chapter 27 of The METAFONTbook explains that",
18253 "you might want to type `I ??" "?' now.)");
18254 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18257 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18259 @<Determine the path join parameters...@>=
18260 if ( mp->cur_cmd==left_brace ) {
18261 @<Put the pre-join direction information into node |q|@>;
18264 if ( d==path_join ) {
18265 @<Determine the tension and/or control points@>;
18266 } else if ( d!=ampersand ) {
18270 if ( mp->cur_cmd==left_brace ) {
18271 @<Put the post-join direction information into |x| and |t|@>;
18272 } else if ( mp_right_type(q)!=mp_explicit ) {
18276 @ The |scan_direction| subroutine looks at the directional information
18277 that is enclosed in braces, and also scans ahead to the following character.
18278 A type code is returned, either |open| (if the direction was $(0,0)$),
18279 or |curl| (if the direction was a curl of known value |cur_exp|), or
18280 |given| (if the direction is given by the |angle| value that now
18281 appears in |cur_exp|).
18283 There's nothing difficult about this subroutine, but the program is rather
18284 lengthy because a variety of potential errors need to be nipped in the bud.
18287 static quarterword mp_scan_direction (MP mp) {
18288 int t; /* the type of information found */
18289 scaled x; /* an |x| coordinate */
18291 if ( mp->cur_cmd==curl_command ) {
18292 @<Scan a curl specification@>;
18294 @<Scan a given direction@>;
18296 if ( mp->cur_cmd!=right_brace ) {
18297 mp_missing_err(mp, "}");
18298 @.Missing `\char`\}'@>
18299 help3("I've scanned a direction spec for part of a path,",
18300 "so a right brace should have come next.",
18301 "I shall pretend that one was there.");
18308 @ @<Scan a curl specification@>=
18309 { mp_get_x_next(mp); mp_scan_expression(mp);
18310 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18311 exp_err("Improper curl has been replaced by 1");
18313 help1("A curl must be a known, nonnegative number.");
18314 mp_put_get_flush_error(mp, unity);
18319 @ @<Scan a given direction@>=
18320 { mp_scan_expression(mp);
18321 if ( mp->cur_type>mp_pair_type ) {
18322 @<Get given directions separated by commas@>;
18326 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18327 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18330 @ @<Get given directions separated by commas@>=
18332 if ( mp->cur_type!=mp_known ) {
18333 exp_err("Undefined x coordinate has been replaced by 0");
18334 @.Undefined coordinates...@>
18335 help5("I need a `known' x value for this part of the path.",
18336 "The value I found (see above) was no good;",
18337 "so I'll try to keep going by using zero instead.",
18338 "(Chapter 27 of The METAFONTbook explains that",
18339 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18340 "you might want to type `I ??" "?' now.)");
18341 mp_put_get_flush_error(mp, 0);
18344 if ( mp->cur_cmd!=comma ) {
18345 mp_missing_err(mp, ",");
18347 help2("I've got the x coordinate of a path direction;",
18348 "will look for the y coordinate next.");
18351 mp_get_x_next(mp); mp_scan_expression(mp);
18352 if ( mp->cur_type!=mp_known ) {
18353 exp_err("Undefined y coordinate has been replaced by 0");
18354 help5("I need a `known' y value for this part of the path.",
18355 "The value I found (see above) was no good;",
18356 "so I'll try to keep going by using zero instead.",
18357 "(Chapter 27 of The METAFONTbook explains that",
18358 "you might want to type `I ??" "?' now.)");
18359 mp_put_get_flush_error(mp, 0);
18361 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18364 @ At this point |mp_right_type(q)| is usually |open|, but it may have been
18365 set to some other value by a previous operation. We must maintain
18366 the value of |mp_right_type(q)| in cases such as
18367 `\.{..\{curl2\}z\{0,0\}..}'.
18369 @<Put the pre-join...@>=
18371 t=mp_scan_direction(mp);
18372 if ( t!=mp_open ) {
18373 mp_right_type(q)=t; right_given(q)=mp->cur_exp;
18374 if ( mp_left_type(q)==mp_open ) {
18375 mp_left_type(q)=t; left_given(q)=mp->cur_exp;
18376 } /* note that |left_given(q)=left_curl(q)| */
18380 @ Since |left_tension| and |mp_left_y| share the same position in knot nodes,
18381 and since |left_given| is similarly equivalent to |mp_left_x|, we use
18382 |x| and |y| to hold the given direction and tension information when
18383 there are no explicit control points.
18385 @<Put the post-join...@>=
18387 t=mp_scan_direction(mp);
18388 if ( mp_right_type(q)!=mp_explicit ) x=mp->cur_exp;
18389 else t=mp_explicit; /* the direction information is superfluous */
18392 @ @<Determine the tension and/or...@>=
18395 if ( mp->cur_cmd==tension ) {
18396 @<Set explicit tensions@>;
18397 } else if ( mp->cur_cmd==controls ) {
18398 @<Set explicit control points@>;
18400 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18403 if ( mp->cur_cmd!=path_join ) {
18404 mp_missing_err(mp, "..");
18406 help1("A path join command should end with two dots.");
18413 @ @<Set explicit tensions@>=
18415 mp_get_x_next(mp); y=mp->cur_cmd;
18416 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18417 mp_scan_primary(mp);
18418 @<Make sure that the current expression is a valid tension setting@>;
18419 if ( y==at_least ) negate(mp->cur_exp);
18420 right_tension(q)=mp->cur_exp;
18421 if ( mp->cur_cmd==and_command ) {
18422 mp_get_x_next(mp); y=mp->cur_cmd;
18423 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18424 mp_scan_primary(mp);
18425 @<Make sure that the current expression is a valid tension setting@>;
18426 if ( y==at_least ) negate(mp->cur_exp);
18431 @ @d min_tension three_quarter_unit
18433 @<Make sure that the current expression is a valid tension setting@>=
18434 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18435 exp_err("Improper tension has been set to 1");
18436 @.Improper tension@>
18437 help1("The expression above should have been a number >=3/4.");
18438 mp_put_get_flush_error(mp, unity);
18441 @ @<Set explicit control points@>=
18443 mp_right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18444 mp_known_pair(mp); mp_right_x(q)=mp->cur_x; mp_right_y(q)=mp->cur_y;
18445 if ( mp->cur_cmd!=and_command ) {
18446 x=mp_right_x(q); y=mp_right_y(q);
18448 mp_get_x_next(mp); mp_scan_primary(mp);
18449 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18453 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18455 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18456 else pp=mp->cur_exp;
18458 while ( mp_link(qq)!=pp ) qq=mp_link(qq);
18459 if ( mp_left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18460 r=mp_copy_knot(mp, pp); mp_link(qq)=r; qq=r;
18462 mp_left_type(pp)=mp_open; mp_right_type(qq)=mp_open;
18465 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18466 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18467 shouldn't have length zero.
18469 @<Get ready to close a cycle@>=
18471 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18472 if ( d==ampersand ) if ( p==q ) {
18473 d=path_join; right_tension(q)=unity; y=unity;
18477 @ @<Join the partial paths and reset |p| and |q|...@>=
18479 if ( d==ampersand ) {
18480 if ( (mp_x_coord(q)!=mp_x_coord(pp))||(mp_y_coord(q)!=mp_y_coord(pp)) ) {
18481 print_err("Paths don't touch; `&' will be changed to `..'");
18482 @.Paths don't touch@>
18483 help3("When you join paths `p&q', the ending point of p",
18484 "must be exactly equal to the starting point of q.",
18485 "So I'm going to pretend that you said `p..q' instead.");
18486 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18489 @<Plug an opening in |mp_right_type(pp)|, if possible@>;
18490 if ( d==ampersand ) {
18491 @<Splice independent paths together@>;
18493 @<Plug an opening in |mp_right_type(q)|, if possible@>;
18494 mp_link(q)=pp; mp_left_y(pp)=y;
18495 if ( t!=mp_open ) { mp_left_x(pp)=x; mp_left_type(pp)=t; };
18500 @ @<Plug an opening in |mp_right_type(q)|...@>=
18501 if ( mp_right_type(q)==mp_open ) {
18502 if ( (mp_left_type(q)==mp_curl)||(mp_left_type(q)==mp_given) ) {
18503 mp_right_type(q)=mp_left_type(q); right_given(q)=left_given(q);
18507 @ @<Plug an opening in |mp_right_type(pp)|...@>=
18508 if ( mp_right_type(pp)==mp_open ) {
18509 if ( (t==mp_curl)||(t==mp_given) ) {
18510 mp_right_type(pp)=t; right_given(pp)=x;
18514 @ @<Splice independent paths together@>=
18516 if ( mp_left_type(q)==mp_open ) if ( mp_right_type(q)==mp_open ) {
18517 mp_left_type(q)=mp_curl; left_curl(q)=unity;
18519 if ( mp_right_type(pp)==mp_open ) if ( t==mp_open ) {
18520 mp_right_type(pp)=mp_curl; right_curl(pp)=unity;
18522 mp_right_type(q)=mp_right_type(pp); mp_link(q)=mp_link(pp);
18523 mp_right_x(q)=mp_right_x(pp); mp_right_y(q)=mp_right_y(pp);
18524 mp_free_node(mp, pp,knot_node_size);
18525 if ( qq==pp ) qq=q;
18528 @ @<Choose control points for the path...@>=
18530 if ( d==ampersand ) p=q;
18532 mp_left_type(p)=mp_endpoint;
18533 if ( mp_right_type(p)==mp_open ) {
18534 mp_right_type(p)=mp_curl; right_curl(p)=unity;
18536 mp_right_type(q)=mp_endpoint;
18537 if ( mp_left_type(q)==mp_open ) {
18538 mp_left_type(q)=mp_curl; left_curl(q)=unity;
18542 mp_make_choices(mp, p);
18543 mp->cur_type=mp_path_type; mp->cur_exp=p
18545 @ Finally, we sometimes need to scan an expression whose value is
18546 supposed to be either |true_code| or |false_code|.
18548 @<Declare the basic parsing subroutines@>=
18549 static void mp_get_boolean (MP mp) {
18550 mp_get_x_next(mp); mp_scan_expression(mp);
18551 if ( mp->cur_type!=mp_boolean_type ) {
18552 exp_err("Undefined condition will be treated as `false'");
18553 @.Undefined condition...@>
18554 help2("The expression shown above should have had a definite",
18555 "true-or-false value. I'm changing it to `false'.");
18556 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18560 @* \[39] Doing the operations.
18561 The purpose of parsing is primarily to permit people to avoid piles of
18562 parentheses. But the real work is done after the structure of an expression
18563 has been recognized; that's when new expressions are generated. We
18564 turn now to the guts of \MP, which handles individual operators that
18565 have come through the parsing mechanism.
18567 We'll start with the easy ones that take no operands, then work our way
18568 up to operators with one and ultimately two arguments. In other words,
18569 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18570 that are invoked periodically by the expression scanners.
18572 First let's make sure that all of the primitive operators are in the
18573 hash table. Although |scan_primary| and its relatives made use of the
18574 \\{cmd} code for these operators, the \\{do} routines base everything
18575 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18576 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18579 mp_primitive(mp, "true",nullary,true_code);
18580 @:true_}{\&{true} primitive@>
18581 mp_primitive(mp, "false",nullary,false_code);
18582 @:false_}{\&{false} primitive@>
18583 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18584 @:null_picture_}{\&{nullpicture} primitive@>
18585 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18586 @:null_pen_}{\&{nullpen} primitive@>
18587 mp_primitive(mp, "jobname",nullary,job_name_op);
18588 @:job_name_}{\&{jobname} primitive@>
18589 mp_primitive(mp, "readstring",nullary,read_string_op);
18590 @:read_string_}{\&{readstring} primitive@>
18591 mp_primitive(mp, "pencircle",nullary,pen_circle);
18592 @:pen_circle_}{\&{pencircle} primitive@>
18593 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18594 @:normal_deviate_}{\&{normaldeviate} primitive@>
18595 mp_primitive(mp, "readfrom",unary,read_from_op);
18596 @:read_from_}{\&{readfrom} primitive@>
18597 mp_primitive(mp, "closefrom",unary,close_from_op);
18598 @:close_from_}{\&{closefrom} primitive@>
18599 mp_primitive(mp, "odd",unary,odd_op);
18600 @:odd_}{\&{odd} primitive@>
18601 mp_primitive(mp, "known",unary,known_op);
18602 @:known_}{\&{known} primitive@>
18603 mp_primitive(mp, "unknown",unary,unknown_op);
18604 @:unknown_}{\&{unknown} primitive@>
18605 mp_primitive(mp, "not",unary,not_op);
18606 @:not_}{\&{not} primitive@>
18607 mp_primitive(mp, "decimal",unary,decimal);
18608 @:decimal_}{\&{decimal} primitive@>
18609 mp_primitive(mp, "reverse",unary,reverse);
18610 @:reverse_}{\&{reverse} primitive@>
18611 mp_primitive(mp, "makepath",unary,make_path_op);
18612 @:make_path_}{\&{makepath} primitive@>
18613 mp_primitive(mp, "makepen",unary,make_pen_op);
18614 @:make_pen_}{\&{makepen} primitive@>
18615 mp_primitive(mp, "oct",unary,oct_op);
18616 @:oct_}{\&{oct} primitive@>
18617 mp_primitive(mp, "hex",unary,hex_op);
18618 @:hex_}{\&{hex} primitive@>
18619 mp_primitive(mp, "ASCII",unary,ASCII_op);
18620 @:ASCII_}{\&{ASCII} primitive@>
18621 mp_primitive(mp, "char",unary,char_op);
18622 @:char_}{\&{char} primitive@>
18623 mp_primitive(mp, "length",unary,length_op);
18624 @:length_}{\&{length} primitive@>
18625 mp_primitive(mp, "turningnumber",unary,turning_op);
18626 @:turning_number_}{\&{turningnumber} primitive@>
18627 mp_primitive(mp, "xpart",unary,x_part);
18628 @:x_part_}{\&{xpart} primitive@>
18629 mp_primitive(mp, "ypart",unary,y_part);
18630 @:y_part_}{\&{ypart} primitive@>
18631 mp_primitive(mp, "xxpart",unary,xx_part);
18632 @:xx_part_}{\&{xxpart} primitive@>
18633 mp_primitive(mp, "xypart",unary,xy_part);
18634 @:xy_part_}{\&{xypart} primitive@>
18635 mp_primitive(mp, "yxpart",unary,yx_part);
18636 @:yx_part_}{\&{yxpart} primitive@>
18637 mp_primitive(mp, "yypart",unary,yy_part);
18638 @:yy_part_}{\&{yypart} primitive@>
18639 mp_primitive(mp, "redpart",unary,red_part);
18640 @:red_part_}{\&{redpart} primitive@>
18641 mp_primitive(mp, "greenpart",unary,green_part);
18642 @:green_part_}{\&{greenpart} primitive@>
18643 mp_primitive(mp, "bluepart",unary,blue_part);
18644 @:blue_part_}{\&{bluepart} primitive@>
18645 mp_primitive(mp, "cyanpart",unary,cyan_part);
18646 @:cyan_part_}{\&{cyanpart} primitive@>
18647 mp_primitive(mp, "magentapart",unary,magenta_part);
18648 @:magenta_part_}{\&{magentapart} primitive@>
18649 mp_primitive(mp, "yellowpart",unary,yellow_part);
18650 @:yellow_part_}{\&{yellowpart} primitive@>
18651 mp_primitive(mp, "blackpart",unary,black_part);
18652 @:black_part_}{\&{blackpart} primitive@>
18653 mp_primitive(mp, "greypart",unary,grey_part);
18654 @:grey_part_}{\&{greypart} primitive@>
18655 mp_primitive(mp, "colormodel",unary,color_model_part);
18656 @:color_model_part_}{\&{colormodel} primitive@>
18657 mp_primitive(mp, "fontpart",unary,font_part);
18658 @:font_part_}{\&{fontpart} primitive@>
18659 mp_primitive(mp, "textpart",unary,text_part);
18660 @:text_part_}{\&{textpart} primitive@>
18661 mp_primitive(mp, "pathpart",unary,path_part);
18662 @:path_part_}{\&{pathpart} primitive@>
18663 mp_primitive(mp, "penpart",unary,pen_part);
18664 @:pen_part_}{\&{penpart} primitive@>
18665 mp_primitive(mp, "dashpart",unary,dash_part);
18666 @:dash_part_}{\&{dashpart} primitive@>
18667 mp_primitive(mp, "sqrt",unary,sqrt_op);
18668 @:sqrt_}{\&{sqrt} primitive@>
18669 mp_primitive(mp, "mexp",unary,mp_m_exp_op);
18670 @:m_exp_}{\&{mexp} primitive@>
18671 mp_primitive(mp, "mlog",unary,mp_m_log_op);
18672 @:m_log_}{\&{mlog} primitive@>
18673 mp_primitive(mp, "sind",unary,sin_d_op);
18674 @:sin_d_}{\&{sind} primitive@>
18675 mp_primitive(mp, "cosd",unary,cos_d_op);
18676 @:cos_d_}{\&{cosd} primitive@>
18677 mp_primitive(mp, "floor",unary,floor_op);
18678 @:floor_}{\&{floor} primitive@>
18679 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18680 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18681 mp_primitive(mp, "charexists",unary,char_exists_op);
18682 @:char_exists_}{\&{charexists} primitive@>
18683 mp_primitive(mp, "fontsize",unary,font_size);
18684 @:font_size_}{\&{fontsize} primitive@>
18685 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18686 @:ll_corner_}{\&{llcorner} primitive@>
18687 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18688 @:lr_corner_}{\&{lrcorner} primitive@>
18689 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18690 @:ul_corner_}{\&{ulcorner} primitive@>
18691 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18692 @:ur_corner_}{\&{urcorner} primitive@>
18693 mp_primitive(mp, "arclength",unary,arc_length);
18694 @:arc_length_}{\&{arclength} primitive@>
18695 mp_primitive(mp, "angle",unary,angle_op);
18696 @:angle_}{\&{angle} primitive@>
18697 mp_primitive(mp, "cycle",cycle,cycle_op);
18698 @:cycle_}{\&{cycle} primitive@>
18699 mp_primitive(mp, "stroked",unary,stroked_op);
18700 @:stroked_}{\&{stroked} primitive@>
18701 mp_primitive(mp, "filled",unary,filled_op);
18702 @:filled_}{\&{filled} primitive@>
18703 mp_primitive(mp, "textual",unary,textual_op);
18704 @:textual_}{\&{textual} primitive@>
18705 mp_primitive(mp, "clipped",unary,clipped_op);
18706 @:clipped_}{\&{clipped} primitive@>
18707 mp_primitive(mp, "bounded",unary,bounded_op);
18708 @:bounded_}{\&{bounded} primitive@>
18709 mp_primitive(mp, "+",plus_or_minus,plus);
18710 @:+ }{\.{+} primitive@>
18711 mp_primitive(mp, "-",plus_or_minus,minus);
18712 @:- }{\.{-} primitive@>
18713 mp_primitive(mp, "*",secondary_binary,times);
18714 @:* }{\.{*} primitive@>
18715 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18716 @:/ }{\.{/} primitive@>
18717 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18718 @:++_}{\.{++} primitive@>
18719 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18720 @:+-+_}{\.{+-+} primitive@>
18721 mp_primitive(mp, "or",tertiary_binary,or_op);
18722 @:or_}{\&{or} primitive@>
18723 mp_primitive(mp, "and",and_command,and_op);
18724 @:and_}{\&{and} primitive@>
18725 mp_primitive(mp, "<",expression_binary,less_than);
18726 @:< }{\.{<} primitive@>
18727 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18728 @:<=_}{\.{<=} primitive@>
18729 mp_primitive(mp, ">",expression_binary,greater_than);
18730 @:> }{\.{>} primitive@>
18731 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18732 @:>=_}{\.{>=} primitive@>
18733 mp_primitive(mp, "=",equals,equal_to);
18734 @:= }{\.{=} primitive@>
18735 mp_primitive(mp, "<>",expression_binary,unequal_to);
18736 @:<>_}{\.{<>} primitive@>
18737 mp_primitive(mp, "substring",primary_binary,substring_of);
18738 @:substring_}{\&{substring} primitive@>
18739 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18740 @:subpath_}{\&{subpath} primitive@>
18741 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18742 @:direction_time_}{\&{directiontime} primitive@>
18743 mp_primitive(mp, "point",primary_binary,point_of);
18744 @:point_}{\&{point} primitive@>
18745 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18746 @:precontrol_}{\&{precontrol} primitive@>
18747 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18748 @:postcontrol_}{\&{postcontrol} primitive@>
18749 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18750 @:pen_offset_}{\&{penoffset} primitive@>
18751 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18752 @:arc_time_of_}{\&{arctime} primitive@>
18753 mp_primitive(mp, "mpversion",nullary,mp_version);
18754 @:mp_verison_}{\&{mpversion} primitive@>
18755 mp_primitive(mp, "&",ampersand,concatenate);
18756 @:!!!}{\.{\&} primitive@>
18757 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18758 @:rotated_}{\&{rotated} primitive@>
18759 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18760 @:slanted_}{\&{slanted} primitive@>
18761 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18762 @:scaled_}{\&{scaled} primitive@>
18763 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18764 @:shifted_}{\&{shifted} primitive@>
18765 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18766 @:transformed_}{\&{transformed} primitive@>
18767 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18768 @:x_scaled_}{\&{xscaled} primitive@>
18769 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18770 @:y_scaled_}{\&{yscaled} primitive@>
18771 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18772 @:z_scaled_}{\&{zscaled} primitive@>
18773 mp_primitive(mp, "infont",secondary_binary,in_font);
18774 @:in_font_}{\&{infont} primitive@>
18775 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18776 @:intersection_times_}{\&{intersectiontimes} primitive@>
18777 mp_primitive(mp, "envelope",primary_binary,envelope_of);
18778 @:envelope_}{\&{envelope} primitive@>
18780 @ @<Cases of |print_cmd...@>=
18783 case primary_binary:
18784 case secondary_binary:
18785 case tertiary_binary:
18786 case expression_binary:
18788 case plus_or_minus:
18793 mp_print_op(mp, m);
18796 @ OK, let's look at the simplest \\{do} procedure first.
18798 @c @<Declare nullary action procedure@>
18799 static void mp_do_nullary (MP mp,quarterword c) {
18801 if ( mp->internal[mp_tracing_commands]>two )
18802 mp_show_cmd_mod(mp, nullary,c);
18804 case true_code: case false_code:
18805 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18807 case null_picture_code:
18808 mp->cur_type=mp_picture_type;
18809 mp->cur_exp=mp_get_node(mp, edge_header_size);
18810 mp_init_edges(mp, mp->cur_exp);
18812 case null_pen_code:
18813 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18815 case normal_deviate:
18816 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18819 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18822 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18823 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18826 mp->cur_type=mp_string_type;
18827 mp->cur_exp=intern(metapost_version) ;
18829 case read_string_op:
18830 @<Read a string from the terminal@>;
18832 } /* there are no other cases */
18836 @ @<Read a string...@>=
18838 if (mp->noninteractive || mp->interaction<=mp_nonstop_mode )
18839 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18840 mp_begin_file_reading(mp); name=is_read;
18841 limit=start; prompt_input("");
18842 mp_finish_read(mp);
18845 @ @<Declare nullary action procedure@>=
18846 static void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18848 str_room((int)mp->last-start);
18849 for (k=(size_t)start;k<=mp->last-1;k++) {
18850 append_char(mp->buffer[k]);
18852 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18853 mp->cur_exp=mp_make_string(mp);
18856 @ Things get a bit more interesting when there's an operand. The
18857 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18859 @c @<Declare unary action procedures@>
18860 static void mp_do_unary (MP mp,quarterword c) {
18861 pointer p,q,r; /* for list manipulation */
18862 integer x; /* a temporary register */
18864 if ( mp->internal[mp_tracing_commands]>two )
18865 @<Trace the current unary operation@>;
18868 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18871 @<Negate the current expression@>;
18873 @<Additional cases of unary operators@>;
18874 } /* there are no other cases */
18878 @ The |nice_pair| function returns |true| if both components of a pair
18881 @<Declare unary action procedures@>=
18882 static boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18883 if ( t==mp_pair_type ) {
18885 if ( mp_type(x_part_loc(p))==mp_known )
18886 if ( mp_type(y_part_loc(p))==mp_known )
18892 @ The |nice_color_or_pair| function is analogous except that it also accepts
18893 fully known colors.
18895 @<Declare unary action procedures@>=
18896 static boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18897 pointer q,r; /* for scanning the big node */
18898 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18902 r=q+mp->big_node_size[mp_type(p)];
18905 if ( mp_type(r)!=mp_known )
18912 @ @<Declare unary action...@>=
18913 static void mp_print_known_or_unknown_type (MP mp,quarterword t, integer v) {
18914 mp_print_char(mp, xord('('));
18915 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18916 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18917 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18918 mp_print_type(mp, t);
18920 mp_print_char(mp, xord(')'));
18923 @ @<Declare unary action...@>=
18924 static void mp_bad_unary (MP mp,quarterword c) {
18925 exp_err("Not implemented: "); mp_print_op(mp, c);
18926 @.Not implemented...@>
18927 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18928 help3("I'm afraid I don't know how to apply that operation to that",
18929 "particular type. Continue, and I'll simply return the",
18930 "argument (shown above) as the result of the operation.");
18931 mp_put_get_error(mp);
18934 @ @<Trace the current unary operation@>=
18936 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18937 mp_print_op(mp, c); mp_print_char(mp, xord('('));
18938 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18939 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18942 @ Negation is easy except when the current expression
18943 is of type |independent|, or when it is a pair with one or more
18944 |independent| components.
18946 It is tempting to argue that the negative of an independent variable
18947 is an independent variable, hence we don't have to do anything when
18948 negating it. The fallacy is that other dependent variables pointing
18949 to the current expression must change the sign of their
18950 coefficients if we make no change to the current expression.
18952 Instead, we work around the problem by copying the current expression
18953 and recycling it afterwards (cf.~the |stash_in| routine).
18955 @<Negate the current expression@>=
18956 switch (mp->cur_type) {
18957 case mp_color_type:
18958 case mp_cmykcolor_type:
18960 case mp_independent:
18961 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18962 if ( mp->cur_type==mp_dependent ) {
18963 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18964 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18965 p=value(mp->cur_exp);
18966 r=p+mp->big_node_size[mp->cur_type];
18969 if ( mp_type(r)==mp_known ) negate(value(r));
18970 else mp_negate_dep_list(mp, dep_list(r));
18972 } /* if |cur_type=mp_known| then |cur_exp=0| */
18973 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18976 case mp_proto_dependent:
18977 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18980 negate(mp->cur_exp);
18983 mp_bad_unary(mp, minus);
18987 @ @<Declare unary action...@>=
18988 static void mp_negate_dep_list (MP mp,pointer p) {
18991 if ( mp_info(p)==null ) return;
18996 @ @<Additional cases of unary operators@>=
18998 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
18999 else mp->cur_exp=true_code+false_code-mp->cur_exp;
19002 @ @d three_sixty_units 23592960 /* that's |360*unity| */
19003 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
19005 @<Additional cases of unary operators@>=
19012 case uniform_deviate:
19014 case char_exists_op:
19015 if ( mp->cur_type!=mp_known ) {
19016 mp_bad_unary(mp, c);
19019 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
19020 case mp_m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
19021 case mp_m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
19024 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
19025 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
19026 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
19028 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
19029 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
19031 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
19032 mp->cur_type=mp_boolean_type;
19034 case char_exists_op:
19035 @<Determine if a character has been shipped out@>;
19037 } /* there are no other cases */
19041 @ @<Additional cases of unary operators@>=
19043 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
19044 p=value(mp->cur_exp);
19045 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
19046 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
19047 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
19049 mp_bad_unary(mp, angle_op);
19053 @ If the current expression is a pair, but the context wants it to
19054 be a path, we call |pair_to_path|.
19056 @<Declare unary action...@>=
19057 static void mp_pair_to_path (MP mp) {
19058 mp->cur_exp=mp_new_knot(mp);
19059 mp->cur_type=mp_path_type;
19063 @d pict_color_type(A) ((mp_link(dummy_loc(mp->cur_exp))!=null) &&
19064 (has_color(mp_link(dummy_loc(mp->cur_exp)))) &&
19065 ((mp_color_model(mp_link(dummy_loc(mp->cur_exp)))==A)
19067 ((mp_color_model(mp_link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) &&
19068 (mp->internal[mp_default_color_model]/unity)==(A))))
19070 @<Additional cases of unary operators@>=
19073 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
19074 mp_take_part(mp, c);
19075 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19076 else mp_bad_unary(mp, c);
19082 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
19083 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19084 else mp_bad_unary(mp, c);
19089 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
19090 else if ( mp->cur_type==mp_picture_type ) {
19091 if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
19092 else mp_bad_color_part(mp, c);
19094 else mp_bad_unary(mp, c);
19100 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
19101 else if ( mp->cur_type==mp_picture_type ) {
19102 if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
19103 else mp_bad_color_part(mp, c);
19105 else mp_bad_unary(mp, c);
19108 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
19109 else if ( mp->cur_type==mp_picture_type ) {
19110 if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
19111 else mp_bad_color_part(mp, c);
19113 else mp_bad_unary(mp, c);
19115 case color_model_part:
19116 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19117 else mp_bad_unary(mp, c);
19120 @ @<Declarations@>=
19121 static void mp_bad_color_part(MP mp, quarterword c);
19124 static void mp_bad_color_part(MP mp, quarterword c) {
19125 pointer p; /* the big node */
19126 p=mp_link(dummy_loc(mp->cur_exp));
19127 exp_err("Wrong picture color model: "); mp_print_op(mp, c);
19128 @.Wrong picture color model...@>
19129 if (mp_color_model(p)==mp_grey_model)
19130 mp_print(mp, " of grey object");
19131 else if (mp_color_model(p)==mp_cmyk_model)
19132 mp_print(mp, " of cmyk object");
19133 else if (mp_color_model(p)==mp_rgb_model)
19134 mp_print(mp, " of rgb object");
19135 else if (mp_color_model(p)==mp_no_model)
19136 mp_print(mp, " of marking object");
19138 mp_print(mp," of defaulted object");
19139 help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,",
19140 "the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ",
19141 "or the greypart of a grey object. No mixing and matching, please.");
19144 mp_flush_cur_exp(mp,unity);
19146 mp_flush_cur_exp(mp,0);
19149 @ In the following procedure, |cur_exp| points to a capsule, which points to
19150 a big node. We want to delete all but one part of the big node.
19152 @<Declare unary action...@>=
19153 static void mp_take_part (MP mp,quarterword c) {
19154 pointer p; /* the big node */
19155 p=value(mp->cur_exp); value(temp_val)=p; mp_type(temp_val)=mp->cur_type;
19156 mp_link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
19157 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
19158 mp_recycle_value(mp, temp_val);
19161 @ @<Initialize table entries...@>=
19162 mp_name_type(temp_val)=mp_capsule;
19164 @ @<Additional cases of unary operators@>=
19170 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19171 else mp_bad_unary(mp, c);
19174 @ @<Declarations@>=
19175 static void mp_scale_edges (MP mp);
19177 @ @<Declare unary action...@>=
19178 static void mp_take_pict_part (MP mp,quarterword c) {
19179 pointer p; /* first graphical object in |cur_exp| */
19180 p=mp_link(dummy_loc(mp->cur_exp));
19183 case x_part: case y_part: case xx_part:
19184 case xy_part: case yx_part: case yy_part:
19185 if ( mp_type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
19186 else goto NOT_FOUND;
19188 case red_part: case green_part: case blue_part:
19189 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
19190 else goto NOT_FOUND;
19192 case cyan_part: case magenta_part: case yellow_part:
19194 if ( has_color(p) ) {
19195 if ( mp_color_model(p)==mp_uninitialized_model && c==black_part)
19196 mp_flush_cur_exp(mp, unity);
19198 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
19199 } else goto NOT_FOUND;
19202 if ( has_color(p) )
19203 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
19204 else goto NOT_FOUND;
19206 case color_model_part:
19207 if ( has_color(p) ) {
19208 if ( mp_color_model(p)==mp_uninitialized_model )
19209 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
19211 mp_flush_cur_exp(mp, mp_color_model(p)*unity);
19212 } else goto NOT_FOUND;
19214 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
19215 } /* all cases have been enumerated */
19219 @<Convert the current expression to a null value appropriate
19223 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
19225 if ( mp_type(p)!=mp_text_code ) goto NOT_FOUND;
19227 mp_flush_cur_exp(mp, mp_text_p(p));
19228 add_str_ref(mp->cur_exp);
19229 mp->cur_type=mp_string_type;
19233 if ( mp_type(p)!=mp_text_code ) goto NOT_FOUND;
19235 mp_flush_cur_exp(mp, rts(mp->font_name[mp_font_n(p)]));
19236 add_str_ref(mp->cur_exp);
19237 mp->cur_type=mp_string_type;
19241 if ( mp_type(p)==mp_text_code ) goto NOT_FOUND;
19242 else if ( is_stop(p) ) mp_confusion(mp, "pict");
19243 @:this can't happen pict}{\quad pict@>
19245 mp_flush_cur_exp(mp, mp_copy_path(mp, mp_path_p(p)));
19246 mp->cur_type=mp_path_type;
19250 if ( ! has_pen(p) ) goto NOT_FOUND;
19252 if ( mp_pen_p(p)==null ) goto NOT_FOUND;
19253 else { mp_flush_cur_exp(mp, copy_pen(mp_pen_p(p)));
19254 mp->cur_type=mp_pen_type;
19259 if ( mp_type(p)!=mp_stroked_code ) goto NOT_FOUND;
19260 else { if ( mp_dash_p(p)==null ) goto NOT_FOUND;
19261 else { add_edge_ref(mp_dash_p(p));
19262 mp->se_sf=dash_scale(p);
19263 mp->se_pic=mp_dash_p(p);
19264 mp_scale_edges(mp);
19265 mp_flush_cur_exp(mp, mp->se_pic);
19266 mp->cur_type=mp_picture_type;
19271 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
19272 parameterless procedure even though it really takes two arguments and updates
19273 one of them. Hence the following globals are needed.
19276 pointer se_pic; /* edge header used and updated by |scale_edges| */
19277 scaled se_sf; /* the scale factor argument to |scale_edges| */
19279 @ @<Convert the current expression to a null value appropriate...@>=
19281 case text_part: case font_part:
19282 mp_flush_cur_exp(mp, null_str);
19283 mp->cur_type=mp_string_type;
19286 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19287 mp_left_type(mp->cur_exp)=mp_endpoint;
19288 mp_right_type(mp->cur_exp)=mp_endpoint;
19289 mp_link(mp->cur_exp)=mp->cur_exp;
19290 mp_x_coord(mp->cur_exp)=0;
19291 mp_y_coord(mp->cur_exp)=0;
19292 mp_originator(mp->cur_exp)=mp_metapost_user;
19293 mp->cur_type=mp_path_type;
19296 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19297 mp->cur_type=mp_pen_type;
19300 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19301 mp_init_edges(mp, mp->cur_exp);
19302 mp->cur_type=mp_picture_type;
19305 mp_flush_cur_exp(mp, 0);
19309 @ @<Additional cases of unary...@>=
19311 if ( mp->cur_type!=mp_known ) {
19312 mp_bad_unary(mp, char_op);
19314 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19315 mp->cur_type=mp_string_type;
19316 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19320 if ( mp->cur_type!=mp_known ) {
19321 mp_bad_unary(mp, decimal);
19323 mp->old_setting=mp->selector; mp->selector=new_string;
19324 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19325 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19331 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19332 else mp_str_to_num(mp, c);
19335 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19336 else @<Find the design size of the font whose name is |cur_exp|@>;
19339 @ @<Declare unary action...@>=
19340 static void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19341 integer n; /* accumulator */
19342 ASCII_code m; /* current character */
19343 pool_pointer k; /* index into |str_pool| */
19344 int b; /* radix of conversion */
19345 boolean bad_char; /* did the string contain an invalid digit? */
19346 if ( c==ASCII_op ) {
19347 if ( length(mp->cur_exp)==0 ) n=-1;
19348 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19350 if ( c==oct_op ) b=8; else b=16;
19351 n=0; bad_char=false;
19352 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19354 if ( (m>='0')&&(m<='9') ) m=m-'0';
19355 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19356 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19357 else { bad_char=true; m=0; };
19358 if ( (int)m>=b ) { bad_char=true; m=0; };
19359 if ( n<32768 / b ) n=n*b+m; else n=32767;
19361 @<Give error messages if |bad_char| or |n>=4096|@>;
19363 mp_flush_cur_exp(mp, n*unity);
19366 @ @<Give error messages if |bad_char|...@>=
19368 exp_err("String contains illegal digits");
19369 @.String contains illegal digits@>
19371 help1("I zeroed out characters that weren't in the range 0..7.");
19373 help1("I zeroed out characters that weren't hex digits.");
19375 mp_put_get_error(mp);
19378 if ( mp->internal[mp_warning_check]>0 ) {
19379 print_err("Number too large (");
19380 mp_print_int(mp, n); mp_print_char(mp, xord(')'));
19381 @.Number too large@>
19382 help2("I have trouble with numbers greater than 4095; watch out.",
19383 "(Set warningcheck:=0 to suppress this message.)");
19384 mp_put_get_error(mp);
19388 @ The length operation is somewhat unusual in that it applies to a variety
19389 of different types of operands.
19391 @<Additional cases of unary...@>=
19393 switch (mp->cur_type) {
19394 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19395 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19396 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19397 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19399 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19400 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19401 value(x_part_loc(value(mp->cur_exp))),
19402 value(y_part_loc(value(mp->cur_exp)))));
19403 else mp_bad_unary(mp, c);
19408 @ @<Declare unary action...@>=
19409 static scaled mp_path_length (MP mp) { /* computes the length of the current path */
19410 scaled n; /* the path length so far */
19411 pointer p; /* traverser */
19413 if ( mp_left_type(p)==mp_endpoint ) n=-unity; else n=0;
19414 do { p=mp_link(p); n=n+unity; } while (p!=mp->cur_exp);
19418 @ @<Declare unary action...@>=
19419 static scaled mp_pict_length (MP mp) {
19420 /* counts interior components in picture |cur_exp| */
19421 scaled n; /* the count so far */
19422 pointer p; /* traverser */
19424 p=mp_link(dummy_loc(mp->cur_exp));
19426 if ( is_start_or_stop(p) )
19427 if ( mp_skip_1component(mp, p)==null ) p=mp_link(p);
19428 while ( p!=null ) {
19429 skip_component(p) return n;
19436 @ Implement |turningnumber|
19438 @<Additional cases of unary...@>=
19440 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19441 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19442 else if ( mp_left_type(mp->cur_exp)==mp_endpoint )
19443 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19445 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19448 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19449 argument is |origin|.
19451 @<Declare unary action...@>=
19452 static angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19453 if ( (! ((xpar==0) && (ypar==0))) )
19454 return mp_n_arg(mp, xpar,ypar);
19459 @ The actual turning number is (for the moment) computed in a C function
19460 that receives eight integers corresponding to the four controlling points,
19461 and returns a single angle. Besides those, we have to account for discrete
19462 moves at the actual points.
19464 @d mp_floor(a) ((a)>=0 ? (int)(a) : -(int)(-(a)))
19465 @d bezier_error (720*(256*256*16))+1
19466 @d mp_sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19467 @d mp_out(A) (double)((A)/(256*256*16))
19468 @d divisor (256*256)
19469 @d double2angle(a) (int)mp_floor(a*256.0*256.0*16.0)
19471 @<Declare unary action...@>=
19472 static angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19473 integer CX,integer CY,integer DX,integer DY);
19476 static angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19477 integer CX,integer CY,integer DX,integer DY) {
19479 integer deltax,deltay;
19480 double ax,ay,bx,by,cx,cy,dx,dy;
19481 angle xi = 0, xo = 0, xm = 0;
19483 ax=(double)(AX/divisor); ay=(double)(AY/divisor);
19484 bx=(double)(BX/divisor); by=(double)(BY/divisor);
19485 cx=(double)(CX/divisor); cy=(double)(CY/divisor);
19486 dx=(double)(DX/divisor); dy=(double)(DY/divisor);
19488 deltax = (BX-AX); deltay = (BY-AY);
19489 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19490 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19491 xi = mp_an_angle(mp,deltax,deltay);
19493 deltax = (CX-BX); deltay = (CY-BY);
19494 xm = mp_an_angle(mp,deltax,deltay);
19496 deltax = (DX-CX); deltay = (DY-CY);
19497 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19498 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19499 xo = mp_an_angle(mp,deltax,deltay);
19501 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19502 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19503 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19505 if ((a==0)&&(c==0)) {
19506 res = (b==0 ? 0 : (mp_out(xo)-mp_out(xi)));
19507 } else if ((a==0)||(c==0)) {
19508 if ((mp_sign(b) == mp_sign(a)) || (mp_sign(b) == mp_sign(c))) {
19509 res = mp_out(xo)-mp_out(xi); /* ? */
19512 else if (res>180.0)
19515 res = mp_out(xo)-mp_out(xi); /* ? */
19517 } else if ((mp_sign(a)*mp_sign(c))<0) {
19518 res = mp_out(xo)-mp_out(xi); /* ? */
19521 else if (res>180.0)
19524 if (mp_sign(a) == mp_sign(b)) {
19525 res = mp_out(xo)-mp_out(xi); /* ? */
19528 else if (res>180.0)
19531 if ((b*b) == (4*a*c)) {
19532 res = (double)bezier_error;
19533 } else if ((b*b) < (4*a*c)) {
19534 res = mp_out(xo)-mp_out(xi); /* ? */
19535 if (res<=0.0 &&res>-180.0)
19537 else if (res>=0.0 && res<180.0)
19540 res = mp_out(xo)-mp_out(xi);
19543 else if (res>180.0)
19548 return double2angle(res);
19552 @d p_nextnext mp_link(mp_link(p))
19553 @d p_next mp_link(p)
19554 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19556 @<Declare unary action...@>=
19557 static scaled mp_new_turn_cycles (MP mp,pointer c) {
19558 angle res,ang; /* the angles of intermediate results */
19559 scaled turns; /* the turn counter */
19560 pointer p; /* for running around the path */
19561 integer xp,yp; /* coordinates of next point */
19562 integer x,y; /* helper coordinates */
19563 angle in_angle,out_angle; /* helper angles */
19564 unsigned old_setting; /* saved |selector| setting */
19568 old_setting = mp->selector; mp->selector=term_only;
19569 if ( mp->internal[mp_tracing_commands]>unity ) {
19570 mp_begin_diagnostic(mp);
19571 mp_print_nl(mp, "");
19572 mp_end_diagnostic(mp, false);
19575 xp = mp_x_coord(p_next); yp = mp_y_coord(p_next);
19576 ang = mp_bezier_slope(mp,mp_x_coord(p), mp_y_coord(p), mp_right_x(p), mp_right_y(p),
19577 mp_left_x(p_next), mp_left_y(p_next), xp, yp);
19578 if ( ang>seven_twenty_deg ) {
19579 print_err("Strange path");
19581 mp->selector=old_setting;
19585 if ( res > one_eighty_deg ) {
19586 res = res - three_sixty_deg;
19587 turns = turns + unity;
19589 if ( res <= -one_eighty_deg ) {
19590 res = res + three_sixty_deg;
19591 turns = turns - unity;
19593 /* incoming angle at next point */
19594 x = mp_left_x(p_next); y = mp_left_y(p_next);
19595 if ( (xp==x)&&(yp==y) ) { x = mp_right_x(p); y = mp_right_y(p); };
19596 if ( (xp==x)&&(yp==y) ) { x = mp_x_coord(p); y = mp_y_coord(p); };
19597 in_angle = mp_an_angle(mp, xp - x, yp - y);
19598 /* outgoing angle at next point */
19599 x = mp_right_x(p_next); y = mp_right_y(p_next);
19600 if ( (xp==x)&&(yp==y) ) { x = mp_left_x(p_nextnext); y = mp_left_y(p_nextnext); };
19601 if ( (xp==x)&&(yp==y) ) { x = mp_x_coord(p_nextnext); y = mp_y_coord(p_nextnext); };
19602 out_angle = mp_an_angle(mp, x - xp, y- yp);
19603 ang = (out_angle - in_angle);
19607 if ( res >= one_eighty_deg ) {
19608 res = res - three_sixty_deg;
19609 turns = turns + unity;
19611 if ( res <= -one_eighty_deg ) {
19612 res = res + three_sixty_deg;
19613 turns = turns - unity;
19618 mp->selector=old_setting;
19623 @ This code is based on Bogus\l{}av Jackowski's
19624 |emergency_turningnumber| macro, with some minor changes by Taco
19625 Hoekwater. The macro code looked more like this:
19627 vardef turning\_number primary p =
19628 ~~save res, ang, turns;
19630 ~~if length p <= 2:
19631 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19633 ~~~~for t = 0 upto length p-1 :
19634 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19635 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19636 ~~~~~~if angc > 180: angc := angc - 360; fi;
19637 ~~~~~~if angc < -180: angc := angc + 360; fi;
19638 ~~~~~~res := res + angc;
19643 The general idea is to calculate only the sum of the angles of
19644 straight lines between the points, of a path, not worrying about cusps
19645 or self-intersections in the segments at all. If the segment is not
19646 well-behaved, the result is not necesarily correct. But the old code
19647 was not always correct either, and worse, it sometimes failed for
19648 well-behaved paths as well. All known bugs that were triggered by the
19649 original code no longer occur with this code, and it runs roughly 3
19650 times as fast because the algorithm is much simpler.
19652 @ It is possible to overflow the return value of the |turn_cycles|
19653 function when the path is sufficiently long and winding, but I am not
19654 going to bother testing for that. In any case, it would only return
19655 the looped result value, which is not a big problem.
19657 The macro code for the repeat loop was a bit nicer to look
19658 at than the pascal code, because it could use |point -1 of p|. In
19659 pascal, the fastest way to loop around the path is not to look
19660 backward once, but forward twice. These defines help hide the trick.
19662 @d p_to mp_link(mp_link(p))
19663 @d p_here mp_link(p)
19666 @<Declare unary action...@>=
19667 static scaled mp_turn_cycles (MP mp,pointer c) {
19668 angle res,ang; /* the angles of intermediate results */
19669 scaled turns; /* the turn counter */
19670 pointer p; /* for running around the path */
19671 res=0; turns= 0; p=c;
19673 ang = mp_an_angle (mp, mp_x_coord(p_to) - mp_x_coord(p_here),
19674 mp_y_coord(p_to) - mp_y_coord(p_here))
19675 - mp_an_angle (mp, mp_x_coord(p_here) - mp_x_coord(p_from),
19676 mp_y_coord(p_here) - mp_y_coord(p_from));
19679 if ( res >= three_sixty_deg ) {
19680 res = res - three_sixty_deg;
19681 turns = turns + unity;
19683 if ( res <= -three_sixty_deg ) {
19684 res = res + three_sixty_deg;
19685 turns = turns - unity;
19692 @ @<Declare unary action...@>=
19693 static scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19695 scaled saved_t_o; /* tracing\_online saved */
19696 if ( (mp_link(c)==c)||(mp_link(mp_link(c))==c) ) {
19697 if ( mp_an_angle (mp, mp_x_coord(c) - mp_right_x(c), mp_y_coord(c) - mp_right_y(c)) > 0 )
19702 nval = mp_new_turn_cycles(mp, c);
19703 oval = mp_turn_cycles(mp, c);
19704 if ( nval!=oval ) {
19705 saved_t_o=mp->internal[mp_tracing_online];
19706 mp->internal[mp_tracing_online]=unity;
19707 mp_begin_diagnostic(mp);
19708 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19709 " The current computed value is ");
19710 mp_print_scaled(mp, nval);
19711 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19712 mp_print_scaled(mp, oval);
19713 mp_end_diagnostic(mp, false);
19714 mp->internal[mp_tracing_online]=saved_t_o;
19720 @ @d type_range(A,B) {
19721 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19722 mp_flush_cur_exp(mp, true_code);
19723 else mp_flush_cur_exp(mp, false_code);
19724 mp->cur_type=mp_boolean_type;
19727 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19728 else mp_flush_cur_exp(mp, false_code);
19729 mp->cur_type=mp_boolean_type;
19732 @<Additional cases of unary operators@>=
19733 case mp_boolean_type:
19734 type_range(mp_boolean_type,mp_unknown_boolean); break;
19735 case mp_string_type:
19736 type_range(mp_string_type,mp_unknown_string); break;
19738 type_range(mp_pen_type,mp_unknown_pen); break;
19740 type_range(mp_path_type,mp_unknown_path); break;
19741 case mp_picture_type:
19742 type_range(mp_picture_type,mp_unknown_picture); break;
19743 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19745 type_test(c); break;
19746 case mp_numeric_type:
19747 type_range(mp_known,mp_independent); break;
19748 case known_op: case unknown_op:
19749 mp_test_known(mp, c); break;
19751 @ @<Declare unary action procedures@>=
19752 static void mp_test_known (MP mp,quarterword c) {
19753 int b; /* is the current expression known? */
19754 pointer p,q; /* locations in a big node */
19756 switch (mp->cur_type) {
19757 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19758 case mp_pen_type: case mp_path_type: case mp_picture_type:
19762 case mp_transform_type:
19763 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19764 p=value(mp->cur_exp);
19765 q=p+mp->big_node_size[mp->cur_type];
19768 if ( mp_type(q)!=mp_known )
19777 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19778 else mp_flush_cur_exp(mp, true_code+false_code-b);
19779 mp->cur_type=mp_boolean_type;
19782 @ @<Additional cases of unary operators@>=
19784 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19785 else if ( mp_left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19786 else mp_flush_cur_exp(mp, false_code);
19787 mp->cur_type=mp_boolean_type;
19790 @ @<Additional cases of unary operators@>=
19792 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19793 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19794 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19797 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19799 @^data structure assumptions@>
19801 @<Additional cases of unary operators@>=
19807 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19808 else if ( mp_link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19809 else if ( mp_type(mp_link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19810 mp_flush_cur_exp(mp, true_code);
19811 else mp_flush_cur_exp(mp, false_code);
19812 mp->cur_type=mp_boolean_type;
19815 @ @<Additional cases of unary operators@>=
19817 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19818 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19820 mp->cur_type=mp_pen_type;
19821 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19825 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19827 mp->cur_type=mp_path_type;
19828 mp_make_path(mp, mp->cur_exp);
19832 if ( mp->cur_type==mp_path_type ) {
19833 p=mp_htap_ypoc(mp, mp->cur_exp);
19834 if ( mp_right_type(p)==mp_endpoint ) p=mp_link(p);
19835 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19836 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19837 else mp_bad_unary(mp, reverse);
19840 @ The |pair_value| routine changes the current expression to a
19841 given ordered pair of values.
19843 @<Declare unary action procedures@>=
19844 static void mp_pair_value (MP mp,scaled x, scaled y) {
19845 pointer p; /* a pair node */
19846 p=mp_get_node(mp, value_node_size);
19847 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19848 mp_type(p)=mp_pair_type; mp_name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19850 mp_type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19851 mp_type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19854 @ @<Additional cases of unary operators@>=
19856 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19857 else mp_pair_value(mp, mp_minx, mp_miny);
19860 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19861 else mp_pair_value(mp, mp_maxx, mp_miny);
19864 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19865 else mp_pair_value(mp, mp_minx, mp_maxy);
19868 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19869 else mp_pair_value(mp, mp_maxx, mp_maxy);
19872 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19873 box of the current expression. The boolean result is |false| if the expression
19874 has the wrong type.
19876 @<Declare unary action procedures@>=
19877 static boolean mp_get_cur_bbox (MP mp) {
19878 switch (mp->cur_type) {
19879 case mp_picture_type:
19880 mp_set_bbox(mp, mp->cur_exp,true);
19881 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19882 mp_minx=0; mp_maxx=0; mp_miny=0; mp_maxy=0;
19884 mp_minx=minx_val(mp->cur_exp);
19885 mp_maxx=maxx_val(mp->cur_exp);
19886 mp_miny=miny_val(mp->cur_exp);
19887 mp_maxy=maxy_val(mp->cur_exp);
19891 mp_path_bbox(mp, mp->cur_exp);
19894 mp_pen_bbox(mp, mp->cur_exp);
19902 @ @<Additional cases of unary operators@>=
19904 case close_from_op:
19905 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19906 else mp_do_read_or_close(mp,c);
19909 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19910 a line from the file or to close the file.
19912 @<Declare unary action procedures@>=
19913 static void mp_do_read_or_close (MP mp,quarterword c) {
19914 readf_index n,n0; /* indices for searching |rd_fname| */
19915 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19916 call |start_read_input| and |goto found| or |not_found|@>;
19917 mp_begin_file_reading(mp);
19919 if ( mp_input_ln(mp, mp->rd_file[n] ) )
19921 mp_end_file_reading(mp);
19923 @<Record the end of file and set |cur_exp| to a dummy value@>;
19926 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19929 mp_flush_cur_exp(mp, 0);
19930 mp_finish_read(mp);
19933 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19936 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19941 fn = str(mp->cur_exp);
19942 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19945 } else if ( c==close_from_op ) {
19948 if ( n0==mp->read_files ) {
19949 if ( mp->read_files<mp->max_read_files ) {
19950 incr(mp->read_files);
19955 l = mp->max_read_files + (mp->max_read_files/4);
19956 rd_file = xmalloc((l+1), sizeof(void *));
19957 rd_fname = xmalloc((l+1), sizeof(char *));
19958 for (k=0;k<=l;k++) {
19959 if (k<=mp->max_read_files) {
19960 rd_file[k]=mp->rd_file[k];
19961 rd_fname[k]=mp->rd_fname[k];
19967 xfree(mp->rd_file); xfree(mp->rd_fname);
19968 mp->max_read_files = l;
19969 mp->rd_file = rd_file;
19970 mp->rd_fname = rd_fname;
19974 if ( mp_start_read_input(mp,fn,n) )
19979 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19981 if ( c==close_from_op ) {
19982 (mp->close_file)(mp,mp->rd_file[n]);
19987 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19988 xfree(mp->rd_fname[n]);
19989 mp->rd_fname[n]=NULL;
19990 if ( n==mp->read_files-1 ) mp->read_files=n;
19991 if ( c==close_from_op )
19993 mp_flush_cur_exp(mp, mp->eof_line);
19994 mp->cur_type=mp_string_type
19996 @ The string denoting end-of-file is a one-byte string at position zero, by definition
19999 str_number eof_line;
20004 @ Finally, we have the operations that combine a capsule~|p|
20005 with the current expression.
20007 @d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
20009 @c @<Declare binary action procedures@>
20010 static void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
20012 @<Recycle any sidestepped |independent| capsules@>;
20014 static void mp_do_binary (MP mp,pointer p, quarterword c) {
20015 pointer q,r,rr; /* for list manipulation */
20016 pointer old_p,old_exp; /* capsules to recycle */
20017 integer v; /* for numeric manipulation */
20019 if ( mp->internal[mp_tracing_commands]>two ) {
20020 @<Trace the current binary operation@>;
20022 @<Sidestep |independent| cases in capsule |p|@>;
20023 @<Sidestep |independent| cases in the current expression@>;
20025 case plus: case minus:
20026 @<Add or subtract the current expression from |p|@>;
20028 @<Additional cases of binary operators@>;
20029 }; /* there are no other cases */
20030 mp_recycle_value(mp, p);
20031 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
20032 mp_finish_binary(mp, old_p, old_exp);
20035 @ @<Declare binary action...@>=
20036 static void mp_bad_binary (MP mp,pointer p, quarterword c) {
20037 mp_disp_err(mp, p,"");
20038 exp_err("Not implemented: ");
20039 @.Not implemented...@>
20040 if ( c>=min_of ) mp_print_op(mp, c);
20041 mp_print_known_or_unknown_type(mp, mp_type(p),p);
20042 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
20043 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
20044 help3("I'm afraid I don't know how to apply that operation to that",
20045 "combination of types. Continue, and I'll return the second",
20046 "argument (see above) as the result of the operation.");
20047 mp_put_get_error(mp);
20049 static void mp_bad_envelope_pen (MP mp) {
20050 mp_disp_err(mp, null,"");
20051 exp_err("Not implemented: envelope(elliptical pen)of(path)");
20052 @.Not implemented...@>
20053 help3("I'm afraid I don't know how to apply that operation to that",
20054 "combination of types. Continue, and I'll return the second",
20055 "argument (see above) as the result of the operation.");
20056 mp_put_get_error(mp);
20059 @ @<Trace the current binary operation@>=
20061 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
20062 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
20063 mp_print_char(mp,xord(')')); mp_print_op(mp,c); mp_print_char(mp,xord('('));
20064 mp_print_exp(mp,null,0); mp_print(mp,")}");
20065 mp_end_diagnostic(mp, false);
20068 @ Several of the binary operations are potentially complicated by the
20069 fact that |independent| values can sneak into capsules. For example,
20070 we've seen an instance of this difficulty in the unary operation
20071 of negation. In order to reduce the number of cases that need to be
20072 handled, we first change the two operands (if necessary)
20073 to rid them of |independent| components. The original operands are
20074 put into capsules called |old_p| and |old_exp|, which will be
20075 recycled after the binary operation has been safely carried out.
20077 @<Recycle any sidestepped |independent| capsules@>=
20078 if ( old_p!=null ) {
20079 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
20081 if ( old_exp!=null ) {
20082 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
20085 @ A big node is considered to be ``tarnished'' if it contains at least one
20086 independent component. We will define a simple function called `|tarnished|'
20087 that returns |null| if and only if its argument is not tarnished.
20089 @<Sidestep |independent| cases in capsule |p|@>=
20090 switch (mp_type(p)) {
20091 case mp_transform_type:
20092 case mp_color_type:
20093 case mp_cmykcolor_type:
20095 old_p=mp_tarnished(mp, p);
20097 case mp_independent: old_p=mp_void; break;
20098 default: old_p=null; break;
20100 if ( old_p!=null ) {
20101 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
20102 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
20105 @ @<Sidestep |independent| cases in the current expression@>=
20106 switch (mp->cur_type) {
20107 case mp_transform_type:
20108 case mp_color_type:
20109 case mp_cmykcolor_type:
20111 old_exp=mp_tarnished(mp, mp->cur_exp);
20113 case mp_independent:old_exp=mp_void; break;
20114 default: old_exp=null; break;
20116 if ( old_exp!=null ) {
20117 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20120 @ @<Declare binary action...@>=
20121 static pointer mp_tarnished (MP mp,pointer p) {
20122 pointer q; /* beginning of the big node */
20123 pointer r; /* current position in the big node */
20124 q=value(p); r=q+mp->big_node_size[mp_type(p)];
20127 if ( mp_type(r)==mp_independent ) return mp_void;
20132 @ @<Add or subtract the current expression from |p|@>=
20133 if ( (mp->cur_type<mp_color_type)||(mp_type(p)<mp_color_type) ) {
20134 mp_bad_binary(mp, p,c);
20136 if ((mp->cur_type>mp_pair_type)&&(mp_type(p)>mp_pair_type) ) {
20137 mp_add_or_subtract(mp, p,null,c);
20139 if ( mp->cur_type!=mp_type(p) ) {
20140 mp_bad_binary(mp, p,c);
20142 q=value(p); r=value(mp->cur_exp);
20143 rr=r+mp->big_node_size[mp->cur_type];
20145 mp_add_or_subtract(mp, q,r,c);
20152 @ The first argument to |add_or_subtract| is the location of a value node
20153 in a capsule or pair node that will soon be recycled. The second argument
20154 is either a location within a pair or transform node of |cur_exp|,
20155 or it is null (which means that |cur_exp| itself should be the second
20156 argument). The third argument is either |plus| or |minus|.
20158 The sum or difference of the numeric quantities will replace the second
20159 operand. Arithmetic overflow may go undetected; users aren't supposed to
20160 be monkeying around with really big values.
20161 @^overflow in arithmetic@>
20163 @<Declare binary action...@>=
20164 @<Declare the procedure called |dep_finish|@>
20165 static void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
20166 quarterword s,t; /* operand types */
20167 pointer r; /* list traverser */
20168 integer v; /* second operand value */
20171 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
20174 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
20176 if ( t==mp_known ) {
20177 if ( c==minus ) negate(v);
20178 if ( mp_type(p)==mp_known ) {
20179 v=mp_slow_add(mp, value(p),v);
20180 if ( q==null ) mp->cur_exp=v; else value(q)=v;
20183 @<Add a known value to the constant term of |dep_list(p)|@>;
20185 if ( c==minus ) mp_negate_dep_list(mp, v);
20186 @<Add operand |p| to the dependency list |v|@>;
20190 @ @<Add a known value to the constant term of |dep_list(p)|@>=
20192 while ( mp_info(r)!=null ) r=mp_link(r);
20193 value(r)=mp_slow_add(mp, value(r),v);
20195 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=mp_type(p);
20196 mp_name_type(q)=mp_capsule;
20198 dep_list(q)=dep_list(p); mp_type(q)=mp_type(p);
20199 prev_dep(q)=prev_dep(p); mp_link(prev_dep(p))=q;
20200 mp_type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
20202 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
20203 nice to retain the extra accuracy of |fraction| coefficients.
20204 But we have to handle both kinds, and mixtures too.
20206 @<Add operand |p| to the dependency list |v|@>=
20207 if ( mp_type(p)==mp_known ) {
20208 @<Add the known |value(p)| to the constant term of |v|@>;
20210 s=mp_type(p); r=dep_list(p);
20211 if ( t==mp_dependent ) {
20212 if ( s==mp_dependent ) {
20213 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
20214 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
20215 } /* |fix_needed| will necessarily be false */
20216 t=mp_proto_dependent;
20217 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
20219 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
20220 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
20222 @<Output the answer, |v| (which might have become |known|)@>;
20225 @ @<Add the known |value(p)| to the constant term of |v|@>=
20227 while ( mp_info(v)!=null ) v=mp_link(v);
20228 value(v)=mp_slow_add(mp, value(p),value(v));
20231 @ @<Output the answer, |v| (which might have become |known|)@>=
20232 if ( q!=null ) mp_dep_finish(mp, v,q,t);
20233 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
20235 @ Here's the current situation: The dependency list |v| of type |t|
20236 should either be put into the current expression (if |q=null|) or
20237 into location |q| within a pair node (otherwise). The destination (|cur_exp|
20238 or |q|) formerly held a dependency list with the same
20239 final pointer as the list |v|.
20241 @<Declare the procedure called |dep_finish|@>=
20242 static void mp_dep_finish (MP mp, pointer v, pointer q, quarterword t) {
20243 pointer p; /* the destination */
20244 scaled vv; /* the value, if it is |known| */
20245 if ( q==null ) p=mp->cur_exp; else p=q;
20246 dep_list(p)=v; mp_type(p)=t;
20247 if ( mp_info(v)==null ) {
20250 mp_flush_cur_exp(mp, vv);
20252 mp_recycle_value(mp, p); mp_type(q)=mp_known; value(q)=vv;
20254 } else if ( q==null ) {
20257 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20260 @ Let's turn now to the six basic relations of comparison.
20262 @<Additional cases of binary operators@>=
20263 case less_than: case less_or_equal: case greater_than:
20264 case greater_or_equal: case equal_to: case unequal_to:
20265 check_arith; /* at this point |arith_error| should be |false|? */
20266 if ( (mp->cur_type>mp_pair_type)&&(mp_type(p)>mp_pair_type) ) {
20267 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20268 } else if ( mp->cur_type!=mp_type(p) ) {
20269 mp_bad_binary(mp, p,c); goto DONE;
20270 } else if ( mp->cur_type==mp_string_type ) {
20271 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20272 } else if ((mp->cur_type==mp_unknown_string)||
20273 (mp->cur_type==mp_unknown_boolean) ) {
20274 @<Check if unknowns have been equated@>;
20275 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20276 @<Reduce comparison of big nodes to comparison of scalars@>;
20277 } else if ( mp->cur_type==mp_boolean_type ) {
20278 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20280 mp_bad_binary(mp, p,c); goto DONE;
20282 @<Compare the current expression with zero@>;
20284 mp->arith_error=false; /* ignore overflow in comparisons */
20287 @ @<Compare the current expression with zero@>=
20288 if ( mp->cur_type!=mp_known ) {
20289 if ( mp->cur_type<mp_known ) {
20290 mp_disp_err(mp, p,"");
20291 help1("The quantities shown above have not been equated.")
20293 help2("Oh dear. I can\'t decide if the expression above is positive,",
20294 "negative, or zero. So this comparison test won't be `true'.");
20296 exp_err("Unknown relation will be considered false");
20297 @.Unknown relation...@>
20298 mp_put_get_flush_error(mp, false_code);
20301 case less_than: boolean_reset(mp->cur_exp<0); break;
20302 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20303 case greater_than: boolean_reset(mp->cur_exp>0); break;
20304 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20305 case equal_to: boolean_reset(mp->cur_exp==0); break;
20306 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20307 }; /* there are no other cases */
20309 mp->cur_type=mp_boolean_type
20311 @ When two unknown strings are in the same ring, we know that they are
20312 equal. Otherwise, we don't know whether they are equal or not, so we
20315 @<Check if unknowns have been equated@>=
20317 q=value(mp->cur_exp);
20318 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20319 if ( q==p ) mp_flush_cur_exp(mp, 0);
20322 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20324 q=value(p); r=value(mp->cur_exp);
20325 rr=r+mp->big_node_size[mp->cur_type]-2;
20326 while (1) { mp_add_or_subtract(mp, q,r,minus);
20327 if ( mp_type(r)!=mp_known ) break;
20328 if ( value(r)!=0 ) break;
20329 if ( r==rr ) break;
20332 mp_take_part(mp, mp_name_type(r)+x_part-mp_x_part_sector);
20335 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20337 @<Additional cases of binary operators@>=
20340 if ( (mp_type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20341 mp_bad_binary(mp, p,c);
20342 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20345 @ @<Additional cases of binary operators@>=
20347 if ( (mp->cur_type<mp_color_type)||(mp_type(p)<mp_color_type) ) {
20348 mp_bad_binary(mp, p,times);
20349 } else if ( (mp->cur_type==mp_known)||(mp_type(p)==mp_known) ) {
20350 @<Multiply when at least one operand is known@>;
20351 } else if ( (mp_nice_color_or_pair(mp, p,mp_type(p))&&(mp->cur_type>mp_pair_type))
20352 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20353 (mp_type(p)>mp_pair_type)) ) {
20354 mp_hard_times(mp, p);
20357 mp_bad_binary(mp, p,times);
20361 @ @<Multiply when at least one operand is known@>=
20363 if ( mp_type(p)==mp_known ) {
20364 v=value(p); mp_free_node(mp, p,value_node_size);
20366 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20368 if ( mp->cur_type==mp_known ) {
20369 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20370 } else if ( (mp->cur_type==mp_pair_type)||
20371 (mp->cur_type==mp_color_type)||
20372 (mp->cur_type==mp_cmykcolor_type) ) {
20373 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20375 p=p-2; mp_dep_mult(mp, p,v,true);
20376 } while (p!=value(mp->cur_exp));
20378 mp_dep_mult(mp, null,v,true);
20383 @ @<Declare binary action...@>=
20384 static void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20385 pointer q; /* the dependency list being multiplied by |v| */
20386 quarterword s,t; /* its type, before and after */
20389 } else if ( mp_type(p)!=mp_known ) {
20392 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20393 else value(p)=mp_take_fraction(mp, value(p),v);
20396 t=mp_type(q); q=dep_list(q); s=t;
20397 if ( t==mp_dependent ) if ( v_is_scaled )
20398 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20399 t=mp_proto_dependent;
20400 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20401 mp_dep_finish(mp, q,p,t);
20404 @ Here is a routine that is similar to |times|; but it is invoked only
20405 internally, when |v| is a |fraction| whose magnitude is at most~1,
20406 and when |cur_type>=mp_color_type|.
20409 static void mp_frac_mult (MP mp,scaled n, scaled d) {
20410 /* multiplies |cur_exp| by |n/d| */
20411 pointer p; /* a pair node */
20412 pointer old_exp; /* a capsule to recycle */
20413 fraction v; /* |n/d| */
20414 if ( mp->internal[mp_tracing_commands]>two ) {
20415 @<Trace the fraction multiplication@>;
20417 switch (mp->cur_type) {
20418 case mp_transform_type:
20419 case mp_color_type:
20420 case mp_cmykcolor_type:
20422 old_exp=mp_tarnished(mp, mp->cur_exp);
20424 case mp_independent: old_exp=mp_void; break;
20425 default: old_exp=null; break;
20427 if ( old_exp!=null ) {
20428 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20430 v=mp_make_fraction(mp, n,d);
20431 if ( mp->cur_type==mp_known ) {
20432 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20433 } else if ( mp->cur_type<=mp_pair_type ) {
20434 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20437 mp_dep_mult(mp, p,v,false);
20438 } while (p!=value(mp->cur_exp));
20440 mp_dep_mult(mp, null,v,false);
20442 if ( old_exp!=null ) {
20443 mp_recycle_value(mp, old_exp);
20444 mp_free_node(mp, old_exp,value_node_size);
20448 @ @<Trace the fraction multiplication@>=
20450 mp_begin_diagnostic(mp);
20451 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,xord('/'));
20452 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20454 mp_end_diagnostic(mp, false);
20457 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20459 @<Declare binary action procedures@>=
20460 static void mp_hard_times (MP mp,pointer p) {
20461 pointer q; /* a copy of the dependent variable |p| */
20462 pointer r; /* a component of the big node for the nice color or pair */
20463 scaled v; /* the known value for |r| */
20464 if ( mp_type(p)<=mp_pair_type ) {
20465 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20466 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20467 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20471 mp_type(r)=mp_type(p);
20472 if ( r==value(mp->cur_exp) )
20474 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20475 mp_dep_mult(mp, r,v,true);
20477 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20478 mp_link(prev_dep(p))=r;
20479 mp_free_node(mp, p,value_node_size);
20480 mp_dep_mult(mp, r,v,true);
20483 @ @<Additional cases of binary operators@>=
20485 if ( (mp->cur_type!=mp_known)||(mp_type(p)<mp_color_type) ) {
20486 mp_bad_binary(mp, p,over);
20488 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20490 @<Squeal about division by zero@>;
20492 if ( mp->cur_type==mp_known ) {
20493 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20494 } else if ( mp->cur_type<=mp_pair_type ) {
20495 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20497 p=p-2; mp_dep_div(mp, p,v);
20498 } while (p!=value(mp->cur_exp));
20500 mp_dep_div(mp, null,v);
20507 @ @<Declare binary action...@>=
20508 static void mp_dep_div (MP mp,pointer p, scaled v) {
20509 pointer q; /* the dependency list being divided by |v| */
20510 quarterword s,t; /* its type, before and after */
20511 if ( p==null ) q=mp->cur_exp;
20512 else if ( mp_type(p)!=mp_known ) q=p;
20513 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20514 t=mp_type(q); q=dep_list(q); s=t;
20515 if ( t==mp_dependent )
20516 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20517 t=mp_proto_dependent;
20518 q=mp_p_over_v(mp, q,v,s,t);
20519 mp_dep_finish(mp, q,p,t);
20522 @ @<Squeal about division by zero@>=
20524 exp_err("Division by zero");
20525 @.Division by zero@>
20526 help2("You're trying to divide the quantity shown above the error",
20527 "message by zero. I'm going to divide it by one instead.");
20528 mp_put_get_error(mp);
20531 @ @<Additional cases of binary operators@>=
20534 if ( (mp->cur_type==mp_known)&&(mp_type(p)==mp_known) ) {
20535 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20536 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20537 } else mp_bad_binary(mp, p,c);
20540 @ The next few sections of the program deal with affine transformations
20541 of coordinate data.
20543 @<Additional cases of binary operators@>=
20544 case rotated_by: case slanted_by:
20545 case scaled_by: case shifted_by: case transformed_by:
20546 case x_scaled: case y_scaled: case z_scaled:
20547 if ( mp_type(p)==mp_path_type ) {
20548 path_trans(c,p); binary_return;
20549 } else if ( mp_type(p)==mp_pen_type ) {
20551 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20552 /* rounding error could destroy convexity */
20554 } else if ( (mp_type(p)==mp_pair_type)||(mp_type(p)==mp_transform_type) ) {
20555 mp_big_trans(mp, p,c);
20556 } else if ( mp_type(p)==mp_picture_type ) {
20557 mp_do_edges_trans(mp, p,c); binary_return;
20559 mp_bad_binary(mp, p,c);
20563 @ Let |c| be one of the eight transform operators. The procedure call
20564 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20565 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20566 change at all if |c=transformed_by|.)
20568 Then, if all components of the resulting transform are |known|, they are
20569 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20570 and |cur_exp| is changed to the known value zero.
20572 @<Declare binary action...@>=
20573 static void mp_set_up_trans (MP mp,quarterword c) {
20574 pointer p,q,r; /* list manipulation registers */
20575 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20576 @<Put the current transform into |cur_exp|@>;
20578 @<If the current transform is entirely known, stash it in global variables;
20579 otherwise |return|@>;
20588 scaled ty; /* current transform coefficients */
20590 @ @<Put the current transform...@>=
20592 p=mp_stash_cur_exp(mp);
20593 mp->cur_exp=mp_id_transform(mp);
20594 mp->cur_type=mp_transform_type;
20595 q=value(mp->cur_exp);
20597 @<For each of the eight cases, change the relevant fields of |cur_exp|
20599 but do nothing if capsule |p| doesn't have the appropriate type@>;
20600 }; /* there are no other cases */
20601 mp_disp_err(mp, p,"Improper transformation argument");
20602 @.Improper transformation argument@>
20603 help3("The expression shown above has the wrong type,",
20604 "so I can\'t transform anything using it.",
20605 "Proceed, and I'll omit the transformation.");
20606 mp_put_get_error(mp);
20608 mp_recycle_value(mp, p);
20609 mp_free_node(mp, p,value_node_size);
20612 @ @<If the current transform is entirely known, ...@>=
20613 q=value(mp->cur_exp); r=q+transform_node_size;
20616 if ( mp_type(r)!=mp_known ) return;
20618 mp->txx=value(xx_part_loc(q));
20619 mp->txy=value(xy_part_loc(q));
20620 mp->tyx=value(yx_part_loc(q));
20621 mp->tyy=value(yy_part_loc(q));
20622 mp->tx=value(x_part_loc(q));
20623 mp->ty=value(y_part_loc(q));
20624 mp_flush_cur_exp(mp, 0)
20626 @ @<For each of the eight cases...@>=
20628 if ( mp_type(p)==mp_known )
20629 @<Install sines and cosines, then |goto done|@>;
20632 if ( mp_type(p)>mp_pair_type ) {
20633 mp_install(mp, xy_part_loc(q),p); goto DONE;
20637 if ( mp_type(p)>mp_pair_type ) {
20638 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20643 if ( mp_type(p)==mp_pair_type ) {
20644 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20645 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20649 if ( mp_type(p)>mp_pair_type ) {
20650 mp_install(mp, xx_part_loc(q),p); goto DONE;
20654 if ( mp_type(p)>mp_pair_type ) {
20655 mp_install(mp, yy_part_loc(q),p); goto DONE;
20659 if ( mp_type(p)==mp_pair_type )
20660 @<Install a complex multiplier, then |goto done|@>;
20662 case transformed_by:
20666 @ @<Install sines and cosines, then |goto done|@>=
20667 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20668 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20669 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20670 value(xy_part_loc(q))=-value(yx_part_loc(q));
20671 value(yy_part_loc(q))=value(xx_part_loc(q));
20675 @ @<Install a complex multiplier, then |goto done|@>=
20678 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20679 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20680 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20681 if ( mp_type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20682 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20683 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20687 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20688 insists that the transformation be entirely known.
20690 @<Declare binary action...@>=
20691 static void mp_set_up_known_trans (MP mp,quarterword c) {
20692 mp_set_up_trans(mp, c);
20693 if ( mp->cur_type!=mp_known ) {
20694 exp_err("Transform components aren't all known");
20695 @.Transform components...@>
20696 help3("I'm unable to apply a partially specified transformation",
20697 "except to a fully known pair or transform.",
20698 "Proceed, and I'll omit the transformation.");
20699 mp_put_get_flush_error(mp, 0);
20700 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20701 mp->tx=0; mp->ty=0;
20705 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20706 coordinates in locations |p| and~|q|.
20708 @<Declare binary action...@>=
20709 static void mp_trans (MP mp,pointer p, pointer q) {
20710 scaled v; /* the new |x| value */
20711 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20712 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20713 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20714 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20718 @ The simplest transformation procedure applies a transform to all
20719 coordinates of a path. The |path_trans(c)(p)| macro applies
20720 a transformation defined by |cur_exp| and the transform operator |c|
20723 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20724 mp_unstash_cur_exp(mp, (B));
20725 mp_do_path_trans(mp, mp->cur_exp); }
20727 @<Declare binary action...@>=
20728 static void mp_do_path_trans (MP mp,pointer p) {
20729 pointer q; /* list traverser */
20732 if ( mp_left_type(q)!=mp_endpoint )
20733 mp_trans(mp, q+3,q+4); /* that's |mp_left_x| and |mp_left_y| */
20734 mp_trans(mp, q+1,q+2); /* that's |mp_x_coord| and |mp_y_coord| */
20735 if ( mp_right_type(q)!=mp_endpoint )
20736 mp_trans(mp, q+5,q+6); /* that's |mp_right_x| and |mp_right_y| */
20737 @^data structure assumptions@>
20742 @ Transforming a pen is very similar, except that there are no |mp_left_type|
20743 and |mp_right_type| fields.
20745 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20746 mp_unstash_cur_exp(mp, (B));
20747 mp_do_pen_trans(mp, mp->cur_exp); }
20749 @<Declare binary action...@>=
20750 static void mp_do_pen_trans (MP mp,pointer p) {
20751 pointer q; /* list traverser */
20752 if ( pen_is_elliptical(p) ) {
20753 mp_trans(mp, p+3,p+4); /* that's |mp_left_x| and |mp_left_y| */
20754 mp_trans(mp, p+5,p+6); /* that's |mp_right_x| and |mp_right_y| */
20758 mp_trans(mp, q+1,q+2); /* that's |mp_x_coord| and |mp_y_coord| */
20759 @^data structure assumptions@>
20764 @ The next transformation procedure applies to edge structures. It will do
20765 any transformation, but the results may be substandard if the picture contains
20766 text that uses downloaded bitmap fonts. The binary action procedure is
20767 |do_edges_trans|, but we also need a function that just scales a picture.
20768 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20769 should be thought of as procedures that update an edge structure |h|, except
20770 that they have to return a (possibly new) structure because of the need to call
20773 @<Declare binary action...@>=
20774 static pointer mp_edges_trans (MP mp, pointer h) {
20775 pointer q; /* the object being transformed */
20776 pointer r,s; /* for list manipulation */
20777 scaled sx,sy; /* saved transformation parameters */
20778 scaled sqdet; /* square root of determinant for |dash_scale| */
20779 integer sgndet; /* sign of the determinant */
20780 scaled v; /* a temporary value */
20781 h=mp_private_edges(mp, h);
20782 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20783 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20784 if ( dash_list(h)!=null_dash ) {
20785 @<Try to transform the dash list of |h|@>;
20787 @<Make the bounding box of |h| unknown if it can't be updated properly
20788 without scanning the whole structure@>;
20789 q=mp_link(dummy_loc(h));
20790 while ( q!=null ) {
20791 @<Transform graphical object |q|@>;
20796 static void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20797 mp_set_up_known_trans(mp, c);
20798 value(p)=mp_edges_trans(mp, value(p));
20799 mp_unstash_cur_exp(mp, p);
20801 static void mp_scale_edges (MP mp) {
20802 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20803 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20804 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20807 @ @<Try to transform the dash list of |h|@>=
20808 if ( (mp->txy!=0)||(mp->tyx!=0)||
20809 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20810 mp_flush_dash_list(mp, h);
20812 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20813 @<Scale the dash list by |txx| and shift it by |tx|@>;
20814 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20817 @ @<Reverse the dash list of |h|@>=
20820 dash_list(h)=null_dash;
20821 while ( r!=null_dash ) {
20823 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20824 mp_link(s)=dash_list(h);
20829 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20831 while ( r!=null_dash ) {
20832 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20833 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20837 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20838 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20839 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20840 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20841 mp_init_bbox(mp, h);
20844 if ( minx_val(h)<=maxx_val(h) ) {
20845 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20852 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20854 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20855 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20858 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20861 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20863 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20864 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20865 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20866 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20867 if ( mp->txx+mp->txy<0 ) {
20868 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20870 if ( mp->tyx+mp->tyy<0 ) {
20871 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20875 @ Now we ready for the main task of transforming the graphical objects in edge
20878 @<Transform graphical object |q|@>=
20879 switch (mp_type(q)) {
20880 case mp_fill_code: case mp_stroked_code:
20881 mp_do_path_trans(mp, mp_path_p(q));
20882 @<Transform |mp_pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20884 case mp_start_clip_code: case mp_start_bounds_code:
20885 mp_do_path_trans(mp, mp_path_p(q));
20889 @<Transform the compact transformation starting at |r|@>;
20891 case mp_stop_clip_code: case mp_stop_bounds_code:
20893 } /* there are no other cases */
20895 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20896 The |dash_scale| has to be adjusted to scale the dash lengths in |mp_dash_p(q)|
20897 since the \ps\ output procedures will try to compensate for the transformation
20898 we are applying to |mp_pen_p(q)|. Since this compensation is based on the square
20899 root of the determinant, |sqdet| is the appropriate factor.
20901 @<Transform |mp_pen_p(q)|, making sure...@>=
20902 if ( mp_pen_p(q)!=null ) {
20903 sx=mp->tx; sy=mp->ty;
20904 mp->tx=0; mp->ty=0;
20905 mp_do_pen_trans(mp, mp_pen_p(q));
20906 if ( ((mp_type(q)==mp_stroked_code)&&(mp_dash_p(q)!=null)) )
20907 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20908 if ( ! pen_is_elliptical(mp_pen_p(q)) )
20910 mp_pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, mp_pen_p(q)),true);
20911 /* this unreverses the pen */
20912 mp->tx=sx; mp->ty=sy;
20915 @ This uses the fact that transformations are stored in the order
20916 |(tx,ty,txx,txy,tyx,tyy)|.
20917 @^data structure assumptions@>
20919 @<Transform the compact transformation starting at |r|@>=
20920 mp_trans(mp, r,r+1);
20921 sx=mp->tx; sy=mp->ty;
20922 mp->tx=0; mp->ty=0;
20923 mp_trans(mp, r+2,r+4);
20924 mp_trans(mp, r+3,r+5);
20925 mp->tx=sx; mp->ty=sy
20927 @ The hard cases of transformation occur when big nodes are involved,
20928 and when some of their components are unknown.
20930 @<Declare binary action...@>=
20931 @<Declare subroutines needed by |big_trans|@>
20932 static void mp_big_trans (MP mp,pointer p, quarterword c) {
20933 pointer q,r,pp,qq; /* list manipulation registers */
20934 quarterword s; /* size of a big node */
20935 s=mp->big_node_size[mp_type(p)]; q=value(p); r=q+s;
20938 if ( mp_type(r)!=mp_known ) {
20939 @<Transform an unknown big node and |return|@>;
20942 @<Transform a known big node@>;
20943 } /* node |p| will now be recycled by |do_binary| */
20945 @ @<Transform an unknown big node and |return|@>=
20947 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20948 r=value(mp->cur_exp);
20949 if ( mp->cur_type==mp_transform_type ) {
20950 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20951 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20952 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20953 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20955 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20956 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20960 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20961 and let |q| point to a another value field. The |bilin1| procedure
20962 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20964 @<Declare subroutines needed by |big_trans|@>=
20965 static void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20966 scaled u, scaled delta) {
20967 pointer r; /* list traverser */
20968 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20970 if ( mp_type(q)==mp_known ) {
20971 delta+=mp_take_scaled(mp, value(q),u);
20973 @<Ensure that |type(p)=mp_proto_dependent|@>;
20974 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20975 mp_proto_dependent,mp_type(q));
20978 if ( mp_type(p)==mp_known ) {
20982 while ( mp_info(r)!=null ) r=mp_link(r);
20984 if ( r!=dep_list(p) ) value(r)=delta;
20985 else { mp_recycle_value(mp, p); mp_type(p)=mp_known; value(p)=delta; };
20987 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20990 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
20991 if ( mp_type(p)!=mp_proto_dependent ) {
20992 if ( mp_type(p)==mp_known )
20993 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
20995 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
20996 mp_proto_dependent,true);
20997 mp_type(p)=mp_proto_dependent;
21000 @ @<Transform a known big node@>=
21001 mp_set_up_trans(mp, c);
21002 if ( mp->cur_type==mp_known ) {
21003 @<Transform known by known@>;
21005 pp=mp_stash_cur_exp(mp); qq=value(pp);
21006 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
21007 if ( mp->cur_type==mp_transform_type ) {
21008 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
21009 value(xy_part_loc(q)),yx_part_loc(qq),null);
21010 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
21011 value(xx_part_loc(q)),yx_part_loc(qq),null);
21012 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
21013 value(yy_part_loc(q)),xy_part_loc(qq),null);
21014 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
21015 value(yx_part_loc(q)),xy_part_loc(qq),null);
21017 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
21018 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
21019 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
21020 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
21021 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
21024 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
21025 at |dep_final|. The following procedure adds |v| times another
21026 numeric quantity to~|p|.
21028 @<Declare subroutines needed by |big_trans|@>=
21029 static void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
21030 if ( mp_type(r)==mp_known ) {
21031 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
21033 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
21034 mp_proto_dependent,mp_type(r));
21035 if ( mp->fix_needed ) mp_fix_dependencies(mp);
21039 @ The |bilin2| procedure is something like |bilin1|, but with known
21040 and unknown quantities reversed. Parameter |p| points to a value field
21041 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
21042 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
21043 unless it is |null| (which stands for zero). Location~|p| will be
21044 replaced by $p\cdot t+v\cdot u+q$.
21046 @<Declare subroutines needed by |big_trans|@>=
21047 static void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
21048 pointer u, pointer q) {
21049 scaled vv; /* temporary storage for |value(p)| */
21050 vv=value(p); mp_type(p)=mp_proto_dependent;
21051 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
21053 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
21054 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
21055 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
21056 if ( dep_list(p)==mp->dep_final ) {
21057 vv=value(mp->dep_final); mp_recycle_value(mp, p);
21058 mp_type(p)=mp_known; value(p)=vv;
21062 @ @<Transform known by known@>=
21064 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
21065 if ( mp->cur_type==mp_transform_type ) {
21066 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
21067 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
21068 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
21069 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
21071 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
21072 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
21075 @ Finally, in |bilin3| everything is |known|.
21077 @<Declare subroutines needed by |big_trans|@>=
21078 static void mp_bilin3 (MP mp,pointer p, scaled t,
21079 scaled v, scaled u, scaled delta) {
21081 delta+=mp_take_scaled(mp, value(p),t);
21084 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
21085 else value(p)=delta;
21088 @ @<Additional cases of binary operators@>=
21090 if ( (mp->cur_type==mp_string_type)&&(mp_type(p)==mp_string_type) ) mp_cat(mp, p);
21091 else mp_bad_binary(mp, p,concatenate);
21094 if ( mp_nice_pair(mp, p,mp_type(p))&&(mp->cur_type==mp_string_type) )
21095 mp_chop_string(mp, value(p));
21096 else mp_bad_binary(mp, p,substring_of);
21099 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21100 if ( mp_nice_pair(mp, p,mp_type(p))&&(mp->cur_type==mp_path_type) )
21101 mp_chop_path(mp, value(p));
21102 else mp_bad_binary(mp, p,subpath_of);
21105 @ @<Declare binary action...@>=
21106 static void mp_cat (MP mp,pointer p) {
21107 str_number a,b; /* the strings being concatenated */
21108 pool_pointer k; /* index into |str_pool| */
21109 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
21110 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
21111 append_char(mp->str_pool[k]);
21113 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
21114 append_char(mp->str_pool[k]);
21116 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
21119 @ @<Declare binary action...@>=
21120 static void mp_chop_string (MP mp,pointer p) {
21121 integer a, b; /* start and stop points */
21122 integer l; /* length of the original string */
21123 integer k; /* runs from |a| to |b| */
21124 str_number s; /* the original string */
21125 boolean reversed; /* was |a>b|? */
21126 a=mp_round_unscaled(mp, value(x_part_loc(p)));
21127 b=mp_round_unscaled(mp, value(y_part_loc(p)));
21128 if ( a<=b ) reversed=false;
21129 else { reversed=true; k=a; a=b; b=k; };
21130 s=mp->cur_exp; l=length(s);
21141 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
21142 append_char(mp->str_pool[k]);
21145 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
21146 append_char(mp->str_pool[k]);
21149 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
21152 @ @<Declare binary action...@>=
21153 static void mp_chop_path (MP mp,pointer p) {
21154 pointer q; /* a knot in the original path */
21155 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
21156 scaled a,b,k,l; /* indices for chopping */
21157 boolean reversed; /* was |a>b|? */
21158 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
21159 if ( a<=b ) reversed=false;
21160 else { reversed=true; k=a; a=b; b=k; };
21161 @<Dispense with the cases |a<0| and/or |b>l|@>;
21163 while ( a>=unity ) {
21164 q=mp_link(q); a=a-unity; b=b-unity;
21167 @<Construct a path from |pp| to |qq| of length zero@>;
21169 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
21171 mp_left_type(pp)=mp_endpoint; mp_right_type(qq)=mp_endpoint; mp_link(qq)=pp;
21172 mp_toss_knot_list(mp, mp->cur_exp);
21174 mp->cur_exp=mp_link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
21180 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
21182 if ( mp_left_type(mp->cur_exp)==mp_endpoint ) {
21183 a=0; if ( b<0 ) b=0;
21185 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
21189 if ( mp_left_type(mp->cur_exp)==mp_endpoint ) {
21190 b=l; if ( a>l ) a=l;
21198 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
21200 pp=mp_copy_knot(mp, q); qq=pp;
21202 q=mp_link(q); rr=qq; qq=mp_copy_knot(mp, q); mp_link(rr)=qq; b=b-unity;
21205 ss=pp; pp=mp_link(pp);
21206 mp_split_cubic(mp, ss,a*010000); pp=mp_link(ss);
21207 mp_free_node(mp, ss,knot_node_size);
21209 b=mp_make_scaled(mp, b,unity-a); rr=pp;
21213 mp_split_cubic(mp, rr,(b+unity)*010000);
21214 mp_free_node(mp, qq,knot_node_size);
21219 @ @<Construct a path from |pp| to |qq| of length zero@>=
21221 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=mp_link(q); };
21222 pp=mp_copy_knot(mp, q); qq=pp;
21225 @ @<Additional cases of binary operators@>=
21226 case point_of: case precontrol_of: case postcontrol_of:
21227 if ( mp->cur_type==mp_pair_type )
21228 mp_pair_to_path(mp);
21229 if ( (mp->cur_type==mp_path_type)&&(mp_type(p)==mp_known) )
21230 mp_find_point(mp, value(p),c);
21232 mp_bad_binary(mp, p,c);
21234 case pen_offset_of:
21235 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,mp_type(p)) )
21236 mp_set_up_offset(mp, value(p));
21238 mp_bad_binary(mp, p,pen_offset_of);
21240 case direction_time_of:
21241 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21242 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,mp_type(p)) )
21243 mp_set_up_direction_time(mp, value(p));
21245 mp_bad_binary(mp, p,direction_time_of);
21248 if ( (mp_type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
21249 mp_bad_binary(mp, p,envelope_of);
21251 mp_set_up_envelope(mp, p);
21254 @ @<Declare binary action...@>=
21255 static void mp_set_up_offset (MP mp,pointer p) {
21256 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
21257 mp_pair_value(mp, mp->cur_x,mp->cur_y);
21259 static void mp_set_up_direction_time (MP mp,pointer p) {
21260 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
21261 value(y_part_loc(p)),mp->cur_exp));
21263 static void mp_set_up_envelope (MP mp,pointer p) {
21264 quarterword ljoin, lcap;
21266 pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
21267 /* TODO: accept elliptical pens for straight paths */
21268 if (pen_is_elliptical(value(p))) {
21269 mp_bad_envelope_pen(mp);
21271 mp->cur_type = mp_path_type;
21274 if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
21275 else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
21277 if ( mp->internal[mp_linecap]>unity ) lcap=2;
21278 else if ( mp->internal[mp_linecap]>0 ) lcap=1;
21280 if ( mp->internal[mp_miterlimit]<unity )
21283 miterlim=mp->internal[mp_miterlimit];
21284 mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
21285 mp->cur_type = mp_path_type;
21288 @ @<Declare binary action...@>=
21289 static void mp_find_point (MP mp,scaled v, quarterword c) {
21290 pointer p; /* the path */
21291 scaled n; /* its length */
21293 if ( mp_left_type(p)==mp_endpoint ) n=-unity; else n=0;
21294 do { p=mp_link(p); n=n+unity; } while (p!=mp->cur_exp);
21297 } else if ( v<0 ) {
21298 if ( mp_left_type(p)==mp_endpoint ) v=0;
21299 else v=n-1-((-v-1) % n);
21300 } else if ( v>n ) {
21301 if ( mp_left_type(p)==mp_endpoint ) v=n;
21305 while ( v>=unity ) { p=mp_link(p); v=v-unity; };
21307 @<Insert a fractional node by splitting the cubic@>;
21309 @<Set the current expression to the desired path coordinates@>;
21312 @ @<Insert a fractional node...@>=
21313 { mp_split_cubic(mp, p,v*010000); p=mp_link(p); }
21315 @ @<Set the current expression to the desired path coordinates...@>=
21318 mp_pair_value(mp, mp_x_coord(p),mp_y_coord(p));
21320 case precontrol_of:
21321 if ( mp_left_type(p)==mp_endpoint ) mp_pair_value(mp, mp_x_coord(p),mp_y_coord(p));
21322 else mp_pair_value(mp, mp_left_x(p),mp_left_y(p));
21324 case postcontrol_of:
21325 if ( mp_right_type(p)==mp_endpoint ) mp_pair_value(mp, mp_x_coord(p),mp_y_coord(p));
21326 else mp_pair_value(mp, mp_right_x(p),mp_right_y(p));
21328 } /* there are no other cases */
21330 @ @<Additional cases of binary operators@>=
21332 if ( mp->cur_type==mp_pair_type )
21333 mp_pair_to_path(mp);
21334 if ( (mp->cur_type==mp_path_type)&&(mp_type(p)==mp_known) )
21335 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21337 mp_bad_binary(mp, p,c);
21340 @ @<Additional cases of bin...@>=
21342 if ( mp_type(p)==mp_pair_type ) {
21343 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21344 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21346 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21347 if ( (mp->cur_type==mp_path_type)&&(mp_type(p)==mp_path_type) ) {
21348 mp_path_intersection(mp, value(p),mp->cur_exp);
21349 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21351 mp_bad_binary(mp, p,intersect);
21355 @ @<Additional cases of bin...@>=
21357 if ( (mp->cur_type!=mp_string_type)||(mp_type(p)!=mp_string_type))
21358 mp_bad_binary(mp, p,in_font);
21359 else { mp_do_infont(mp, p); binary_return; }
21362 @ Function |new_text_node| owns the reference count for its second argument
21363 (the text string) but not its first (the font name).
21365 @<Declare binary action...@>=
21366 static void mp_do_infont (MP mp,pointer p) {
21368 q=mp_get_node(mp, edge_header_size);
21369 mp_init_edges(mp, q);
21370 mp_link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
21371 obj_tail(q)=mp_link(obj_tail(q));
21372 mp_free_node(mp, p,value_node_size);
21373 mp_flush_cur_exp(mp, q);
21374 mp->cur_type=mp_picture_type;
21377 @* \[40] Statements and commands.
21378 The chief executive of \MP\ is the |do_statement| routine, which
21379 contains the master switch that causes all the various pieces of \MP\
21380 to do their things, in the right order.
21382 In a sense, this is the grand climax of the program: It applies all the
21383 tools that we have worked so hard to construct. In another sense, this is
21384 the messiest part of the program: It necessarily refers to other pieces
21385 of code all over the place, so that a person can't fully understand what is
21386 going on without paging back and forth to be reminded of conventions that
21387 are defined elsewhere. We are now at the hub of the web.
21389 The structure of |do_statement| itself is quite simple. The first token
21390 of the statement is fetched using |get_x_next|. If it can be the first
21391 token of an expression, we look for an equation, an assignment, or a
21392 title. Otherwise we use a \&{case} construction to branch at high speed to
21393 the appropriate routine for various and sundry other types of commands,
21394 each of which has an ``action procedure'' that does the necessary work.
21396 The program uses the fact that
21397 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21398 to interpret a statement that starts with, e.g., `\&{string}',
21399 as a type declaration rather than a boolean expression.
21401 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21402 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21403 if ( mp->cur_cmd>max_primary_command ) {
21404 @<Worry about bad statement@>;
21405 } else if ( mp->cur_cmd>max_statement_command ) {
21406 @<Do an equation, assignment, title, or
21407 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21409 @<Do a statement that doesn't begin with an expression@>;
21411 if ( mp->cur_cmd<semicolon )
21412 @<Flush unparsable junk that was found after the statement@>;
21416 @ @<Declarations@>=
21417 @<Declare action procedures for use by |do_statement|@>
21419 @ The only command codes |>max_primary_command| that can be present
21420 at the beginning of a statement are |semicolon| and higher; these
21421 occur when the statement is null.
21423 @<Worry about bad statement@>=
21425 if ( mp->cur_cmd<semicolon ) {
21426 print_err("A statement can't begin with `");
21427 @.A statement can't begin with x@>
21428 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, xord('\''));
21429 help5("I was looking for the beginning of a new statement.",
21430 "If you just proceed without changing anything, I'll ignore",
21431 "everything up to the next `;'. Please insert a semicolon",
21432 "now in front of anything that you don't want me to delete.",
21433 "(See Chapter 27 of The METAFONTbook for an example.)");
21434 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21435 mp_back_error(mp); mp_get_x_next(mp);
21439 @ The help message printed here says that everything is flushed up to
21440 a semicolon, but actually the commands |end_group| and |stop| will
21441 also terminate a statement.
21443 @<Flush unparsable junk that was found after the statement@>=
21445 print_err("Extra tokens will be flushed");
21446 @.Extra tokens will be flushed@>
21447 help6("I've just read as much of that statement as I could fathom,",
21448 "so a semicolon should have been next. It's very puzzling...",
21449 "but I'll try to get myself back together, by ignoring",
21450 "everything up to the next `;'. Please insert a semicolon",
21451 "now in front of anything that you don't want me to delete.",
21452 "(See Chapter 27 of The METAFONTbook for an example.)");
21453 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21454 mp_back_error(mp); mp->scanner_status=flushing;
21457 @<Decrease the string reference count...@>;
21458 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21459 mp->scanner_status=normal;
21462 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21463 |cur_type=mp_vacuous| unless the statement was simply an expression;
21464 in the latter case, |cur_type| and |cur_exp| should represent that
21467 @<Do a statement that doesn't...@>=
21469 if ( mp->internal[mp_tracing_commands]>0 )
21471 switch (mp->cur_cmd ) {
21472 case type_name:mp_do_type_declaration(mp); break;
21474 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21475 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21477 @<Cases of |do_statement| that invoke particular commands@>;
21478 } /* there are no other cases */
21479 mp->cur_type=mp_vacuous;
21482 @ The most important statements begin with expressions.
21484 @<Do an equation, assignment, title, or...@>=
21486 mp->var_flag=assignment; mp_scan_expression(mp);
21487 if ( mp->cur_cmd<end_group ) {
21488 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21489 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21490 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21491 else if ( mp->cur_type!=mp_vacuous ){
21492 exp_err("Isolated expression");
21493 @.Isolated expression@>
21494 help3("I couldn't find an `=' or `:=' after the",
21495 "expression that is shown above this error message,",
21496 "so I guess I'll just ignore it and carry on.");
21497 mp_put_get_error(mp);
21499 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21505 if ( mp->internal[mp_tracing_titles]>0 ) {
21506 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21510 @ Equations and assignments are performed by the pair of mutually recursive
21512 routines |do_equation| and |do_assignment|. These routines are called when
21513 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21514 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21515 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21516 will be equal to the right-hand side (which will normally be equal
21517 to the left-hand side).
21520 @<Declare the procedure called |make_eq|@>
21521 static void mp_do_equation (MP mp) ;
21524 void mp_do_equation (MP mp) {
21525 pointer lhs; /* capsule for the left-hand side */
21526 pointer p; /* temporary register */
21527 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21528 mp->var_flag=assignment; mp_scan_expression(mp);
21529 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21530 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21531 if ( mp->internal[mp_tracing_commands]>two )
21532 @<Trace the current equation@>;
21533 if ( mp->cur_type==mp_unknown_path ) if ( mp_type(lhs)==mp_pair_type ) {
21534 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21535 }; /* in this case |make_eq| will change the pair to a path */
21536 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21539 @ And |do_assignment| is similar to |do_equation|:
21542 static void mp_do_assignment (MP mp);
21545 void mp_do_assignment (MP mp) {
21546 pointer lhs; /* token list for the left-hand side */
21547 pointer p; /* where the left-hand value is stored */
21548 pointer q; /* temporary capsule for the right-hand value */
21549 if ( mp->cur_type!=mp_token_list ) {
21550 exp_err("Improper `:=' will be changed to `='");
21552 help2("I didn't find a variable name at the left of the `:=',",
21553 "so I'm going to pretend that you said `=' instead.");
21554 mp_error(mp); mp_do_equation(mp);
21556 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21557 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21558 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21559 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21560 if ( mp->internal[mp_tracing_commands]>two )
21561 @<Trace the current assignment@>;
21562 if ( mp_info(lhs)>hash_end ) {
21563 @<Assign the current expression to an internal variable@>;
21565 @<Assign the current expression to the variable |lhs|@>;
21567 mp_flush_node_list(mp, lhs);
21571 @ @<Trace the current equation@>=
21573 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21574 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21575 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21578 @ @<Trace the current assignment@>=
21580 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21581 if ( mp_info(lhs)>hash_end )
21582 mp_print(mp, mp->int_name[mp_info(lhs)-(hash_end)]);
21584 mp_show_token_list(mp, lhs,null,1000,0);
21585 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21586 mp_print_char(mp, xord('}')); mp_end_diagnostic(mp, false);
21589 @ @<Assign the current expression to an internal variable@>=
21590 if ( mp->cur_type==mp_known ) {
21591 mp->internal[mp_info(lhs)-(hash_end)]=mp->cur_exp;
21593 exp_err("Internal quantity `");
21594 @.Internal quantity...@>
21595 mp_print(mp, mp->int_name[mp_info(lhs)-(hash_end)]);
21596 mp_print(mp, "' must receive a known value");
21597 help2("I can\'t set an internal quantity to anything but a known",
21598 "numeric value, so I'll have to ignore this assignment.");
21599 mp_put_get_error(mp);
21602 @ @<Assign the current expression to the variable |lhs|@>=
21604 p=mp_find_variable(mp, lhs);
21606 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21607 mp_recycle_value(mp, p);
21608 mp_type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21609 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21611 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21616 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21617 a pointer to a capsule that is to be equated to the current expression.
21619 @<Declare the procedure called |make_eq|@>=
21620 static void mp_make_eq (MP mp,pointer lhs) ;
21624 @c void mp_make_eq (MP mp,pointer lhs) {
21625 quarterword t; /* type of the left-hand side */
21626 pointer p,q; /* pointers inside of big nodes */
21627 integer v=0; /* value of the left-hand side */
21630 if ( t<=mp_pair_type ) v=value(lhs);
21632 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21633 is incompatible with~|t|@>;
21634 } /* all cases have been listed */
21635 @<Announce that the equation cannot be performed@>;
21637 check_arith; mp_recycle_value(mp, lhs);
21638 mp_free_node(mp, lhs,value_node_size);
21641 @ @<Announce that the equation cannot be performed@>=
21642 mp_disp_err(mp, lhs,"");
21643 exp_err("Equation cannot be performed (");
21644 @.Equation cannot be performed@>
21645 if ( mp_type(lhs)<=mp_pair_type ) mp_print_type(mp, mp_type(lhs));
21646 else mp_print(mp, "numeric");
21647 mp_print_char(mp, xord('='));
21648 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21649 else mp_print(mp, "numeric");
21650 mp_print_char(mp, xord(')'));
21651 help2("I'm sorry, but I don't know how to make such things equal.",
21652 "(See the two expressions just above the error message.)");
21653 mp_put_get_error(mp)
21655 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21656 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21657 case mp_path_type: case mp_picture_type:
21658 if ( mp->cur_type==t+unknown_tag ) {
21659 mp_nonlinear_eq(mp, v,mp->cur_exp,false);
21660 mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
21661 } else if ( mp->cur_type==t ) {
21662 @<Report redundant or inconsistent equation and |goto done|@>;
21665 case unknown_types:
21666 if ( mp->cur_type==t-unknown_tag ) {
21667 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21668 } else if ( mp->cur_type==t ) {
21669 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21670 } else if ( mp->cur_type==mp_pair_type ) {
21671 if ( t==mp_unknown_path ) {
21672 mp_pair_to_path(mp); goto RESTART;
21676 case mp_transform_type: case mp_color_type:
21677 case mp_cmykcolor_type: case mp_pair_type:
21678 if ( mp->cur_type==t ) {
21679 @<Do multiple equations and |goto done|@>;
21682 case mp_known: case mp_dependent:
21683 case mp_proto_dependent: case mp_independent:
21684 if ( mp->cur_type>=mp_known ) {
21685 mp_try_eq(mp, lhs,null); goto DONE;
21691 @ @<Report redundant or inconsistent equation and |goto done|@>=
21693 if ( mp->cur_type<=mp_string_type ) {
21694 if ( mp->cur_type==mp_string_type ) {
21695 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21698 } else if ( v!=mp->cur_exp ) {
21701 @<Exclaim about a redundant equation@>; goto DONE;
21703 print_err("Redundant or inconsistent equation");
21704 @.Redundant or inconsistent equation@>
21705 help2("An equation between already-known quantities can't help.",
21706 "But don't worry; continue and I'll just ignore it.");
21707 mp_put_get_error(mp); goto DONE;
21709 print_err("Inconsistent equation");
21710 @.Inconsistent equation@>
21711 help2("The equation I just read contradicts what was said before.",
21712 "But don't worry; continue and I'll just ignore it.");
21713 mp_put_get_error(mp); goto DONE;
21716 @ @<Do multiple equations and |goto done|@>=
21718 p=v+mp->big_node_size[t];
21719 q=value(mp->cur_exp)+mp->big_node_size[t];
21721 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21726 @ The first argument to |try_eq| is the location of a value node
21727 in a capsule that will soon be recycled. The second argument is
21728 either a location within a pair or transform node pointed to by
21729 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21730 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21731 but to equate the two operands.
21734 static void mp_try_eq (MP mp,pointer l, pointer r) ;
21737 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21738 pointer p; /* dependency list for right operand minus left operand */
21739 int t; /* the type of list |p| */
21740 pointer q; /* the constant term of |p| is here */
21741 pointer pp; /* dependency list for right operand */
21742 int tt; /* the type of list |pp| */
21743 boolean copied; /* have we copied a list that ought to be recycled? */
21744 @<Remove the left operand from its container, negate it, and
21745 put it into dependency list~|p| with constant term~|q|@>;
21746 @<Add the right operand to list |p|@>;
21747 if ( mp_info(p)==null ) {
21748 @<Deal with redundant or inconsistent equation@>;
21750 mp_linear_eq(mp, p,t);
21751 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21752 if ( mp_type(mp->cur_exp)==mp_known ) {
21753 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21754 mp_free_node(mp, pp,value_node_size);
21760 @ @<Remove the left operand from its container, negate it, and...@>=
21762 if ( t==mp_known ) {
21763 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21764 } else if ( t==mp_independent ) {
21765 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21768 p=dep_list(l); q=p;
21771 if ( mp_info(q)==null ) break;
21774 mp_link(prev_dep(l))=mp_link(q); prev_dep(mp_link(q))=prev_dep(l);
21775 mp_type(l)=mp_known;
21778 @ @<Deal with redundant or inconsistent equation@>=
21780 if ( abs(value(p))>64 ) { /* off by .001 or more */
21781 print_err("Inconsistent equation");
21782 @.Inconsistent equation@>
21783 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21784 mp_print_char(mp, xord(')'));
21785 help2("The equation I just read contradicts what was said before.",
21786 "But don't worry; continue and I'll just ignore it.");
21787 mp_put_get_error(mp);
21788 } else if ( r==null ) {
21789 @<Exclaim about a redundant equation@>;
21791 mp_free_node(mp, p,dep_node_size);
21794 @ @<Add the right operand to list |p|@>=
21796 if ( mp->cur_type==mp_known ) {
21797 value(q)=value(q)+mp->cur_exp; goto DONE1;
21800 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21801 else pp=dep_list(mp->cur_exp);
21804 if ( mp_type(r)==mp_known ) {
21805 value(q)=value(q)+value(r); goto DONE1;
21808 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21809 else pp=dep_list(r);
21812 if ( tt!=mp_independent ) copied=false;
21813 else { copied=true; tt=mp_dependent; };
21814 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21815 if ( copied ) mp_flush_node_list(mp, pp);
21818 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21819 mp->watch_coefs=false;
21821 p=mp_p_plus_q(mp, p,pp,t);
21822 } else if ( t==mp_proto_dependent ) {
21823 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21826 while ( mp_info(q)!=null ) {
21827 value(q)=mp_round_fraction(mp, value(q)); q=mp_link(q);
21829 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21831 mp->watch_coefs=true;
21833 @ Our next goal is to process type declarations. For this purpose it's
21834 convenient to have a procedure that scans a $\langle\,$declared
21835 variable$\,\rangle$ and returns the corresponding token list. After the
21836 following procedure has acted, the token after the declared variable
21837 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21841 static pointer mp_scan_declared_variable (MP mp) ;
21844 pointer mp_scan_declared_variable (MP mp) {
21845 pointer x; /* hash address of the variable's root */
21846 pointer h,t; /* head and tail of the token list to be returned */
21847 pointer l; /* hash address of left bracket */
21848 mp_get_symbol(mp); x=mp->cur_sym;
21849 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21850 h=mp_get_avail(mp); mp_info(h)=x; t=h;
21853 if ( mp->cur_sym==0 ) break;
21854 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21855 if ( mp->cur_cmd==left_bracket ) {
21856 @<Descend past a collective subscript@>;
21861 mp_link(t)=mp_get_avail(mp); t=mp_link(t); mp_info(t)=mp->cur_sym;
21863 if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
21864 if ( equiv(x)==null ) mp_new_root(mp, x);
21868 @ If the subscript isn't collective, we don't accept it as part of the
21871 @<Descend past a collective subscript@>=
21873 l=mp->cur_sym; mp_get_x_next(mp);
21874 if ( mp->cur_cmd!=right_bracket ) {
21875 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21877 mp->cur_sym=collective_subscript;
21881 @ Type declarations are introduced by the following primitive operations.
21884 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21885 @:numeric_}{\&{numeric} primitive@>
21886 mp_primitive(mp, "string",type_name,mp_string_type);
21887 @:string_}{\&{string} primitive@>
21888 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21889 @:boolean_}{\&{boolean} primitive@>
21890 mp_primitive(mp, "path",type_name,mp_path_type);
21891 @:path_}{\&{path} primitive@>
21892 mp_primitive(mp, "pen",type_name,mp_pen_type);
21893 @:pen_}{\&{pen} primitive@>
21894 mp_primitive(mp, "picture",type_name,mp_picture_type);
21895 @:picture_}{\&{picture} primitive@>
21896 mp_primitive(mp, "transform",type_name,mp_transform_type);
21897 @:transform_}{\&{transform} primitive@>
21898 mp_primitive(mp, "color",type_name,mp_color_type);
21899 @:color_}{\&{color} primitive@>
21900 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21901 @:color_}{\&{rgbcolor} primitive@>
21902 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21903 @:color_}{\&{cmykcolor} primitive@>
21904 mp_primitive(mp, "pair",type_name,mp_pair_type);
21905 @:pair_}{\&{pair} primitive@>
21907 @ @<Cases of |print_cmd...@>=
21908 case type_name: mp_print_type(mp, m); break;
21910 @ Now we are ready to handle type declarations, assuming that a
21911 |type_name| has just been scanned.
21913 @<Declare action procedures for use by |do_statement|@>=
21914 static void mp_do_type_declaration (MP mp) ;
21917 void mp_do_type_declaration (MP mp) {
21918 quarterword t; /* the type being declared */
21919 pointer p; /* token list for a declared variable */
21920 pointer q; /* value node for the variable */
21921 if ( mp->cur_mod>=mp_transform_type )
21924 t=mp->cur_mod+unknown_tag;
21926 p=mp_scan_declared_variable(mp);
21927 mp_flush_variable(mp, equiv(mp_info(p)),mp_link(p),false);
21928 q=mp_find_variable(mp, p);
21930 mp_type(q)=t; value(q)=null;
21932 print_err("Declared variable conflicts with previous vardef");
21933 @.Declared variable conflicts...@>
21934 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.",
21935 "Proceed, and I'll ignore the illegal redeclaration.");
21936 mp_put_get_error(mp);
21938 mp_flush_list(mp, p);
21939 if ( mp->cur_cmd<comma ) {
21940 @<Flush spurious symbols after the declared variable@>;
21942 } while (! end_of_statement);
21945 @ @<Flush spurious symbols after the declared variable@>=
21947 print_err("Illegal suffix of declared variable will be flushed");
21948 @.Illegal suffix...flushed@>
21949 help5("Variables in declarations must consist entirely of",
21950 "names and collective subscripts, e.g., `x[]a'.",
21951 "Are you trying to use a reserved word in a variable name?",
21952 "I'm going to discard the junk I found here,",
21953 "up to the next comma or the end of the declaration.");
21954 if ( mp->cur_cmd==numeric_token )
21955 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21956 mp_put_get_error(mp); mp->scanner_status=flushing;
21959 @<Decrease the string reference count...@>;
21960 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21961 mp->scanner_status=normal;
21964 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21965 until coming to the end of the user's program.
21966 Each execution of |do_statement| concludes with
21967 |cur_cmd=semicolon|, |end_group|, or |stop|.
21970 static void mp_main_control (MP mp) {
21972 mp_do_statement(mp);
21973 if ( mp->cur_cmd==end_group ) {
21974 print_err("Extra `endgroup'");
21975 @.Extra `endgroup'@>
21976 help2("I'm not currently working on a `begingroup',",
21977 "so I had better not try to end anything.");
21978 mp_flush_error(mp, 0);
21980 } while (mp->cur_cmd!=stop);
21982 int mp_run (MP mp) {
21983 if (mp->history < mp_fatal_error_stop ) {
21984 xfree(mp->jump_buf);
21985 mp->jump_buf = malloc(sizeof(jmp_buf));
21986 if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)) != 0)
21987 return mp->history;
21988 mp_main_control(mp); /* come to life */
21989 mp_final_cleanup(mp); /* prepare for death */
21990 mp_close_files_and_terminate(mp);
21992 return mp->history;
21995 @ For |mp_execute|, we need to define a structure to store the
21996 redirected input and output. This structure holds the five relevant
21997 streams: the three informational output streams, the PostScript
21998 generation stream, and the input stream. These streams have many
21999 things in common, so it makes sense to give them their own structure
22002 \item{fptr} is a virtual file pointer
22003 \item{data} is the data this stream holds
22004 \item{cur} is a cursor pointing into |data|
22005 \item{size} is the allocated length of the data stream
22006 \item{used} is the actual length of the data stream
22008 There are small differences between input and output: |term_in| never
22009 uses |used|, whereas the other four never use |cur|.
22011 @<Exported types@>=
22021 mp_stream term_out;
22022 mp_stream error_out;
22026 struct mp_edge_object *edges;
22029 @ We need a function to clear an output stream, this is called at the
22030 beginning of |mp_execute|. We also need one for destroying an output
22031 stream, this is called just before a stream is (re)opened.
22034 static void mp_reset_stream(mp_stream *str) {
22040 static void mp_free_stream(mp_stream *str) {
22042 mp_reset_stream(str);
22045 @ @<Declarations@>=
22046 static void mp_reset_stream(mp_stream *str);
22047 static void mp_free_stream(mp_stream *str);
22049 @ The global instance contains a pointer instead of the actual structure
22050 even though it is essentially static, because that makes it is easier to move
22054 mp_run_data run_data;
22056 @ Another type is needed: the indirection will overload some of the
22057 file pointer objects in the instance (but not all). For clarity, an
22058 indirect object is used that wraps a |FILE *|.
22061 typedef struct File {
22065 @ Here are all of the functions that need to be overloaded for |mp_execute|.
22068 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype);
22069 static int mplib_get_char(void *f, mp_run_data * mplib_data);
22070 static void mplib_unget_char(void *f, mp_run_data * mplib_data, int c);
22071 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size);
22072 static void mplib_write_ascii_file(MP mp, void *ff, const char *s);
22073 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size);
22074 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size);
22075 static void mplib_close_file(MP mp, void *ff);
22076 static int mplib_eof_file(MP mp, void *ff);
22077 static void mplib_flush_file(MP mp, void *ff);
22078 static void mplib_shipout_backend(MP mp, int h);
22080 @ The |xmalloc(1,1)| calls make sure the stored indirection values are unique.
22082 @d reset_stream(a) do {
22083 mp_reset_stream(&(a));
22085 ff->f = xmalloc(1,1);
22091 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype)
22093 File *ff = xmalloc(1, sizeof(File));
22094 mp_run_data *run = mp_rundata(mp);
22096 if (ftype == mp_filetype_terminal) {
22097 if (fmode[0] == 'r') {
22099 ff->f = xmalloc(1,1);
22100 run->term_in.fptr = ff->f;
22103 reset_stream(run->term_out);
22105 } else if (ftype == mp_filetype_error) {
22106 reset_stream(run->error_out);
22107 } else if (ftype == mp_filetype_log) {
22108 reset_stream(run->log_out);
22109 } else if (ftype == mp_filetype_postscript) {
22110 mp_free_stream(&(run->ps_out));
22111 ff->f = xmalloc(1,1);
22112 run->ps_out.fptr = ff->f;
22115 char *f = (mp->find_file)(mp, fname, fmode, ftype);
22118 realmode[0] = *fmode;
22121 ff->f = fopen(f, realmode);
22123 if ((fmode[0] == 'r') && (ff->f == NULL)) {
22131 static int mplib_get_char(void *f, mp_run_data * run)
22134 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22135 if (run->term_in.size == 0) {
22136 if (run->term_in.cur != NULL) {
22137 run->term_in.cur = NULL;
22139 xfree(run->term_in.data);
22143 run->term_in.size--;
22144 c = *(run->term_in.cur)++;
22152 static void mplib_unget_char(void *f, mp_run_data * run, int c)
22154 if (f == run->term_in.fptr && run->term_in.cur != NULL) {
22155 run->term_in.size++;
22156 run->term_in.cur--;
22163 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size)
22168 size_t len = 0, lim = 128;
22169 mp_run_data *run = mp_rundata(mp);
22170 FILE *f = ((File *) ff)->f;
22174 c = mplib_get_char(f, run);
22180 while (c != EOF && c != '\n' && c != '\r') {
22182 s = xrealloc(s, (lim + (lim >> 2)),1);
22188 c = mplib_get_char(f, run);
22191 c = mplib_get_char(f, run);
22192 if (c != EOF && c != '\n')
22193 mplib_unget_char(f, run, c);
22201 static void mp_append_string (MP mp, mp_stream *a,const char *b) {
22202 size_t l = strlen(b);
22203 if ((a->used+l)>=a->size) {
22204 a->size += 256+(a->size)/5+l;
22205 a->data = xrealloc(a->data,a->size,1);
22207 (void)strcpy(a->data+a->used,b);
22212 static void mplib_write_ascii_file(MP mp, void *ff, const char *s)
22215 void *f = ((File *) ff)->f;
22216 mp_run_data *run = mp_rundata(mp);
22218 if (f == run->term_out.fptr) {
22219 mp_append_string(mp,&(run->term_out), s);
22220 } else if (f == run->error_out.fptr) {
22221 mp_append_string(mp,&(run->error_out), s);
22222 } else if (f == run->log_out.fptr) {
22223 mp_append_string(mp,&(run->log_out), s);
22224 } else if (f == run->ps_out.fptr) {
22225 mp_append_string(mp,&(run->ps_out), s);
22227 fprintf((FILE *) f, "%s", s);
22233 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size)
22238 FILE *f = ((File *) ff)->f;
22240 len = fread(*data, 1, *size, f);
22245 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size)
22249 FILE *f = ((File *) ff)->f;
22251 (void)fwrite(s, size, 1, f);
22255 static void mplib_close_file(MP mp, void *ff)
22258 mp_run_data *run = mp_rundata(mp);
22259 void *f = ((File *) ff)->f;
22261 if (f != run->term_out.fptr
22262 && f != run->error_out.fptr
22263 && f != run->log_out.fptr
22264 && f != run->ps_out.fptr
22265 && f != run->term_in.fptr) {
22273 static int mplib_eof_file(MP mp, void *ff)
22276 mp_run_data *run = mp_rundata(mp);
22277 FILE *f = ((File *) ff)->f;
22280 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22281 return (run->term_in.size == 0);
22288 static void mplib_flush_file(MP mp, void *ff)
22295 static void mplib_shipout_backend(MP mp, int h)
22297 mp_edge_object *hh = mp_gr_export(mp, h);
22299 mp_run_data *run = mp_rundata(mp);
22300 if (run->edges==NULL) {
22303 mp_edge_object *p = run->edges;
22304 while (p->next!=NULL) { p = p->next; }
22311 @ This is where we fill them all in.
22312 @<Prepare function pointers for non-interactive use@>=
22314 mp->open_file = mplib_open_file;
22315 mp->close_file = mplib_close_file;
22316 mp->eof_file = mplib_eof_file;
22317 mp->flush_file = mplib_flush_file;
22318 mp->write_ascii_file = mplib_write_ascii_file;
22319 mp->read_ascii_file = mplib_read_ascii_file;
22320 mp->write_binary_file = mplib_write_binary_file;
22321 mp->read_binary_file = mplib_read_binary_file;
22322 mp->shipout_backend = mplib_shipout_backend;
22325 @ Perhaps this is the most important API function in the library.
22327 @<Exported function ...@>=
22328 extern mp_run_data *mp_rundata (MP mp) ;
22331 mp_run_data *mp_rundata (MP mp) {
22332 return &(mp->run_data);
22336 mp_free_stream(&(mp->run_data.term_in));
22337 mp_free_stream(&(mp->run_data.term_out));
22338 mp_free_stream(&(mp->run_data.log_out));
22339 mp_free_stream(&(mp->run_data.error_out));
22340 mp_free_stream(&(mp->run_data.ps_out));
22342 @ @<Finish non-interactive use@>=
22343 xfree(mp->term_out);
22344 xfree(mp->term_in);
22345 xfree(mp->err_out);
22347 @ @<Start non-interactive work@>=
22348 @<Initialize the output routines@>;
22349 mp->input_ptr=0; mp->max_in_stack=0;
22350 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
22351 mp->param_ptr=0; mp->max_param_stack=0;
22352 start = loc = iindex = 0; mp->first = 0;
22353 line=0; name=is_term;
22354 mp->mpx_name[0]=absent;
22355 mp->force_eof=false;
22357 mp->scanner_status=normal;
22358 if (mp->mem_ident==NULL) {
22359 if ( ! mp_load_mem_file(mp) ) {
22360 (mp->close_file)(mp, mp->mem_file);
22361 mp->history = mp_fatal_error_stop;
22362 return mp->history;
22364 (mp->close_file)(mp, mp->mem_file);
22366 mp_fix_date_and_time(mp);
22367 if (mp->random_seed==0)
22368 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
22369 mp_init_randoms(mp, mp->random_seed);
22370 @<Initialize the print |selector|...@>;
22371 mp_open_log_file(mp);
22373 mp_init_map_file(mp, mp->troff_mode);
22374 mp->history=mp_spotless; /* ready to go! */
22375 if (mp->troff_mode) {
22376 mp->internal[mp_gtroffmode]=unity;
22377 mp->internal[mp_prologues]=unity;
22379 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
22380 mp->cur_sym=mp->start_sym; mp_back_input(mp);
22384 int mp_execute (MP mp, char *s, size_t l) {
22385 mp_reset_stream(&(mp->run_data.term_out));
22386 mp_reset_stream(&(mp->run_data.log_out));
22387 mp_reset_stream(&(mp->run_data.error_out));
22388 mp_reset_stream(&(mp->run_data.ps_out));
22389 if (mp->finished) {
22390 return mp->history;
22391 } else if (!mp->noninteractive) {
22392 mp->history = mp_fatal_error_stop ;
22393 return mp->history;
22395 if (mp->history < mp_fatal_error_stop ) {
22396 xfree(mp->jump_buf);
22397 mp->jump_buf = malloc(sizeof(jmp_buf));
22398 if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)) != 0) {
22399 return mp->history;
22401 if (s==NULL) { /* this signals EOF */
22402 mp_final_cleanup(mp); /* prepare for death */
22403 mp_close_files_and_terminate(mp);
22404 return mp->history;
22407 mp->term_offset=0; mp->file_offset=0;
22408 /* Perhaps some sort of warning here when |data| is not
22409 * yet exhausted would be nice ... this happens after errors
22411 if (mp->run_data.term_in.data)
22412 xfree(mp->run_data.term_in.data);
22413 mp->run_data.term_in.data = xstrdup(s);
22414 mp->run_data.term_in.cur = mp->run_data.term_in.data;
22415 mp->run_data.term_in.size = l;
22416 if (mp->run_state == 0) {
22417 mp->selector=term_only;
22418 @<Start non-interactive work@>;
22421 (void)mp_input_ln(mp,mp->term_in);
22422 mp_firm_up_the_line(mp);
22423 mp->buffer[limit]=xord('%');
22424 mp->first=(size_t)(limit+1);
22427 mp_do_statement(mp);
22428 } while (mp->cur_cmd!=stop);
22429 mp_final_cleanup(mp);
22430 mp_close_files_and_terminate(mp);
22432 return mp->history;
22435 @ This function cleans up
22437 int mp_finish (MP mp) {
22439 if (mp->finished || mp->history >= mp_fatal_error_stop) {
22440 history = mp->history;
22444 xfree(mp->jump_buf);
22445 mp->jump_buf = malloc(sizeof(jmp_buf));
22446 if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)) != 0) {
22447 history = mp->history;
22449 history = mp->history;
22450 mp_final_cleanup(mp); /* prepare for death */
22452 mp_close_files_and_terminate(mp);
22457 @ People may want to know the library version
22459 char * mp_metapost_version (void) {
22460 return mp_strdup(metapost_version);
22463 @ @<Exported function headers@>=
22464 int mp_run (MP mp);
22465 int mp_execute (MP mp, char *s, size_t l);
22466 int mp_finish (MP mp);
22467 char * mp_metapost_version (void);
22470 mp_primitive(mp, "end",stop,0);
22471 @:end_}{\&{end} primitive@>
22472 mp_primitive(mp, "dump",stop,1);
22473 @:dump_}{\&{dump} primitive@>
22475 @ @<Cases of |print_cmd...@>=
22477 if ( m==0 ) mp_print(mp, "end");
22478 else mp_print(mp, "dump");
22482 Let's turn now to statements that are classified as ``commands'' because
22483 of their imperative nature. We'll begin with simple ones, so that it
22484 will be clear how to hook command processing into the |do_statement| routine;
22485 then we'll tackle the tougher commands.
22487 Here's one of the simplest:
22489 @<Cases of |do_statement|...@>=
22490 case mp_random_seed: mp_do_random_seed(mp); break;
22492 @ @<Declare action procedures for use by |do_statement|@>=
22493 static void mp_do_random_seed (MP mp) ;
22495 @ @c void mp_do_random_seed (MP mp) {
22497 if ( mp->cur_cmd!=assignment ) {
22498 mp_missing_err(mp, ":=");
22500 help1("Always say `randomseed:=<numeric expression>'.");
22503 mp_get_x_next(mp); mp_scan_expression(mp);
22504 if ( mp->cur_type!=mp_known ) {
22505 exp_err("Unknown value will be ignored");
22506 @.Unknown value...ignored@>
22507 help2("Your expression was too random for me to handle,",
22508 "so I won't change the random seed just now.");
22509 mp_put_get_flush_error(mp, 0);
22511 @<Initialize the random seed to |cur_exp|@>;
22515 @ @<Initialize the random seed to |cur_exp|@>=
22517 mp_init_randoms(mp, mp->cur_exp);
22518 if ( mp->selector>=log_only && mp->selector<write_file) {
22519 mp->old_setting=mp->selector; mp->selector=log_only;
22520 mp_print_nl(mp, "{randomseed:=");
22521 mp_print_scaled(mp, mp->cur_exp);
22522 mp_print_char(mp, xord('}'));
22523 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
22527 @ And here's another simple one (somewhat different in flavor):
22529 @<Cases of |do_statement|...@>=
22531 mp_print_ln(mp); mp->interaction=mp->cur_mod;
22532 @<Initialize the print |selector| based on |interaction|@>;
22533 if ( mp->log_opened ) mp->selector=mp->selector+2;
22538 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
22539 @:mp_batch_mode_}{\&{batchmode} primitive@>
22540 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
22541 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
22542 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
22543 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
22544 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
22545 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
22547 @ @<Cases of |print_cmd_mod|...@>=
22550 case mp_batch_mode: mp_print(mp, "batchmode"); break;
22551 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
22552 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
22553 default: mp_print(mp, "errorstopmode"); break;
22557 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
22559 @<Cases of |do_statement|...@>=
22560 case protection_command: mp_do_protection(mp); break;
22563 mp_primitive(mp, "inner",protection_command,0);
22564 @:inner_}{\&{inner} primitive@>
22565 mp_primitive(mp, "outer",protection_command,1);
22566 @:outer_}{\&{outer} primitive@>
22568 @ @<Cases of |print_cmd...@>=
22569 case protection_command:
22570 if ( m==0 ) mp_print(mp, "inner");
22571 else mp_print(mp, "outer");
22574 @ @<Declare action procedures for use by |do_statement|@>=
22575 static void mp_do_protection (MP mp) ;
22577 @ @c void mp_do_protection (MP mp) {
22578 int m; /* 0 to unprotect, 1 to protect */
22579 halfword t; /* the |eq_type| before we change it */
22582 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
22584 if ( t>=outer_tag )
22585 eq_type(mp->cur_sym)=t-outer_tag;
22586 } else if ( t<outer_tag ) {
22587 eq_type(mp->cur_sym)=t+outer_tag;
22590 } while (mp->cur_cmd==comma);
22593 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
22594 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
22595 declaration assigns the command code |left_delimiter| to `\.{(}' and
22596 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
22597 hash address of its mate.
22599 @<Cases of |do_statement|...@>=
22600 case delimiters: mp_def_delims(mp); break;
22602 @ @<Declare action procedures for use by |do_statement|@>=
22603 static void mp_def_delims (MP mp) ;
22605 @ @c void mp_def_delims (MP mp) {
22606 pointer l_delim,r_delim; /* the new delimiter pair */
22607 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
22608 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
22609 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
22610 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
22614 @ Here is a procedure that is called when \MP\ has reached a point
22615 where some right delimiter is mandatory.
22618 static void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim);
22621 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
22622 if ( mp->cur_cmd==right_delimiter )
22623 if ( mp->cur_mod==l_delim )
22625 if ( mp->cur_sym!=r_delim ) {
22626 mp_missing_err(mp, str(text(r_delim)));
22628 help2("I found no right delimiter to match a left one. So I've",
22629 "put one in, behind the scenes; this may fix the problem.");
22632 print_err("The token `"); mp_print_text(r_delim);
22633 @.The token...delimiter@>
22634 mp_print(mp, "' is no longer a right delimiter");
22635 help3("Strange: This token has lost its former meaning!",
22636 "I'll read it as a right delimiter this time;",
22637 "but watch out, I'll probably miss it later.");
22642 @ The next four commands save or change the values associated with tokens.
22644 @<Cases of |do_statement|...@>=
22647 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
22648 } while (mp->cur_cmd==comma);
22650 case interim_command: mp_do_interim(mp); break;
22651 case let_command: mp_do_let(mp); break;
22652 case new_internal: mp_do_new_internal(mp); break;
22654 @ @<Declare action procedures for use by |do_statement|@>=
22655 static void mp_do_statement (MP mp);
22656 static void mp_do_interim (MP mp);
22658 @ @c void mp_do_interim (MP mp) {
22660 if ( mp->cur_cmd!=internal_quantity ) {
22661 print_err("The token `");
22662 @.The token...quantity@>
22663 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
22664 else mp_print_text(mp->cur_sym);
22665 mp_print(mp, "' isn't an internal quantity");
22666 help1("Something like `tracingonline' should follow `interim'.");
22669 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
22671 mp_do_statement(mp);
22674 @ The following procedure is careful not to undefine the left-hand symbol
22675 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
22677 @<Declare action procedures for use by |do_statement|@>=
22678 static void mp_do_let (MP mp) ;
22680 @ @c void mp_do_let (MP mp) {
22681 pointer l; /* hash location of the left-hand symbol */
22682 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
22683 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
22684 mp_missing_err(mp, "=");
22686 help3("You should have said `let symbol = something'.",
22687 "But don't worry; I'll pretend that an equals sign",
22688 "was present. The next token I read will be `something'.");
22692 switch (mp->cur_cmd) {
22693 case defined_macro: case secondary_primary_macro:
22694 case tertiary_secondary_macro: case expression_tertiary_macro:
22695 add_mac_ref(mp->cur_mod);
22700 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
22701 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
22702 else equiv(l)=mp->cur_mod;
22706 @ @<Declarations@>=
22707 static void mp_do_new_internal (MP mp) ;
22709 @ @<Internal library ...@>=
22710 void mp_grow_internals (MP mp, int l);
22713 void mp_grow_internals (MP mp, int l) {
22717 if ( hash_end+l>max_halfword ) {
22718 mp_confusion(mp, "out of memory space"); /* can't be reached */
22720 int_name = xmalloc ((l+1),sizeof(char *));
22721 internal = xmalloc ((l+1),sizeof(scaled));
22722 for (k=0;k<=l; k++ ) {
22723 if (k<=mp->max_internal) {
22724 internal[k]=mp->internal[k];
22725 int_name[k]=mp->int_name[k];
22731 xfree(mp->internal); xfree(mp->int_name);
22732 mp->int_name = int_name;
22733 mp->internal = internal;
22734 mp->max_internal = l;
22737 void mp_do_new_internal (MP mp) {
22739 if ( mp->int_ptr==mp->max_internal ) {
22740 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal/4)));
22742 mp_get_clear_symbol(mp); incr(mp->int_ptr);
22743 eq_type(mp->cur_sym)=internal_quantity;
22744 equiv(mp->cur_sym)=mp->int_ptr;
22745 if(mp->int_name[mp->int_ptr]!=NULL)
22746 xfree(mp->int_name[mp->int_ptr]);
22747 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
22748 mp->internal[mp->int_ptr]=0;
22750 } while (mp->cur_cmd==comma);
22753 @ @<Dealloc variables@>=
22754 for (k=0;k<=mp->max_internal;k++) {
22755 xfree(mp->int_name[k]);
22757 xfree(mp->internal);
22758 xfree(mp->int_name);
22761 @ The various `\&{show}' commands are distinguished by modifier fields
22764 @d show_token_code 0 /* show the meaning of a single token */
22765 @d show_stats_code 1 /* show current memory and string usage */
22766 @d show_code 2 /* show a list of expressions */
22767 @d show_var_code 3 /* show a variable and its descendents */
22768 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22771 mp_primitive(mp, "showtoken",show_command,show_token_code);
22772 @:show_token_}{\&{showtoken} primitive@>
22773 mp_primitive(mp, "showstats",show_command,show_stats_code);
22774 @:show_stats_}{\&{showstats} primitive@>
22775 mp_primitive(mp, "show",show_command,show_code);
22776 @:show_}{\&{show} primitive@>
22777 mp_primitive(mp, "showvariable",show_command,show_var_code);
22778 @:show_var_}{\&{showvariable} primitive@>
22779 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22780 @:show_dependencies_}{\&{showdependencies} primitive@>
22782 @ @<Cases of |print_cmd...@>=
22785 case show_token_code:mp_print(mp, "showtoken"); break;
22786 case show_stats_code:mp_print(mp, "showstats"); break;
22787 case show_code:mp_print(mp, "show"); break;
22788 case show_var_code:mp_print(mp, "showvariable"); break;
22789 default: mp_print(mp, "showdependencies"); break;
22793 @ @<Cases of |do_statement|...@>=
22794 case show_command:mp_do_show_whatever(mp); break;
22796 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22797 if it's |show_code|, complicated structures are abbreviated, otherwise
22800 @<Declare action procedures for use by |do_statement|@>=
22801 static void mp_do_show (MP mp) ;
22803 @ @c void mp_do_show (MP mp) {
22805 mp_get_x_next(mp); mp_scan_expression(mp);
22806 mp_print_nl(mp, ">> ");
22808 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22809 } while (mp->cur_cmd==comma);
22812 @ @<Declare action procedures for use by |do_statement|@>=
22813 static void mp_disp_token (MP mp) ;
22815 @ @c void mp_disp_token (MP mp) {
22816 mp_print_nl(mp, "> ");
22818 if ( mp->cur_sym==0 ) {
22819 @<Show a numeric or string or capsule token@>;
22821 mp_print_text(mp->cur_sym); mp_print_char(mp, xord('='));
22822 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22823 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22824 if ( mp->cur_cmd==defined_macro ) {
22825 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22826 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22831 @ @<Show a numeric or string or capsule token@>=
22833 if ( mp->cur_cmd==numeric_token ) {
22834 mp_print_scaled(mp, mp->cur_mod);
22835 } else if ( mp->cur_cmd==capsule_token ) {
22836 mp_print_capsule(mp,mp->cur_mod);
22838 mp_print_char(mp, xord('"'));
22839 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, xord('"'));
22840 delete_str_ref(mp->cur_mod);
22844 @ The following cases of |print_cmd_mod| might arise in connection
22845 with |disp_token|, although they don't necessarily correspond to
22848 @<Cases of |print_cmd_...@>=
22849 case left_delimiter:
22850 case right_delimiter:
22851 if ( c==left_delimiter ) mp_print(mp, "left");
22852 else mp_print(mp, "right");
22853 mp_print(mp, " delimiter that matches ");
22857 if ( m==null ) mp_print(mp, "tag");
22858 else mp_print(mp, "variable");
22860 case defined_macro:
22861 mp_print(mp, "macro:");
22863 case secondary_primary_macro:
22864 case tertiary_secondary_macro:
22865 case expression_tertiary_macro:
22866 mp_print_cmd_mod(mp, macro_def,c);
22867 mp_print(mp, "'d macro:");
22868 mp_print_ln(mp); mp_show_token_list(mp, mp_link(mp_link(m)),null,1000,0);
22871 mp_print(mp, "[repeat the loop]");
22873 case internal_quantity:
22874 mp_print(mp, mp->int_name[m]);
22877 @ @<Declare action procedures for use by |do_statement|@>=
22878 static void mp_do_show_token (MP mp) ;
22880 @ @c void mp_do_show_token (MP mp) {
22882 get_t_next; mp_disp_token(mp);
22884 } while (mp->cur_cmd==comma);
22887 @ @<Declare action procedures for use by |do_statement|@>=
22888 static void mp_do_show_stats (MP mp) ;
22890 @ @c void mp_do_show_stats (MP mp) {
22891 mp_print_nl(mp, "Memory usage ");
22892 @.Memory usage...@>
22893 mp_print_int(mp, mp->var_used); mp_print_char(mp, xord('&')); mp_print_int(mp, mp->dyn_used);
22894 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22895 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22896 mp_print_nl(mp, "String usage ");
22897 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22898 mp_print_char(mp, xord('&')); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22899 mp_print(mp, " (");
22900 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, xord('&'));
22901 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22902 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22906 @ Here's a recursive procedure that gives an abbreviated account
22907 of a variable, for use by |do_show_var|.
22909 @<Declare action procedures for use by |do_statement|@>=
22910 static void mp_disp_var (MP mp,pointer p) ;
22912 @ @c void mp_disp_var (MP mp,pointer p) {
22913 pointer q; /* traverses attributes and subscripts */
22914 int n; /* amount of macro text to show */
22915 if ( mp_type(p)==mp_structured ) {
22916 @<Descend the structure@>;
22917 } else if ( mp_type(p)>=mp_unsuffixed_macro ) {
22918 @<Display a variable macro@>;
22919 } else if ( mp_type(p)!=undefined ){
22920 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22921 mp_print_char(mp, xord('='));
22922 mp_print_exp(mp, p,0);
22926 @ @<Descend the structure@>=
22929 do { mp_disp_var(mp, q); q=mp_link(q); } while (q!=end_attr);
22931 while ( mp_name_type(q)==mp_subscr ) {
22932 mp_disp_var(mp, q); q=mp_link(q);
22936 @ @<Display a variable macro@>=
22938 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22939 if ( mp_type(p)>mp_unsuffixed_macro )
22940 mp_print(mp, "@@#"); /* |suffixed_macro| */
22941 mp_print(mp, "=macro:");
22942 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22943 else n=mp->max_print_line-mp->file_offset-15;
22944 mp_show_macro(mp, value(p),null,n);
22947 @ @<Declare action procedures for use by |do_statement|@>=
22948 static void mp_do_show_var (MP mp) ;
22950 @ @c void mp_do_show_var (MP mp) {
22953 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22954 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22955 mp_disp_var(mp, mp->cur_mod); goto DONE;
22960 } while (mp->cur_cmd==comma);
22963 @ @<Declare action procedures for use by |do_statement|@>=
22964 static void mp_do_show_dependencies (MP mp) ;
22966 @ @c void mp_do_show_dependencies (MP mp) {
22967 pointer p; /* link that runs through all dependencies */
22968 p=mp_link(dep_head);
22969 while ( p!=dep_head ) {
22970 if ( mp_interesting(mp, p) ) {
22971 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22972 if ( mp_type(p)==mp_dependent ) mp_print_char(mp, xord('='));
22973 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22974 mp_print_dependency(mp, dep_list(p),mp_type(p));
22977 while ( mp_info(p)!=null ) p=mp_link(p);
22983 @ Finally we are ready for the procedure that governs all of the
22986 @<Declare action procedures for use by |do_statement|@>=
22987 static void mp_do_show_whatever (MP mp) ;
22989 @ @c void mp_do_show_whatever (MP mp) {
22990 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
22991 switch (mp->cur_mod) {
22992 case show_token_code:mp_do_show_token(mp); break;
22993 case show_stats_code:mp_do_show_stats(mp); break;
22994 case show_code:mp_do_show(mp); break;
22995 case show_var_code:mp_do_show_var(mp); break;
22996 case show_dependencies_code:mp_do_show_dependencies(mp); break;
22997 } /* there are no other cases */
22998 if ( mp->internal[mp_showstopping]>0 ){
23001 if ( mp->interaction<mp_error_stop_mode ) {
23002 help0; decr(mp->error_count);
23004 help1("This isn't an error message; I'm just showing something.");
23006 if ( mp->cur_cmd==semicolon ) mp_error(mp);
23007 else mp_put_get_error(mp);
23011 @ The `\&{addto}' command needs the following additional primitives:
23013 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
23014 @d contour_code 1 /* command modifier for `\&{contour}' */
23015 @d also_code 2 /* command modifier for `\&{also}' */
23017 @ Pre and postscripts need two new identifiers:
23019 @d with_mp_pre_script 11
23020 @d with_mp_post_script 13
23023 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
23024 @:double_path_}{\&{doublepath} primitive@>
23025 mp_primitive(mp, "contour",thing_to_add,contour_code);
23026 @:contour_}{\&{contour} primitive@>
23027 mp_primitive(mp, "also",thing_to_add,also_code);
23028 @:also_}{\&{also} primitive@>
23029 mp_primitive(mp, "withpen",with_option,mp_pen_type);
23030 @:with_pen_}{\&{withpen} primitive@>
23031 mp_primitive(mp, "dashed",with_option,mp_picture_type);
23032 @:dashed_}{\&{dashed} primitive@>
23033 mp_primitive(mp, "withprescript",with_option,with_mp_pre_script);
23034 @:with_mp_pre_script_}{\&{withprescript} primitive@>
23035 mp_primitive(mp, "withpostscript",with_option,with_mp_post_script);
23036 @:with_mp_post_script_}{\&{withpostscript} primitive@>
23037 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
23038 @:with_color_}{\&{withoutcolor} primitive@>
23039 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
23040 @:with_color_}{\&{withgreyscale} primitive@>
23041 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
23042 @:with_color_}{\&{withcolor} primitive@>
23043 /* \&{withrgbcolor} is an alias for \&{withcolor} */
23044 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
23045 @:with_color_}{\&{withrgbcolor} primitive@>
23046 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
23047 @:with_color_}{\&{withcmykcolor} primitive@>
23049 @ @<Cases of |print_cmd...@>=
23051 if ( m==contour_code ) mp_print(mp, "contour");
23052 else if ( m==double_path_code ) mp_print(mp, "doublepath");
23053 else mp_print(mp, "also");
23056 if ( m==mp_pen_type ) mp_print(mp, "withpen");
23057 else if ( m==with_mp_pre_script ) mp_print(mp, "withprescript");
23058 else if ( m==with_mp_post_script ) mp_print(mp, "withpostscript");
23059 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
23060 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
23061 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
23062 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
23063 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
23064 else mp_print(mp, "dashed");
23067 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
23068 updates the list of graphical objects starting at |p|. Each $\langle$with
23069 clause$\rangle$ updates all graphical objects whose |type| is compatible.
23070 Other objects are ignored.
23072 @<Declare action procedures for use by |do_statement|@>=
23073 static void mp_scan_with_list (MP mp,pointer p) ;
23075 @ @c void mp_scan_with_list (MP mp,pointer p) {
23076 quarterword t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
23077 pointer q; /* for list manipulation */
23078 unsigned old_setting; /* saved |selector| setting */
23079 pointer k; /* for finding the near-last item in a list */
23080 str_number s; /* for string cleanup after combining */
23081 pointer cp,pp,dp,ap,bp;
23082 /* objects being updated; |void| initially; |null| to suppress update */
23083 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
23085 while ( mp->cur_cmd==with_option ){
23088 if ( t!=mp_no_model ) mp_scan_expression(mp);
23089 if (((t==with_mp_pre_script)&&(mp->cur_type!=mp_string_type))||
23090 ((t==with_mp_post_script)&&(mp->cur_type!=mp_string_type))||
23091 ((t==mp_uninitialized_model)&&
23092 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
23093 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
23094 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
23095 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
23096 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
23097 ((t==mp_pen_type)&&(mp->cur_type!=t))||
23098 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
23099 @<Complain about improper type@>;
23100 } else if ( t==mp_uninitialized_model ) {
23101 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23103 @<Transfer a color from the current expression to object~|cp|@>;
23104 mp_flush_cur_exp(mp, 0);
23105 } else if ( t==mp_rgb_model ) {
23106 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23108 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
23109 mp_flush_cur_exp(mp, 0);
23110 } else if ( t==mp_cmyk_model ) {
23111 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23113 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
23114 mp_flush_cur_exp(mp, 0);
23115 } else if ( t==mp_grey_model ) {
23116 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23118 @<Transfer a greyscale from the current expression to object~|cp|@>;
23119 mp_flush_cur_exp(mp, 0);
23120 } else if ( t==mp_no_model ) {
23121 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23123 @<Transfer a noncolor from the current expression to object~|cp|@>;
23124 } else if ( t==mp_pen_type ) {
23125 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
23127 if ( mp_pen_p(pp)!=null ) mp_toss_knot_list(mp, mp_pen_p(pp));
23128 mp_pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
23130 } else if ( t==with_mp_pre_script ) {
23133 while ( (ap!=null)&&(! has_color(ap)) )
23136 if ( mp_pre_script(ap)!=null ) { /* build a new,combined string */
23137 s=mp_pre_script(ap);
23138 old_setting=mp->selector;
23139 mp->selector=new_string;
23140 str_room(length(mp_pre_script(ap))+length(mp->cur_exp)+2);
23141 mp_print_str(mp, mp->cur_exp);
23142 append_char(13); /* a forced \ps\ newline */
23143 mp_print_str(mp, mp_pre_script(ap));
23144 mp_pre_script(ap)=mp_make_string(mp);
23146 mp->selector=old_setting;
23148 mp_pre_script(ap)=mp->cur_exp;
23150 mp->cur_type=mp_vacuous;
23152 } else if ( t==with_mp_post_script ) {
23156 while ( mp_link(k)!=null ) {
23158 if ( has_color(k) ) bp=k;
23161 if ( mp_post_script(bp)!=null ) {
23162 s=mp_post_script(bp);
23163 old_setting=mp->selector;
23164 mp->selector=new_string;
23165 str_room(length(mp_post_script(bp))+length(mp->cur_exp)+2);
23166 mp_print_str(mp, mp_post_script(bp));
23167 append_char(13); /* a forced \ps\ newline */
23168 mp_print_str(mp, mp->cur_exp);
23169 mp_post_script(bp)=mp_make_string(mp);
23171 mp->selector=old_setting;
23173 mp_post_script(bp)=mp->cur_exp;
23175 mp->cur_type=mp_vacuous;
23178 if ( dp==mp_void ) {
23179 @<Make |dp| a stroked node in list~|p|@>;
23182 if ( mp_dash_p(dp)!=null ) delete_edge_ref(mp_dash_p(dp));
23183 mp_dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
23184 dash_scale(dp)=unity;
23185 mp->cur_type=mp_vacuous;
23189 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
23193 @ @<Complain about improper type@>=
23194 { exp_err("Improper type");
23196 help2("Next time say `withpen <known pen expression>';",
23197 "I'll ignore the bad `with' clause and look for another.");
23198 if ( t==with_mp_pre_script )
23199 mp->help_line[1]="Next time say `withprescript <known string expression>';";
23200 else if ( t==with_mp_post_script )
23201 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
23202 else if ( t==mp_picture_type )
23203 mp->help_line[1]="Next time say `dashed <known picture expression>';";
23204 else if ( t==mp_uninitialized_model )
23205 mp->help_line[1]="Next time say `withcolor <known color expression>';";
23206 else if ( t==mp_rgb_model )
23207 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
23208 else if ( t==mp_cmyk_model )
23209 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
23210 else if ( t==mp_grey_model )
23211 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
23212 mp_put_get_flush_error(mp, 0);
23215 @ Forcing the color to be between |0| and |unity| here guarantees that no
23216 picture will ever contain a color outside the legal range for \ps\ graphics.
23218 @<Transfer a color from the current expression to object~|cp|@>=
23219 { if ( mp->cur_type==mp_color_type )
23220 @<Transfer a rgbcolor from the current expression to object~|cp|@>
23221 else if ( mp->cur_type==mp_cmykcolor_type )
23222 @<Transfer a cmykcolor from the current expression to object~|cp|@>
23223 else if ( mp->cur_type==mp_known )
23224 @<Transfer a greyscale from the current expression to object~|cp|@>
23225 else if ( mp->cur_exp==false_code )
23226 @<Transfer a noncolor from the current expression to object~|cp|@>;
23229 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
23230 { q=value(mp->cur_exp);
23235 red_val(cp)=value(red_part_loc(q));
23236 green_val(cp)=value(green_part_loc(q));
23237 blue_val(cp)=value(blue_part_loc(q));
23238 mp_color_model(cp)=mp_rgb_model;
23239 if ( red_val(cp)<0 ) red_val(cp)=0;
23240 if ( green_val(cp)<0 ) green_val(cp)=0;
23241 if ( blue_val(cp)<0 ) blue_val(cp)=0;
23242 if ( red_val(cp)>unity ) red_val(cp)=unity;
23243 if ( green_val(cp)>unity ) green_val(cp)=unity;
23244 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
23247 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
23248 { q=value(mp->cur_exp);
23249 cyan_val(cp)=value(cyan_part_loc(q));
23250 magenta_val(cp)=value(magenta_part_loc(q));
23251 yellow_val(cp)=value(yellow_part_loc(q));
23252 black_val(cp)=value(black_part_loc(q));
23253 mp_color_model(cp)=mp_cmyk_model;
23254 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
23255 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
23256 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
23257 if ( black_val(cp)<0 ) black_val(cp)=0;
23258 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
23259 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
23260 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
23261 if ( black_val(cp)>unity ) black_val(cp)=unity;
23264 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
23271 mp_color_model(cp)=mp_grey_model;
23272 if ( grey_val(cp)<0 ) grey_val(cp)=0;
23273 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
23276 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
23283 mp_color_model(cp)=mp_no_model;
23286 @ @<Make |cp| a colored object in object list~|p|@>=
23288 while ( cp!=null ){
23289 if ( has_color(cp) ) break;
23294 @ @<Make |pp| an object in list~|p| that needs a pen@>=
23296 while ( pp!=null ) {
23297 if ( has_pen(pp) ) break;
23302 @ @<Make |dp| a stroked node in list~|p|@>=
23304 while ( dp!=null ) {
23305 if ( mp_type(dp)==mp_stroked_code ) break;
23310 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
23311 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
23312 if ( pp>mp_void ) {
23313 @<Copy |mp_pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
23315 if ( dp>mp_void ) {
23316 @<Make stroked nodes linked to |dp| refer to |mp_dash_p(dp)|@>;
23320 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
23322 while ( q!=null ) {
23323 if ( has_color(q) ) {
23324 red_val(q)=red_val(cp);
23325 green_val(q)=green_val(cp);
23326 blue_val(q)=blue_val(cp);
23327 black_val(q)=black_val(cp);
23328 mp_color_model(q)=mp_color_model(cp);
23334 @ @<Copy |mp_pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
23336 while ( q!=null ) {
23337 if ( has_pen(q) ) {
23338 if ( mp_pen_p(q)!=null ) mp_toss_knot_list(mp, mp_pen_p(q));
23339 mp_pen_p(q)=copy_pen(mp_pen_p(pp));
23345 @ @<Make stroked nodes linked to |dp| refer to |mp_dash_p(dp)|@>=
23347 while ( q!=null ) {
23348 if ( mp_type(q)==mp_stroked_code ) {
23349 if ( mp_dash_p(q)!=null ) delete_edge_ref(mp_dash_p(q));
23350 mp_dash_p(q)=mp_dash_p(dp);
23351 dash_scale(q)=unity;
23352 if ( mp_dash_p(q)!=null ) add_edge_ref(mp_dash_p(q));
23358 @ One of the things we need to do when we've parsed an \&{addto} or
23359 similar command is find the header of a supposed \&{picture} variable, given
23360 a token list for that variable. Since the edge structure is about to be
23361 updated, we use |private_edges| to make sure that this is possible.
23363 @<Declare action procedures for use by |do_statement|@>=
23364 static pointer mp_find_edges_var (MP mp, pointer t) ;
23366 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
23368 pointer cur_edges; /* the return value */
23369 p=mp_find_variable(mp, t); cur_edges=null;
23371 mp_obliterated(mp, t); mp_put_get_error(mp);
23372 } else if ( mp_type(p)!=mp_picture_type ) {
23373 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
23374 @.Variable x is the wrong type@>
23375 mp_print(mp, " is the wrong type (");
23376 mp_print_type(mp, mp_type(p)); mp_print_char(mp, xord(')'));
23377 help2("I was looking for a \"known\" picture variable.",
23378 "So I'll not change anything just now.");
23379 mp_put_get_error(mp);
23381 value(p)=mp_private_edges(mp, value(p));
23382 cur_edges=value(p);
23384 mp_flush_node_list(mp, t);
23388 @ @<Cases of |do_statement|...@>=
23389 case add_to_command: mp_do_add_to(mp); break;
23390 case bounds_command:mp_do_bounds(mp); break;
23393 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
23394 @:clip_}{\&{clip} primitive@>
23395 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
23396 @:set_bounds_}{\&{setbounds} primitive@>
23398 @ @<Cases of |print_cmd...@>=
23399 case bounds_command:
23400 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
23401 else mp_print(mp, "setbounds");
23404 @ The following function parses the beginning of an \&{addto} or \&{clip}
23405 command: it expects a variable name followed by a token with |cur_cmd=sep|
23406 and then an expression. The function returns the token list for the variable
23407 and stores the command modifier for the separator token in the global variable
23408 |last_add_type|. We must be careful because this variable might get overwritten
23409 any time we call |get_x_next|.
23412 quarterword last_add_type;
23413 /* command modifier that identifies the last \&{addto} command */
23415 @ @<Declare action procedures for use by |do_statement|@>=
23416 static pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
23418 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
23419 pointer lhv; /* variable to add to left */
23420 quarterword add_type=0; /* value to be returned in |last_add_type| */
23422 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
23423 if ( mp->cur_type!=mp_token_list ) {
23424 @<Abandon edges command because there's no variable@>;
23426 lhv=mp->cur_exp; add_type=mp->cur_mod;
23427 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
23429 mp->last_add_type=add_type;
23433 @ @<Abandon edges command because there's no variable@>=
23434 { exp_err("Not a suitable variable");
23435 @.Not a suitable variable@>
23436 help4("At this point I needed to see the name of a picture variable.",
23437 "(Or perhaps you have indeed presented me with one; I might",
23438 "have missed it, if it wasn't followed by the proper token.)",
23439 "So I'll not change anything just now.");
23440 mp_put_get_flush_error(mp, 0);
23443 @ Here is an example of how to use |start_draw_cmd|.
23445 @<Declare action procedures for use by |do_statement|@>=
23446 static void mp_do_bounds (MP mp) ;
23448 @ @c void mp_do_bounds (MP mp) {
23449 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23450 pointer p; /* for list manipulation */
23451 integer m; /* initial value of |cur_mod| */
23453 lhv=mp_start_draw_cmd(mp, to_token);
23455 lhe=mp_find_edges_var(mp, lhv);
23457 mp_flush_cur_exp(mp, 0);
23458 } else if ( mp->cur_type!=mp_path_type ) {
23459 exp_err("Improper `clip'");
23460 @.Improper `addto'@>
23461 help2("This expression should have specified a known path.",
23462 "So I'll not change anything just now.");
23463 mp_put_get_flush_error(mp, 0);
23464 } else if ( mp_left_type(mp->cur_exp)==mp_endpoint ) {
23465 @<Complain about a non-cycle@>;
23467 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
23472 @ @<Complain about a non-cycle@>=
23473 { print_err("Not a cycle");
23475 help2("That contour should have ended with `..cycle' or `&cycle'.",
23476 "So I'll not change anything just now."); mp_put_get_error(mp);
23479 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
23480 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
23481 mp_link(p)=mp_link(dummy_loc(lhe));
23482 mp_link(dummy_loc(lhe))=p;
23483 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
23484 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
23485 mp_type(p)=stop_type(m);
23486 mp_link(obj_tail(lhe))=p;
23488 mp_init_bbox(mp, lhe);
23491 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
23492 cases to deal with.
23494 @<Declare action procedures for use by |do_statement|@>=
23495 static void mp_do_add_to (MP mp) ;
23497 @ @c void mp_do_add_to (MP mp) {
23498 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23499 pointer p; /* the graphical object or list for |scan_with_list| to update */
23500 pointer e; /* an edge structure to be merged */
23501 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
23502 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
23504 if ( add_type==also_code ) {
23505 @<Make sure the current expression is a suitable picture and set |e| and |p|
23508 @<Create a graphical object |p| based on |add_type| and the current
23511 mp_scan_with_list(mp, p);
23512 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
23516 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
23517 setting |e:=null| prevents anything from being added to |lhe|.
23519 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
23522 if ( mp->cur_type!=mp_picture_type ) {
23523 exp_err("Improper `addto'");
23524 @.Improper `addto'@>
23525 help2("This expression should have specified a known picture.",
23526 "So I'll not change anything just now.");
23527 mp_put_get_flush_error(mp, 0);
23529 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
23530 p=mp_link(dummy_loc(e));
23534 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
23535 attempts to add to the edge structure.
23537 @<Create a graphical object |p| based on |add_type| and the current...@>=
23539 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
23540 if ( mp->cur_type!=mp_path_type ) {
23541 exp_err("Improper `addto'");
23542 @.Improper `addto'@>
23543 help2("This expression should have specified a known path.",
23544 "So I'll not change anything just now.");
23545 mp_put_get_flush_error(mp, 0);
23546 } else if ( add_type==contour_code ) {
23547 if ( mp_left_type(mp->cur_exp)==mp_endpoint ) {
23548 @<Complain about a non-cycle@>;
23550 p=mp_new_fill_node(mp, mp->cur_exp);
23551 mp->cur_type=mp_vacuous;
23554 p=mp_new_stroked_node(mp, mp->cur_exp);
23555 mp->cur_type=mp_vacuous;
23559 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
23560 lhe=mp_find_edges_var(mp, lhv);
23562 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
23563 if ( e!=null ) delete_edge_ref(e);
23564 } else if ( add_type==also_code ) {
23566 @<Merge |e| into |lhe| and delete |e|@>;
23570 } else if ( p!=null ) {
23571 mp_link(obj_tail(lhe))=p;
23573 if ( add_type==double_path_code )
23574 if ( mp_pen_p(p)==null )
23575 mp_pen_p(p)=mp_get_pen_circle(mp, 0);
23578 @ @<Merge |e| into |lhe| and delete |e|@>=
23579 { if ( mp_link(dummy_loc(e))!=null ) {
23580 mp_link(obj_tail(lhe))=mp_link(dummy_loc(e));
23581 obj_tail(lhe)=obj_tail(e);
23582 obj_tail(e)=dummy_loc(e);
23583 mp_link(dummy_loc(e))=null;
23584 mp_flush_dash_list(mp, lhe);
23586 mp_toss_edges(mp, e);
23589 @ @<Cases of |do_statement|...@>=
23590 case ship_out_command: mp_do_ship_out(mp); break;
23592 @ @<Declare action procedures for use by |do_statement|@>=
23593 @<Declare the \ps\ output procedures@>
23594 static void mp_do_ship_out (MP mp) ;
23596 @ @c void mp_do_ship_out (MP mp) {
23597 integer c; /* the character code */
23598 mp_get_x_next(mp); mp_scan_expression(mp);
23599 if ( mp->cur_type!=mp_picture_type ) {
23600 @<Complain that it's not a known picture@>;
23602 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
23603 if ( c<0 ) c=c+256;
23604 @<Store the width information for character code~|c|@>;
23605 mp_ship_out(mp, mp->cur_exp);
23606 mp_flush_cur_exp(mp, 0);
23610 @ @<Complain that it's not a known picture@>=
23612 exp_err("Not a known picture");
23613 help1("I can only output known pictures.");
23614 mp_put_get_flush_error(mp, 0);
23617 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
23620 @<Cases of |do_statement|...@>=
23621 case every_job_command:
23622 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
23626 halfword start_sym; /* a symbolic token to insert at beginning of job */
23631 @ Finally, we have only the ``message'' commands remaining.
23634 @d err_message_code 1
23636 @d filename_template_code 3
23637 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
23638 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
23640 mp->pool_ptr = mp->pool_ptr - g;
23642 mp_print_char(mp, xord('0'));
23645 mp_print_int(mp, (A));
23650 mp_primitive(mp, "message",message_command,message_code);
23651 @:message_}{\&{message} primitive@>
23652 mp_primitive(mp, "errmessage",message_command,err_message_code);
23653 @:err_message_}{\&{errmessage} primitive@>
23654 mp_primitive(mp, "errhelp",message_command,err_help_code);
23655 @:err_help_}{\&{errhelp} primitive@>
23656 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
23657 @:filename_template_}{\&{filenametemplate} primitive@>
23659 @ @<Cases of |print_cmd...@>=
23660 case message_command:
23661 if ( m<err_message_code ) mp_print(mp, "message");
23662 else if ( m==err_message_code ) mp_print(mp, "errmessage");
23663 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
23664 else mp_print(mp, "errhelp");
23667 @ @<Cases of |do_statement|...@>=
23668 case message_command: mp_do_message(mp); break;
23670 @ @<Declare action procedures for use by |do_statement|@>=
23671 @<Declare a procedure called |no_string_err|@>
23672 static void mp_do_message (MP mp) ;
23675 @c void mp_do_message (MP mp) {
23676 int m; /* the type of message */
23677 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
23678 if ( mp->cur_type!=mp_string_type )
23679 mp_no_string_err(mp, "A message should be a known string expression.");
23683 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
23685 case err_message_code:
23686 @<Print string |cur_exp| as an error message@>;
23688 case err_help_code:
23689 @<Save string |cur_exp| as the |err_help|@>;
23691 case filename_template_code:
23692 @<Save the filename template@>;
23694 } /* there are no other cases */
23696 mp_flush_cur_exp(mp, 0);
23699 @ @<Declare a procedure called |no_string_err|@>=
23700 static void mp_no_string_err (MP mp, const char *s) {
23701 exp_err("Not a string");
23704 mp_put_get_error(mp);
23707 @ The global variable |err_help| is zero when the user has most recently
23708 given an empty help string, or if none has ever been given.
23710 @<Save string |cur_exp| as the |err_help|@>=
23712 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
23713 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
23714 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
23717 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
23718 \&{errhelp}, we don't want to give a long help message each time. So we
23719 give a verbose explanation only once.
23722 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
23724 @ @<Set init...@>=mp->long_help_seen=false;
23726 @ @<Print string |cur_exp| as an error message@>=
23728 print_err(""); mp_print_str(mp, mp->cur_exp);
23729 if ( mp->err_help!=0 ) {
23730 mp->use_err_help=true;
23731 } else if ( mp->long_help_seen ) {
23732 help1("(That was another `errmessage'.)") ;
23734 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
23735 help4("This error message was generated by an `errmessage'",
23736 "command, so I can\'t give any explicit help.",
23737 "Pretend that you're Miss Marple: Examine all clues,",
23739 "and deduce the truth by inspired guesses.");
23741 mp_put_get_error(mp); mp->use_err_help=false;
23744 @ @<Cases of |do_statement|...@>=
23745 case write_command: mp_do_write(mp); break;
23747 @ @<Declare action procedures for use by |do_statement|@>=
23748 static void mp_do_write (MP mp) ;
23750 @ @c void mp_do_write (MP mp) {
23751 str_number t; /* the line of text to be written */
23752 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
23753 unsigned old_setting; /* for saving |selector| during output */
23755 mp_scan_expression(mp);
23756 if ( mp->cur_type!=mp_string_type ) {
23757 mp_no_string_err(mp, "The text to be written should be a known string expression");
23758 } else if ( mp->cur_cmd!=to_token ) {
23759 print_err("Missing `to' clause");
23760 help1("A write command should end with `to <filename>'");
23761 mp_put_get_error(mp);
23763 t=mp->cur_exp; mp->cur_type=mp_vacuous;
23765 mp_scan_expression(mp);
23766 if ( mp->cur_type!=mp_string_type )
23767 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23769 @<Write |t| to the file named by |cur_exp|@>;
23773 mp_flush_cur_exp(mp, 0);
23776 @ @<Write |t| to the file named by |cur_exp|@>=
23778 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23779 |cur_exp| must be inserted@>;
23780 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23781 @<Record the end of file on |wr_file[n]|@>;
23783 old_setting=mp->selector;
23784 mp->selector=n+write_file;
23785 mp_print_str(mp, t); mp_print_ln(mp);
23786 mp->selector = old_setting;
23790 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23792 char *fn = str(mp->cur_exp);
23794 n0=mp->write_files;
23795 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23796 if ( n==0 ) { /* bottom reached */
23797 if ( n0==mp->write_files ) {
23798 if ( mp->write_files<mp->max_write_files ) {
23799 incr(mp->write_files);
23804 l = mp->max_write_files + (mp->max_write_files/4);
23805 wr_file = xmalloc((l+1),sizeof(void *));
23806 wr_fname = xmalloc((l+1),sizeof(char *));
23807 for (k=0;k<=l;k++) {
23808 if (k<=mp->max_write_files) {
23809 wr_file[k]=mp->wr_file[k];
23810 wr_fname[k]=mp->wr_fname[k];
23816 xfree(mp->wr_file); xfree(mp->wr_fname);
23817 mp->max_write_files = l;
23818 mp->wr_file = wr_file;
23819 mp->wr_fname = wr_fname;
23823 mp_open_write_file(mp, fn ,n);
23826 if ( mp->wr_fname[n]==NULL ) n0=n;
23831 @ @<Record the end of file on |wr_file[n]|@>=
23832 { (mp->close_file)(mp,mp->wr_file[n]);
23833 xfree(mp->wr_fname[n]);
23834 if ( n==mp->write_files-1 ) mp->write_files=n;
23838 @* \[42] Writing font metric data.
23839 \TeX\ gets its knowledge about fonts from font metric files, also called
23840 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23841 but other programs know about them too. One of \MP's duties is to
23842 write \.{TFM} files so that the user's fonts can readily be
23843 applied to typesetting.
23844 @:TFM files}{\.{TFM} files@>
23845 @^font metric files@>
23847 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23848 Since the number of bytes is always a multiple of~4, we could
23849 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23850 byte interpretation. The format of \.{TFM} files was designed by
23851 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23852 @^Ramshaw, Lyle Harold@>
23853 of information in a compact but useful form.
23856 void * tfm_file; /* the font metric output goes here */
23857 char * metric_file_name; /* full name of the font metric file */
23859 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23860 integers that give the lengths of the various subsequent portions
23861 of the file. These twelve integers are, in order:
23862 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23863 |lf|&length of the entire file, in words;\cr
23864 |lh|&length of the header data, in words;\cr
23865 |bc|&smallest character code in the font;\cr
23866 |ec|&largest character code in the font;\cr
23867 |nw|&number of words in the width table;\cr
23868 |nh|&number of words in the height table;\cr
23869 |nd|&number of words in the depth table;\cr
23870 |ni|&number of words in the italic correction table;\cr
23871 |nl|&number of words in the lig/kern table;\cr
23872 |nk|&number of words in the kern table;\cr
23873 |ne|&number of words in the extensible character table;\cr
23874 |np|&number of font parameter words.\cr}}$$
23875 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23877 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23878 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23879 and as few as 0 characters (if |bc=ec+1|).
23881 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23882 16 or more bits, the most significant bytes appear first in the file.
23883 This is called BigEndian order.
23884 @^BigEndian order@>
23886 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23889 The most important data type used here is a |fix_word|, which is
23890 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23891 quantity, with the two's complement of the entire word used to represent
23892 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23893 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23894 the smallest is $-2048$. We will see below, however, that all but two of
23895 the |fix_word| values must lie between $-16$ and $+16$.
23897 @ The first data array is a block of header information, which contains
23898 general facts about the font. The header must contain at least two words,
23899 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23900 header information of use to other software routines might also be
23901 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23902 For example, 16 more words of header information are in use at the Xerox
23903 Palo Alto Research Center; the first ten specify the character coding
23904 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23905 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23906 last gives the ``face byte.''
23908 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23909 the \.{GF} output file. This helps ensure consistency between files,
23910 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23911 should match the check sums on actual fonts that are used. The actual
23912 relation between this check sum and the rest of the \.{TFM} file is not
23913 important; the check sum is simply an identification number with the
23914 property that incompatible fonts almost always have distinct check sums.
23917 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23918 font, in units of \TeX\ points. This number must be at least 1.0; it is
23919 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23920 font, i.e., a font that was designed to look best at a 10-point size,
23921 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23922 $\delta$ \.{pt}', the effect is to override the design size and replace it
23923 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23924 the font image by a factor of $\delta$ divided by the design size. {\sl
23925 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23926 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23927 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23928 since many fonts have a design size equal to one em. The other dimensions
23929 must be less than 16 design-size units in absolute value; thus,
23930 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23931 \.{TFM} file whose first byte might be something besides 0 or 255.
23934 @ Next comes the |char_info| array, which contains one |char_info_word|
23935 per character. Each word in this part of the file contains six fields
23936 packed into four bytes as follows.
23938 \yskip\hang first byte: |width_index| (8 bits)\par
23939 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23941 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23943 \hang fourth byte: |remainder| (8 bits)\par
23945 The actual width of a character is \\{width}|[width_index]|, in design-size
23946 units; this is a device for compressing information, since many characters
23947 have the same width. Since it is quite common for many characters
23948 to have the same height, depth, or italic correction, the \.{TFM} format
23949 imposes a limit of 16 different heights, 16 different depths, and
23950 64 different italic corrections.
23952 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23953 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23954 value of zero. The |width_index| should never be zero unless the
23955 character does not exist in the font, since a character is valid if and
23956 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23958 @ The |tag| field in a |char_info_word| has four values that explain how to
23959 interpret the |remainder| field.
23961 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23962 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23963 program starting at location |remainder| in the |lig_kern| array.\par
23964 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23965 characters of ascending sizes, and not the largest in the chain. The
23966 |remainder| field gives the character code of the next larger character.\par
23967 \hang|tag=3| (|ext_tag|) means that this character code represents an
23968 extensible character, i.e., a character that is built up of smaller pieces
23969 so that it can be made arbitrarily large. The pieces are specified in
23970 |exten[remainder]|.\par
23972 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23973 unless they are used in special circumstances in math formulas. For example,
23974 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23975 operation looks for both |list_tag| and |ext_tag|.
23977 @d no_tag 0 /* vanilla character */
23978 @d lig_tag 1 /* character has a ligature/kerning program */
23979 @d list_tag 2 /* character has a successor in a charlist */
23980 @d ext_tag 3 /* character is extensible */
23982 @ The |lig_kern| array contains instructions in a simple programming language
23983 that explains what to do for special letter pairs. Each word in this array is a
23984 |lig_kern_command| of four bytes.
23986 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23987 step if the byte is 128 or more, otherwise the next step is obtained by
23988 skipping this number of intervening steps.\par
23989 \hang second byte: |next_char|, ``if |next_char| follows the current character,
23990 then perform the operation and stop, otherwise continue.''\par
23991 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
23992 a kern step otherwise.\par
23993 \hang fourth byte: |remainder|.\par
23996 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
23997 between the current character and |next_char|. This amount is
23998 often negative, so that the characters are brought closer together
23999 by kerning; but it might be positive.
24001 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
24002 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
24003 |remainder| is inserted between the current character and |next_char|;
24004 then the current character is deleted if $b=0$, and |next_char| is
24005 deleted if $c=0$; then we pass over $a$~characters to reach the next
24006 current character (which may have a ligature/kerning program of its own).
24008 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
24009 the |next_char| byte is the so-called right boundary character of this font;
24010 the value of |next_char| need not lie between |bc| and~|ec|.
24011 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
24012 there is a special ligature/kerning program for a left boundary character,
24013 beginning at location |256*op_byte+remainder|.
24014 The interpretation is that \TeX\ puts implicit boundary characters
24015 before and after each consecutive string of characters from the same font.
24016 These implicit characters do not appear in the output, but they can affect
24017 ligatures and kerning.
24019 If the very first instruction of a character's |lig_kern| program has
24020 |skip_byte>128|, the program actually begins in location
24021 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
24022 arrays, because the first instruction must otherwise
24023 appear in a location |<=255|.
24025 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
24027 $$\hbox{|256*op_byte+remainder<nl|.}$$
24028 If such an instruction is encountered during
24029 normal program execution, it denotes an unconditional halt; no ligature
24030 command is performed.
24033 /* value indicating `\.{STOP}' in a lig/kern program */
24034 @d kern_flag (128) /* op code for a kern step */
24035 @d skip_byte(A) mp->lig_kern[(A)].b0
24036 @d next_char(A) mp->lig_kern[(A)].b1
24037 @d op_byte(A) mp->lig_kern[(A)].b2
24038 @d rem_byte(A) mp->lig_kern[(A)].b3
24040 @ Extensible characters are specified by an |extensible_recipe|, which
24041 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
24042 order). These bytes are the character codes of individual pieces used to
24043 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
24044 present in the built-up result. For example, an extensible vertical line is
24045 like an extensible bracket, except that the top and bottom pieces are missing.
24047 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
24048 if the piece isn't present. Then the extensible characters have the form
24049 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
24050 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
24051 The width of the extensible character is the width of $R$; and the
24052 height-plus-depth is the sum of the individual height-plus-depths of the
24053 components used, since the pieces are butted together in a vertical list.
24055 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
24056 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
24057 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
24058 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
24060 @ The final portion of a \.{TFM} file is the |param| array, which is another
24061 sequence of |fix_word| values.
24063 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
24064 to help position accents. For example, |slant=.25| means that when you go
24065 up one unit, you also go .25 units to the right. The |slant| is a pure
24066 number; it is the only |fix_word| other than the design size itself that is
24067 not scaled by the design size.
24070 \hang|param[2]=space| is the normal spacing between words in text.
24071 Note that character 040 in the font need not have anything to do with
24074 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
24076 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
24078 \hang|param[5]=x_height| is the size of one ex in the font; it is also
24079 the height of letters for which accents don't have to be raised or lowered.
24081 \hang|param[6]=quad| is the size of one em in the font.
24083 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
24087 If fewer than seven parameters are present, \TeX\ sets the missing parameters
24092 @d space_stretch_code 3
24093 @d space_shrink_code 4
24096 @d extra_space_code 7
24098 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
24099 information, and it does this all at once at the end of a job.
24100 In order to prepare for such frenetic activity, it squirrels away the
24101 necessary facts in various arrays as information becomes available.
24103 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
24104 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
24105 |tfm_ital_corr|. Other information about a character (e.g., about
24106 its ligatures or successors) is accessible via the |char_tag| and
24107 |char_remainder| arrays. Other information about the font as a whole
24108 is kept in additional arrays called |header_byte|, |lig_kern|,
24109 |kern|, |exten|, and |param|.
24111 @d max_tfm_int 32510
24112 @d undefined_label max_tfm_int /* an undefined local label */
24115 #define TFM_ITEMS 257
24117 eight_bits ec; /* smallest and largest character codes shipped out */
24118 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
24119 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
24120 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
24121 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
24122 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
24123 int char_tag[TFM_ITEMS]; /* |remainder| category */
24124 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
24125 char *header_byte; /* bytes of the \.{TFM} header */
24126 int header_last; /* last initialized \.{TFM} header byte */
24127 int header_size; /* size of the \.{TFM} header */
24128 four_quarters *lig_kern; /* the ligature/kern table */
24129 short nl; /* the number of ligature/kern steps so far */
24130 scaled *kern; /* distinct kerning amounts */
24131 short nk; /* the number of distinct kerns so far */
24132 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
24133 short ne; /* the number of extensible characters so far */
24134 scaled *param; /* \&{fontinfo} parameters */
24135 short np; /* the largest \&{fontinfo} parameter specified so far */
24136 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
24137 short skip_table[TFM_ITEMS]; /* local label status */
24138 boolean lk_started; /* has there been a lig/kern step in this command yet? */
24139 integer bchar; /* right boundary character */
24140 short bch_label; /* left boundary starting location */
24141 short ll;short lll; /* registers used for lig/kern processing */
24142 short label_loc[257]; /* lig/kern starting addresses */
24143 eight_bits label_char[257]; /* characters for |label_loc| */
24144 short label_ptr; /* highest position occupied in |label_loc| */
24146 @ @<Allocate or initialize ...@>=
24147 mp->header_size = 128; /* just for init */
24148 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
24150 @ @<Dealloc variables@>=
24151 xfree(mp->header_byte);
24152 xfree(mp->lig_kern);
24157 for (k=0;k<= 255;k++ ) {
24158 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
24159 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
24160 mp->skip_table[k]=undefined_label;
24162 memset(mp->header_byte,0,(size_t)mp->header_size);
24163 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
24164 mp->internal[mp_boundary_char]=-unity;
24165 mp->bch_label=undefined_label;
24166 mp->label_loc[0]=-1; mp->label_ptr=0;
24168 @ @<Declarations@>=
24169 static scaled mp_tfm_check (MP mp,quarterword m) ;
24172 static scaled mp_tfm_check (MP mp,quarterword m) {
24173 if ( abs(mp->internal[m])>=fraction_half ) {
24174 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
24175 @.Enormous charwd...@>
24176 @.Enormous chardp...@>
24177 @.Enormous charht...@>
24178 @.Enormous charic...@>
24179 @.Enormous designsize...@>
24180 mp_print(mp, " has been reduced");
24181 help1("Font metric dimensions must be less than 2048pt.");
24182 mp_put_get_error(mp);
24183 if ( mp->internal[m]>0 ) return (fraction_half-1);
24184 else return (1-fraction_half);
24186 return mp->internal[m];
24190 @ @<Store the width information for character code~|c|@>=
24191 if ( c<mp->bc ) mp->bc=(eight_bits)c;
24192 if ( c>mp->ec ) mp->ec=(eight_bits)c;
24193 mp->char_exists[c]=true;
24194 mp->tfm_width[c]=mp_tfm_check(mp,mp_char_wd);
24195 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
24196 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
24197 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
24199 @ Now let's consider \MP's special \.{TFM}-oriented commands.
24201 @<Cases of |do_statement|...@>=
24202 case tfm_command: mp_do_tfm_command(mp); break;
24204 @ @d char_list_code 0
24205 @d lig_table_code 1
24206 @d extensible_code 2
24207 @d header_byte_code 3
24208 @d font_dimen_code 4
24211 mp_primitive(mp, "charlist",tfm_command,char_list_code);
24212 @:char_list_}{\&{charlist} primitive@>
24213 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
24214 @:lig_table_}{\&{ligtable} primitive@>
24215 mp_primitive(mp, "extensible",tfm_command,extensible_code);
24216 @:extensible_}{\&{extensible} primitive@>
24217 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
24218 @:header_byte_}{\&{headerbyte} primitive@>
24219 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
24220 @:font_dimen_}{\&{fontdimen} primitive@>
24222 @ @<Cases of |print_cmd...@>=
24225 case char_list_code:mp_print(mp, "charlist"); break;
24226 case lig_table_code:mp_print(mp, "ligtable"); break;
24227 case extensible_code:mp_print(mp, "extensible"); break;
24228 case header_byte_code:mp_print(mp, "headerbyte"); break;
24229 default: mp_print(mp, "fontdimen"); break;
24233 @ @<Declare action procedures for use by |do_statement|@>=
24234 static eight_bits mp_get_code (MP mp) ;
24236 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
24237 integer c; /* the code value found */
24238 mp_get_x_next(mp); mp_scan_expression(mp);
24239 if ( mp->cur_type==mp_known ) {
24240 c=mp_round_unscaled(mp, mp->cur_exp);
24241 if ( c>=0 ) if ( c<256 ) return (eight_bits)c;
24242 } else if ( mp->cur_type==mp_string_type ) {
24243 if ( length(mp->cur_exp)==1 ) {
24244 c=mp->str_pool[mp->str_start[mp->cur_exp]];
24245 return (eight_bits)c;
24248 exp_err("Invalid code has been replaced by 0");
24249 @.Invalid code...@>
24250 help2("I was looking for a number between 0 and 255, or for a",
24251 "string of length 1. Didn't find it; will use 0 instead.");
24252 mp_put_get_flush_error(mp, 0); c=0;
24253 return (eight_bits)c;
24256 @ @<Declare action procedures for use by |do_statement|@>=
24257 static void mp_set_tag (MP mp,halfword c, quarterword t, halfword r) ;
24259 @ @c void mp_set_tag (MP mp,halfword c, quarterword t, halfword r) {
24260 if ( mp->char_tag[c]==no_tag ) {
24261 mp->char_tag[c]=t; mp->char_remainder[c]=r;
24263 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
24264 mp->label_char[mp->label_ptr]=(eight_bits)c;
24267 @<Complain about a character tag conflict@>;
24271 @ @<Complain about a character tag conflict@>=
24273 print_err("Character ");
24274 if ( (c>' ')&&(c<127) ) mp_print_char(mp,xord(c));
24275 else if ( c==256 ) mp_print(mp, "||");
24276 else { mp_print(mp, "code "); mp_print_int(mp, c); };
24277 mp_print(mp, " is already ");
24278 @.Character c is already...@>
24279 switch (mp->char_tag[c]) {
24280 case lig_tag: mp_print(mp, "in a ligtable"); break;
24281 case list_tag: mp_print(mp, "in a charlist"); break;
24282 case ext_tag: mp_print(mp, "extensible"); break;
24283 } /* there are no other cases */
24284 help2("It's not legal to label a character more than once.",
24285 "So I'll not change anything just now.");
24286 mp_put_get_error(mp);
24289 @ @<Declare action procedures for use by |do_statement|@>=
24290 static void mp_do_tfm_command (MP mp) ;
24292 @ @c void mp_do_tfm_command (MP mp) {
24293 int c,cc; /* character codes */
24294 int k; /* index into the |kern| array */
24295 int j; /* index into |header_byte| or |param| */
24296 switch (mp->cur_mod) {
24297 case char_list_code:
24299 /* we will store a list of character successors */
24300 while ( mp->cur_cmd==colon ) {
24301 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
24304 case lig_table_code:
24305 if (mp->lig_kern==NULL)
24306 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
24307 if (mp->kern==NULL)
24308 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
24309 @<Store a list of ligature/kern steps@>;
24311 case extensible_code:
24312 @<Define an extensible recipe@>;
24314 case header_byte_code:
24315 case font_dimen_code:
24316 c=mp->cur_mod; mp_get_x_next(mp);
24317 mp_scan_expression(mp);
24318 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
24319 exp_err("Improper location");
24320 @.Improper location@>
24321 help2("I was looking for a known, positive number.",
24322 "For safety's sake I'll ignore the present command.");
24323 mp_put_get_error(mp);
24325 j=mp_round_unscaled(mp, mp->cur_exp);
24326 if ( mp->cur_cmd!=colon ) {
24327 mp_missing_err(mp, ":");
24329 help1("A colon should follow a headerbyte or fontinfo location.");
24332 if ( c==header_byte_code ) {
24333 @<Store a list of header bytes@>;
24335 if (mp->param==NULL)
24336 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
24337 @<Store a list of font dimensions@>;
24341 } /* there are no other cases */
24344 @ @<Store a list of ligature/kern steps@>=
24346 mp->lk_started=false;
24349 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
24350 @<Process a |skip_to| command and |goto done|@>;
24351 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
24352 else { mp_back_input(mp); c=mp_get_code(mp); };
24353 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
24354 @<Record a label in a lig/kern subprogram and |goto continue|@>;
24356 if ( mp->cur_cmd==lig_kern_token ) {
24357 @<Compile a ligature/kern command@>;
24359 print_err("Illegal ligtable step");
24360 @.Illegal ligtable step@>
24361 help1("I was looking for `=:' or `kern' here.");
24362 mp_back_error(mp); next_char(mp->nl)=qi(0);
24363 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
24364 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
24366 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
24368 if ( mp->cur_cmd==comma ) goto CONTINUE;
24369 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
24374 mp_primitive(mp, "=:",lig_kern_token,0);
24375 @:=:_}{\.{=:} primitive@>
24376 mp_primitive(mp, "=:|",lig_kern_token,1);
24377 @:=:/_}{\.{=:\char'174} primitive@>
24378 mp_primitive(mp, "=:|>",lig_kern_token,5);
24379 @:=:/>_}{\.{=:\char'174>} primitive@>
24380 mp_primitive(mp, "|=:",lig_kern_token,2);
24381 @:=:/_}{\.{\char'174=:} primitive@>
24382 mp_primitive(mp, "|=:>",lig_kern_token,6);
24383 @:=:/>_}{\.{\char'174=:>} primitive@>
24384 mp_primitive(mp, "|=:|",lig_kern_token,3);
24385 @:=:/_}{\.{\char'174=:\char'174} primitive@>
24386 mp_primitive(mp, "|=:|>",lig_kern_token,7);
24387 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
24388 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
24389 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
24390 mp_primitive(mp, "kern",lig_kern_token,128);
24391 @:kern_}{\&{kern} primitive@>
24393 @ @<Cases of |print_cmd...@>=
24394 case lig_kern_token:
24396 case 0:mp_print(mp, "=:"); break;
24397 case 1:mp_print(mp, "=:|"); break;
24398 case 2:mp_print(mp, "|=:"); break;
24399 case 3:mp_print(mp, "|=:|"); break;
24400 case 5:mp_print(mp, "=:|>"); break;
24401 case 6:mp_print(mp, "|=:>"); break;
24402 case 7:mp_print(mp, "|=:|>"); break;
24403 case 11:mp_print(mp, "|=:|>>"); break;
24404 default: mp_print(mp, "kern"); break;
24408 @ Local labels are implemented by maintaining the |skip_table| array,
24409 where |skip_table[c]| is either |undefined_label| or the address of the
24410 most recent lig/kern instruction that skips to local label~|c|. In the
24411 latter case, the |skip_byte| in that instruction will (temporarily)
24412 be zero if there were no prior skips to this label, or it will be the
24413 distance to the prior skip.
24415 We may need to cancel skips that span more than 127 lig/kern steps.
24417 @d cancel_skips(A) mp->ll=(A);
24419 mp->lll=qo(skip_byte(mp->ll));
24420 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
24421 } while (mp->lll!=0)
24422 @d skip_error(A) { print_err("Too far to skip");
24423 @.Too far to skip@>
24424 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
24425 mp_error(mp); cancel_skips((A));
24428 @<Process a |skip_to| command and |goto done|@>=
24431 if ( mp->nl-mp->skip_table[c]>128 ) {
24432 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
24434 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
24435 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
24436 mp->skip_table[c]=mp->nl-1; goto DONE;
24439 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
24441 if ( mp->cur_cmd==colon ) {
24442 if ( c==256 ) mp->bch_label=mp->nl;
24443 else mp_set_tag(mp, c,lig_tag,mp->nl);
24444 } else if ( mp->skip_table[c]<undefined_label ) {
24445 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
24447 mp->lll=qo(skip_byte(mp->ll));
24448 if ( mp->nl-mp->ll>128 ) {
24449 skip_error(mp->ll); goto CONTINUE;
24451 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
24452 } while (mp->lll!=0);
24457 @ @<Compile a ligature/kern...@>=
24459 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
24460 if ( mp->cur_mod<128 ) { /* ligature op */
24461 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
24463 mp_get_x_next(mp); mp_scan_expression(mp);
24464 if ( mp->cur_type!=mp_known ) {
24465 exp_err("Improper kern");
24467 help2("The amount of kern should be a known numeric value.",
24468 "I'm zeroing this one. Proceed, with fingers crossed.");
24469 mp_put_get_flush_error(mp, 0);
24471 mp->kern[mp->nk]=mp->cur_exp;
24473 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
24475 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
24478 op_byte(mp->nl)=kern_flag+(k / 256);
24479 rem_byte(mp->nl)=qi((k % 256));
24481 mp->lk_started=true;
24484 @ @d missing_extensible_punctuation(A)
24485 { mp_missing_err(mp, (A));
24486 @.Missing `\char`\#'@>
24487 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
24490 @<Define an extensible recipe@>=
24492 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
24493 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
24494 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
24495 ext_top(mp->ne)=qi(mp_get_code(mp));
24496 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24497 ext_mid(mp->ne)=qi(mp_get_code(mp));
24498 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24499 ext_bot(mp->ne)=qi(mp_get_code(mp));
24500 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24501 ext_rep(mp->ne)=qi(mp_get_code(mp));
24505 @ The header could contain ASCII zeroes, so can't use |strdup|.
24507 @<Store a list of header bytes@>=
24509 if ( j>=mp->header_size ) {
24510 size_t l = (size_t)(mp->header_size + (mp->header_size/4));
24511 char *t = xmalloc(l,1);
24513 memcpy(t,mp->header_byte,(size_t)mp->header_size);
24514 xfree (mp->header_byte);
24515 mp->header_byte = t;
24516 mp->header_size = (int)l;
24518 mp->header_byte[j]=(char)mp_get_code(mp);
24519 incr(j); incr(mp->header_last);
24520 } while (mp->cur_cmd==comma)
24522 @ @<Store a list of font dimensions@>=
24524 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
24525 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
24526 mp_get_x_next(mp); mp_scan_expression(mp);
24527 if ( mp->cur_type!=mp_known ){
24528 exp_err("Improper font parameter");
24529 @.Improper font parameter@>
24530 help1("I'm zeroing this one. Proceed, with fingers crossed.");
24531 mp_put_get_flush_error(mp, 0);
24533 mp->param[j]=mp->cur_exp; incr(j);
24534 } while (mp->cur_cmd==comma)
24536 @ OK: We've stored all the data that is needed for the \.{TFM} file.
24537 All that remains is to output it in the correct format.
24539 An interesting problem needs to be solved in this connection, because
24540 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
24541 and 64~italic corrections. If the data has more distinct values than
24542 this, we want to meet the necessary restrictions by perturbing the
24543 given values as little as possible.
24545 \MP\ solves this problem in two steps. First the values of a given
24546 kind (widths, heights, depths, or italic corrections) are sorted;
24547 then the list of sorted values is perturbed, if necessary.
24549 The sorting operation is facilitated by having a special node of
24550 essentially infinite |value| at the end of the current list.
24552 @<Initialize table entries...@>=
24553 value(inf_val)=fraction_four;
24555 @ Straight linear insertion is good enough for sorting, since the lists
24556 are usually not terribly long. As we work on the data, the current list
24557 will start at |mp_link(temp_head)| and end at |inf_val|; the nodes in this
24558 list will be in increasing order of their |value| fields.
24560 Given such a list, the |sort_in| function takes a value and returns a pointer
24561 to where that value can be found in the list. The value is inserted in
24562 the proper place, if necessary.
24564 At the time we need to do these operations, most of \MP's work has been
24565 completed, so we will have plenty of memory to play with. The value nodes
24566 that are allocated for sorting will never be returned to free storage.
24568 @d clear_the_list mp_link(temp_head)=inf_val
24571 static pointer mp_sort_in (MP mp,scaled v) {
24572 pointer p,q,r; /* list manipulation registers */
24576 if ( v<=value(q) ) break;
24579 if ( v<value(q) ) {
24580 r=mp_get_node(mp, value_node_size); value(r)=v; mp_link(r)=q; mp_link(p)=r;
24585 @ Now we come to the interesting part, where we reduce the list if necessary
24586 until it has the required size. The |min_cover| routine is basic to this
24587 process; it computes the minimum number~|m| such that the values of the
24588 current sorted list can be covered by |m|~intervals of width~|d|. It
24589 also sets the global value |perturbation| to the smallest value $d'>d$
24590 such that the covering found by this algorithm would be different.
24592 In particular, |min_cover(0)| returns the number of distinct values in the
24593 current list and sets |perturbation| to the minimum distance between
24597 static integer mp_min_cover (MP mp,scaled d) {
24598 pointer p; /* runs through the current list */
24599 scaled l; /* the least element covered by the current interval */
24600 integer m; /* lower bound on the size of the minimum cover */
24601 m=0; p=mp_link(temp_head); mp->perturbation=el_gordo;
24602 while ( p!=inf_val ){
24603 incr(m); l=value(p);
24604 do { p=mp_link(p); } while (value(p)<=l+d);
24605 if ( value(p)-l<mp->perturbation )
24606 mp->perturbation=value(p)-l;
24612 scaled perturbation; /* quantity related to \.{TFM} rounding */
24613 integer excess; /* the list is this much too long */
24615 @ The smallest |d| such that a given list can be covered with |m| intervals
24616 is determined by the |threshold| routine, which is sort of an inverse
24617 to |min_cover|. The idea is to increase the interval size rapidly until
24618 finding the range, then to go sequentially until the exact borderline has
24622 static scaled mp_threshold (MP mp,integer m) {
24623 scaled d; /* lower bound on the smallest interval size */
24624 mp->excess=mp_min_cover(mp, 0)-m;
24625 if ( mp->excess<=0 ) {
24629 d=mp->perturbation;
24630 } while (mp_min_cover(mp, d+d)>m);
24631 while ( mp_min_cover(mp, d)>m )
24632 d=mp->perturbation;
24637 @ The |skimp| procedure reduces the current list to at most |m| entries,
24638 by changing values if necessary. It also sets |mp_info(p):=k| if |value(p)|
24639 is the |k|th distinct value on the resulting list, and it sets
24640 |perturbation| to the maximum amount by which a |value| field has
24641 been changed. The size of the resulting list is returned as the
24645 static integer mp_skimp (MP mp,integer m) {
24646 scaled d; /* the size of intervals being coalesced */
24647 pointer p,q,r; /* list manipulation registers */
24648 scaled l; /* the least value in the current interval */
24649 scaled v; /* a compromise value */
24650 d=mp_threshold(mp, m); mp->perturbation=0;
24651 q=temp_head; m=0; p=mp_link(temp_head);
24652 while ( p!=inf_val ) {
24653 incr(m); l=value(p); mp_info(p)=m;
24654 if ( value(mp_link(p))<=l+d ) {
24655 @<Replace an interval of values by its midpoint@>;
24662 @ @<Replace an interval...@>=
24665 p=mp_link(p); mp_info(p)=m;
24666 decr(mp->excess); if ( mp->excess==0 ) d=0;
24667 } while (value(mp_link(p))<=l+d);
24668 v=l+halfp(value(p)-l);
24669 if ( value(p)-v>mp->perturbation )
24670 mp->perturbation=value(p)-v;
24673 r=mp_link(r); value(r)=v;
24675 mp_link(q)=p; /* remove duplicate values from the current list */
24678 @ A warning message is issued whenever something is perturbed by
24679 more than 1/16\thinspace pt.
24682 static void mp_tfm_warning (MP mp,quarterword m) {
24683 mp_print_nl(mp, "(some ");
24684 mp_print(mp, mp->int_name[m]);
24685 @.some charwds...@>
24686 @.some chardps...@>
24687 @.some charhts...@>
24688 @.some charics...@>
24689 mp_print(mp, " values had to be adjusted by as much as ");
24690 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
24693 @ Here's an example of how we use these routines.
24694 The width data needs to be perturbed only if there are 256 distinct
24695 widths, but \MP\ must check for this case even though it is
24698 An integer variable |k| will be defined when we use this code.
24699 The |dimen_head| array will contain pointers to the sorted
24700 lists of dimensions.
24702 @<Massage the \.{TFM} widths@>=
24704 for (k=mp->bc;k<=mp->ec;k++) {
24705 if ( mp->char_exists[k] )
24706 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
24708 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=mp_link(temp_head);
24709 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
24712 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
24714 @ Heights, depths, and italic corrections are different from widths
24715 not only because their list length is more severely restricted, but
24716 also because zero values do not need to be put into the lists.
24718 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
24720 for (k=mp->bc;k<=mp->ec;k++) {
24721 if ( mp->char_exists[k] ) {
24722 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
24723 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
24726 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=mp_link(temp_head);
24727 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
24729 for (k=mp->bc;k<=mp->ec;k++) {
24730 if ( mp->char_exists[k] ) {
24731 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
24732 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
24735 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=mp_link(temp_head);
24736 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
24738 for (k=mp->bc;k<=mp->ec;k++) {
24739 if ( mp->char_exists[k] ) {
24740 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
24741 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
24744 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=mp_link(temp_head);
24745 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
24747 @ @<Initialize table entries...@>=
24748 value(zero_val)=0; mp_info(zero_val)=0;
24750 @ Bytes 5--8 of the header are set to the design size, unless the user has
24751 some crazy reason for specifying them differently.
24754 Error messages are not allowed at the time this procedure is called,
24755 so a warning is printed instead.
24757 The value of |max_tfm_dimen| is calculated so that
24758 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
24759 < \\{three\_bytes}.$$
24761 @d three_bytes 0100000000 /* $2^{24}$ */
24764 static void mp_fix_design_size (MP mp) {
24765 scaled d; /* the design size */
24766 d=mp->internal[mp_design_size];
24767 if ( (d<unity)||(d>=fraction_half) ) {
24769 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24770 @.illegal design size...@>
24771 d=040000000; mp->internal[mp_design_size]=d;
24773 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24774 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24775 mp->header_byte[4]=d / 04000000;
24776 mp->header_byte[5]=(d / 4096) % 256;
24777 mp->header_byte[6]=(d / 16) % 256;
24778 mp->header_byte[7]=(d % 16)*16;
24780 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
24781 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24784 @ The |dimen_out| procedure computes a |fix_word| relative to the
24785 design size. If the data was out of range, it is corrected and the
24786 global variable |tfm_changed| is increased by~one.
24789 static integer mp_dimen_out (MP mp,scaled x) {
24790 if ( abs(x)>mp->max_tfm_dimen ) {
24791 incr(mp->tfm_changed);
24792 if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
24794 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24799 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24800 integer tfm_changed; /* the number of data entries that were out of bounds */
24802 @ If the user has not specified any of the first four header bytes,
24803 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24804 from the |tfm_width| data relative to the design size.
24808 static void mp_fix_check_sum (MP mp) {
24809 eight_bits k; /* runs through character codes */
24810 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24811 integer x; /* hash value used in check sum computation */
24812 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24813 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24814 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24815 mp->header_byte[0]=(char)B1; mp->header_byte[1]=(char)B2;
24816 mp->header_byte[2]=(char)B3; mp->header_byte[3]=(char)B4;
24821 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24822 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24823 for (k=mp->bc;k<=mp->ec;k++) {
24824 if ( mp->char_exists[k] ) {
24825 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24826 B1=(eight_bits)((B1+B1+x) % 255);
24827 B2=(eight_bits)((B2+B2+x) % 253);
24828 B3=(eight_bits)((B3+B3+x) % 251);
24829 B4=(eight_bits)((B4+B4+x) % 247);
24833 @ Finally we're ready to actually write the \.{TFM} information.
24834 Here are some utility routines for this purpose.
24836 @d tfm_out(A) do { /* output one byte to |tfm_file| */
24837 unsigned char s=(unsigned char)(A);
24838 (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
24842 static void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24843 tfm_out(x / 256); tfm_out(x % 256);
24845 static void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24846 if ( x>=0 ) tfm_out(x / three_bytes);
24848 x=x+010000000000; /* use two's complement for negative values */
24850 tfm_out((x / three_bytes) + 128);
24852 x=x % three_bytes; tfm_out(x / unity);
24853 x=x % unity; tfm_out(x / 0400);
24856 static void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24857 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24858 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24861 @ @<Finish the \.{TFM} file@>=
24862 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24863 mp_pack_job_name(mp, ".tfm");
24864 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24865 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24866 mp->metric_file_name=xstrdup(mp->name_of_file);
24867 @<Output the subfile sizes and header bytes@>;
24868 @<Output the character information bytes, then
24869 output the dimensions themselves@>;
24870 @<Output the ligature/kern program@>;
24871 @<Output the extensible character recipes and the font metric parameters@>;
24872 if ( mp->internal[mp_tracing_stats]>0 )
24873 @<Log the subfile sizes of the \.{TFM} file@>;
24874 mp_print_nl(mp, "Font metrics written on ");
24875 mp_print(mp, mp->metric_file_name); mp_print_char(mp, xord('.'));
24876 @.Font metrics written...@>
24877 (mp->close_file)(mp,mp->tfm_file)
24879 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24882 @<Output the subfile sizes and header bytes@>=
24884 LH=(k+3) / 4; /* this is the number of header words */
24885 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24886 @<Compute the ligature/kern program offset and implant the
24887 left boundary label@>;
24888 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24889 +lk_offset+mp->nk+mp->ne+mp->np);
24890 /* this is the total number of file words that will be output */
24891 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24892 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24893 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24894 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24895 mp_tfm_two(mp, mp->np);
24896 for (k=0;k< 4*LH;k++) {
24897 tfm_out(mp->header_byte[k]);
24900 @ @<Output the character information bytes...@>=
24901 for (k=mp->bc;k<=mp->ec;k++) {
24902 if ( ! mp->char_exists[k] ) {
24903 mp_tfm_four(mp, 0);
24905 tfm_out(mp_info(mp->tfm_width[k])); /* the width index */
24906 tfm_out((mp_info(mp->tfm_height[k]))*16+mp_info(mp->tfm_depth[k]));
24907 tfm_out((mp_info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24908 tfm_out(mp->char_remainder[k]);
24912 for (k=1;k<=4;k++) {
24913 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24914 while ( p!=inf_val ) {
24915 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=mp_link(p);
24920 @ We need to output special instructions at the beginning of the
24921 |lig_kern| array in order to specify the right boundary character
24922 and/or to handle starting addresses that exceed 255. The |label_loc|
24923 and |label_char| arrays have been set up to record all the
24924 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24925 \le|label_loc|[|label_ptr]|$.
24927 @<Compute the ligature/kern program offset...@>=
24928 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24929 if ((mp->bchar<0)||(mp->bchar>255))
24930 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24931 else { mp->lk_started=true; lk_offset=1; };
24932 @<Find the minimum |lk_offset| and adjust all remainders@>;
24933 if ( mp->bch_label<undefined_label )
24934 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24935 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24936 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24937 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24940 @ @<Find the minimum |lk_offset|...@>=
24941 k=mp->label_ptr; /* pointer to the largest unallocated label */
24942 if ( mp->label_loc[k]+lk_offset>255 ) {
24943 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24945 mp->char_remainder[mp->label_char[k]]=lk_offset;
24946 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24947 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24949 incr(lk_offset); decr(k);
24950 } while (! (lk_offset+mp->label_loc[k]<256));
24951 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24953 if ( lk_offset>0 ) {
24955 mp->char_remainder[mp->label_char[k]]
24956 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24961 @ @<Output the ligature/kern program@>=
24962 for (k=0;k<= 255;k++ ) {
24963 if ( mp->skip_table[k]<undefined_label ) {
24964 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24965 @.local label l:: was missing@>
24966 cancel_skips(mp->skip_table[k]);
24969 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24970 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24972 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24973 mp->ll=mp->label_loc[mp->label_ptr];
24974 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24975 else { tfm_out(255); tfm_out(mp->bchar); };
24976 mp_tfm_two(mp, mp->ll+lk_offset);
24978 decr(mp->label_ptr);
24979 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24982 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24983 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24985 @ @<Output the extensible character recipes...@>=
24986 for (k=0;k<=mp->ne-1;k++)
24987 mp_tfm_qqqq(mp, mp->exten[k]);
24988 for (k=1;k<=mp->np;k++) {
24990 if ( abs(mp->param[1])<fraction_half ) {
24991 mp_tfm_four(mp, mp->param[1]*16);
24993 incr(mp->tfm_changed);
24994 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
24995 else mp_tfm_four(mp, -el_gordo);
24998 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
25001 if ( mp->tfm_changed>0 ) {
25002 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
25003 @.a font metric dimension...@>
25005 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
25006 @.font metric dimensions...@>
25007 mp_print(mp, " font metric dimensions");
25009 mp_print(mp, " had to be decreased)");
25012 @ @<Log the subfile sizes of the \.{TFM} file@>=
25016 if ( mp->bch_label<undefined_label ) decr(mp->nl);
25017 mp_snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
25018 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
25022 @* \[43] Reading font metric data.
25024 \MP\ isn't a typesetting program but it does need to find the bounding box
25025 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
25026 well as write them.
25031 @ All the width, height, and depth information is stored in an array called
25032 |font_info|. This array is allocated sequentially and each font is stored
25033 as a series of |char_info| words followed by the width, height, and depth
25034 tables. Since |font_name| entries are permanent, their |str_ref| values are
25035 set to |max_str_ref|.
25038 typedef unsigned int font_number; /* |0..font_max| */
25040 @ The |font_info| array is indexed via a group directory arrays.
25041 For example, the |char_info| data for character~|c| in font~|f| will be
25042 in |font_info[char_base[f]+c].qqqq|.
25045 font_number font_max; /* maximum font number for included text fonts */
25046 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
25047 memory_word *font_info; /* height, width, and depth data */
25048 char **font_enc_name; /* encoding names, if any */
25049 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
25050 size_t next_fmem; /* next unused entry in |font_info| */
25051 font_number last_fnum; /* last font number used so far */
25052 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
25053 char **font_name; /* name as specified in the \&{infont} command */
25054 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
25055 font_number last_ps_fnum; /* last valid |font_ps_name| index */
25056 eight_bits *font_bc;
25057 eight_bits *font_ec; /* first and last character code */
25058 int *char_base; /* base address for |char_info| */
25059 int *width_base; /* index for zeroth character width */
25060 int *height_base; /* index for zeroth character height */
25061 int *depth_base; /* index for zeroth character depth */
25062 pointer *font_sizes;
25064 @ @<Allocate or initialize ...@>=
25065 mp->font_mem_size = 10000;
25066 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
25067 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
25068 mp->last_fnum = null_font;
25070 @ @<Dealloc variables@>=
25071 for (k=1;k<=(int)mp->last_fnum;k++) {
25072 xfree(mp->font_enc_name[k]);
25073 xfree(mp->font_name[k]);
25074 xfree(mp->font_ps_name[k]);
25076 xfree(mp->font_info);
25077 xfree(mp->font_enc_name);
25078 xfree(mp->font_ps_name_fixed);
25079 xfree(mp->font_dsize);
25080 xfree(mp->font_name);
25081 xfree(mp->font_ps_name);
25082 xfree(mp->font_bc);
25083 xfree(mp->font_ec);
25084 xfree(mp->char_base);
25085 xfree(mp->width_base);
25086 xfree(mp->height_base);
25087 xfree(mp->depth_base);
25088 xfree(mp->font_sizes);
25092 void mp_reallocate_fonts (MP mp, font_number l) {
25094 XREALLOC(mp->font_enc_name, l, char *);
25095 XREALLOC(mp->font_ps_name_fixed, l, boolean);
25096 XREALLOC(mp->font_dsize, l, scaled);
25097 XREALLOC(mp->font_name, l, char *);
25098 XREALLOC(mp->font_ps_name, l, char *);
25099 XREALLOC(mp->font_bc, l, eight_bits);
25100 XREALLOC(mp->font_ec, l, eight_bits);
25101 XREALLOC(mp->char_base, l, int);
25102 XREALLOC(mp->width_base, l, int);
25103 XREALLOC(mp->height_base, l, int);
25104 XREALLOC(mp->depth_base, l, int);
25105 XREALLOC(mp->font_sizes, l, pointer);
25106 for (f=(mp->last_fnum+1);f<=l;f++) {
25107 mp->font_enc_name[f]=NULL;
25108 mp->font_ps_name_fixed[f] = false;
25109 mp->font_name[f]=NULL;
25110 mp->font_ps_name[f]=NULL;
25111 mp->font_sizes[f]=null;
25116 @ @<Internal library declarations@>=
25117 void mp_reallocate_fonts (MP mp, font_number l);
25120 @ A |null_font| containing no characters is useful for error recovery. Its
25121 |font_name| entry starts out empty but is reset each time an erroneous font is
25122 found. This helps to cut down on the number of duplicate error messages without
25123 wasting a lot of space.
25125 @d null_font 0 /* the |font_number| for an empty font */
25127 @<Set initial...@>=
25128 mp->font_dsize[null_font]=0;
25129 mp->font_bc[null_font]=1;
25130 mp->font_ec[null_font]=0;
25131 mp->char_base[null_font]=0;
25132 mp->width_base[null_font]=0;
25133 mp->height_base[null_font]=0;
25134 mp->depth_base[null_font]=0;
25136 mp->last_fnum=null_font;
25137 mp->last_ps_fnum=null_font;
25138 mp->font_name[null_font]=(char *)"nullfont";
25139 mp->font_ps_name[null_font]=(char *)"";
25140 mp->font_ps_name_fixed[null_font] = false;
25141 mp->font_enc_name[null_font]=NULL;
25142 mp->font_sizes[null_font]=null;
25144 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
25145 the |width index|; the |b1| field contains the height
25146 index; the |b2| fields contains the depth index, and the |b3| field used only
25147 for temporary storage. (It is used to keep track of which characters occur in
25148 an edge structure that is being shipped out.)
25149 The corresponding words in the width, height, and depth tables are stored as
25150 |scaled| values in units of \ps\ points.
25152 With the macros below, the |char_info| word for character~|c| in font~|f| is
25153 |char_mp_info(f,c)| and the width is
25154 $$\hbox{|char_width(f,char_mp_info(f,c)).sc|.}$$
25156 @d char_mp_info(A,B) mp->font_info[mp->char_base[(A)]+(B)].qqqq
25157 @d char_width(A,B) mp->font_info[mp->width_base[(A)]+(B).b0].sc
25158 @d char_height(A,B) mp->font_info[mp->height_base[(A)]+(B).b1].sc
25159 @d char_depth(A,B) mp->font_info[mp->depth_base[(A)]+(B).b2].sc
25160 @d ichar_exists(A) ((A).b0>0)
25162 @ When we have a font name and we don't know whether it has been loaded yet,
25163 we scan the |font_name| array before calling |read_font_info|.
25166 static font_number mp_find_font (MP mp, char *f) ;
25169 font_number mp_find_font (MP mp, char *f) {
25171 for (n=0;n<=mp->last_fnum;n++) {
25172 if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
25177 n = mp_read_font_info(mp, f);
25182 @ This is an interface function for getting the width of character,
25183 as a double in ps units
25185 @c double mp_get_char_dimension (MP mp, char *fname, int c, int t) {
25190 for (n=0;n<=mp->last_fnum;n++) {
25191 if (mp_xstrcmp(fname,mp->font_name[n])==0 ) {
25198 cc = char_mp_info(f,c);
25199 if (! ichar_exists(cc) )
25202 w = (double)char_width(f,cc);
25204 w = (double)char_height(f,cc);
25206 w = (double)char_depth(f,cc);
25207 return w/655.35*(72.27/72);
25210 @ @<Exported function ...@>=
25211 double mp_get_char_dimension (MP mp, char *fname, int n, int t);
25214 @ One simple application of |find_font| is the implementation of the |font_size|
25215 operator that gets the design size for a given font name.
25217 @<Find the design size of the font whose name is |cur_exp|@>=
25218 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
25220 @ If we discover that the font doesn't have a requested character, we omit it
25221 from the bounding box computation and expect the \ps\ interpreter to drop it.
25222 This routine issues a warning message if the user has asked for it.
25225 static void mp_lost_warning (MP mp,font_number f, pool_pointer k);
25228 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
25229 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
25230 mp_begin_diagnostic(mp);
25231 if ( mp->selector==log_only ) incr(mp->selector);
25232 mp_print_nl(mp, "Missing character: There is no ");
25233 @.Missing character@>
25234 mp_print_str(mp, mp->str_pool[k]);
25235 mp_print(mp, " in font ");
25236 mp_print(mp, mp->font_name[f]); mp_print_char(mp, xord('!'));
25237 mp_end_diagnostic(mp, false);
25241 @ The whole purpose of saving the height, width, and depth information is to be
25242 able to find the bounding box of an item of text in an edge structure. The
25243 |set_text_box| procedure takes a text node and adds this information.
25246 static void mp_set_text_box (MP mp,pointer p);
25249 void mp_set_text_box (MP mp,pointer p) {
25250 font_number f; /* |mp_font_n(p)| */
25251 ASCII_code bc,ec; /* range of valid characters for font |f| */
25252 pool_pointer k,kk; /* current character and character to stop at */
25253 four_quarters cc; /* the |char_info| for the current character */
25254 scaled h,d; /* dimensions of the current character */
25256 height_val(p)=-el_gordo;
25257 depth_val(p)=-el_gordo;
25258 f=(font_number)mp_font_n(p);
25261 kk=str_stop(mp_text_p(p));
25262 k=mp->str_start[mp_text_p(p)];
25264 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
25266 @<Set the height and depth to zero if the bounding box is empty@>;
25269 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
25271 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
25272 mp_lost_warning(mp, f,k);
25274 cc=char_mp_info(f,mp->str_pool[k]);
25275 if ( ! ichar_exists(cc) ) {
25276 mp_lost_warning(mp, f,k);
25278 width_val(p)=width_val(p)+char_width(f,cc);
25279 h=char_height(f,cc);
25280 d=char_depth(f,cc);
25281 if ( h>height_val(p) ) height_val(p)=h;
25282 if ( d>depth_val(p) ) depth_val(p)=d;
25288 @ Let's hope modern compilers do comparisons correctly when the difference would
25291 @<Set the height and depth to zero if the bounding box is empty@>=
25292 if ( height_val(p)<-depth_val(p) ) {
25297 @ The new primitives fontmapfile and fontmapline.
25299 @<Declare action procedures for use by |do_statement|@>=
25300 static void mp_do_mapfile (MP mp) ;
25301 static void mp_do_mapline (MP mp) ;
25304 static void mp_do_mapfile (MP mp) {
25305 mp_get_x_next(mp); mp_scan_expression(mp);
25306 if ( mp->cur_type!=mp_string_type ) {
25307 @<Complain about improper map operation@>;
25309 mp_map_file(mp,mp->cur_exp);
25312 static void mp_do_mapline (MP mp) {
25313 mp_get_x_next(mp); mp_scan_expression(mp);
25314 if ( mp->cur_type!=mp_string_type ) {
25315 @<Complain about improper map operation@>;
25317 mp_map_line(mp,mp->cur_exp);
25321 @ @<Complain about improper map operation@>=
25323 exp_err("Unsuitable expression");
25324 help1("Only known strings can be map files or map lines.");
25325 mp_put_get_error(mp);
25328 @ To print |scaled| value to PDF output we need some subroutines to ensure
25331 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
25334 scaled one_bp; /* scaled value corresponds to 1bp */
25335 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
25336 scaled one_hundred_inch; /* scaled value corresponds to 100in */
25337 integer ten_pow[10]; /* $10^0..10^9$ */
25338 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
25341 mp->one_bp = 65782; /* 65781.76 */
25342 mp->one_hundred_bp = 6578176;
25343 mp->one_hundred_inch = 473628672;
25344 mp->ten_pow[0] = 1;
25345 for (i = 1;i<= 9; i++ ) {
25346 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
25349 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
25351 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
25355 if ( s < 0 ) { sign = -sign; s = -s; }
25356 if ( m < 0 ) { sign = -sign; m = -m; }
25358 mp_confusion(mp, "arithmetic: divided by zero");
25359 else if ( m >= (max_integer / 10) )
25360 mp_confusion(mp, "arithmetic: number too big");
25363 for (i = 1;i<=dd;i++) {
25364 q = 10*q + (10*r) / m;
25367 if ( 2*r >= m ) { incr(q); r = r - m; }
25368 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
25372 @* \[44] Shipping pictures out.
25373 The |ship_out| procedure, to be described below, is given a pointer to
25374 an edge structure. Its mission is to output a file containing the \ps\
25375 description of an edge structure.
25377 @ Each time an edge structure is shipped out we write a new \ps\ output
25378 file named according to the current \&{charcode}.
25379 @:char_code_}{\&{charcode} primitive@>
25381 This is the only backend function that remains in the main |mpost.w| file.
25382 There are just too many variable accesses needed for status reporting
25383 etcetera to make it worthwile to move the code to |psout.w|.
25385 @<Internal library declarations@>=
25386 void mp_open_output_file (MP mp) ;
25389 static char *mp_set_output_file_name (MP mp, integer c) {
25390 char *ss = NULL; /* filename extension proposal */
25391 char *nn = NULL; /* temp string for str() */
25392 unsigned old_setting; /* previous |selector| setting */
25393 pool_pointer i; /* indexes into |filename_template| */
25394 integer cc; /* a temporary integer for template building */
25395 integer f,g=0; /* field widths */
25396 if ( mp->job_name==NULL ) mp_open_log_file(mp);
25397 if ( mp->filename_template==0 ) {
25398 char *s; /* a file extension derived from |c| */
25402 @<Use |c| to compute the file extension |s|@>;
25403 mp_pack_job_name(mp, s);
25405 ss = xstrdup(mp->name_of_file);
25406 } else { /* initializations */
25407 str_number s, n; /* a file extension derived from |c| */
25408 old_setting=mp->selector;
25409 mp->selector=new_string;
25411 i = mp->str_start[mp->filename_template];
25412 n = null_str; /* initialize */
25413 while ( i<str_stop(mp->filename_template) ) {
25414 if ( mp->str_pool[i]=='%' ) {
25417 if ( i<str_stop(mp->filename_template) ) {
25418 if ( mp->str_pool[i]=='j' ) {
25419 mp_print(mp, mp->job_name);
25420 } else if ( mp->str_pool[i]=='d' ) {
25421 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
25422 print_with_leading_zeroes(cc);
25423 } else if ( mp->str_pool[i]=='m' ) {
25424 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
25425 print_with_leading_zeroes(cc);
25426 } else if ( mp->str_pool[i]=='y' ) {
25427 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
25428 print_with_leading_zeroes(cc);
25429 } else if ( mp->str_pool[i]=='H' ) {
25430 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
25431 print_with_leading_zeroes(cc);
25432 } else if ( mp->str_pool[i]=='M' ) {
25433 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
25434 print_with_leading_zeroes(cc);
25435 } else if ( mp->str_pool[i]=='c' ) {
25436 if ( c<0 ) mp_print(mp, "ps");
25437 else print_with_leading_zeroes(c);
25438 } else if ( (mp->str_pool[i]>='0') &&
25439 (mp->str_pool[i]<='9') ) {
25441 f = (f*10) + mp->str_pool[i]-'0';
25444 mp_print_str(mp, mp->str_pool[i]);
25448 if ( mp->str_pool[i]=='.' )
25450 n = mp_make_string(mp);
25451 mp_print_str(mp, mp->str_pool[i]);
25455 s = mp_make_string(mp);
25456 mp->selector= old_setting;
25457 if (length(n)==0) {
25463 mp_pack_file_name(mp, nn,"",ss);
25471 static char * mp_get_output_file_name (MP mp) {
25473 char *saved_name; /* saved |name_of_file| */
25474 saved_name = xstrdup(mp->name_of_file);
25475 f = xstrdup(mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code])));
25476 mp_pack_file_name(mp, saved_name,NULL,NULL);
25481 void mp_open_output_file (MP mp) {
25482 char *ss; /* filename extension proposal */
25483 integer c; /* \&{charcode} rounded to the nearest integer */
25484 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25485 ss = mp_set_output_file_name(mp, c);
25486 while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
25487 mp_prompt_file_name(mp, "file name for output",ss);
25489 @<Store the true output file name if appropriate@>;
25492 @ The file extension created here could be up to five characters long in
25493 extreme cases so it may have to be shortened on some systems.
25494 @^system dependencies@>
25496 @<Use |c| to compute the file extension |s|@>=
25499 mp_snprintf(s,7,".%i",(int)c);
25502 @ The user won't want to see all the output file names so we only save the
25503 first and last ones and a count of how many there were. For this purpose
25504 files are ordered primarily by \&{charcode} and secondarily by order of
25506 @:char_code_}{\&{charcode} primitive@>
25508 @<Store the true output file name if appropriate@>=
25509 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
25510 mp->first_output_code=c;
25511 xfree(mp->first_file_name);
25512 mp->first_file_name=xstrdup(mp->name_of_file);
25514 if ( c>=mp->last_output_code ) {
25515 mp->last_output_code=c;
25516 xfree(mp->last_file_name);
25517 mp->last_file_name=xstrdup(mp->name_of_file);
25521 char * first_file_name;
25522 char * last_file_name; /* full file names */
25523 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
25524 @:char_code_}{\&{charcode} primitive@>
25525 integer total_shipped; /* total number of |ship_out| operations completed */
25528 mp->first_file_name=xstrdup("");
25529 mp->last_file_name=xstrdup("");
25530 mp->first_output_code=32768;
25531 mp->last_output_code=-32768;
25532 mp->total_shipped=0;
25534 @ @<Dealloc variables@>=
25535 xfree(mp->first_file_name);
25536 xfree(mp->last_file_name);
25538 @ @<Begin the progress report for the output of picture~|c|@>=
25539 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
25540 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, xord(' '));
25541 mp_print_char(mp, xord('['));
25542 if ( c>=0 ) mp_print_int(mp, c)
25544 @ @<End progress report@>=
25545 mp_print_char(mp, xord(']'));
25547 incr(mp->total_shipped)
25549 @ @<Explain what output files were written@>=
25550 if ( mp->total_shipped>0 ) {
25551 mp_print_nl(mp, "");
25552 mp_print_int(mp, mp->total_shipped);
25553 if (mp->noninteractive) {
25554 mp_print(mp, " figure");
25555 if ( mp->total_shipped>1 ) mp_print_char(mp, xord('s'));
25556 mp_print(mp, " created.");
25558 mp_print(mp, " output file");
25559 if ( mp->total_shipped>1 ) mp_print_char(mp, xord('s'));
25560 mp_print(mp, " written: ");
25561 mp_print(mp, mp->first_file_name);
25562 if ( mp->total_shipped>1 ) {
25563 if ( 31+strlen(mp->first_file_name)+
25564 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
25566 mp_print(mp, " .. ");
25567 mp_print(mp, mp->last_file_name);
25572 @ @<Internal library declarations@>=
25573 boolean mp_has_font_size(MP mp, font_number f );
25576 boolean mp_has_font_size(MP mp, font_number f ) {
25577 return (mp->font_sizes[f]!=null);
25580 @ The \&{special} command saves up lines of text to be printed during the next
25581 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25584 pointer last_pending; /* the last token in a list of pending specials */
25587 mp->last_pending=spec_head;
25589 @ @<Cases of |do_statement|...@>=
25590 case special_command:
25591 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25592 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25596 @ @<Declare action procedures for use by |do_statement|@>=
25597 static void mp_do_special (MP mp) ;
25599 @ @c void mp_do_special (MP mp) {
25600 mp_get_x_next(mp); mp_scan_expression(mp);
25601 if ( mp->cur_type!=mp_string_type ) {
25602 @<Complain about improper special operation@>;
25604 mp_link(mp->last_pending)=mp_stash_cur_exp(mp);
25605 mp->last_pending=mp_link(mp->last_pending);
25606 mp_link(mp->last_pending)=null;
25610 @ @<Complain about improper special operation@>=
25612 exp_err("Unsuitable expression");
25613 help1("Only known strings are allowed for output as specials.");
25614 mp_put_get_error(mp);
25617 @ On the export side, we need an extra object type for special strings.
25619 @<Graphical object codes@>=
25622 @ @<Export pending specials@>=
25623 p=mp_link(spec_head);
25624 while ( p!=null ) {
25625 mp_special_object *tp;
25626 tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
25627 gr_pre_script(tp) = str(value(p));
25628 if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
25629 else gr_link(hp) = (mp_graphic_object *)tp;
25630 hp = (mp_graphic_object *)tp;
25633 mp_flush_token_list(mp, mp_link(spec_head));
25634 mp_link(spec_head)=null;
25635 mp->last_pending=spec_head
25637 @ We are now ready for the main output procedure. Note that the |selector|
25638 setting is saved in a global variable so that |begin_diagnostic| can access it.
25640 @<Declare the \ps\ output procedures@>=
25641 static void mp_ship_out (MP mp, pointer h) ;
25643 @ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
25645 @d export_color(q,p)
25646 if ( mp_color_model(p)==mp_uninitialized_model ) {
25647 gr_color_model(q) = (unsigned char)(mp->internal[mp_default_color_model]/65536);
25648 gr_cyan_val(q) = 0;
25649 gr_magenta_val(q) = 0;
25650 gr_yellow_val(q) = 0;
25651 gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
25653 gr_color_model(q) = (unsigned char)mp_color_model(p);
25654 gr_cyan_val(q) = cyan_val(p);
25655 gr_magenta_val(q) = magenta_val(p);
25656 gr_yellow_val(q) = yellow_val(p);
25657 gr_black_val(q) = black_val(p);
25660 @d export_scripts(q,p)
25661 if (mp_pre_script(p)!=null) gr_pre_script(q) = str(mp_pre_script(p));
25662 if (mp_post_script(p)!=null) gr_post_script(q) = str(mp_post_script(p));
25665 struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
25666 pointer p; /* the current graphical object */
25667 integer t; /* a temporary value */
25668 integer c; /* a rounded charcode */
25669 scaled d_width; /* the current pen width */
25670 mp_edge_object *hh; /* the first graphical object */
25671 mp_graphic_object *hq; /* something |hp| points to */
25672 mp_text_object *tt;
25673 mp_fill_object *tf;
25674 mp_stroked_object *ts;
25675 mp_clip_object *tc;
25676 mp_bounds_object *tb;
25677 mp_graphic_object *hp = NULL; /* the current graphical object */
25678 mp_set_bbox(mp, h, true);
25679 hh = xmalloc(1,sizeof(mp_edge_object));
25683 hh->minx = minx_val(h);
25684 hh->miny = miny_val(h);
25685 hh->maxx = maxx_val(h);
25686 hh->maxy = maxy_val(h);
25687 hh->filename = mp_get_output_file_name(mp);
25688 c = mp_round_unscaled(mp,mp->internal[mp_char_code]);
25690 hh->width = mp->internal[mp_char_wd];
25691 hh->height = mp->internal[mp_char_ht];
25692 hh->depth = mp->internal[mp_char_dp];
25693 hh->ital_corr = mp->internal[mp_char_ic];
25694 @<Export pending specials@>;
25695 p=mp_link(dummy_loc(h));
25696 while ( p!=null ) {
25697 hq = mp_new_graphic_object(mp,mp_type(p));
25698 switch (mp_type(p)) {
25700 tf = (mp_fill_object *)hq;
25701 gr_pen_p(tf) = mp_export_knot_list(mp,mp_pen_p(p));
25702 d_width = mp_get_pen_scale(mp, mp_pen_p(p));
25703 if ((mp_pen_p(p)==null) || pen_is_elliptical(mp_pen_p(p))) {
25704 gr_path_p(tf) = mp_export_knot_list(mp,mp_path_p(p));
25707 pc = mp_copy_path(mp, mp_path_p(p));
25708 pp = mp_make_envelope(mp, pc, mp_pen_p(p),ljoin_val(p),0,miterlim_val(p));
25709 gr_path_p(tf) = mp_export_knot_list(mp,pp);
25710 mp_toss_knot_list(mp, pp);
25711 pc = mp_htap_ypoc(mp, mp_path_p(p));
25712 pp = mp_make_envelope(mp, pc, mp_pen_p(p),ljoin_val(p),0,miterlim_val(p));
25713 gr_htap_p(tf) = mp_export_knot_list(mp,pp);
25714 mp_toss_knot_list(mp, pp);
25716 export_color(tf,p) ;
25717 export_scripts(tf,p);
25718 gr_ljoin_val(tf) = (unsigned char)ljoin_val(p);
25719 gr_miterlim_val(tf) = miterlim_val(p);
25721 case mp_stroked_code:
25722 ts = (mp_stroked_object *)hq;
25723 gr_pen_p(ts) = mp_export_knot_list(mp,mp_pen_p(p));
25724 d_width = mp_get_pen_scale(mp, mp_pen_p(p));
25725 if (pen_is_elliptical(mp_pen_p(p))) {
25726 gr_path_p(ts) = mp_export_knot_list(mp,mp_path_p(p));
25729 pc=mp_copy_path(mp, mp_path_p(p));
25731 if ( mp_left_type(pc)!=mp_endpoint ) {
25732 mp_left_type(mp_insert_knot(mp, pc,mp_x_coord(pc),mp_y_coord(pc)))=mp_endpoint;
25733 mp_right_type(pc)=mp_endpoint;
25737 pc=mp_make_envelope(mp,pc,mp_pen_p(p),ljoin_val(p),t,miterlim_val(p));
25738 gr_path_p(ts) = mp_export_knot_list(mp,pc);
25739 mp_toss_knot_list(mp, pc);
25741 export_color(ts,p) ;
25742 export_scripts(ts,p);
25743 gr_ljoin_val(ts) = (unsigned char)ljoin_val(p);
25744 gr_miterlim_val(ts) = miterlim_val(p);
25745 gr_lcap_val(ts) = (unsigned char)lcap_val(p);
25746 gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
25749 tt = (mp_text_object *)hq;
25750 gr_text_p(tt) = str(mp_text_p(p));
25751 gr_font_n(tt) = (unsigned int)mp_font_n(p);
25752 gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[mp_font_n(p)]);
25753 gr_font_dsize(tt) = (unsigned int)mp->font_dsize[mp_font_n(p)];
25754 export_color(tt,p) ;
25755 export_scripts(tt,p);
25756 gr_width_val(tt) = width_val(p);
25757 gr_height_val(tt) = height_val(p);
25758 gr_depth_val(tt) = depth_val(p);
25759 gr_tx_val(tt) = tx_val(p);
25760 gr_ty_val(tt) = ty_val(p);
25761 gr_txx_val(tt) = txx_val(p);
25762 gr_txy_val(tt) = txy_val(p);
25763 gr_tyx_val(tt) = tyx_val(p);
25764 gr_tyy_val(tt) = tyy_val(p);
25766 case mp_start_clip_code:
25767 tc = (mp_clip_object *)hq;
25768 gr_path_p(tc) = mp_export_knot_list(mp,mp_path_p(p));
25770 case mp_start_bounds_code:
25771 tb = (mp_bounds_object *)hq;
25772 gr_path_p(tb) = mp_export_knot_list(mp,mp_path_p(p));
25774 case mp_stop_clip_code:
25775 case mp_stop_bounds_code:
25776 /* nothing to do here */
25779 if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
25786 @ @<Declarations@>=
25787 static struct mp_edge_object *mp_gr_export(MP mp, int h);
25789 @ This function is now nearly trivial.
25792 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25793 integer c; /* \&{charcode} rounded to the nearest integer */
25794 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25795 @<Begin the progress report for the output of picture~|c|@>;
25796 (mp->shipout_backend) (mp, h);
25797 @<End progress report@>;
25798 if ( mp->internal[mp_tracing_output]>0 )
25799 mp_print_edges(mp, h," (just shipped out)",true);
25802 @ @<Declarations@>=
25803 static void mp_shipout_backend (MP mp, pointer h);
25806 void mp_shipout_backend (MP mp, pointer h) {
25807 mp_edge_object *hh; /* the first graphical object */
25808 hh = mp_gr_export(mp,h);
25809 (void)mp_gr_ship_out (hh,
25810 (mp->internal[mp_prologues]/65536),
25811 (mp->internal[mp_procset]/65536),
25813 mp_gr_toss_objects(hh);
25816 @ @<Exported types@>=
25817 typedef void (*mp_backend_writer)(MP, int);
25819 @ @<Option variables@>=
25820 mp_backend_writer shipout_backend;
25822 @ Now that we've finished |ship_out|, let's look at the other commands
25823 by which a user can send things to the \.{GF} file.
25825 @ @<Determine if a character has been shipped out@>=
25827 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
25828 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
25829 boolean_reset(mp->char_exists[mp->cur_exp]);
25830 mp->cur_type=mp_boolean_type;
25836 @ @<Allocate or initialize ...@>=
25837 mp_backend_initialize(mp);
25840 mp_backend_free(mp);
25843 @* \[45] Dumping and undumping the tables.
25844 After \.{INIMP} has seen a collection of macros, it
25845 can write all the necessary information on an auxiliary file so
25846 that production versions of \MP\ are able to initialize their
25847 memory at high speed. The present section of the program takes
25848 care of such output and input. We shall consider simultaneously
25849 the processes of storing and restoring,
25850 so that the inverse relation between them is clear.
25853 The global variable |mem_ident| is a string that is printed right
25854 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
25855 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
25856 for example, `\.{(mem=plain 1990.4.14)}', showing the year,
25857 month, and day that the mem file was created. We have |mem_ident=0|
25858 before \MP's tables are loaded.
25862 void * mem_file; /* for input or output of mem information */
25865 mp->mem_ident=NULL;
25867 @ @<Initialize table entries...@>=
25868 mp->mem_ident=xstrdup(" (INIMP)");
25870 @ @<Declarations@>=
25871 extern void mp_store_mem_file (MP mp) ;
25872 extern boolean mp_load_mem_file (MP mp);
25873 extern boolean mp_undump_constants (MP mp);
25875 @ @<Dealloc variables@>=
25876 xfree(mp->mem_ident);
25879 @* \[46] The main program.
25880 This is it: the part of \MP\ that executes all those procedures we have
25883 Well---almost. We haven't put the parsing subroutines into the
25884 program yet; and we'd better leave space for a few more routines that may
25885 have been forgotten.
25887 @c @<Declare the basic parsing subroutines@>
25888 @<Declare miscellaneous procedures that were declared |forward|@>
25890 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
25892 has to be run first; it initializes everything from scratch, without
25893 reading a mem file, and it has the capability of dumping a mem file.
25894 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
25896 to input a mem file in order to get started. \.{VIRMP} typically has
25897 a bit more memory capacity than \.{INIMP}, because it does not need the
25898 space consumed by the dumping/undumping routines and the numerous calls on
25901 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
25902 the best implementations therefore allow for production versions of \MP\ that
25903 not only avoid the loading routine for object code, they also have
25904 a mem file pre-loaded.
25906 @ @<Option variables@>=
25907 int ini_version; /* are we iniMP? */
25909 @ @<Set |ini_version|@>=
25910 mp->ini_version = (opt->ini_version ? true : false);
25912 @ The code below make the final chosen hash size the next larger
25913 multiple of 2 from the requested size, and this array is a list of
25914 suitable prime numbers to go with such values.
25916 The top limit is chosen such that it is definately lower than
25917 |max_halfword-3*param_size|, because |param_size| cannot be larger
25918 than |max_halfword/sizeof(pointer)|.
25921 static int mp_prime_choices[] =
25922 { 12289, 24593, 49157, 98317,
25923 196613, 393241, 786433, 1572869,
25924 3145739, 6291469, 12582917, 25165843,
25925 50331653, 100663319 };
25927 @ @<Find constant sizes@>=
25928 if (mp->ini_version) {
25930 set_value(mp->mem_top,opt->main_memory,5000);
25931 mp->mem_max = mp->mem_top;
25932 set_value(mp->param_size,opt->param_size,150);
25933 set_value(mp->max_in_open,opt->max_in_open,10);
25934 if (opt->hash_size>0x8000000)
25935 opt->hash_size=0x8000000;
25936 set_value(mp->hash_size,(2*opt->hash_size-1),16384);
25937 mp->hash_size = mp->hash_size>>i;
25938 while (mp->hash_size>=2) {
25939 mp->hash_size /= 2;
25942 mp->hash_size = mp->hash_size << i;
25943 if (mp->hash_size>0x8000000)
25944 mp->hash_size=0x8000000;
25945 mp->hash_prime=mp_prime_choices[(i-14)];
25947 if (mp->mem_name == NULL) {
25948 mp->mem_name = mp_xstrdup(mp,"plain");
25950 if (mp_open_mem_file(mp)) {
25951 if (!mp_undump_constants(mp))
25953 set_value(mp->mem_max,opt->main_memory,mp->mem_top);
25957 wterm_ln("(Fatal mem file error; I'm stymied)\n");
25958 mp->history = mp_fatal_error_stop;
25964 @ Here we do whatever is needed to complete \MP's job gracefully on the
25965 local operating system. The code here might come into play after a fatal
25966 error; it must therefore consist entirely of ``safe'' operations that
25967 cannot produce error messages. For example, it would be a mistake to call
25968 |str_room| or |make_string| at this time, because a call on |overflow|
25969 might lead to an infinite loop.
25970 @^system dependencies@>
25972 This program doesn't bother to close the input files that may still be open.
25975 void mp_close_files_and_terminate (MP mp) {
25976 integer k; /* all-purpose index */
25977 integer LH; /* the length of the \.{TFM} header, in words */
25978 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
25979 pointer p; /* runs through a list of \.{TFM} dimensions */
25982 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
25983 if ( mp->internal[mp_tracing_stats]>0 )
25984 @<Output statistics about this job@>;
25986 @<Do all the finishing work on the \.{TFM} file@>;
25987 @<Explain what output files were written@>;
25988 if ( mp->log_opened && ! mp->noninteractive ){
25990 (mp->close_file)(mp,mp->log_file);
25991 mp->selector=mp->selector-2;
25992 if ( mp->selector==term_only ) {
25993 mp_print_nl(mp, "Transcript written on ");
25994 @.Transcript written...@>
25995 mp_print(mp, mp->log_name); mp_print_char(mp, xord('.'));
25999 mp->finished = true;
26002 @ @<Declarations@>=
26003 static void mp_close_files_and_terminate (MP mp) ;
26005 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
26006 if (mp->rd_fname!=NULL) {
26007 for (k=0;k<=(int)mp->read_files-1;k++ ) {
26008 if ( mp->rd_fname[k]!=NULL ) {
26009 (mp->close_file)(mp,mp->rd_file[k]);
26010 xfree(mp->rd_fname[k]);
26014 if (mp->wr_fname!=NULL) {
26015 for (k=0;k<=(int)mp->write_files-1;k++) {
26016 if ( mp->wr_fname[k]!=NULL ) {
26017 (mp->close_file)(mp,mp->wr_file[k]);
26018 xfree(mp->wr_fname[k]);
26024 for (k=0;k<(int)mp->max_read_files;k++ ) {
26025 if ( mp->rd_fname[k]!=NULL ) {
26026 (mp->close_file)(mp,mp->rd_file[k]);
26027 xfree(mp->rd_fname[k]);
26030 xfree(mp->rd_file);
26031 xfree(mp->rd_fname);
26032 for (k=0;k<(int)mp->max_write_files;k++) {
26033 if ( mp->wr_fname[k]!=NULL ) {
26034 (mp->close_file)(mp,mp->wr_file[k]);
26035 xfree(mp->wr_fname[k]);
26038 xfree(mp->wr_file);
26039 xfree(mp->wr_fname);
26042 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
26044 We reclaim all of the variable-size memory at this point, so that
26045 there is no chance of another memory overflow after the memory capacity
26046 has already been exceeded.
26048 @<Do all the finishing work on the \.{TFM} file@>=
26049 if ( mp->internal[mp_fontmaking]>0 ) {
26050 @<Make the dynamic memory into one big available node@>;
26051 @<Massage the \.{TFM} widths@>;
26052 mp_fix_design_size(mp); mp_fix_check_sum(mp);
26053 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
26054 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
26055 @<Finish the \.{TFM} file@>;
26058 @ @<Make the dynamic memory into one big available node@>=
26059 mp->rover=lo_mem_stat_max+1; mp_link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26060 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26061 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26062 lmp_link(mp->rover)=mp->rover; rmp_link(mp->rover)=mp->rover;
26063 mp_link(mp->lo_mem_max)=null; mp_info(mp->lo_mem_max)=null
26065 @ The present section goes directly to the log file instead of using
26066 |print| commands, because there's no need for these strings to take
26067 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26069 @<Output statistics...@>=
26070 if ( mp->log_opened ) {
26073 wlog_ln("Here is how much of MetaPost's memory you used:");
26074 @.Here is how much...@>
26075 mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26076 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26077 (int)(mp->max_strings-1-mp->init_str_use));
26079 mp_snprintf(s,128," %i string characters out of %i",
26080 (int)mp->max_pl_used-mp->init_pool_ptr,
26081 (int)mp->pool_size-mp->init_pool_ptr);
26083 mp_snprintf(s,128," %i words of memory out of %i",
26084 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26087 mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26089 mp_snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
26090 (int)mp->max_in_stack,(int)mp->int_ptr,
26091 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26092 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26094 mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26095 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26099 @ It is nice to have have some of the stats available from the API.
26101 @<Exported function ...@>=
26102 int mp_memory_usage (MP mp );
26103 int mp_hash_usage (MP mp );
26104 int mp_param_usage (MP mp );
26105 int mp_open_usage (MP mp );
26108 int mp_memory_usage (MP mp ) {
26109 return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
26111 int mp_hash_usage (MP mp ) {
26112 return (int)mp->st_count;
26114 int mp_param_usage (MP mp ) {
26115 return (int)mp->max_param_stack;
26117 int mp_open_usage (MP mp ) {
26118 return (int)mp->max_in_stack;
26121 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26125 void mp_final_cleanup (MP mp) {
26126 quarterword c; /* 0 for \&{end}, 1 for \&{dump} */
26128 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26129 while ( mp->input_ptr>0 ) {
26130 if ( token_state ) mp_end_token_list(mp);
26131 else mp_end_file_reading(mp);
26133 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26134 while ( mp->open_parens>0 ) {
26135 mp_print(mp, " )"); decr(mp->open_parens);
26137 while ( mp->cond_ptr!=null ) {
26138 mp_print_nl(mp, "(end occurred when ");
26139 @.end occurred...@>
26140 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26141 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26142 if ( mp->if_line!=0 ) {
26143 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26145 mp_print(mp, " was incomplete)");
26146 mp->if_line=if_line_field(mp->cond_ptr);
26147 mp->cur_if=mp_name_type(mp->cond_ptr); mp->cond_ptr=mp_link(mp->cond_ptr);
26149 if ( mp->history!=mp_spotless )
26150 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26151 if ( mp->selector==term_and_log ) {
26152 mp->selector=term_only;
26153 mp_print_nl(mp, "(see the transcript file for additional information)");
26154 @.see the transcript file...@>
26155 mp->selector=term_and_log;
26158 if (mp->ini_version) {
26159 mp_store_mem_file(mp); return;
26161 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26162 @.dump...only by INIMP@>
26166 @ @<Declarations@>=
26167 static void mp_final_cleanup (MP mp) ;
26168 static void mp_init_prim (MP mp) ;
26169 static void mp_init_tab (MP mp) ;
26172 void mp_init_prim (MP mp) { /* initialize all the primitives */
26176 void mp_init_tab (MP mp) { /* initialize other tables */
26177 integer k; /* all-purpose index */
26178 @<Initialize table entries (done by \.{INIMP} only)@>;
26182 @ When we begin the following code, \MP's tables may still contain garbage;
26183 thus we must proceed cautiously to get bootstrapped in.
26185 But when we finish this part of the program, \MP\ is ready to call on the
26186 |main_control| routine to do its work.
26188 @<Get the first line...@>=
26190 @<Initialize the input routines@>;
26191 if (mp->mem_ident==NULL) {
26192 if ( ! mp_load_mem_file(mp) ) {
26193 (mp->close_file)(mp, mp->mem_file);
26194 mp->history = mp_fatal_error_stop;
26197 (mp->close_file)(mp, mp->mem_file);
26199 @<Initializations following first line@>;
26202 @ @<Initializations following first line@>=
26203 mp->buffer[limit]=(ASCII_code)'%';
26204 mp_fix_date_and_time(mp);
26205 if (mp->random_seed==0)
26206 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
26207 mp_init_randoms(mp, mp->random_seed);
26208 @<Initialize the print |selector|...@>;
26209 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26210 mp_start_input(mp); /* \&{input} assumed */
26212 @ @<Run inimpost commands@>=
26214 mp_get_strings_started(mp);
26215 mp_init_tab(mp); /* initialize the tables */
26216 mp_init_prim(mp); /* call |primitive| for each primitive */
26217 mp->init_str_use=mp->max_str_ptr=mp->str_ptr;
26218 mp->init_pool_ptr=mp->max_pool_ptr=mp->pool_ptr;
26219 mp_fix_date_and_time(mp);
26222 @ Saving the filename template
26224 @<Save the filename template@>=
26226 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26227 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26229 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26233 @* \[47] Debugging.
26236 @* \[48] System-dependent changes.
26237 This section should be replaced, if necessary, by any special
26238 modification of the program
26239 that are necessary to make \MP\ work at a particular installation.
26240 It is usually best to design your change file so that all changes to
26241 previous sections preserve the section numbering; then everybody's version
26242 will be consistent with the published program. More extensive changes,
26243 which introduce new sections, can be inserted here; then only the index
26244 itself will get a new section number.
26245 @^system dependencies@>
26248 Here is where you can find all uses of each identifier in the program,
26249 with underlined entries pointing to where the identifier was defined.
26250 If the identifier is only one letter long, however, you get to see only
26251 the underlined entries. {\sl All references are to section numbers instead of
26254 This index also lists error messages and other aspects of the program
26255 that you might want to look up some day. For example, the entry
26256 for ``system dependencies'' lists all sections that should receive
26257 special attention from people who are installing \MP\ in a new
26258 operating environment. A list of various things that can't happen appears
26259 under ``this can't happen''.
26260 Approximately 25 sections are listed under ``inner loop''; these account
26261 for more than 60\pct! of \MP's running time, exclusive of input and output.